From thenriksen at common-lisp.net Mon May 1 18:36:41 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 1 May 2006 14:36:41 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060501183641.9DC2B4E003@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18869 Modified Files: packages.lisp gui.lisp Log Message: Changed the colors of `climacs-rv' slightly and exported the symbol from the :climacs-gui package. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/04/30 15:20:46 1.90 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/01 18:36:41 1.91 @@ -174,6 +174,7 @@ ;;(:import-from :lisp-string) (:export :climacs ; Main entry point. ;; GUI functions follow. + :climacs-rv ; Entry point with alternate colors. :current-window :point :syntax --- /project/climacs/cvsroot/climacs/gui.lisp 2006/03/27 15:54:31 1.209 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/01 18:36:41 1.210 @@ -203,23 +203,17 @@ "Starts up a climacs session" ;; SBCL doesn't inherit dynamic bindings when starting new ;; processes, so start a new processes and THEN setup the colors. - (if new-process - (clim-sys:make-process (lambda () - (let ((*bg-color* +black+) - (*fg-color* +white+) - (*info-bg-color* +blue+) - (*info-fg-color* +yellow+) - (*mini-bg-color* +black+) - (*mini-fg-color* +white+)) - (climacs :new-process nil :width width :height height))) - :name process-name) - (let ((*bg-color* +black+) - (*fg-color* +white+) - (*info-bg-color* +blue+) - (*info-fg-color* +yellow+) - (*mini-bg-color* +black+) - (*mini-fg-color* +white+)) - (climacs :new-process new-process :process-name process-name :width width :height height)))) + (flet ((run () + (let ((*bg-color* +black+) + (*fg-color* +gray+) + (*info-bg-color* +darkslategray+) + (*info-fg-color* +gray+) + (*mini-bg-color* +black+) + (*mini-fg-color* +white+)) + (climacs :new-process nil :width width :height height)))) + (if new-process + (clim-sys:make-process #'run :name process-name) + (run)))) (defun display-info (frame pane) (let* ((master-pane (master-pane pane)) From thenriksen at common-lisp.net Tue May 2 14:25:25 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 10:25:25 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060502142525.06E555300F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4377 Modified Files: lisp-syntax.lisp Log Message: Added clear highlighting of macros and special forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 21:36:23 1.57 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:25:24 1.58 @@ -1294,6 +1294,17 @@ form (form-toplevel (parent form) syntax))) +(defgeneric operator-p (token syntax) + (:documentation "Return true if `token' is the operator of its form. Otherwise, + return nil.") + (:method (token syntax) + (with-accessors ((pre-token preceding-parse-tree)) token + (cond ((typep pre-token 'left-parenthesis-lexeme) + t) + ((typep pre-token 'comment) + (operator-p pre-token syntax)) + (t nil))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display @@ -1305,8 +1316,10 @@ (defparameter *standard-faces* `((:error ,+red+ nil) - (:string ,+foreground-ink+ ,(make-text-style nil :italic nil)) + (:string ,+coral+ ,(make-text-style nil :italic nil)) (:keyword ,+dark-violet+ nil) + (:macro ,+cyan+) + (:special-form ,+cyan+) (:lambda-list-keyword ,+dark-green+ nil) (:comment ,+maroon+ nil) (:reader-conditional ,+gray50+ nil))) @@ -1315,6 +1328,8 @@ `((:error ,+red+ nil) (:string ,+gray50+ ,(make-text-style nil :italic nil)) (:keyword ,+gray50+ nil) + (:macro ,+gray50+ nil) + (:special-form ,+gray50+ nil) (:lambda-list-keyword ,+gray50+ nil) (:comment ,+gray50+ nil) (:reader-conditional ,+gray50+ nil))) @@ -1399,7 +1414,7 @@ (end-offset parse-symbol)) 'string))) (multiple-value-bind (symbol status) - (token-to-symbol syntax parse-symbol) + (token-to-object syntax parse-symbol) (with-output-as-presentation (pane (if status symbol string) (if status 'symbol 'unknown-symbol) :single-box :highlighting) @@ -1409,8 +1424,15 @@ ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) (with-face (:lambda-list-keyword) (call-next-method))) - (t (call-next-method))) - ))) + ((and (macro-function symbol) + (operator-p parse-symbol syntax)) + (with-face (:macro) + (call-next-method))) + ((and (special-operator-p symbol) + (operator-p parse-symbol syntax)) + (with-face (:special-form) + (call-next-method))) + (t (call-next-method)))))) (call-next-method))) (defmethod display-parse-tree ((parser-symbol lisp-lexeme) (syntax lisp-syntax) pane) From thenriksen at common-lisp.net Tue May 2 14:29:44 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 10:29:44 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060502142944.7B5F0550CF@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4439 Modified Files: lisp-syntax.lisp Log Message: Added two form extraction functions. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:25:24 1.58 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:29:44 1.59 @@ -1307,6 +1307,27 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Useful functions for selecting forms based on the mark. + +(defun expression-at-mark (mark syntax) + "Return the form at `mark'. If `mark' is just after, +or inside, a top-level-form, or if there are no forms after +`mark', the form preceding `mark' is returned. Otherwise, the +form following `mark' is returned." + (or (form-around syntax (offset mark)) + (form-after syntax (offset mark)) + (form-before syntax (offset mark)))) + +(defun definition-at-mark (mark syntax) + "Return the top-level form at `mark'. If `mark' is just after, +or inside, a top-level-form, or if there are no forms after +`mark', the top-level-form preceding `mark' is +returned. Otherwise, the top-level-form following `mark' is +returned." + (form-toplevel (expression-at-mark mark syntax) syntax)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; display (defvar *white-space-start* nil) From thenriksen at common-lisp.net Tue May 2 14:33:33 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 10:33:33 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060502143333.3685D56161@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5927 Modified Files: lisp-syntax.lisp Log Message: Fixed the form-to-object methods and the form-to-symbol function. Converted all calls to `form-to-symbol' to `form-to-object'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:29:44 1.59 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:33:33 1.60 @@ -1131,7 +1131,7 @@ (when (typep x 'complete-list-form) (let ((candidate (first-form (children x)))) (and (typep candidate 'token-mixin) - (eq (token-to-symbol syntax candidate) + (eq (token-to-object syntax candidate) 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) @@ -1285,7 +1285,7 @@ ;; operands and return nil. (mapcar #'(lambda (operand) (if (typep operand 'form) - (token-to-object syntax operand t))) + (token-to-object syntax operand :no-error t))) (rest-forms (children form)))) (defun form-toplevel (form syntax) @@ -1557,7 +1557,7 @@ (start-offset conditional) (end-offset conditional)) 'string)) - (symbol (parse-symbol string +keyword-package+))) + (symbol (parse-symbol string :package +keyword-package+))) (member symbol *features*))) (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) @@ -1576,7 +1576,7 @@ (start-offset type) (end-offset type)) 'string)) - (type-symbol (parse-symbol type-string +keyword-package+))) + (type-symbol (parse-symbol type-string :package +keyword-package+))) (case type-symbol (:and (funcall #'every #'eval-fc conditionals)) (:or (funcall #'some #'eval-fc conditionals)) @@ -1843,7 +1843,7 @@ (defmethod form-operator ((form list-form) syntax) (let* ((operator-token (first-noncomment (rest (children form)))) (operator-symbol (when operator-token - (token-to-symbol syntax operator-token)))) + (token-to-object syntax operator-token)))) operator-symbol)) ;;; shamelessly replacing SWANK code @@ -1978,12 +1978,13 @@ (end-offset token)) 'string)) -(defun parse-symbol (string &optional (package *package*)) +(defun parse-symbol (string &key (package *package*) (case (readtable-case *readtable*))) "Find the symbol named STRING. Return the symbol and a flag indicating whether the symbol was found in the package. Note that a symbol may be returned even if it was not found in a package." - (multiple-value-bind (symbol-name package-name) (parse-token string) + (multiple-value-bind (symbol-name package-name) + (parse-token string case) (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (find-package package-name)) (t package)))) @@ -1994,56 +1995,58 @@ (values symbol status) (values (make-symbol symbol-name) nil)))))) -(defun token-to-symbol (syntax token) - "Return the symbol `token' represents. If `token' represents -anything else than a symbol, or it cannot be correctly converted -to a symbol, return nil. If the symbol cannot be found in a -package, an uninterned symbol will be returned." - (token-to-object syntax token t)) - -;; FIXME? This generic function often errors on erroneous input. Since -;; we are an editor, we might consider being a bit more lenient. Also, -;; it will never intern symbols itself, but return NIL for uninterned -;; symbols. -(defgeneric token-to-object (syntax token &optional no-error) +(defun token-to-symbol (syntax token &optional (case (readtable-case *readtable*))) + "Return the symbol `token' represents. If the symbol cannot be +found in a package, an uninterned symbol will be returned." + (token-to-object syntax token + :case case + :no-error t)) + +(defgeneric token-to-object (syntax token &key no-error &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax token &optional no-error) + (:method :around (syntax token &key no-error package) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) (slot-value syntax 'package) (typep (slot-value syntax 'package) 'package)) (slot-value syntax 'package) - (find-package :common-lisp)))) + (or (when package + (if (packagep package) + package + (find-package package))) + (find-package :common-lisp))))) (call-next-method)) (t () (unless no-error (error "Cannot convert token to Lisp object: ~A" token))))) - (:method (syntax (token t) &optional no-error) + (:method (syntax (token t) &key no-error) (declare (ignore no-error)) ;; We ignore `no-error' as it is truly a bug in Climacs if no ;; handler method is specialized on this form. (error "Cannot convert token to Lisp object: ~A" token)) - (:method (syntax (token incomplete-form-mixin) &optional no-error) + (:method (syntax (token incomplete-form-mixin) &key no-error) (unless no-error (error "Cannot convert incomplete form to Lisp object: ~A" token)))) -(defmethod token-to-object (syntax (token complete-token-lexeme) &optional no-error) +(defmethod token-to-object (syntax (token complete-token-lexeme) + &key no-error + (case (readtable-case *readtable*))) (declare (ignore no-error)) - (parse-symbol (token-string syntax token))) + (parse-symbol (token-string syntax token) :case case)) -(defmethod token-to-object (syntax (token number-lexeme) &optional no-error) +(defmethod token-to-object (syntax (token number-lexeme) &key no-error) (declare (ignore no-error)) (let ((*read-base* (base syntax))) (read-from-string (token-string syntax token)))) -(defmethod token-to-object (syntax (token list-form) &optional no-error) +(defmethod token-to-object (syntax (token list-form) &key no-error) (declare (ignore no-error)) (mapcar #'(lambda (form) (token-to-object syntax form)) @@ -2051,7 +2054,7 @@ (typep form 'form)) (children token)))) -(defmethod token-to-object (syntax (token simple-vector-form) &optional no-error) +(defmethod token-to-object (syntax (token simple-vector-form) &key no-error) (declare (ignore no-error)) (apply #'vector (mapcar #'(lambda (form) @@ -2060,19 +2063,19 @@ (typep form 'form)) (children token))))) -(defmethod token-to-object (syntax (token incomplete-string-form) &optional no-error) +(defmethod token-to-object (syntax (token incomplete-string-form) &key no-error) (declare (ignore no-error)) (read-from-string (concatenate 'string (token-string syntax token) "\""))) -(defmethod token-to-object (syntax (token complete-string-form) &optional no-error) +(defmethod token-to-object (syntax (token complete-string-form) &key no-error) (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token quote-form) &optional no-error) +(defmethod token-to-object (syntax (token quote-form) &key no-error) (list 'cl:quote - (token-to-object syntax (second (children token)) no-error))) + (token-to-object syntax (second (children token)) :no-error no-error))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -2111,8 +2114,8 @@ (values tree 1) (let ((first-child (elt-noncomment (children tree) 1))) (cond ((and (typep first-child 'token-mixin) - (token-to-symbol syntax first-child)) - (compute-list-indentation syntax (token-to-symbol syntax first-child) tree path)) + (token-to-object syntax first-child)) + (compute-list-indentation syntax (token-to-object syntax first-child) tree path)) ((null (cdr path)) ;; top level (if (= (car path) 2) From thenriksen at common-lisp.net Tue May 2 17:04:37 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 13:04:37 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060502170437.741A01A000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24098 Modified Files: lisp-syntax.lisp Log Message: Fixed `form-operator'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:33:33 1.60 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 17:04:37 1.61 @@ -1272,7 +1272,7 @@ (defmethod form-operator ((form list-form) syntax) (let* ((operator-token (first-form (rest (children form)))) (operator-symbol (when operator-token - (token-to-object syntax operator-token t)))) + (token-to-object syntax operator-token :no-error t)))) operator-symbol)) (defgeneric form-operands (form syntax) From thenriksen at common-lisp.net Tue May 2 17:47:19 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 13:47:19 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060502174719.BF76D4D009@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv30253 Modified Files: lisp-syntax.lisp Log Message: Proper indentation of multi-line string forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 17:04:37 1.61 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 17:47:19 1.62 @@ -2089,6 +2089,9 @@ (values (elt-noncomment (children tree) (1- (car path))) 0)) (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) +(defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) + (values (form-toplevel tree syntax) 0)) + ;; FIXME: The next two methods are basically identical to the above definition, ;; something should be done about this duplication. From thenriksen at common-lisp.net Tue May 2 18:01:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 14:01:49 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060502180149.307E56102A@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv496 Modified Files: packages.lisp esa.lisp Log Message: Added command and command-binding description functions. --- /project/climacs/cvsroot/esa/packages.lisp 2006/04/08 23:36:44 1.2 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/05/02 18:01:49 1.3 @@ -9,6 +9,9 @@ #: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 #:set-key #:find-applicable-command-table)) --- /project/climacs/cvsroot/esa/esa.lisp 2006/04/30 11:59:03 1.8 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/02 18:01:49 1.9 @@ -639,6 +639,67 @@ :height (* length (stream-line-height stream))) (scroll-extent stream 0 0)))) +(defun print-docstring-for-command (command-name &optional (stream *standard-output*)) + "Print documentation for `command-name', which should + be a symbol bound to a function, to `stream. If no + documentation can be found, this fact will be printed to the stream." + ;; Eventually, we should try to parse the docstring and hyperlink + ;; it to other relevant symbols. + (let ((command-documentation (or (documentation command-name 'function) + "This command is not documented."))) + (princ command-documentation stream))) + +(defun describe-command-binding-to-stream (gesture-name command &key + (command-table (find-applicable-command-table *application-frame*)) + (stream *standard-output*)) + "Describe `command' as invoked by `gesture' to `stream'." + (let* ((command-name (if (listp command) + (first command) + command)) + (command-args (if (listp command) + (rest command))) + (real-command-table (or (command-accessible-in-command-table-p + command-name + command-table) + command-table))) + (princ "The gesture " stream) + (with-text-face (stream :italic) + (princ gesture-name 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 :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)) + (terpri stream) + (print-docstring-for-command command-name stream))) + +(defun describe-command-to-stream (command-name &key + (command-table (esa: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))) + (present command-name 'command-name :stream stream) + (princ " calls the function " stream) + (present command-name 'symbol :stream stream) + (princ " and is accessible in " stream) + (present (command-accessible-in-command-table-p command-name command-table) 'command-table + :stream stream) + (format stream ".~%") + (when (plusp (length keystrokes)) + (princ "It is bound to " stream) + (loop for gestures-list on (first keystrokes) + do (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 stream))) + ;;; help commands (define-command-table help-table) From thenriksen at common-lisp.net Tue May 2 18:02:15 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 14:02:15 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060502180215.29B9B62010@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv632 Modified Files: gui.lisp Log Message: Added new help commands. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/01 18:36:41 1.210 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/02 18:02:15 1.211 @@ -478,3 +478,49 @@ (set-key 'com-kill-buffer 'pane-table '((#\x :control) (#\k))) + +;;; Commands for calling 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)))))) + +(define-command (com-describe-command :name t :command-table 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 + 'help-table + '((#\h :control) (#\k))) + +(set-key '(com-describe-command nil) + '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)) \ No newline at end of file From thenriksen at common-lisp.net Tue May 2 19:59:21 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 2 May 2006 15:59:21 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060502195921.D49157E000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv14735 Modified Files: syntax.lisp misc-commands.lisp Log Message: Make Climacs not signal an error when an invalid syntax is input. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/04/23 12:11:26 1.62 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/05/02 19:59:21 1.63 @@ -258,7 +258,10 @@ :value-key #'syntax-description-class-name)) :partial-completers '(#\Space) :allow-any-input t) - (declare (ignore success string)) + (declare (ignore success)) + (if (find string *syntaxes* :key #'first :test #'string=) + (values object type) + (input-not-of-required-type string type)) object)) (defun syntax-from-name (syntax) --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/30 15:12:05 1.7 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/02 19:59:21 1.8 @@ -786,7 +786,10 @@ (define-command (com-set-syntax :name t :command-table buffer-table) () (let* ((pane (current-window)) (buffer (buffer pane))) - (set-syntax buffer (accept 'syntax :prompt "Set Syntax")))) + (handler-case (set-syntax buffer (accept 'syntax :prompt "Set Syntax")) + (input-not-of-required-type + (message) + (display-message "Invalid syntax: ~A." message))))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands From thenriksen at common-lisp.net Wed May 3 16:14:27 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 3 May 2006 12:14:27 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060503161427.AA97634024@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12922 Modified Files: lisp-syntax.lisp Log Message: Added `incomplete-character-lexeme' class and removed duplicate definition of `form-operator' (oops). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 17:47:19 1.62 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/03 16:14:27 1.63 @@ -210,6 +210,7 @@ (defclass comma-at-lexeme (lisp-lexeme) ()) (defclass comma-dot-lexeme (lisp-lexeme) ()) (defclass form-lexeme (form lisp-lexeme) ()) +(defclass incomplete-character-lexeme (form-lexeme incomplete-form-mixin) ()) (defclass character-lexeme (form-lexeme) ()) (defclass function-lexeme (lisp-lexeme) ()) (defclass line-comment-start-lexeme (lisp-lexeme) ()) @@ -301,7 +302,7 @@ (make-instance 'error-lexeme)) (#\\ (fo) (cond ((end-of-buffer-p scan) - (make-instance 'incomplete-lexeme)) + (make-instance 'incomplete-character-lexeme)) ((not (constituentp (object-after scan))) (fo) (make-instance 'character-lexeme)) (t (loop until (end-of-buffer-p scan) @@ -1835,17 +1836,6 @@ (defun in-comment-p (mark syntax) (in-type-p mark syntax 'comment)) -(defgeneric form-operator (form syntax) - (:documentation "Return the operator of `form' as a -symbol. Returns nil if none can be found.") - (:method (form syntax) nil)) - -(defmethod form-operator ((form list-form) syntax) - (let* ((operator-token (first-noncomment (rest (children form)))) - (operator-symbol (when operator-token - (token-to-object syntax operator-token)))) - operator-symbol)) - ;;; shamelessly replacing SWANK code ;; We first work through the string removing the characters and noting ;; which ones are escaped. We then replace each character with the From crhodes at common-lisp.net Thu May 4 08:06:29 2006 From: crhodes at common-lisp.net (crhodes) Date: Thu, 4 May 2006 04:06:29 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060504080629.5A26012034@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv8949 Modified Files: esa.lisp Log Message: Handle parse errors on the minibuffer. Not completely ideal, but probably mostly works right now. Will work better with the new command processor. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/02 18:01:49 1.9 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/04 08:06:29 1.10 @@ -59,6 +59,17 @@ (declare (ignore type args)) (window-clear pane)) +(defmethod stream-accept :around ((pane minibuffer-pane) type &rest args) + (declare (ignore args)) + ;; FIXME: this isn't the friendliest way of indicating a parse + ;; error: there's no feedback, unlike emacs' quite nice "[no + ;; match]". + (loop + (handler-case + (return (call-next-method)) + (parse-error () + nil)))) + (defun display-minibuffer (frame pane) (declare (ignore frame)) (when (message pane) From crhodes at common-lisp.net Thu May 4 08:08:36 2006 From: crhodes at common-lisp.net (crhodes) Date: Thu, 4 May 2006 04:08:36 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060504080836.EF5661A000@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv9089 Modified Files: esa.lisp Log Message: Fix esa describe-bindings. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/04 08:06:29 1.10 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/04 08:08:36 1.11 @@ -610,7 +610,10 @@ results)) (defun sort-by-name (list) - (sort list #'string< :key (lambda (item) (symbol-name (second item))))) + (sort list #'string< :key (lambda (item) + (symbol-name (if (listp (cdr item)) + (cadr item) + (cdr item)))))) (defun sort-by-keystrokes (list) (sort list (lambda (a b) @@ -628,10 +631,11 @@ (defun describe-bindings (stream command-table &optional (sort-function #'sort-by-name)) (formatting-table (stream) - (loop for (keys command) + (loop for (keys . command) in (funcall sort-function (find-all-keystrokes-and-commands-with-inheritance command-table)) + when (consp command) do (setq command (car command)) do (formatting-row (stream) (formatting-cell (stream :align-x :right) (with-text-style (stream '(:sans-serif nil nil)) From dmurray at common-lisp.net Thu May 4 18:32:38 2006 From: dmurray at common-lisp.net (dmurray) Date: Thu, 4 May 2006 14:32:38 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060504183238.3CE13305A@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv26407 Modified Files: esa.lisp Log Message: Added some docstrings for commands. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/04 08:08:36 1.11 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/04 18:32:38 1.12 @@ -471,6 +471,8 @@ (define-command-table global-esa-table) (define-command (com-quit :name t :command-table global-esa-table) () + "Exit Climacs. +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*)) (set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control))) @@ -479,6 +481,7 @@ :name t :command-table global-esa-table) () + "Prompt for a command name and arguments, then run it." (let ((item (handler-case (accept `(command :command-table ,(find-applicable-command-table *application-frame*)) @@ -720,6 +723,7 @@ (define-command-table help-table) (define-command (com-describe-key-briefly :name t :command-table help-table) () + "Prompt for a key and show the command it invokes." (display-message "Describe key briefly:") (redisplay-frame-panes *application-frame*) (describe-key-briefly (car (windows *application-frame*)))) @@ -727,6 +731,7 @@ (set-key 'com-describe-key-briefly 'help-table '((#\h :control) (#\c))) (define-command (com-where-is :name t :command-table help-table) () + "Prompt for a command name and show the key that invokes it." (let* ((command-table (command-table (car (windows *application-frame*)))) (command (handler-case @@ -749,6 +754,8 @@ (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. +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") @@ -774,6 +781,8 @@ :name t :command-table keyboard-macro-table) () + "Start recording keys to define a keyboard macro. +Use C-x ) to finish recording the macro, and C-x e to run it." (setf (recordingp *application-frame*) t) (setf (recorded-keys *application-frame*) '())) @@ -783,6 +792,8 @@ :name t :command-table keyboard-macro-table) () + "Finish recording keys that define a keyboard macro. +Use C-x ( to start recording a macro, and C-x e to run it." (setf (recordingp *application-frame*) nil) (setf (recorded-keys *application-frame*) ;; this won't work if the command was invoked in any old way @@ -794,6 +805,8 @@ :name t :command-table keyboard-macro-table) () + "Run the last keyboard macro that was defined. +Use C-x ( to start and C-x ) to finish recording a keyboard macro." (setf (remaining-keys *application-frame*) (recorded-keys *application-frame*)) (setf (executingp *application-frame*) t)) From dmurray at common-lisp.net Thu May 4 18:53:52 2006 From: dmurray at common-lisp.net (dmurray) Date: Thu, 4 May 2006 14:53:52 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060504185352.E564E13002@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28462 Modified Files: file-commands.lisp Log Message: Added some docstrings to commands. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 19:37:58 1.9 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/04 18:53:52 1.10 @@ -251,6 +251,8 @@ (user-homedir-pathname))))) (define-command (com-find-file :name t :command-table buffer-table) () + "Prompt for a filename then edit that file. +If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." (let* ((filepath (accept 'pathname :prompt "Find File" :default (directory-of-buffer (buffer (current-window))) :default-type 'pathname @@ -298,6 +300,8 @@ nil))))))) (define-command (com-find-file-read-only :name t :command-table buffer-table) () + "Prompt for a filename then open that file readonly. +If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error." (let ((filepath (accept 'pathname :Prompt "Find file read only" :default (directory-of-buffer (buffer (current-window))) :default-type 'pathname @@ -309,6 +313,8 @@ '((#\x :control) (#\r :control))) (define-command (com-read-only :name t :command-table buffer-table) () + "Toggle the readonly status of the current buffer. +When a buffer is readonly, attempts to change the contents of the buffer signal an error." (let ((buffer (buffer (current-window)))) (setf (read-only-p buffer) (not (read-only-p buffer))))) @@ -322,6 +328,8 @@ (needs-saving buffer) t)) (define-command (com-set-visited-file-name :name t :command-table buffer-table) () + "Prompt for a new filename for the current buffer. +The next time the buffer is saved it will be saved to a file with that filename." (let ((filename (accept 'pathname :prompt "New file name" :default (directory-of-buffer (buffer (current-window))) :default-type 'pathname @@ -329,6 +337,8 @@ (set-visited-file-name filename (buffer (current-window))))) (define-command (com-insert-file :name t :command-table buffer-table) () + "Prompt for a filename and insert its contents at point. +Leaves mark after the inserted contents." (let ((filename (accept 'pathname :prompt "Insert File" :default (directory-of-buffer (buffer (current-window))) :default-type 'pathname @@ -349,6 +359,8 @@ '((#\x :control) (#\i :control))) (define-command (com-revert-buffer :name t :command-table buffer-table) () + "Replace the contents of the current buffer with the visited file. +Signals an error if the file does not exist." (let* ((pane (current-window)) (buffer (buffer pane)) (filepath (filepath buffer)) @@ -389,6 +401,8 @@ (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." (let ((buffer (buffer (current-window)))) (if (or (null (filepath buffer)) (needs-saving buffer)) @@ -418,6 +432,8 @@ (call-next-method))) (define-command (com-write-buffer :name t :command-table buffer-table) () + "Prompt for a filename and write the current buffer to it. +Changes the file visted by the buffer to the given file." (let ((filepath (accept 'pathname :prompt "Write Buffer to File" :default (directory-of-buffer (buffer (current-window))) :default-type 'pathname From dmurray at common-lisp.net Thu May 4 19:03:46 2006 From: dmurray at common-lisp.net (dmurray) Date: Thu, 4 May 2006 15:03:46 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060504190346.ED3DC1A000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv30103 Modified Files: gui.lisp Log Message: Added some docstrings to commands. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/02 18:02:15 1.211 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/04 19:03:46 1.212 @@ -314,6 +314,8 @@ (find-command-table 'global-climacs-table))) (define-command (com-full-redisplay :name t :command-table base-table) () + "Redisplay the contents of the current window. +FIXME: does this really have that effect?" (full-redisplay (current-window))) (set-key 'com-full-redisplay @@ -332,6 +334,8 @@ (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))) @@ -429,6 +433,8 @@ ;; (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 @@ -469,6 +475,8 @@ (kill-buffer (buffer (current-window)))) (define-command (com-kill-buffer :name t :command-table pane-table) () + "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)) From dmurray at common-lisp.net Thu May 4 20:30:30 2006 From: dmurray at common-lisp.net (dmurray) Date: Thu, 4 May 2006 16:30:30 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060504203030.0FA9A4D00C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8008 Modified Files: misc-commands.lisp Log Message: Added some docstrings for commands. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/02 19:59:21 1.8 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/04 20:30:29 1.9 @@ -36,6 +36,8 @@ (evaluate-local-options-line (current-buffer))) (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." (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) @@ -44,6 +46,8 @@ '((:insert))) (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." (setf (needs-saving (buffer (current-window))) nil)) (set-key 'com-not-modified @@ -52,6 +56,8 @@ (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." (set-fill-column column)) (set-key `(com-set-fill-column ,*numeric-argument-marker*) @@ -97,6 +103,7 @@ (loop repeat count do (insert-character *current-gesture*))) (define-command (com-beginning-of-line :name t :command-table movement-table) () + "Move point to the beginning of the current line." (beginning-of-line (point (current-window)))) (set-key 'com-beginning-of-line @@ -108,6 +115,7 @@ '((#\a :control))) (define-command (com-end-of-line :name t :command-table movement-table) () + "Move point to the end of the current line." (end-of-line (point (current-window)))) (set-key 'com-end-of-line @@ -121,6 +129,8 @@ (define-command (com-delete-object :name t :command-table deletion-table) ((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." (let* ((point (point (current-window))) (mark (clone-mark point))) (forward-object mark count) @@ -142,6 +152,8 @@ (define-command (com-backward-delete-object :name t :command-table deletion-table) ((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." (let* ((point (point (current-window))) (mark (clone-mark point))) (backward-object mark count) @@ -156,6 +168,8 @@ '(#\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. +Characters can be entered in #\ format." (let* ((item (handler-case (accept 't :prompt "Zap to Object") (error () (progn (beep) (display-message "Not a valid object") @@ -167,6 +181,8 @@ (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." (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. ") @@ -196,6 +212,9 @@ (forward-object mark)))) (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." (transpose-objects (point (current-window)))) (set-key 'com-transpose-objects @@ -204,6 +223,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." (backward-object (point (current-window)) count)) (set-key `(com-backward-object ,*numeric-argument-marker*) @@ -216,6 +237,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." (forward-object (point (current-window)) count)) (set-key `(com-forward-object ,*numeric-argument-marker*) @@ -250,6 +273,9 @@ (forward-word mark)))) (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)." (transpose-words (point (current-window)))) (set-key 'com-transpose-words @@ -279,6 +305,8 @@ (insert-object mark #\Newline))) (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." (transpose-lines (point (current-window)))) (set-key 'com-transpose-lines @@ -287,6 +315,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'." (let* ((window (current-window)) (point (point window))) (unless (or (eq (previous-command window) 'com-previous-line) @@ -306,6 +336,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'." (let* ((window (current-window)) (point (point window))) (unless (or (eq (previous-command window) 'com-previous-line) @@ -325,6 +357,8 @@ (define-command (com-open-line :name t :command-table editing-table) ((numarg 'integer :prompt "How many lines?")) + "Insert a #\Newline and leave point before it. +With a numeric argument greater than 1, insert that many #\Newlines." (open-line (point (current-window)) numarg)) (set-key `(com-open-line ,*numeric-argument-marker*) @@ -362,6 +396,8 @@ (define-command (com-kill-line :name t :command-table deletion-table) ((numarg 'integer :prompt "Kill how many lines?") (numargp 'boolean :prompt "Kill entire lines?")) + "Kill the objects on the current line after point. +When at the end of a line, kill the #\Newline. With a numeric argument of 0, kill the objects on the current line before point. With a non-zero numeric argument, kill that many lines forward (backward, if negative) from point. Successive kills append to the kill ring." (let* ((pane (current-window)) (point (point pane)) (concatenate-p (eq (previous-command pane) 'com-kill-line))) @@ -373,6 +409,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." (if (plusp count) (forward-word (point (current-window)) count) (backward-word (point (current-window)) (- count)))) @@ -387,6 +425,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." (backward-word (point (current-window)) count)) (set-key `(com-backward-word ,*numeric-argument-marker*) @@ -399,6 +439,8 @@ (define-command (com-delete-word :name t :command-table deletion-table) ((count 'integer :prompt "Number of words")) + "Delete from point until the next word end. +With a positive numeric argument, delete that many words forward." (delete-word (point (current-window)) count)) (defun kill-word (mark &optional (count 1) (concatenate-p nil)) @@ -423,6 +465,8 @@ (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." (let* ((pane (current-window)) (point (point pane)) (concatenate-p (eq (previous-command pane) 'com-kill-word))) @@ -434,6 +478,8 @@ (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." (let* ((pane (current-window)) (point (point pane)) (concatenate-p (eq (previous-command pane) 'com-backward-kill-word))) @@ -445,6 +491,8 @@ (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." (let* ((pane (current-window)) (point (point pane)) (mark (mark pane))) @@ -460,21 +508,28 @@ (define-command (com-backward-delete-word :name t :command-table deletion-table) ((count 'integer :prompt "Number of words")) + "Delete from point until the previous word beginning. +With a positive numeric argument, delete that many words backward." (backward-delete-word (point (current-window)) count)) (define-command (com-upcase-region :name t :command-table case-table) () + "Convert the region to upper case." (let ((cw (current-window))) (upcase-region (mark cw) (point cw)))) (define-command (com-downcase-region :name t :command-table case-table) () + "Convert the region to lower case." (let ((cw (current-window))) (downcase-region (mark cw) (point cw)))) (define-command (com-capitalize-region :name t :command-table case-table) () + "Capitalize each word in the region." (let ((cw (current-window))) (capitalize-region (mark cw) (point cw)))) (define-command (com-upcase-word :name t :command-table case-table) () + "Convert the characters from point until the next word end to upper case. +Leave point at the word end." (upcase-word (point (current-window)))) (set-key 'com-upcase-word @@ -482,6 +537,8 @@ '((#\u :meta))) (define-command (com-downcase-word :name t :command-table case-table) () + "Convert the characters from point until the next word end to lower case. +Leave point at the word end." (downcase-word (point (current-window)))) (set-key 'com-downcase-word @@ -489,6 +546,8 @@ '((#\l :meta))) (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." (capitalize-word (point (current-window)))) (set-key 'com-capitalize-word @@ -496,11 +555,15 @@ '((#\c :meta))) (define-command (com-tabify-region :name t :command-table editing-table) () + "Replace runs of spaces with tabs in region where possible. +Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane." (let ((pane (current-window))) (tabify-region (mark pane) (point pane) (tab-space-count (stream-default-view pane))))) (define-command (com-untabify-region :name t :command-table editing-table) () + "Replace tabs with equivalent runs of spaces in the region. +Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane." (let ((pane (current-window))) (untabify-region (mark pane) (point pane) (tab-space-count (stream-default-view pane))))) @@ -568,6 +631,8 @@ (indent-region pane point mark))) (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." (delete-indentation (point (current-window)))) (set-key 'com-delete-indentation @@ -603,6 +668,7 @@ '((#\q :meta))) (define-command (com-beginning-of-buffer :name t :command-table movement-table) () + "Move point to the beginning of the buffer." (beginning-of-buffer (point (current-window)))) (set-key 'com-beginning-of-buffer @@ -638,6 +704,7 @@ '((:prior))) (define-command (com-end-of-buffer :name t :command-table movement-table) () + "Move point to the end of the buffer." (end-of-buffer (point (current-window)))) (set-key 'com-end-of-buffer @@ -649,6 +716,7 @@ '((:end :control))) (define-command (com-mark-whole-buffer :name t :command-table marking-table) () + "Place point at the beginning and mark at the end of the buffer." (beginning-of-buffer (point (current-window))) (end-of-buffer (mark (current-window)))) @@ -663,6 +731,8 @@ do (forward-object mark))) (define-command (com-back-to-indentation :name t :command-table movement-table) () + "Move point to the first non-whitespace object on the current line. +If there is no non-whitespace object, leaves point at the end of the line." (back-to-indentation (point (current-window)))) (set-key 'com-back-to-indentation @@ -683,6 +753,8 @@ (define-command (com-delete-horizontal-space :name t :command-table deletion-table) ((backward-only-p 'boolean :prompt "Delete backwards only?")) + "Delete whitespace around point. +With a numeric argument, only delete whitespace before point." (delete-horizontal-space (point (current-window)) backward-only-p)) (set-key `(com-delete-horizontal-space ,*numeric-argument-p*) @@ -705,6 +777,9 @@ (define-command (com-just-one-space :name t :command-table deletion-table) ((count 'integer :prompt "Number of spaces")) + "Delete whitespace around point, leaving a single space. +With a positive numeric argument, leave that many spaces. +FIXME: should distinguish between types of whitespace." (just-one-space (point (current-window)) count)) (set-key `(com-just-one-space ,*numeric-argument-marker*) @@ -715,6 +790,7 @@ (setf (offset mark) pos)) (define-command (com-goto-position :name t :command-table movement-table) () + "Prompts for an integer, and sets the offset of point to that integer." (goto-position (point (current-window)) (handler-case (accept 'integer :prompt "Goto Position") @@ -735,6 +811,8 @@ (setf (offset mark) (offset m)))) (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." (goto-line (point (current-window)) (handler-case (accept 'integer :prompt "Goto Line") (error () (progn (beep) @@ -749,6 +827,7 @@ (ccl:run-program "/usr/bin/open" `(,url) :wait nil))) (define-command (com-set-mark :name t :command-table marking-table) () + "Set mark to the current position of point." (let ((pane (current-window))) (setf (mark pane) (clone-mark (point pane))))) @@ -757,6 +836,7 @@ '((#\Space :control))) (define-command (com-exchange-point-and-mark :name t :command-table marking-table) () + "Exchange the positions of point and mark." (let ((pane (current-window))) (psetf (offset (mark pane)) (offset (point pane)) (offset (point pane)) (offset (mark pane))))) @@ -784,6 +864,8 @@ (display-message "No such syntax: ~A." syntax))))) (define-command (com-set-syntax :name t :command-table buffer-table) () + "Prompts for a syntax to set for the current buffer. +Setting a syntax will cause the buffer to be reparsed using the new syntax." (let* ((pane (current-window)) (buffer (buffer pane))) (handler-case (set-syntax buffer (accept 'syntax :prompt "Set Syntax")) @@ -796,6 +878,7 @@ ;; Copies an element from a kill-ring to a buffer at the given offset (define-command (com-yank :name t :command-table editing-table) () + "Insert the objects most recently added to the kill ring at point." (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))) (set-key 'com-yank @@ -804,6 +887,8 @@ ;; Destructively cut a given buffer region into the kill-ring (define-command (com-kill-region :name t :command-table editing-table) () + "Kill the objects between point and mark. +That is, push them onto the kill ring, and delete them from the buffer." (let ((pane (current-window))) (kill-ring-standard-push [325 lines skipped] From dmurray at common-lisp.net Sat May 6 06:27:14 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 6 May 2006 02:27:14 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506062714.EA11E23000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6143 Modified Files: pane.lisp packages.lisp file-commands.lisp Log Message: Changed backup behaviour. Now makes emacs-style versioned backups (foo.lisp~42~) once per session. Also checks to see if the file has changed on disk when saving and reverting. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/04/23 19:37:58 1.37 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/05/06 06:27:14 1.38 @@ -227,8 +227,10 @@ (defparameter +climacs-textual-view+ (make-instance 'climacs-textual-view)) -(defclass filepath-mixin () - ((filepath :initform nil :accessor filepath))) +(defclass file-mixin () + ((filepath :initform nil :accessor filepath) + (file-saved-p :initform nil :accessor file-saved-p) + (file-write-time :initform nil :accessor file-write-time))) ;(defgeneric indent-tabs-mode (climacs-buffer)) @@ -238,7 +240,7 @@ (defclass extended-binseq2-buffer (read-only-mixin binseq2-buffer p-undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks.")) -(defclass climacs-buffer (delegating-buffer filepath-mixin name-mixin) +(defclass climacs-buffer (delegating-buffer file-mixin name-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :accessor syntax) (point :initform nil :initarg :point :accessor point) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/05/01 18:36:41 1.91 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/06 06:27:14 1.92 @@ -145,7 +145,8 @@ (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :flexichain :undo) - (:export #:climacs-buffer #:needs-saving #:filepath + (:export #:climacs-buffer #:needs-saving + #:filepath #:file-saved-p #:file-write-time #:read-only-p #:buffer-read-only #:climacs-pane #:point #:mark #:clear-cache --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/04 18:53:52 1.10 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 06:27:14 1.11 @@ -212,7 +212,7 @@ (switch-to-buffer existing-buffer) (let ((buffer (make-buffer)) (pane (current-window))) - ;; Clear the panes cache; otherwise residue from the + ;; Clear the pane's cache; otherwise residue from the ;; previously displayed buffer may under certain ;; circumstances be displayed. (clear-cache pane) @@ -223,6 +223,7 @@ (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-local-options-line buffer)) @@ -242,7 +243,7 @@ (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 users home + If BUFFER does not have a filepath, the path to the user's home directory will be returned." (make-pathname :directory @@ -324,6 +325,8 @@ (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)) @@ -371,15 +374,51 @@ (display-message "~A is a directory name." filepath) (beep)) ((probe-file filepath) + (unless (check-file-times buffer filepath "Revert" "reverted") + (return-from com-revert-buffer)) (erase-buffer buffer) (with-open-file (stream filepath :direction :input) (input-from-stream stream buffer 0)) - (setf (offset (point pane)) - (min (size buffer) save))) + (setf (offset (point pane)) (min (size buffer) save) + (file-saved-p buffer) nil)) (t (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")))) @@ -388,16 +427,22 @@ (display-message "~A is a directory." filepath) (beep)) (t - (when (probe-file filepath) + (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 (concatenate 'string (pathname-type 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)))) + :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 buffer)) + (display-message "Wrote: ~a" filepath) (setf (needs-saving buffer) nil))))) (define-command (com-save-buffer :name t :command-table buffer-table) () From dmurray at common-lisp.net Sat May 6 11:41:57 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 6 May 2006 07:41:57 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506114157.A62A01A000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11198 Modified Files: file-commands.lisp Log Message: Made local-options parsing a bit more robust, removed dependence on split-sequence, and added command Reparse Attribute List (a la Zmacs). Changed terminology from 'local options' to 'attribute line/list'. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 06:27:14 1.11 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 11:41:57 1.12 @@ -129,20 +129,8 @@ :key #'climacs-syntax::syntax-description-pathname-types)) 'basic-syntax)) -(defun parse-local-options-line (line) - "Parse the local options line `line' and return an alist - mapping options to values. All option names will be coerced to - uppercase. `Line' must be stripped of the leading and - terminating -*- tokens." - (loop for pair in (split-sequence:split-sequence #\; line) - when (find #\: pair) - collect (destructuring-bind (key value) - (loop for elem in (split-sequence:split-sequence #\: pair) - collecting (string-trim " " elem)) - (list (string-upcase key) value)))) - -(defun evaluate-local-options (buffer options) - "Evaluate the local options `options' and modify `buffer' as +(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 @@ -152,8 +140,8 @@ (let ((specified-syntax (syntax-from-name (second (find-if #'(lambda (name) - (or (string= name "SYNTAX") - (string= name "MODE"))) + (or (string-equal name "SYNTAX") + (string-equal name "MODE"))) options :key #'first))))) (when specified-syntax @@ -163,32 +151,74 @@ ;; Now we iterate through the options (discarding SYNTAX and MODE ;; options). (loop for (name value) in options - unless (or (string= name "SYNTAX") - (string= name "MODE")) + unless (or (string-equal name "SYNTAX") + (string-equal name "MODE")) do (eval-option (syntax buffer) name value))) -(defun evaluate-local-options-line (buffer) - "Evaluate the local options line of `buffer'. If `buffer' does - not have a local options line, this function is a no-op." - ;; This could be simplified a bit by using regexps. - (let* ((beginning-mark (beginning-of-buffer - (clone-mark (point buffer)))) - (end-mark (end-of-line (clone-mark beginning-mark))) - (line (buffer-sequence buffer (offset beginning-mark) (offset end-mark))) - (first-occurence (search "-*-" line)) - (second-occurence - (when first-occurence - (search "-*-" line :start2 (1+ first-occurence))))) - (when (and first-occurence - second-occurence) - ;; Strip away the -*-s. - (let ((cleaned-options-line (coerce (subseq line - (+ first-occurence 3) - second-occurence) - 'string))) - (evaluate-local-options - buffer - (parse-local-options-line cleaned-options-line)))))) +(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 (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 +from the corresponding value by a colon. If another keyword-value pair +follows, the value should be terminated by a colon. The attribute list +is surrounded by '-*-' sequences, but the opening '-*-' need not be at the +beginning of the line. Climacs looks for the attribute list +on the first or second non-blank line of the file. + +An example attribute-list is: + +;; -*- Syntax: Lisp; Base: 10 -*- " + (evaluate-attributes-line (buffer (current-window)))) ;; Adapted from cl-fad/PCL (defun directory-pathname-p (pathspec) From dmurray at common-lisp.net Sat May 6 11:57:23 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 6 May 2006 07:57:23 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506115723.80E821E005@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12867 Modified Files: syntax.lisp lisp-syntax.lisp Log Message: Fixed some string-upcasing issues with my earlier changes. Made lisp-syntax accept attribute-line specified packages that aren't in the image yet (like IN-PACKAGE handling does). --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/05/02 19:59:21 1.63 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/05/06 11:57:23 1.64 @@ -218,7 +218,7 @@ (defmethod eval-option :around (syntax (name string) value) ;; Convert the name to a keyword symbol... - (eval-option syntax (intern name (find-package :keyword)) + (eval-option syntax (intern (string-upcase name) (find-package :keyword)) value)) (defmacro define-option-for-syntax --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/03 16:14:27 1.63 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/06 11:57:23 1.64 @@ -50,7 +50,7 @@ (option-specified-package :accessor option-specified-package :initform nil :documentation "The package - specified in the local options + specified in the attribute line (may be overridden by (in-package) forms).")) (:name "Lisp") @@ -59,8 +59,7 @@ (define-option-for-syntax lisp-syntax "Package" (syntax package-name) (let ((specified-package (find-package package-name))) - (when specified-package - (setf (option-specified-package syntax) specified-package)))) + (setf (option-specified-package syntax) (or specified-package package-name)))) (define-option-for-syntax lisp-syntax "Base" (syntax base) (let ((integer-base (parse-integer base :junk-allowed t))) From thenriksen at common-lisp.net Sat May 6 15:38:43 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 6 May 2006 11:38:43 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506153843.14DFE5D0F6@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12374 Modified Files: misc-commands.lisp file-commands.lisp Log Message: Made `find-file' use `evaluate-attributes-line' and removed the now obsolete `com-reload-local-options-line'. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/04 20:30:29 1.9 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/06 15:38:42 1.10 @@ -28,13 +28,6 @@ (in-package :climacs-gui) -(define-command (com-reload-local-options-line - :name t - :command-table buffer-table) - () - "Reload the local options line." - (evaluate-local-options-line (current-buffer))) - (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." --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 11:41:57 1.12 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 15:38:42 1.13 @@ -256,7 +256,7 @@ (setf (file-write-time buffer) (file-write-date filepath)) ;; A file! That means we may have a local options ;; line to parse. - (evaluate-local-options-line buffer)) + (evaluate-attributes-line buffer)) ;; If the local options line didn't set a syntax, do ;; it now. (when (null (syntax buffer)) @@ -486,7 +486,7 @@ (set-key 'com-save-buffer 'buffer-table - '((#\x :control) (#\s :control))) +n '((#\x :control) (#\s :control))) (defmethod frame-exit :around ((frame climacs) #-mcclim &key) (loop for buffer in (buffers frame) From thenriksen at common-lisp.net Sat May 6 15:40:47 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 6 May 2006 11:40:47 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506154047.D82B06400A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12519 Modified Files: file-commands.lisp Log Message: Fixed typo. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 15:38:42 1.13 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 15:40:47 1.14 @@ -486,7 +486,7 @@ (set-key 'com-save-buffer 'buffer-table -n '((#\x :control) (#\s :control))) + '((#\x :control) (#\s :control))) (defmethod frame-exit :around ((frame climacs) #-mcclim &key) (loop for buffer in (buffers frame) From thenriksen at common-lisp.net Sat May 6 17:23:33 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 6 May 2006 13:23:33 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506172333.659D43A008@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24921 Modified Files: lisp-syntax.lisp Log Message: Now calling `buffer-substring' and `token-string' instead of `buffer-subsequence'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/06 11:57:23 1.64 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/06 17:23:33 1.65 @@ -1141,29 +1141,22 @@ (let ((package-name (typecase package-form (token-mixin - (coerce (buffer-sequence - buffer - (start-offset package-form) - (end-offset package-form)) - 'string)) + (token-string syntax package-form)) (complete-string-form - (coerce (buffer-sequence - buffer - (1+ (start-offset package-form)) - (1- (end-offset package-form))) - 'string)) + (buffer-substring + buffer + (1+ (start-offset package-form)) + (1- (end-offset package-form)))) (quote-form - (coerce (buffer-sequence - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form)))) - 'string)) + (buffer-substring + buffer + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form))))) (uninterned-symbol-form - (coerce (buffer-sequence - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form)))) - 'string)) + (buffer-substring + buffer + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form))))) (t 'nil)))) (when package-name (let ((package-symbol (parse-token package-name))) @@ -1430,10 +1423,7 @@ (defmethod display-parse-tree ((parse-symbol token-mixin) (syntax lisp-syntax) pane) (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) - (let ((string (coerce (buffer-sequence (buffer syntax) - (start-offset parse-symbol) - (end-offset parse-symbol)) - 'string))) + (let ((string (token-string syntax parse-symbol))) (multiple-value-bind (symbol status) (token-to-object syntax parse-symbol) (with-output-as-presentation @@ -1471,10 +1461,7 @@ (with-slots (ink face) parser-symbol (setf ink (medium-ink (sheet-medium pane)) face (text-style-face (medium-text-style (sheet-medium pane)))) - (let ((string (coerce (buffer-sequence (buffer syntax) - (start-offset parser-symbol) - (end-offset parser-symbol)) - 'string))) + (let ((string (token-string syntax parser-symbol))) (present string 'string :stream pane)))))) (defmethod display-parse-tree :before ((parse-symbol lisp-lexeme) (syntax lisp-syntax) pane) @@ -1487,10 +1474,9 @@ (defmethod display-parse-tree ((parse-symbol complete-string-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) (if (third children) - (let ((string (coerce (buffer-sequence (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children 2)))) - 'string))) + (let ((string (buffer-substring (buffer syntax) + (start-offset (second children)) + (end-offset (car (last children 2)))))) (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) (display-parse-tree (pop children) syntax pane) @@ -1504,10 +1490,9 @@ (defmethod display-parse-tree ((parse-symbol incomplete-string-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) (if (second children) - (let ((string (coerce (buffer-sequence (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children)))) - 'string))) + (let ((string (buffer-substring (buffer syntax) + (start-offset (second children)) + (end-offset (car (last children)))))) (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) (display-parse-tree (pop children) syntax pane) @@ -1553,10 +1538,7 @@ "The KEYWORD package.") (defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) - (let* ((string (coerce (buffer-sequence (buffer syntax) - (start-offset conditional) - (end-offset conditional)) - 'string)) + (let* ((string (token-string syntax conditional)) (symbol (parse-symbol string :package +keyword-package+))) (member symbol *features*))) @@ -1572,10 +1554,7 @@ (remove-if #'(lambda (child) (typep child 'comment)) children)))) - (type-string (coerce (buffer-sequence (buffer syntax) - (start-offset type) - (end-offset type)) - 'string)) + (type-string (token-string syntax type)) (type-symbol (parse-symbol type-string :package +keyword-package+))) (case type-symbol (:and (funcall #'every #'eval-fc conditionals)) @@ -1781,10 +1760,7 @@ when (and (mark<= (start-offset form) mark) (mark<= mark (end-offset form))) do (return (eval (read-from-string - (coerce (buffer-sequence (buffer syntax) - (start-offset form) - (end-offset form)) - 'string))))))) + (token-string syntax form))))))) (defmethod beginning-of-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax @@ -1962,10 +1938,9 @@ (defun token-string (syntax token) "Return the string that specifies `token' in the buffer of `syntax'." - (coerce (buffer-sequence (buffer syntax) - (start-offset token) - (end-offset token)) - 'string)) + (buffer-substring (buffer syntax) + (start-offset token) + (end-offset token))) (defun parse-symbol (string &key (package *package*) (case (readtable-case *readtable*))) "Find the symbol named STRING. From dmurray at common-lisp.net Sat May 6 19:51:05 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 6 May 2006 15:51:05 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506195105.450BDD00B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9866 Modified Files: cl-syntax.lisp fundamental-syntax.lisp html-syntax.lisp lisp-syntax.lisp misc-commands.lisp packages.lisp pane.lisp prolog-syntax.lisp slidemacs.lisp ttcn3-syntax.lisp Log Message: Changed mark-visibility to region visibility. Turn it on and off with Visible Region, for now. --- /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/03/03 19:38:57 1.17 +++ /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/05/06 19:51:04 1.18 @@ -1141,7 +1141,7 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p))) --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2005/08/15 23:31:22 1.2 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/05/06 19:51:04 1.3 @@ -185,7 +185,7 @@ :cache-value line :cache-test #'eq) (display-line pane (start-mark (element* lines i)))))))))) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/climacs/cvsroot/climacs/html-syntax.lisp 2005/08/15 23:31:22 1.32 +++ /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/05/06 19:51:04 1.33 @@ -798,6 +798,6 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p))) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/06 17:23:33 1.65 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/06 19:51:04 1.66 @@ -1590,7 +1590,7 @@ (let ((*current-faces* *standard-faces*)) (with-slots (stack-top) syntax (display-parse-tree stack-top syntax pane))) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/06 15:38:42 1.10 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/06 19:51:04 1.11 @@ -1538,7 +1538,6 @@ 'marking-table '((#\h :control :meta))) -(define-command (com-visible-mark :name t :command-table marking-table) () - "Toggle the visibility of the mark in the current pane. -This is particularly (only?) useful for experimenting with marking commands." - (setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window))))) +(define-command (com-visible-region :name t :command-table marking-table) () + "Toggle the visibility of the region in the current pane." + (setf (region-visible-p (current-window)) (not (region-visible-p (current-window))))) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/05/06 06:27:14 1.92 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/06 19:51:04 1.93 @@ -152,7 +152,7 @@ #:clear-cache #:redisplay-pane #:full-redisplay #:display-cursor - #:display-mark + #:display-region #:page-down #:page-up #:top #:bot #:tab-space-count #:space-width #:tab-width @@ -163,7 +163,7 @@ #:isearch-mode #:isearch-states #:isearch-previous-string #:query-replace-state #:string1 #:string2 #:query-replace-mode - #:mark-visible-p + #:region-visible-p #:with-undo #:url #:climacs-textual-view #:+climacs-textual-view+)) --- /project/climacs/cvsroot/climacs/pane.lisp 2006/05/06 06:27:14 1.38 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/05/06 19:51:04 1.39 @@ -280,7 +280,7 @@ (isearch-previous-string :initform nil :accessor isearch-previous-string) (query-replace-mode :initform nil :accessor query-replace-mode) (query-replace-state :initform nil :accessor query-replace-state) - (mark-visible-p :initform nil :accessor mark-visible-p) + (region-visible-p :initform nil :accessor region-visible-p) (full-redisplay-p :initform nil :accessor full-redisplay-p) (cache :initform (let ((cache (make-instance 'standard-flexichain))) (insert* cache 0 nil) @@ -564,7 +564,7 @@ (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p) (display-cache pane) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p)) (defgeneric redisplay-pane (pane current-p)) @@ -589,43 +589,118 @@ (defgeneric display-cursor (pane syntax current-p)) (defmethod display-cursor ((pane climacs-pane) (syntax basic-syntax) current-p) - (with-slots (top) pane - (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (style (medium-text-style pane)) - (ascent (text-style-ascent style pane)) - (descent (text-style-descent style pane)) - (height (+ ascent descent)) - (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) - (cursor-column - (buffer-display-column - (buffer (point pane)) (offset (point pane)) - (round (tab-width pane) (space-width pane)))) - (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) + (let ((point (point pane))) + (multiple-value-bind (cursor-x cursor-y line-height) + (offset-to-screen-position (offset point) pane) (updating-output (pane :unique-id -1) (draw-rectangle* pane (1- cursor-x) cursor-y - (+ cursor-x 2) (+ cursor-y ascent descent) + (+ cursor-x 2) (+ cursor-y line-height) :ink (if current-p +red+ +blue+)))))) -(defgeneric display-mark (pane syntax)) +(defgeneric display-region (pane syntax)) -(defmethod display-mark ((pane climacs-pane) (syntax basic-syntax)) +(defmethod display-region ((pane climacs-pane) (syntax basic-syntax)) + (multiple-value-bind (cursor-x cursor-y line-height) + (offset-to-screen-position (offset (point pane)) pane) + (multiple-value-bind (mark-x mark-y) + (offset-to-screen-position (offset (mark pane)) pane) + (cond + ;; 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 (compose-in +green+ + (make-opacity .1))) + (draw-rectangle* pane + 0 cursor-y + cursor-x (+ cursor-y line-height) + :ink (compose-in +green+ + (make-opacity .1))))) + ;; 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 (compose-in +green+ + (make-opacity .1))) + (draw-rectangle* pane + cursor-x cursor-y + (stream-text-margin pane) (+ cursor-y line-height) + :ink (compose-in +green+ + (make-opacity .1))))) + ;; 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) + (draw-rectangle* pane + mark-x mark-y + cursor-x (+ cursor-y line-height) + :ink (compose-in +green+ + (make-opacity .1))))) + ;; 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 (compose-in +green+ + (make-opacity .1))) + (draw-rectangle* pane + 0 cursor-y + cursor-x (+ cursor-y line-height) + :ink (compose-in +green+ + (make-opacity .1))) + (draw-rectangle* pane + 0 (+ mark-y line-height) + (stream-text-margin pane) cursor-y + :ink (compose-in +green+ + (make-opacity .1))))) + ;; 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 (compose-in +green+ + (make-opacity .1))) + (draw-rectangle* pane + 0 mark-y + mark-x (+ mark-y line-height) + :ink (compose-in +green+ + (make-opacity .1))) + (draw-rectangle* pane + 0 (+ cursor-y line-height) + (stream-text-margin pane) mark-y + :ink (compose-in +green+ + (make-opacity .1))))))))) + +(defun offset-to-screen-position (offset pane) + "Returns the position of offset as a screen position. +Returns X Y LINE-HEIGHT CHAR-WIDTH as values if offset is on the screen, +NIL if offset is before the beginning of the screen, +and T if offset is after the end of the screen." (with-slots (top bot) pane - (let ((mark (mark pane))) - (when (<= (offset top) (offset mark) (offset bot)) - (let* ((mark-line (number-of-lines-in-region top mark)) - (style (medium-text-style pane)) - (ascent (text-style-ascent style pane)) - (descent (text-style-descent style pane)) - (height (+ ascent descent)) - (mark-y (+ (* mark-line (+ height (stream-vertical-spacing pane))))) - (mark-column - (buffer-display-column - (buffer mark) (offset mark) - (round (tab-width pane) (space-width pane)))) - (mark-x (* mark-column (text-style-width (medium-text-style pane) pane)))) - (updating-output (pane :unique-id -2) - (draw-rectangle* pane - (1- mark-x) mark-y - (+ mark-x 2) (+ mark-y ascent descent) - :ink +green+))))))) \ No newline at end of file + (cond + ((< offset (offset top)) nil) + ((< (offset bot) offset) t) + (t + (let* ((line (number-of-lines-in-region top offset)) + (style (medium-text-style pane)) + (style-width (text-style-width style pane)) + (ascent (text-style-ascent style pane)) + (descent (text-style-descent style pane)) + (height (+ ascent descent)) + (y (+ (* line (+ height (stream-vertical-spacing pane))))) + (column + (buffer-display-column + (buffer pane) offset + (round (tab-width pane) (space-width pane)))) + (x (* column style-width))) + (values x y height style-width)))))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/03/03 19:38:57 1.26 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/05/06 19:51:04 1.27 @@ -1310,7 +1310,7 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p))) #| --- /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/03/03 19:38:57 1.8 +++ /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/05/06 19:51:04 1.9 @@ -454,5 +454,5 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p))) --- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/03/03 19:38:57 1.4 +++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/05/06 19:51:04 1.5 @@ -452,6 +452,6 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (when (mark-visible-p pane) (display-mark pane syntax)) + (when (region-visible-p pane) (display-region pane syntax)) (display-cursor pane syntax current-p))) From dmurray at common-lisp.net Sat May 6 20:40:10 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 6 May 2006 16:40:10 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060506204010.C508924002@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv15173 Modified Files: pane.lisp Log Message: Generalised region highlighting. There is now a (as yet unexported) gf in pane.lisp that will highlight between two points (marks or offsets) in a buffer, with a given ink: highlight-region pane mark1 offset2 &optional ink --- /project/climacs/cvsroot/climacs/pane.lisp 2006/05/06 19:51:04 1.39 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/05/06 20:40:10 1.40 @@ -601,10 +601,19 @@ (defgeneric display-region (pane syntax)) (defmethod display-region ((pane climacs-pane) (syntax basic-syntax)) + (highlight-region pane (point pane) (mark pane))) + +(defgeneric highlight-region (pane mark1 offset2 &optional ink)) + +(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (offset2 integer) + &optional (ink (compose-in +green+ (make-opacity .1)))) + ;; FIXME stream-vertical-spacing between lines + ;; FIXME note sure updating output is working properly... + ;; we'll call offset1 CURSOR and offset2 MARK (multiple-value-bind (cursor-x cursor-y line-height) - (offset-to-screen-position (offset (point pane)) pane) + (offset-to-screen-position offset1 pane) (multiple-value-bind (mark-x mark-y) - (offset-to-screen-position (offset (mark pane)) pane) + (offset-to-screen-position offset2 pane) (cond ;; mark is above the top of the screen ((and (null mark-y) (null mark-x)) @@ -612,13 +621,11 @@ (draw-rectangle* pane 0 0 (stream-text-margin pane) cursor-y - :ink (compose-in +green+ - (make-opacity .1))) + :ink ink) (draw-rectangle* pane 0 cursor-y cursor-x (+ cursor-y line-height) - :ink (compose-in +green+ - (make-opacity .1))))) + :ink ink))) ;; mark is below the bottom of the screen ((and (null mark-y) mark-x) (updating-output (pane :unique-id -3) @@ -626,13 +633,11 @@ 0 (+ cursor-y line-height) (stream-text-margin pane) (bounding-rectangle-height (window-viewport pane)) - :ink (compose-in +green+ - (make-opacity .1))) + :ink ink) (draw-rectangle* pane cursor-x cursor-y (stream-text-margin pane) (+ cursor-y line-height) - :ink (compose-in +green+ - (make-opacity .1))))) + :ink ink))) ;; mark is at point ((and (= mark-x cursor-x) (= mark-y cursor-y)) nil) @@ -642,44 +647,49 @@ (draw-rectangle* pane mark-x mark-y cursor-x (+ cursor-y line-height) - :ink (compose-in +green+ - (make-opacity .1))))) + :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 (compose-in +green+ - (make-opacity .1))) + :ink ink) (draw-rectangle* pane 0 cursor-y cursor-x (+ cursor-y line-height) - :ink (compose-in +green+ - (make-opacity .1))) + :ink ink) (draw-rectangle* pane 0 (+ mark-y line-height) (stream-text-margin pane) cursor-y - :ink (compose-in +green+ - (make-opacity .1))))) + :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 (compose-in +green+ - (make-opacity .1))) + :ink ink) (draw-rectangle* pane 0 mark-y mark-x (+ mark-y line-height) - :ink (compose-in +green+ - (make-opacity .1))) + :ink ink) (draw-rectangle* pane 0 (+ cursor-y line-height) (stream-text-margin pane) mark-y - :ink (compose-in +green+ - (make-opacity .1))))))))) + :ink ink))))))) + +(defmethod highlight-region ((pane climacs-pane) (mark1 mark) (mark2 mark) + &optional (ink (compose-in +green+ (make-opacity .1)))) + (highlight-region pane (offset mark1) (offset mark2) ink)) + +(defmethod highlight-region ((pane climacs-pane) (mark1 mark) (offset2 integer) + &optional (ink (compose-in +green+ (make-opacity .1)))) + (highlight-region pane (offset mark1) offset2 ink)) + +(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (mark2 mark) + &optional (ink (compose-in +green+ (make-opacity .1)))) + (highlight-region pane offset1 (offset mark2) ink)) (defun offset-to-screen-position (offset pane) "Returns the position of offset as a screen position. From dmurray at common-lisp.net Sun May 7 06:40:19 2006 From: dmurray at common-lisp.net (dmurray) Date: Sun, 7 May 2006 02:40:19 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060507064019.A51CA5903A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv23067 Modified Files: pane.lisp Log Message: Added the missing cases to highlight-region. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/05/06 20:40:10 1.40 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/05/07 06:40:19 1.41 @@ -615,6 +615,24 @@ (multiple-value-bind (mark-x mark-y) (offset-to-screen-position offset2 pane) (cond + ;; mark and point are above the screen + ((and (null cursor-y) (null mark-y) + (null cursor-x) (null mark-x)) + nil) + ;; mark and point are below the screen + ((and (null cursor-y) (null mark-y) + cursor-x mark-x) + nil) + ;; 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))) ;; mark is above the top of the screen ((and (null mark-y) (null mark-x)) (updating-output (pane :unique-id -3) From dmurray at common-lisp.net Sun May 7 20:11:20 2006 From: dmurray at common-lisp.net (dmurray) Date: Sun, 7 May 2006 16:11:20 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060507201120.E611923000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28753 Modified Files: file-commands.lisp Log Message: find-file now takes an optional readonlyp argument, meaning find-file-read-only (which had got out of sync/date) can go. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/06 15:40:47 1.14 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/07 20:11:20 1.15 @@ -228,7 +228,7 @@ (and (or (null name) (eql name :unspecific)) (or (null type) (eql type :unspecific))))) -(defun find-file (filepath) +(defun find-file (filepath &optional readonlyp) (cond ((null filepath) (display-message "No file name given.") (beep)) @@ -238,38 +238,45 @@ (t (let ((existing-buffer (find filepath (buffers *application-frame*) :key #'filepath :test #'equal))) - (if existing-buffer + (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) (switch-to-buffer existing-buffer) - (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) - (beginning-of-buffer (point pane)) - (update-syntax buffer (syntax buffer)) - (clear-modify buffer) - 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. @@ -294,42 +301,6 @@ 'buffer-table '((#\x :control) (#\f :control))) -(defun find-file-read-only (filepath) - (cond ((null filepath) - (display-message "No file name given.") - (beep)) - ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath) - (beep)) - (t - (let ((existing-buffer (find filepath (buffers *application-frame*) - :key #'filepath :test #'equal))) - (if (and existing-buffer (read-only-p existing-buffer)) - (switch-to-buffer existing-buffer) - (if (probe-file filepath) - (let ((buffer (make-buffer)) - (pane (current-window))) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer (current-window)) buffer) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer (buffer (point pane)))) - (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0)) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil - (read-only-p buffer) t) - (beginning-of-buffer (point pane)) - ;; this one is needed so that the buffer modification protocol - ;; resets the low and high marks after redisplay - (redisplay-frame-panes *application-frame*) - buffer) - (progn - (display-message "No such file: ~A" filepath) - (beep) - nil))))))) - (define-command (com-find-file-read-only :name t :command-table buffer-table) () "Prompt for a filename then open that file readonly. If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error." @@ -337,7 +308,7 @@ :default (directory-of-buffer (buffer (current-window))) :default-type 'pathname :insert-default t))) - (find-file-read-only filepath))) + (find-file filepath t))) (set-key 'com-find-file-read-only 'buffer-table From crhodes at common-lisp.net Wed May 10 08:41:50 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 04:41:50 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510084150.1F8D64610C@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv18087 Modified Files: esa.lisp Log Message: implement numeric arguments for keyboard macros --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/04 18:32:38 1.12 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 08:41:49 1.13 @@ -804,14 +804,15 @@ (define-command (com-call-last-kbd-macro :name t :command-table keyboard-macro-table) - () + ((count 'integer :prompt "How many times?")) "Run the last keyboard macro that was defined. Use C-x ( to start and C-x ) to finish recording a keyboard macro." (setf (remaining-keys *application-frame*) - (recorded-keys *application-frame*)) + (loop repeat count append (recorded-keys *application-frame*))) (setf (executingp *application-frame*) t)) -(set-key 'com-call-last-kbd-macro 'keyboard-macro-table '((#\x :control) #\e)) +(set-key `(com-call-last-kbd-macro ,*numeric-argument-marker*) + 'keyboard-macro-table '((#\x :control) #\e)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From crhodes at common-lisp.net Wed May 10 09:36:15 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 05:36:15 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510093615.3C3275831B@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv29181 Added Files: .cvsignore Log Message: cvsignore *.fasl --- /project/climacs/cvsroot/esa/.cvsignore 2006/05/10 09:36:15 NONE +++ /project/climacs/cvsroot/esa/.cvsignore 2006/05/10 09:36:15 1.1 *.fasl From crhodes at common-lisp.net Wed May 10 09:38:12 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 05:38:12 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510093812.060095831B@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv29250 Modified Files: esa.asd Log Message: No need for a distinct esa system package. --- /project/climacs/cvsroot/esa/esa.asd 2006/04/08 22:34:09 1.2 +++ /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:38:12 1.3 @@ -1,12 +1,8 @@ -(defpackage :esa.system - (:use :cl :asdf)) - -(in-package :esa.system) - (defsystem :esa :depends-on (:mcclim) :components ((:file "packages") (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages")) (:file "esa-buffer" :depends-on ("packages" "esa")) - (:file "esa-io" :depends-on ("packages" "esa")))) + (:file "esa-io" :depends-on ("packages" "esa")) + (:file "esa-command-parser" :depends-on ("packages" "esa")))) From crhodes at common-lisp.net Wed May 10 09:38:57 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 05:38:57 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510093857.837D46102A@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv29308 Modified Files: esa.asd Log Message: Whoops. remove too-eager addition of esa-command-parser.lisp to the system description. --- /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:38:12 1.3 +++ /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:38:57 1.4 @@ -4,5 +4,4 @@ (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages")) (:file "esa-buffer" :depends-on ("packages" "esa")) - (:file "esa-io" :depends-on ("packages" "esa")) - (:file "esa-command-parser" :depends-on ("packages" "esa")))) + (:file "esa-io" :depends-on ("packages" "esa")))) From crhodes at common-lisp.net Wed May 10 09:41:42 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 05:41:42 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510094142.7BD5472022@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv29508 Modified Files: esa.lisp Log Message: write a primary STREAM-ACCEPT method for the minibuffer. This basically does the same as the usual STREAM-ACCEPT, except that it turns input sensitizing off (which works around the problem with Goatee with nested accepts on the same extended stream). Some other bits are slightly less hairy, too. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 08:41:49 1.13 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:41:42 1.14 @@ -70,6 +70,160 @@ (parse-error () nil)))) +(defmethod stream-accept ((pane minibuffer-pane) type &rest args + &key (view (stream-default-view pane)) + &allow-other-keys) + ;; default CLIM prompting is OK for now... + (apply #'prompt-for-accept pane type view args) + ;; but we need to turn some of ACCEPT-1 off. + (apply #'accept-1-for-minibuffer pane type args)) + +;;; simpler version of McCLIM's internal operators of the same names: +;;; HANDLE-EMPTY-INPUT to make default processing work, EMPTY-INPUT-P +;;; and INVOKE-HANDLE-EMPTY-INPUT to support it. We don't support +;;; recursive bouncing to see who most wants to handle the empty +;;; input, but that's OK, because we are always conceptually one-level +;;; deep in accept (even if sometimes we call ACCEPT recursively for +;;; e.g. command-names and arguments). +(defmacro handle-empty-input ((stream) input-form &body handler-forms) + "see climi::handle-empty-input" + (let ((input-cont (gensym "INPUT-CONT")) + (handler-cont (gensym "HANDLER-CONT"))) + `(flet ((,input-cont () + ,input-form) + (,handler-cont () + , at handler-forms)) + (declare (dynamic-extent #',input-cont #',handler-cont)) + (invoke-handle-empty-input ,stream #',input-cont #',handler-cont)))) + +;;; The code that signalled the error might have consumed the gesture, or +;;; not. +;;; XXX Actually, it would be a violation of the `accept' protocol to consume +;;; the gesture, but who knows what random accept methods are doing. +(defun empty-input-p + (stream begin-scan-pointer activation-gestures delimiter-gestures) + (let ((scan-pointer (stream-scan-pointer stream)) + (fill-pointer (fill-pointer (stream-input-buffer stream)))) + ;; activated? + (cond ((and (eql begin-scan-pointer scan-pointer) + (eql scan-pointer fill-pointer)) + t) + ((or (eql begin-scan-pointer scan-pointer) + (eql begin-scan-pointer (1- scan-pointer))) + (let ((gesture + (aref (stream-input-buffer stream) begin-scan-pointer))) + (and (characterp gesture) + (flet ((gesture-matches-p (g) + (if (characterp g) + (char= gesture g) + ;; FIXME: not quite portable -- + ;; apparently + ;; EVENT-MATCHES-GESTURE-NAME-P need + ;; not work on raw characters + (event-matches-gesture-name-p gesture g)))) + (or (some #'gesture-matches-p activation-gestures) + (some #'gesture-matches-p delimiter-gestures)))))) + (t nil)))) + +(defun invoke-handle-empty-input + (stream input-continuation handler-continuation) + (unless (input-editing-stream-p stream) + (return-from invoke-handle-empty-input (funcall input-continuation))) + (let ((begin-scan-pointer (stream-scan-pointer stream)) + (activation-gestures *activation-gestures*) + (delimiter-gestures *delimiter-gestures*)) + (block empty-input + (handler-bind + ((parse-error + #'(lambda (c) + (when (empty-input-p stream begin-scan-pointer + activation-gestures delimiter-gestures) + (return-from empty-input nil))))) + (return-from invoke-handle-empty-input (funcall input-continuation)))) + (funcall handler-continuation))) + +(defun accept-1-for-minibuffer + (stream type &key + (view (stream-default-view stream)) + (default nil defaultp) (default-type nil default-type-p) + provide-default insert-default (replace-input t) + history active-p prompt prompt-mode display-default + query-identifier (activation-gestures nil activationsp) + (additional-activation-gestures nil additional-activations-p) + (delimiter-gestures nil delimitersp) + (additional-delimiter-gestures nil additional-delimiters-p)) + (declare (ignore provide-default history active-p + prompt prompt-mode + display-default query-identifier)) + (when (and defaultp (not default-type-p)) + (error ":default specified without :default-type")) + (when (and activationsp additional-activations-p) + (error "only one of :activation-gestures or ~ + :additional-activation-gestures may be passed to accept.")) + (unless (or activationsp additional-activations-p *activation-gestures*) + (setq activation-gestures *standard-activation-gestures*)) + (with-input-editing + ;; this is the main change from CLIM:ACCEPT-1 -- no sensitizer. + (stream :input-sensitizer nil) + ;; KLUDGE: no call to CLIMI::WITH-INPUT-POSITION here, but that's + ;; OK because we are always going to create a new editing stream + ;; for each call to accept/accept-1-for-minibuffer, so the default + ;; default for the BUFFER-START argument to REPLACE-INPUT is + ;; right. + (when insert-default + ;; Insert the default value to the input stream. It should + ;; become fully keyboard-editable. + (presentation-replace-input + stream default default-type view)) + (with-input-context (type) + (object object-type event options) + (with-activation-gestures ((if additional-activations-p + additional-activation-gestures + activation-gestures) + :override activationsp) + (with-delimiter-gestures ((if additional-delimiters-p + additional-delimiter-gestures + delimiter-gestures) + :override delimitersp) + (let ((accept-results nil)) + (climi::handle-empty-input (stream) + (setq accept-results + (multiple-value-list + (if defaultp + (funcall-presentation-generic-function + accept type stream view + :default default :default-type default-type) + (funcall-presentation-generic-function + accept type stream view)))) + ;; User entered activation or delimiter gesture + ;; without any input. + (if defaultp + (presentation-replace-input + stream default default-type view :rescan nil) + (simple-parse-error + "Empty input for type ~S with no supplied default" + type)) + (setq accept-results (list default default-type))) + ;; Eat trailing activation gesture + ;; XXX what about pointer gestures? + ;; XXX and delimiter gestures? + ;; + ;; deleted check for *RECURSIVE-ACCEPT-P* + (let ((ag (read-char-no-hang stream nil stream t))) + (unless (or (null ag) (eq ag stream)) + (unless (activation-gesture-p ag) + (unread-char ag stream)))) + (values (car accept-results) + (if (cdr accept-results) (cadr accept-results) type))))) + ;; A presentation was clicked on, or something. + (t + (when (and replace-input + (getf options :echo t) + (not (stream-rescanning-p stream))) + (presentation-replace-input + stream object object-type view :rescan nil)) + (values object object-type))))) + (defun display-minibuffer (frame pane) (declare (ignore frame)) (when (message pane) From crhodes at common-lisp.net Wed May 10 09:52:05 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 05:52:05 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510095205.28900111C9@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv31073 Modified Files: esa.asd esa.lisp packages.lisp Added Files: esa-command-parser.lisp Log Message: New command parser. Make it the default for frames running esa-top-level. Use the prompt argument to esa-top-level to determing com-extended-command's prompt. export esa:esa-command-parser and esa:esa-partial-command-parser. rewrite some other bits of the top-level loop to use the partial command parser where appropriate. --- /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:38:57 1.4 +++ /project/climacs/cvsroot/esa/esa.asd 2006/05/10 09:52:05 1.5 @@ -4,4 +4,5 @@ (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages")) (:file "esa-buffer" :depends-on ("packages" "esa")) - (:file "esa-io" :depends-on ("packages" "esa")))) + (:file "esa-io" :depends-on ("packages" "esa")) + (:file "esa-command-parser" :depends-on ("packages" "esa")))) --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:41:42 1.14 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:52:05 1.15 @@ -440,6 +440,12 @@ (setf command (list command))) (setf command (substitute-numeric-argument-marker command numarg)) (setf command (substitute-numeric-argument-p command numargp)) + (when (member *unsupplied-argument-marker* command :test #'eq) + (setq command + (funcall + *partial-command-parser* + (frame-command-table frame) + (frame-standard-input frame) command 0))) (execute-frame-command frame command) (return))) (t nil)))))) @@ -449,10 +455,10 @@ (let ((command (command-menu-item-value object))) (unless (listp command) (setq command (list command))) - (when (and (typep (frame-standard-input frame) 'interactor-pane) - (member *unsupplied-argument-marker* command :test #'eq)) + (when (member *unsupplied-argument-marker* command :test #'eq) (setq command - (command-line-read-remaining-arguments-for-partial-command + (funcall + *partial-command-parser* (frame-command-table frame) (frame-standard-input frame) command 0))) (execute-frame-command frame command))))) @@ -467,6 +473,8 @@ ;; FIXME: I'm not sure that we want to do this for commands sent ;; from other threads; we almost certainly don't want to do it twice ;; in such cases... + ;; + ;; FIXME: also, um, throwing away the arguments is likely to be bad. (setf (previous-command (car (windows frame))) (if (consp command) (car command) @@ -486,15 +494,26 @@ ;;; ;;; Top level +(defvar *extended-command-prompt*) + (defun esa-top-level (frame &key - command-parser command-unparser - partial-command-parser prompt) - (declare (ignore command-parser command-unparser partial-command-parser prompt)) + (command-parser 'esa-command-parser) + ;; FIXME: maybe customize this? Under what + ;; circumstances would it be used? Maybe try + ;; turning the clim listener into an ESA? + (command-unparser 'command-line-command-unparser) + (partial-command-parser 'esa-partial-command-parser) + (prompt "Extended Command: ")) + (declare (ignore prompt)) (with-slots (windows) frame (let ((*standard-output* (car windows)) (*standard-input* (frame-standard-input frame)) (*print-pretty* nil) (*abort-gestures* `((:keyboard #\g ,(make-modifier-state :control)))) + (*command-parser* command-parser) + (*command-unparser* command-unparser) + (*partial-command-parser* partial-command-parser) + (*extended-command-prompt* prompt) (*pointer-documentation-output* (frame-pointer-documentation-output frame))) (unless (eq (frame-state frame) :enabled) @@ -632,23 +651,25 @@ (set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control))) (define-command (com-extended-command + ;; FIXME: I don't think it makes any sense for + ;; Extended Command to be named. :name t :command-table global-esa-table) () "Prompt for a command name and arguments, then run it." (let ((item (handler-case - (accept - `(command :command-table ,(find-applicable-command-table *application-frame*)) - :prompt "Extended Command") - ((or command-not-accessible command-not-present) () - (beep) + (accept + `(command :command-table ,(find-applicable-command-table *application-frame*)) + ;; this gets erased immediately anyway + :prompt "" :prompt-mode :raw) + ((or command-not-accessible command-not-present) () + (beep) (display-message "No such command") (return-from com-extended-command nil))))) (execute-frame-command *application-frame* item))) (set-key 'com-extended-command 'global-esa-table '((#\x :meta))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Help --- /project/climacs/cvsroot/esa/packages.lisp 2006/05/02 18:01:49 1.3 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/05/10 09:52:05 1.4 @@ -13,7 +13,9 @@ #:describe-command-to-stream #:gesture-name #:set-key - #:find-applicable-command-table)) + #:find-applicable-command-table + #:esa-command-parser + #:esa-partial-command-parser)) (defpackage :esa-buffer (:use :clim-lisp :clim :esa) --- /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/10 09:52:05 NONE +++ /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/10 09:52:05 1.1 ;;; -*- Mode: Lisp; Package: ESA -*- ;;; (c) copyright 2006 by ;;; Christophe Rhodes (c.rhodes at gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :esa) (defun esa-parse-one-arg (stream name ptype accept-args &optional (default *unsupplied-argument-marker*)) (declare (ignore name)) ;; this conditional doesn't feel entirely happy. The issue is that ;; we could be called either recursively from an outer call to ;; (accept 'command), in which case we want our inner accept to ;; occur on the minibuffer stream not the input-editing-stream, or ;; from the toplevel when handed a partial command. Maybe the ;; toplevel should establish an input editing context for partial ;; commands anyway? Then ESA-PARSE-ONE-ARG would always be called ;; with an input-editing-stream. (let ((stream (if (encapsulating-stream-p stream) (encapsulating-stream-stream stream) stream))) (apply #'accept (eval ptype) :stream stream (append (unless (eq default *unsupplied-argument-marker*) ;; adjust to taste. `(:default ,default :insert-default nil :display-default t)) ;; This is fucking nuts. FIXME: the clim spec says ;; ":GESTURE is not evaluated at all". Um, but how are ;; you meant to tell if a keyword argument is :GESTURE, ;; then? The following does not actually allow variable ;; keys: anyone who writes (DEFINE-COMMAND FOO ((BAR ;; 'PATHNAME *RANDOM-ARG* ""))) and expects it to work ;; deserves to lose. ;; ;; FIXME: this will do the wrong thing on malformed accept ;; arguments, such improper lists or those with an odd ;; number of keyword arguments. I doubt that ;; DEFINE-COMMAND is checking the syntax, so we probably ;; should. (loop for (key val) on accept-args by #'cddr unless (eq key :gesture) collect key and collect (eval val)))))) (defun esa-command-parser (command-table stream) (let ((command-name nil)) (flet ((maybe-clear-input () (let ((gesture (read-gesture :stream stream :peek-p t :timeout 0))) (when (and gesture (or (delimiter-gesture-p gesture) (activation-gesture-p gesture))) (read-gesture :stream stream))))) (with-delimiter-gestures (*command-name-delimiters* :override t) ;; While reading the command name we want use the history of ;; the (accept 'command ...) that's calling this function. ;; ;; FIXME: does this :history nil actually achieve the above? (setq command-name (accept `(command-name :command-table ,command-table) :stream (encapsulating-stream-stream stream) :prompt *extended-command-prompt* :prompt-mode :raw :history nil)) (maybe-clear-input)) (with-delimiter-gestures (*command-argument-delimiters* :override t) ;; FIXME, except we can't: use of CLIM-INTERNALS. (let* ((info (gethash command-name climi::*command-parser-table*)) (required-args (climi::required-args info)) (keyword-args (climi::keyword-args info))) (declare (ignore keyword-args)) (let (result) ;; only required args for now. (dolist (arg required-args (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg (push (esa-parse-one-arg stream name ptype args) result) (maybe-clear-input))))))))) (defun esa-partial-command-parser (command-table stream command position) (declare (ignore command-table position)) (let ((command-name (car command)) (command-args (cdr command))) (flet ((maybe-clear-input () (let ((gesture (read-gesture :stream stream :peek-p t :timeout 0))) (when (and gesture (or (delimiter-gesture-p gesture) (activation-gesture-p gesture))) (read-gesture :stream stream))))) (with-delimiter-gestures (*command-argument-delimiters* :override t) ;; FIXME, except we can't: use of CLIM-INTERNALS. (let* ((info (gethash command-name climi::*command-parser-table*)) (required-args (climi::required-args info)) (keyword-args (climi::keyword-args info))) ;; keyword arguments not yet supported (declare (ignore keyword-args)) (let (result) ;; only required args for now. (do ((required-args required-args (cdr required-args)) (arg (car required-args) (car required-args)) (command-args command-args (cdr command-args)) (command-arg (car command-args) (car command-args))) ((null required-args) (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg (push (esa-parse-one-arg stream name ptype args command-arg) result) (maybe-clear-input))))))))) From crhodes at common-lisp.net Wed May 10 09:53:55 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 May 2006 05:53:55 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510095355.E53E012034@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv31345 Modified Files: esa-io.lisp Log Message: Modify the IO commands to take advantage of the new command parser. Also add an editable default where that seems appropriate. (Possibly this calls for a 'pathname-with-buffer-default presentation type, to save typing the same thing many times...) --- /project/climacs/cvsroot/esa/esa-io.lisp 2006/03/25 00:08:07 1.1.1.1 +++ /project/climacs/cvsroot/esa/esa-io.lisp 2006/05/10 09:53:55 1.2 @@ -157,11 +157,21 @@ (needs-saving buffer) nil) buffer))))) -(define-command (com-find-file :name t :command-table esa-io-table) () - (let* ((filepath (accept 'pathname :prompt "Find File"))) - (find-file filepath *application-frame*))) +(defun directory-of-current-buffer () + (make-pathname + :directory + (pathname-directory + (or (filepath (current-buffer *application-frame*)) + (user-homedir-pathname))))) + +(define-command (com-find-file :name t :command-table esa-io-table) + ((filepath 'pathname :prompt "Find File: " :prompt-mode :raw + :default (directory-of-current-buffer) :default-type 'pathname + :insert-default t)) + (find-file filepath *application-frame*)) -(set-key 'com-find-file 'esa-io-table '((#\x :control) (#\f :control))) +(set-key `(com-find-file ,*unsupplied-argument-marker*) + 'esa-io-table '((#\x :control) (#\f :control))) (defmethod find-file-read-only (filepath application-frame) (cond ((null filepath) @@ -185,11 +195,12 @@ (beep) nil)))))) -(define-command (com-find-file-read-only :name t :command-table esa-io-table) () - (let ((filepath (accept 'pathname :Prompt "Find file read only"))) - (find-file-read-only filepath *application-frame*))) +(define-command (com-find-file-read-only :name t :command-table esa-io-table) + ((filepath 'pathname :prompt "Find File read-only: " :prompt-mode :raw)) + (find-file-read-only filepath *application-frame*)) -(set-key 'com-find-file-read-only 'esa-io-table '((#\x :control) (#\r :control))) +(set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) + 'esa-io-table '((#\x :control) (#\r :control))) (define-command (com-read-only :name t :command-table esa-io-table) () (let ((buffer (current-buffer *application-frame*))) @@ -202,9 +213,11 @@ (name buffer) (filepath-filename filename) (needs-saving buffer) t)) -(define-command (com-set-visited-file-name :name t :command-table esa-io-table) () - (let ((filename (accept 'pathname :prompt "New file name"))) - (set-visited-file-name filename (current-buffer *application-frame*) *application-frame*))) +(define-command (com-set-visited-file-name :name t :command-table esa-io-table) + ((filename 'pathname :prompt "New file name: " :prompt-mode :raw + :default (directory-of-current-buffer) :insert-default t + :default-type 'pathname)) + (set-visited-file-name filename (current-buffer *application-frame*) *application-frame*)) (defmethod save-buffer (buffer application-frame) (let ((filepath (or (filepath buffer) @@ -247,10 +260,13 @@ (needs-saving buffer) nil) (display-message "Wrote: ~a" (filepath buffer))))) -(define-command (com-write-buffer :name t :command-table esa-io-table) () - (let ((filepath (accept 'pathname :prompt "Write Buffer to File")) - (buffer (current-buffer *application-frame*))) +(define-command (com-write-buffer :name t :command-table esa-io-table) + ((filepath 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw + :default (directory-of-current-buffer) :insert-default t + :default-type 'pathname)) + (let ((buffer (current-buffer *application-frame*))) (write-buffer buffer filepath *application-frame*))) -(set-key 'com-write-buffer 'esa-io-table '((#\x :control) (#\w :control))) +(set-key `(com-write-buffer ,*unsupplied-argument-marker*) + 'esa-io-table '((#\x :control) (#\w :control))) From thenriksen at common-lisp.net Wed May 10 16:22:20 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 10 May 2006 12:22:20 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060510162220.BB27372022@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv19623 Modified Files: esa.lisp Log Message: Use sans-serif font for documentation, `present' command names in Describe Bindings, remove single linebreaks from docstrings. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:52:05 1.15 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 16:22:20 1.16 @@ -817,11 +817,9 @@ do (formatting-row (stream) (formatting-cell (stream :align-x :right) (with-text-style (stream '(:sans-serif nil nil)) - (format stream "~A" - (or (command-line-name-for-command command - command-table - :errorp nil) - command)))) + (present command + `(command-name :command-table ,command-table) + :stream stream))) (formatting-cell (stream) (with-drawing-options (stream :ink +dark-blue+ :text-style '(:fix nil nil)) @@ -832,66 +830,90 @@ :height (* length (stream-line-height stream))) (scroll-extent stream 0 0)))) -(defun print-docstring-for-command (command-name &optional (stream *standard-output*)) +(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 documentation can be found, this fact will be printed to the stream." - ;; Eventually, we should try to parse the docstring and hyperlink - ;; it to other relevant symbols. - (let ((command-documentation (or (documentation command-name 'function) - "This command is not documented."))) - (princ command-documentation 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))))))) -(defun describe-command-binding-to-stream (gesture-name command &key +(defun describe-command-binding-to-stream (gesture command &key (command-table (find-applicable-command-table *application-frame*)) (stream *standard-output*)) "Describe `command' as invoked by `gesture' to `stream'." (let* ((command-name (if (listp command) - (first command) - command)) - (command-args (if (listp command) - (rest command))) - (real-command-table (or (command-accessible-in-command-table-p + (first command) + command)) + (command-args (if (listp command) + (rest command))) + (real-command-table (or (command-accessible-in-command-table-p command-name command-table) command-table))) - (princ "The gesture " stream) - (with-text-face (stream :italic) - (princ gesture-name 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 :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)) - (terpri stream) - (print-docstring-for-command command-name stream))) + (with-text-style (stream '(:sans-serif nil nil)) + (princ "The gesture " stream) + (with-text-style (stream '(: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) + (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)) + (terpri stream) + (print-docstring-for-command command-name command-table stream)))) (defun describe-command-to-stream (command-name &key (command-table (esa: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))) - (present command-name 'command-name :stream stream) - (princ " calls the function " stream) - (present command-name 'symbol :stream stream) - (princ " and is accessible in " stream) - (present (command-accessible-in-command-table-p command-name command-table) 'command-table - :stream stream) - (format stream ".~%") - (when (plusp (length keystrokes)) - (princ "It is bound to " stream) - (loop for gestures-list on (first keystrokes) - do (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 stream))) + (with-text-style (stream '(:sans-serif nil 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) + (if (command-accessible-in-command-table-p command-name command-table) + (present (command-accessible-in-command-table-p command-name command-table) + 'command-table + :stream stream) + (princ "an unknown command table" stream)) + (format stream ".~%") + (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)) + (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)))) ;;; help commands From dmurray at common-lisp.net Wed May 10 20:33:45 2006 From: dmurray at common-lisp.net (dmurray) Date: Wed, 10 May 2006 16:33:45 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060510203345.A721271035@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8094 Modified Files: file-commands.lisp Log Message: Changed file commands to take arguments, taking advantage of CSR's esa command-handling changes. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/07 20:11:20 1.15 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/10 20:33:45 1.16 @@ -288,29 +288,30 @@ (or (filepath buffer) (user-homedir-pathname))))) -(define-command (com-find-file :name t :command-table buffer-table) () +(define-command (com-find-file :name t :command-table buffer-table) + ((filepath 'pathname + :prompt "Find File" + :default (directory-of-buffer (buffer (current-window))) + :default-type 'pathname + :insert-default t)) "Prompt for a filename then edit that file. If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." - (let* ((filepath (accept 'pathname :prompt "Find File" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t))) - (find-file filepath))) + (find-file filepath)) -(set-key 'com-find-file +(set-key `(com-find-file ,*unsupplied-argument-marker*) 'buffer-table '((#\x :control) (#\f :control))) -(define-command (com-find-file-read-only :name t :command-table buffer-table) () +(define-command (com-find-file-read-only :name t :command-table buffer-table) + ((filepath 'pathname :Prompt "Find file read only" + :default (directory-of-buffer (buffer (current-window))) + :default-type 'pathname + :insert-default t)) "Prompt for a filename then open that file readonly. If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error." - (let ((filepath (accept 'pathname :Prompt "Find file read only" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t))) - (find-file filepath t))) + (find-file filepath t)) -(set-key 'com-find-file-read-only +(set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) 'buffer-table '((#\x :control) (#\r :control))) @@ -331,23 +332,23 @@ (name buffer) (filepath-filename filename) (needs-saving buffer) t)) -(define-command (com-set-visited-file-name :name t :command-table buffer-table) () +(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))) + :default-type 'pathname + :insert-default t)) "Prompt for a new filename for the current buffer. The next time the buffer is saved it will be saved to a file with that filename." - (let ((filename (accept 'pathname :prompt "New file name" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t))) - (set-visited-file-name filename (buffer (current-window))))) + (set-visited-file-name filename (buffer (current-window)))) -(define-command (com-insert-file :name t :command-table buffer-table) () +(define-command (com-insert-file :name t :command-table buffer-table) + ((filename 'pathname :prompt "Insert File" + :default (directory-of-buffer (buffer (current-window))) + :default-type 'pathname + :insert-default t)) "Prompt for a filename and insert its contents at point. Leaves mark after the inserted contents." - (let ((filename (accept 'pathname :prompt "Insert File" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - (pane (current-window))) + (let ((pane (current-window))) (when (probe-file filename) (setf (mark pane) (clone-mark (point pane) :left)) (with-open-file (stream filename :direction :input) @@ -358,7 +359,7 @@ (offset (point pane)) (offset (mark pane)))) (redisplay-frame-panes *application-frame*))) -(set-key 'com-insert-file +(set-key `(com-insert-file ,*unsupplied-argument-marker*) 'buffer-table '((#\x :control) (#\i :control))) @@ -477,14 +478,14 @@ (return-from frame-exit nil))))) (call-next-method))) -(define-command (com-write-buffer :name t :command-table buffer-table) () +(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))) + :default-type 'pathname + :insert-default t)) "Prompt for a filename and write the current buffer to it. Changes the file visted by the buffer to the given file." - (let ((filepath (accept 'pathname :prompt "Write Buffer to File" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - (buffer (buffer (current-window)))) + (let ((buffer (buffer (current-window)))) (cond ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath)) @@ -496,7 +497,7 @@ (needs-saving buffer) nil) (display-message "Wrote: ~a" (filepath buffer)))))) -(set-key 'com-write-buffer +(set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'buffer-table '((#\x :control) (#\w :control))) From crhodes at common-lisp.net Thu May 11 15:36:56 2006 From: crhodes at common-lisp.net (crhodes) Date: Thu, 11 May 2006 11:36:56 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060511153656.A475422007@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv30784 Modified Files: esa.lisp Log Message: remove a probably-bogus handle-repaint :before method. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 16:22:20 1.16 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/11 15:36:56 1.17 @@ -260,10 +260,6 @@ (previous-command :initform nil :accessor previous-command) (command-table :initarg :command-table :accessor command-table))) -(defmethod handle-repaint :before ((pane esa-pane-mixin) region) - (declare (ignore region)) - (redisplay-frame-pane *application-frame* pane)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ESA frame mixin From crhodes at common-lisp.net Fri May 12 10:31:57 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 12 May 2006 06:31:57 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060512103157.53BEF7800B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19824 Modified Files: gui.lisp window-commands.lisp Log Message: Don't scribble over ESA's command tables; instead, define a climacs-help-table to contain customizations of commands. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/04 19:03:46 1.212 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/12 10:31:56 1.213 @@ -104,6 +104,14 @@ ;;; windows (make-command-table 'window-table :errorp nil) +;;; customization of help. FIXME: this might be better done by having +;;; the functions that the ESA commands call be customizeable generic +;;; functions; however, while they're not, scribbling over the ESA +;;; command tables is a bad thing. +(make-command-table 'climacs-help-table :inherit-from '(help-table) + :errorp nil) + + (defvar *bg-color* +white+) (defvar *fg-color* +black+) (defvar *info-bg-color* +gray85+) @@ -119,7 +127,7 @@ (:command-table (global-climacs-table :inherit-from (global-esa-table keyboard-macro-table - help-table + climacs-help-table base-table buffer-table case-table @@ -172,7 +180,7 @@ (vertically (:scroll-bars nil) climacs-window minibuffer))) - (:top-level (esa-top-level))) + (:top-level (esa-top-level :prompt "M-x "))) (defmethod frame-standard-input ((frame climacs)) (get-frame-pane frame 'minibuffer)) @@ -507,7 +515,7 @@ :stream out-stream)) (display-message "Unbound gesture: ~A" gesture-name)))))) -(define-command (com-describe-command :name t :command-table help-table) +(define-command (com-describe-command :name t :command-table climacs-help-table) ((command 'command-name)) "Display documentation for the given command." (unless command @@ -519,16 +527,16 @@ :stream out-stream))) (set-key 'com-describe-binding - 'help-table + 'climacs-help-table '((#\h :control) (#\k))) (set-key '(com-describe-command nil) - 'help-table + 'climacs-help-table '((#\h :control) (#\f))) (define-presentation-to-command-translator describe-command - (command-name com-describe-command help-table + (command-name com-describe-command climacs-help-table :gesture :select :documentation "Describe command") (object) - (list object)) \ No newline at end of file + (list object)) --- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/03/30 16:10:18 1.6 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/05/12 10:31:56 1.7 @@ -103,7 +103,7 @@ (full-redisplay current-window) new-pane)))) -(define-command (com-describe-bindings :name t :command-table help-table) +(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))) @@ -115,7 +115,7 @@ #'esa::sort-by-keystrokes #'esa::sort-by-name)))) -(set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b))) +(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 From dmurray at common-lisp.net Fri May 12 16:52:33 2006 From: dmurray at common-lisp.net (dmurray) Date: Fri, 12 May 2006 12:52:33 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060512165233.F3D034610D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6788 Modified Files: search-commands.lisp Log Message: New commands: Multiple Query Replace, Query Exchange, and Multiple Query Replace From Buffer. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2005/11/12 09:38:32 1.1 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/12 16:52:33 1.2 @@ -194,12 +194,12 @@ (string2 (handler-case (if old-string2 (accept 'string - :prompt (format nil "Query Replace ~A with" + :prompt (format nil "Replace ~A with" string1) :default old-string2 :default-type 'string) (accept 'string - :prompt (format nil "Query Replace ~A with" string1))) + :prompt (format nil "Replace ~A with" string1))) (error () (progn (beep) (display-message "Empty string") (return-from com-query-replace nil))))) @@ -211,7 +211,7 @@ :string1 string1 :string2 string2) (query-replace-mode pane) t) - (display-message "Query Replace ~A with ~A:" + (display-message "Replace ~A with ~A:" string1 string2) (simple-command-loop 'query-replace-climacs-table (query-replace-mode pane) @@ -242,7 +242,7 @@ (:capitalized (capitalize-buffer-region buffer offset1 offset2))))) (incf occurrences) (if (query-replace-find-next-match point string1) - (display-message "Query Replace ~A with ~A:" + (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))) @@ -251,7 +251,7 @@ (let* ((pane (current-window)) (point (point pane))) (if (query-replace-find-next-match point string1) - (display-message "Query Replace ~A with ~A:" + (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))) @@ -287,3 +287,163 @@ :activation-gestures '(:newline :return)))) (re-search-backward (point (current-window)) string))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Multiple query replace + +(make-command-table 'multiple-query-replace-climacs-table :errorp nil) + +(defun multiple-query-replace-find-next-match (mark re list) + (multiple-value-bind (foundp start) + (re-search-forward mark re) + (when foundp + (loop with buffer = (buffer mark) + for string in list + when (buffer-looking-at buffer start string) + do (return string))))) + +(define-command (com-multiple-query-replace :name t :command-table search-table) () + "Prompts for pairs of strings, replacing the first with the second. +Entering an empty search string stops the prompting." + (let ((strings + (loop for string1 = (accept 'string :prompt "Multiple Query Replace") + until (string= string1 "") + for string2 + = (accept 'string + :prompt (format nil + "Replace ~A with" + string1)) + collecting (cons string1 string2)))) + (multiple-query-replace strings))) + +(define-command (com-multiple-query-replace-from-buffer :name t :command-table search-table) + ((buffer 'buffer :prompt "Buffer with Query Repace strings")) + (unless (member buffer (buffers *application-frame*)) + (beep) + (display-message "~A not an existing buffer" (name buffer)) + (return-from com-multiple-query-replace-from-buffer nil)) + (let* ((contents (buffer-substring buffer 0 (1- (size buffer)))) + (strings (loop with length = (length contents) + with index = 0 + with start = 0 + while (< index length) + do (loop until (>= index length) + while (whitespacep (char contents index)) + do (incf index)) + (setf start index) + (loop until (>= index length) + until (whitespacep (char contents index)) + do (incf index)) + until (= start index) + collecting (string-trim '(#\Space #\Tab #\Newline) + (subseq contents start index))))) + (unless (evenp (length strings)) + (beep) + (display-message "Uneven number of strings in ~A" (name buffer)) + (return-from com-multiple-query-replace-from-buffer nil)) + (multiple-query-replace (loop for (string1 string2) on strings by #'cddr + collect (cons string1 string2))))) + +(define-command (com-query-exchange :name t :command-table search-table) () + "Prompts for two strings to exchange for one another." + (let* ((string1 (accept 'string :prompt "Query Exchange")) + (string2 (accept 'string :prompt (format nil + "Exchange ~A and" + string1)))) + (multiple-query-replace (list (cons string1 string2) (cons string2 string1))))) + +(defun multiple-query-replace (strings) + (declare (special strings)) + (let* ((occurrences 0) + (search-strings (mapcar #'car strings)) + (re (format nil "~{~A~^|~}" search-strings))) + (declare (special occurrences re)) + (when strings + (let* ((pane (current-window)) + (point (point pane)) + (found (multiple-query-replace-find-next-match point re search-strings))) + (when found + (setf (query-replace-state pane) + (make-instance 'query-replace-state + :string1 found + :string2 (cdr (assoc found strings :test #'string=))) + (query-replace-mode pane) + t) + (display-message "Replace ~A with ~A: " + (string1 (query-replace-state pane)) + (string2 (query-replace-state pane))) + (simple-command-loop 'multiple-query-replace-climacs-table + (query-replace-mode pane) + ((setf (query-replace-mode pane) nil)))))) + (display-message "Replaced ~D occurrence~:P" occurrences))) + +(define-command (com-multiple-query-replace-replace + :name t + :command-table multiple-query-replace-climacs-table) + () + (declare (special strings occurrences re)) + (let* ((pane (current-window)) + (point (point pane)) + (buffer (buffer pane)) + (state (query-replace-state pane)) + (string1-length (length (string1 state)))) + (backward-object point string1-length) + (let* ((offset1 (offset point)) + (offset2 (+ offset1 string1-length)) + (region-case (buffer-region-case buffer offset1 offset2))) + (delete-range point string1-length) + (insert-sequence point (string2 state)) + (let ((new-offset2 (+ offset1 (length (string2 state))))) + (case region-case + (:upper-case (upcase-buffer-region buffer offset1 new-offset2)) + (:lower-case (downcase-buffer-region buffer offset1 new-offset2)) + (:capitalized (capitalize-buffer-region buffer offset1 new-offset2))))) + (incf occurrences) + (let ((found (multiple-query-replace-find-next-match + point + re + (mapcar #'car strings)))) + (cond ((null found) (setf (query-replace-mode pane) nil)) + (t (setf (query-replace-state pane) + (make-instance 'query-replace-state + :string1 found + :string2 (cdr (assoc found strings :test #'string=)))) + (display-message "Replace ~A with ~A: " + (string1 (query-replace-state pane)) + (string2 (query-replace-state pane)))))))) + +(define-command (com-multiple-query-replace-skip + :name t + :command-table multiple-query-replace-climacs-table) + () + (declare (special strings re)) + (let* ((pane (current-window)) + (point (point pane)) + (found (multiple-query-replace-find-next-match + point + re + (mapcar #'car strings)))) + (cond ((null found) (setf (query-replace-mode pane) nil)) + (t (setf (query-replace-state pane) + (make-instance 'query-replace-state + :string1 found + :string2 (cdr (assoc found strings :test #'string=)))) + (display-message "Replace ~A with ~A: " + (string1 (query-replace-state pane)) + (string2 (query-replace-state pane))))))) + +(defun multiple-query-replace-set-key (gesture command) + (add-command-to-command-table command 'multiple-query-replace-climacs-table + :keystroke gesture + :errorp nil)) + +(multiple-query-replace-set-key '(#\Newline) 'com-query-replace-exit) +(multiple-query-replace-set-key '(#\Space) 'com-multiple-query-replace-replace) +(multiple-query-replace-set-key '(#\Backspace) 'com-multiple-query-replace-skip) +(multiple-query-replace-set-key '(#\Rubout) 'com-multiple-query-replace-skip) +(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) + + From dmurray at common-lisp.net Fri May 12 18:51:54 2006 From: dmurray at common-lisp.net (dmurray) Date: Fri, 12 May 2006 14:51:54 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060512185154.038533A006@common-lisp.net> 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) - , at 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) + , at end-clauses)) + (redisplay-frame-panes *application-frame*))) + (abort-gesture () + , at end-clauses)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From dmurray at common-lisp.net Fri May 12 18:59:05 2006 From: dmurray at common-lisp.net (dmurray) Date: Fri, 12 May 2006 14:59:05 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060512185905.A1DD37C021@common-lisp.net> 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)) From dmurray at common-lisp.net Sat May 13 16:48:04 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 13 May 2006 12:48:04 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060513164804.C200F5E0F1@common-lisp.net> 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 From dmurray at common-lisp.net Sat May 13 17:15:10 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 13 May 2006 13:15:10 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060513171510.BC8CB4E003@common-lisp.net> 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 From dmurray at common-lisp.net Sat May 13 17:19:11 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 13 May 2006 13:19:11 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060513171911.0913252000@common-lisp.net> 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)) From dmurray at common-lisp.net Sun May 14 07:13:43 2006 From: dmurray at common-lisp.net (dmurray) Date: Sun, 14 May 2006 03:13:43 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060514071343.80AB0305A@common-lisp.net> 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 From dmurray at common-lisp.net Sun May 14 07:14:17 2006 From: dmurray at common-lisp.net (dmurray) Date: Sun, 14 May 2006 03:14:17 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060514071417.AB8CD7068@common-lisp.net> 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] From thenriksen at common-lisp.net Sun May 14 09:37:01 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 May 2006 05:37:01 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060514093701.8E21F710E7@common-lisp.net> 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)) From crhodes at common-lisp.net Sun May 14 17:42:21 2006 From: crhodes at common-lisp.net (crhodes) Date: Sun, 14 May 2006 13:42:21 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060514174221.3BC541E015@common-lisp.net> 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 at 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) From dmurray at common-lisp.net Sun May 14 20:35:44 2006 From: dmurray at common-lisp.net (dmurray) Date: Sun, 14 May 2006 16:35:44 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060514203544.C49FB22015@common-lisp.net> 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) - - From thenriksen at common-lisp.net Tue May 16 14:45:59 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 10:45:59 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060516144559.0EBCC232B2@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv518 Modified Files: esa-command-parser.lisp Log Message: Fixed handling of *unsupplied-argument-marker* for commands with >1 arguments. Previously, every argument would be treated as if it was *unsupplied-argument-marker* if just a single one was. Was this on purpose? It looked like a slight oversight regarding the behavior of DO. --- /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/10 09:52:05 1.1 +++ /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/16 14:45:58 1.2 @@ -108,11 +108,13 @@ (let (result) ;; only required args for now. (do ((required-args required-args (cdr required-args)) - (arg (car required-args) (car required-args)) + (arg (car required-args) (cadr required-args)) (command-args command-args (cdr command-args)) - (command-arg (car command-args) (car command-args))) + (command-arg (car command-args) (cadr command-args))) ((null required-args) (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg - (push (esa-parse-one-arg stream name ptype args command-arg) + (push (if (eq command-arg *unsupplied-argument-marker*) + (esa-parse-one-arg stream name ptype args command-arg) + command-arg) result) (maybe-clear-input))))))))) From thenriksen at common-lisp.net Tue May 16 19:33:41 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 15:33:41 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516193341.D759713004@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13303 Modified Files: lisp-syntax.lisp Log Message: Added syntactical recognition of literal cons cells. May need more work on error-detection. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/06 19:51:04 1.66 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:33:41 1.67 @@ -450,11 +450,13 @@ ;; May need more work. Can recognize symbols and numbers. (flet ((fo () (forward-object scan))) (let ((could-be-number t) - sign-seen dot-seen slash-seen) + sign-seen dot-seen slash-seen nondot-seen) (flet ((return-token-or-number-lexeme () (return-from lex-token (if could-be-number - (make-instance 'number-lexeme) + (if nondot-seen + (make-instance 'number-lexeme) + (make-instance 'dot-lexeme)) (make-instance 'complete-token-lexeme)))) (this-object () (object-after scan))) @@ -463,6 +465,8 @@ (when (end-of-buffer-p scan) (return-token-or-number-lexeme)) (when (constituentp (object-after scan)) + (when (not (eql (this-object) #\.)) + (setf nondot-seen t)) (cond ((or (eql (this-object) #\+) (eql (this-object) #\-)) (when sign-seen @@ -681,6 +685,42 @@ (define-lisp-action (|( form* | (eql nil)) (reduce-until-type incomplete-list-form left-parenthesis-lexeme)) +;;;;;;;;;;;;;;;; Cons cell +;; Also (foo bar baz . quux) constructs. +;; (foo bar . baz quux) flagged as an error (too aggressively?). + +;;; parse trees +(defclass cons-cell-form (form) ()) +(defclass complete-cons-cell-form (cons-cell-form complete-list-form) ()) +(defclass incomplete-cons-cell-form (cons-cell-form incomplete-list-form) ()) + +(define-parser-state |( form* dot-lexeme | + (lexer-list-state form-may-follow) ()) +(define-parser-state |( form* dot-lexeme form | + (lexer-list-state form-may-follow) ()) +(define-parser-state |( form* dot-lexeme form ) | + (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (|( form* | dot-lexeme) + |( form* dot-lexeme |) +(define-new-lisp-state (|( form* dot-lexeme | form) + |( form* dot-lexeme form |) +(define-new-lisp-state (|( form* dot-lexeme | comment) + |( form* dot-lexeme |) +(define-new-lisp-state (|( form* dot-lexeme form | right-parenthesis-lexeme) + |( form* dot-lexeme form ) |) +(define-new-lisp-state (|( form* dot-lexeme form | comment) + |( form* dot-lexeme form |) + +(define-lisp-action (|( form* dot-lexeme form ) | t) + (reduce-until-type complete-cons-cell-form left-parenthesis-lexeme)) + +;;; Reduce at end of buffer. +(define-lisp-action (|( form* dot-lexeme | (eql nil)) + (reduce-until-type incomplete-cons-cell-form left-parenthesis-lexeme)) +(define-lisp-action (|( form* dot-lexeme form | (eql nil)) + (reduce-until-type incomplete-cons-cell-form left-parenthesis-lexeme)) + ;;;;;;;;;;;;;;;; Simple Vector ;;; parse trees From thenriksen at common-lisp.net Tue May 16 19:38:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 15:38:49 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516193849.7238C22008@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13589 Modified Files: lisp-syntax.lisp Log Message: Oops. Added defclass for dot-lexeme. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:33:41 1.67 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:38:49 1.68 @@ -208,6 +208,7 @@ (defclass comma-lexeme (lisp-lexeme) ()) (defclass comma-at-lexeme (lisp-lexeme) ()) (defclass comma-dot-lexeme (lisp-lexeme) ()) +(defclass dot-lexeme (lisp-lexeme) ()) (defclass form-lexeme (form lisp-lexeme) ()) (defclass incomplete-character-lexeme (form-lexeme incomplete-form-mixin) ()) (defclass character-lexeme (form-lexeme) ()) From thenriksen at common-lisp.net Tue May 16 19:48:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 15:48:52 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516194852.E52EC3300A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv15202 Modified Files: lisp-syntax.lisp Log Message: Expanded, improved and fixed the `token-to-object' generic function and its methods. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:38:49 1.68 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:48:52 1.69 @@ -2007,15 +2007,15 @@ :case case :no-error t)) -(defgeneric token-to-object (syntax token &key no-error &allow-other-keys) +(defgeneric token-to-object (syntax token &rest args &key no-error package quote &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax token &key no-error package) + (:method :around (syntax token &rest args &key no-error package quote) ;; Ensure that every symbol that is READ will be looked up - ;; in the correct package. + ;; in the correct package. Also handle quoting. (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) (slot-value syntax 'package) (typep (slot-value syntax 'package) 'package)) @@ -2025,8 +2025,13 @@ package (find-package package))) (find-package :common-lisp))))) - (call-next-method)) + (if quote + (progn + (setf (getf args :quote) nil) + `',(call-next-method)) + (call-next-method))) (t () + ;; Needs more usable error. (unless no-error (error "Cannot convert token to Lisp object: ~A" token))))) (:method (syntax (token t) &key no-error) @@ -2034,7 +2039,7 @@ ;; We ignore `no-error' as it is truly a bug in Climacs if no ;; handler method is specialized on this form. (error "Cannot convert token to Lisp object: ~A" - token)) + token)) (:method (syntax (token incomplete-form-mixin) &key no-error) (unless no-error (error "Cannot convert incomplete form to Lisp object: ~A" @@ -2046,30 +2051,31 @@ (declare (ignore no-error)) (parse-symbol (token-string syntax token) :case case)) -(defmethod token-to-object (syntax (token number-lexeme) &key no-error) +(defmethod token-to-object (syntax (token complete-token-form) + &key no-error + (case (readtable-case *readtable*))) (declare (ignore no-error)) + (clouseau:inspector (parse-symbol (token-string syntax token) :case case))) + +(defmethod token-to-object (syntax (token number-lexeme) &rest args) + (declare (ignore args)) (let ((*read-base* (base syntax))) (read-from-string (token-string syntax token)))) -(defmethod token-to-object (syntax (token list-form) &key no-error) - (declare (ignore no-error)) - (mapcar #'(lambda (form) - (token-to-object syntax form)) - (remove-if-not #'(lambda (form) - (typep form 'form)) - (children token)))) +(defmethod token-to-object (syntax (token list-form) &rest args) + (loop for child in (children token) + if (typep child 'comma-at-form) + ;; How should we handle this? + collect (apply #'token-to-object syntax child args) + else if (typep child 'form) + collect (apply #'token-to-object syntax child args))) -(defmethod token-to-object (syntax (token simple-vector-form) &key no-error) - (declare (ignore no-error)) +(defmethod token-to-object (syntax (token simple-vector-form) &key) (apply #'vector - (mapcar #'(lambda (form) - (token-to-object syntax form)) - (remove-if-not #'(lambda (form) - (typep form 'form)) - (children token))))) + (call-next-method))) -(defmethod token-to-object (syntax (token incomplete-string-form) &key no-error) - (declare (ignore no-error)) +(defmethod token-to-object (syntax (token incomplete-string-form) &rest args) + (declare (ignore args)) (read-from-string (concatenate 'string (token-string syntax token) "\""))) @@ -2078,9 +2084,61 @@ (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token quote-form) &key no-error) - (list 'cl:quote - (token-to-object syntax (second (children token)) :no-error no-error))) +(defmethod token-to-object (syntax (token quote-form) &rest args) + (apply #'token-to-object syntax (second (children token)) :quote t args)) + +;; I'm not sure backquotes are handled correctly, but then again, +;; `token-to-object' is not meant to be a perfect Lisp reader, only a +;; convenience function. +(defmethod token-to-object (syntax (token backquote-form) &rest args) + (let ((backquoted-form (first-form (children token)))) + (if (typep backquoted-form 'list-form) + `'(,@(apply #'token-to-object syntax backquoted-form args)) + `',(apply #'token-to-object syntax backquoted-form args)))) + +(defmethod token-to-object (syntax (token comma-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) args)) + +(defmethod token-to-object (syntax (token comma-at-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) args)) + +(defmethod token-to-object (syntax (token function-form) &rest args) + (list 'cl:function (apply #'token-to-object syntax (second (children token)) + args))) + +(defmethod token-to-object (syntax (token character-lexeme) &key) + (read-from-string (token-string syntax token))) + +(defmethod token-to-object (syntax (token cons-cell-form) &key) + (let ((components (remove-if #'(lambda (token) + (not (typep token 'form))) + (children token)))) + (if (<= (length components) 2) + (cons (token-to-object syntax (first components)) + (token-to-object syntax (second components))) + (loop for (head . tail) on components + if (rest tail) + collect (token-to-object syntax head) + else if (not (null tail)) + append (cons (token-to-object syntax head) + (token-to-object syntax (first tail))))))) + +;; Perhaps just returning NIL for conditionals whose condition +;; evaluates to NIL isn't such a good idea? I don't think it's very +;; Intuitive. +(defmethod token-to-object (syntax (token reader-conditional-positive-form) &key) + (let ((conditional (second-noncomment (children token)))) + (when (eval-feature-conditional conditional syntax) + (token-to-object syntax (third-noncomment (children token)))))) + +(defmethod token-to-object (syntax (token reader-conditional-negative-form) &key) + (let ((conditional (second-noncomment (children token)))) + (when (not (eval-feature-conditional conditional syntax)) + (token-to-object syntax (third-noncomment (children token)))))) + +(defmethod token-to-object (syntax (token undefined-reader-macro-form) &key) + ;; ??? + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Tue May 16 20:00:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 16:00:52 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516200052.A39AC39003@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16994 Modified Files: lisp-syntax.lisp Log Message: Added ":no-error t" arguments to calls to `token-to-object'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 19:48:52 1.69 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:00:50 1.70 @@ -1172,7 +1172,8 @@ (when (typep x 'complete-list-form) (let ((candidate (first-form (children x)))) (and (typep candidate 'token-mixin) - (eq (token-to-object syntax candidate) + (eq (token-to-object syntax candidate + :no-error t) 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) @@ -1466,7 +1467,7 @@ (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) (let ((string (token-string syntax parse-symbol))) (multiple-value-bind (symbol status) - (token-to-object syntax parse-symbol) + (token-to-object syntax parse-symbol :no-error t) (with-output-as-presentation (pane (if status symbol string) (if status 'symbol 'unknown-symbol) :single-box :highlighting) From thenriksen at common-lisp.net Tue May 16 20:13:17 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 16:13:17 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516201317.E14F77D008@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17472 Modified Files: lisp-syntax.lisp Log Message: Made the quote-characters use the same face as the rest of the string when displaying string lexemes. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:00:50 1.70 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:13:17 1.71 @@ -1521,13 +1521,14 @@ (end-offset (car (last children 2)))))) (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) - (display-parse-tree (pop children) syntax pane) (with-face (:string) + (display-parse-tree (pop children) syntax pane) (loop until (null (cdr children)) - do (display-parse-tree (pop children) syntax pane))) - (display-parse-tree (pop children) syntax pane))) - (progn (display-parse-tree (pop children) syntax pane) - (display-parse-tree (pop children) syntax pane))))) + do (display-parse-tree (pop children) syntax pane)) + (display-parse-tree (pop children) syntax pane)))) + (with-face (:string) + (progn (display-parse-tree (pop children) syntax pane) + (display-parse-tree (pop children) syntax pane)))))) (defmethod display-parse-tree ((parse-symbol incomplete-string-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) @@ -1537,11 +1538,12 @@ (end-offset (car (last children)))))) (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) - (display-parse-tree (pop children) syntax pane) (with-face (:string) + (display-parse-tree (pop children) syntax pane) (loop until (null children) do (display-parse-tree (pop children) syntax pane))))) - (display-parse-tree (pop children) syntax pane)))) + (with-face (:string) + (display-parse-tree (pop children) syntax pane))))) (defmethod display-parse-tree ((parse-symbol line-comment-form) (syntax lisp-syntax) pane) (with-face (:comment) From thenriksen at common-lisp.net Tue May 16 20:38:31 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 16:38:31 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516203831.DF65F53012@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20950 Modified Files: lisp-syntax.lisp Log Message: Use colors that are more visible on a white background and resembles out-of-the-box GNU Emacs. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:13:17 1.71 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:38:31 1.72 @@ -1372,10 +1372,10 @@ (defparameter *standard-faces* `((:error ,+red+ nil) - (:string ,+coral+ ,(make-text-style nil :italic nil)) - (:keyword ,+dark-violet+ nil) - (:macro ,+cyan+) - (:special-form ,+cyan+) + (:string ,+rosy-brown+ ,(make-text-style nil :italic nil)) + (:keyword ,+orchid+ nil) + (:macro ,+purple+ nil) + (:special-form ,+purple+ nil) (:lambda-list-keyword ,+dark-green+ nil) (:comment ,+maroon+ nil) (:reader-conditional ,+gray50+ nil))) From thenriksen at common-lisp.net Tue May 16 20:59:16 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 16:59:16 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516205916.320C25D096@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22841 Modified Files: misc-commands.lisp Log Message: Changed all commands in file to use proper command arguments instead of calling `accept' explicitly. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/14 07:14:17 1.12 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/16 20:59:16 1.13 @@ -817,7 +817,7 @@ (loop until (end-of-line-p mark) while (whitespacep (object-after mark)) repeat count do (forward-object mark) - finally (setf offset (offset mark))) + finally (setf offset (offset mark))) (loop until (end-of-line-p mark) while (whitespacep (object-after mark)) do (forward-object mark)) @@ -838,14 +838,12 @@ (defun goto-position (mark pos) (setf (offset mark) pos)) -(define-command (com-goto-position :name t :command-table movement-table) () +(define-command (com-goto-position :name t :command-table movement-table) + ((position 'integer :prompt "Goto Position")) "Prompts for an integer, and sets the offset of point to that integer." (goto-position (point (current-window)) - (handler-case (accept 'integer :prompt "Goto Position") - (error () (progn (beep) - (display-message "Not a valid position") - (return-from com-goto-position nil)))))) + position)) (defun goto-line (mark line-number) (loop with m = (clone-mark (low-mark (buffer mark)) @@ -859,24 +857,22 @@ finally (beginning-of-line m) (setf (offset mark) (offset m)))) -(define-command (com-goto-line :name t :command-table movement-table) () +(define-command (com-goto-line :name t :command-table movement-table) + ((line-number 'integer :prompt "Goto Line")) "Prompts for a line number, and sets point to the beginning of that line. 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) - (display-message "Not a valid line number") - (return-from com-goto-line nil)))))) - -(define-command (com-browse-url :name t :command-table base-table) () - (let ((url (accept 'url :prompt "Browse URL"))) - #+ (and sbcl darwin) - (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil) - #+ (and openmcl darwin) - (ccl:run-program "/usr/bin/open" `(,url) :wait nil))) + (goto-line (point (current-window)) line-number)) + +(define-command (com-browse-url :name t :command-table base-table) + ((url 'url :prompt "Browse URL")) + (declare (ignorable url)) + #+ (and sbcl darwin) + (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil) + #+ (and openmcl darwin) + (ccl:run-program "/usr/bin/open" `(,url) :wait nil)) (define-command (com-set-mark :name t :command-table marking-table) () "Set mark to the current position of point." @@ -915,15 +911,12 @@ (beep) (display-message "No such syntax: ~A." syntax))))) -(define-command (com-set-syntax :name t :command-table buffer-table) () +(define-command (com-set-syntax :name t :command-table buffer-table) + ((syntax 'syntax + :prompt "Name of syntax")) "Prompts for a syntax to set for the current buffer. -Setting a syntax will cause the buffer to be reparsed using the new syntax." - (let* ((pane (current-window)) - (buffer (buffer pane))) - (handler-case (set-syntax buffer (accept 'syntax :prompt "Set Syntax")) - (input-not-of-required-type - (message) - (display-message "Invalid syntax: ~A." message))))) + Setting a syntax will cause the buffer to be reparsed using the new syntax." + (set-syntax (current-buffer) syntax)) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -979,14 +972,11 @@ 'editing-table '((#\y :meta))) -(define-command (com-resize-kill-ring :name t :command-table editing-table) () +(define-command (com-resize-kill-ring :name t :command-table editing-table) + ((size 'integer :prompt "New kill ring size")) "Prompt for a new size for the kill ring. The default is 5. A number less than 5 will be replaced by 5." - (let ((size (handler-case (accept 'integer :prompt "New kill ring size") - (error () (progn (beep) - (display-message "Not a valid kill ring size") - (return-from com-resize-kill-ring nil)))))) - (setf (kill-ring-max-size *kill-ring*) size))) + (setf (kill-ring-max-size *kill-ring*) size)) (define-command (com-append-next-kill :name t :command-table editing-table) () "Set the kill ring to append the next kill to the previous one." @@ -1336,17 +1326,14 @@ '((#\x :control) (#\=))) (define-command (com-eval-expression :name t :command-table base-table) - ((insertp 'boolean :prompt "Insert?")) + ((exp 'expression :prompt "Eval") + (insertp 'boolean :prompt "Insert?")) "Prompt for and evaluate a lisp expression. With a numeric argument inserts the result at point as a string; otherwise prints the result." (let* ((*package* (find-package :climacs-gui)) - (string (handler-case (accept 'string :prompt "Eval") - (error () (progn (beep) - (display-message "Empty string") - (return-from com-eval-expression nil))))) - (values (multiple-value-list - (handler-case (eval (read-from-string string)) + (values (multiple-value-list + (handler-case (eval exp) (error (condition) (progn (beep) (display-message "~a" condition) (return-from com-eval-expression nil)))))) @@ -1355,7 +1342,7 @@ (insert-sequence (point (current-window)) result) (display-message result)))) -(set-key `(com-eval-expression ,*numeric-argument-p*) +(set-key `(com-eval-expression ,*unsupplied-argument-marker* ,*numeric-argument-p*) 'base-table '((#\: :shift :meta))) From dmurray at common-lisp.net Tue May 16 21:08:08 2006 From: dmurray at common-lisp.net (dmurray) Date: Tue, 16 May 2006 17:08:08 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516210808.DF2C261004@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24606 Modified Files: search-commands.lisp Log Message: Preliminary addition of some extra options for isearch: C-j (appends a #\Newline to the search string) C-w (appends the word after point) C-y (appends the remainder of the line after point) M-y (appends the most recent kill) Still work to be done, but useful even now. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/14 20:35:44 1.3 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/16 21:08:08 1.4 @@ -28,6 +28,13 @@ (in-package :climacs-gui) +(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)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; String search @@ -107,7 +114,7 @@ (- (offset mark2) (length string)) (+ (offset mark2) (length string))))) (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" - success forwardp string) + success forwardp (display-string string)) (push (make-instance 'isearch-state :search-string string :search-mark mark @@ -133,18 +140,60 @@ 'search-table '((#\r :control))) -(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) () +(defun isearch-append-char (char) (let* ((pane (current-window)) (states (isearch-states pane)) (string (concatenate 'string (search-string (first states)) - (string *current-gesture*))) + (string char))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) (unless forwardp (incf (offset mark))) (isearch-from-mark pane mark string forwardp))) +(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) () + (isearch-append-char *current-gesture*)) + +(define-command (com-isearch-append-newline :name t :command-table isearch-climacs-table) () + (isearch-append-char #\Newline)) + +(defun isearch-append-text (movement-function) + (let* ((pane (current-window)) + (states (isearch-states pane)) + (buffer (buffer pane)) + (point (point pane)) + (start (clone-mark point)) + (mark (clone-mark (search-mark (first states)))) + (forwardp (search-forward-p (first states)))) + (funcall movement-function point) + (let ((string (concatenate 'string + (search-string (first states)) + (buffer-substring buffer + (offset start) + (offset point))))) + (unless forwardp + (incf (offset mark))) + (isearch-from-mark pane mark string forwardp)))) + +(define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) () + (isearch-append-text #'forward-word)) + +(define-command (com-isearch-append-line :name t :command-table isearch-climacs-table) () + (isearch-append-text #'end-of-line)) + +(define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) () + (let* ((pane (current-window)) + (states (isearch-states pane)) + (string (concatenate 'string + (search-string (first states)) + (kill-ring-yank *kill-ring*))) + (mark (clone-mark (search-mark (first states)))) + (forwardp (search-forward-p (first states)))) + (unless forwardp + (incf (offset mark))) + (isearch-from-mark pane mark string forwardp))) + (define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) () (let* ((pane (current-window))) (cond ((null (second (isearch-states pane))) @@ -164,7 +213,7 @@ (length (search-string state))))) (display-message "Isearch~:[ backward~;~]: ~A" (search-forward-p state) - (search-string state))))))) + (display-string (search-string state)))))))) (define-command (com-isearch-search-forward :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) @@ -200,6 +249,10 @@ (isearch-set-key '(#\Backspace) 'com-isearch-delete-char) (isearch-set-key '(#\s :control) 'com-isearch-search-forward) (isearch-set-key '(#\r :control) 'com-isearch-search-backward) +(isearch-set-key '(#\j :control) 'com-isearch-append-newline) +(isearch-set-key '(#\w :control) 'com-isearch-append-word) +(isearch-set-key '(#\y :control) 'com-isearch-append-line) +(isearch-set-key '(#\y :meta) 'com-isearch-append-kill) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Tue May 16 21:36:29 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 May 2006 17:36:29 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060516213629.BAE1468003@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28282 Modified Files: lisp-syntax.lisp Log Message: Removed call to Clouseau (oops again). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 20:38:31 1.72 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 21:36:29 1.73 @@ -2058,7 +2058,7 @@ &key no-error (case (readtable-case *readtable*))) (declare (ignore no-error)) - (clouseau:inspector (parse-symbol (token-string syntax token) :case case))) + (parse-symbol (token-string syntax token) :case case)) (defmethod token-to-object (syntax (token number-lexeme) &rest args) (declare (ignore args)) From dmurray at common-lisp.net Wed May 17 06:33:12 2006 From: dmurray at common-lisp.net (dmurray) Date: Wed, 17 May 2006 02:33:12 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060517063312.DD73B50006@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv32495 Modified Files: search-commands.lisp Log Message: Fixed buglet when reverse-isearching from end of buffer. (It now works.) --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/16 21:08:08 1.4 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/17 06:33:12 1.5 @@ -148,7 +148,7 @@ (string char))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) - (unless forwardp + (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark))) (isearch-from-mark pane mark string forwardp))) @@ -172,7 +172,7 @@ (buffer-substring buffer (offset start) (offset point))))) - (unless forwardp + (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark))) (isearch-from-mark pane mark string forwardp)))) @@ -190,7 +190,7 @@ (kill-ring-yank *kill-ring*))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) - (unless forwardp + (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark))) (isearch-from-mark pane mark string forwardp))) From thenriksen at common-lisp.net Thu May 18 21:43:39 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 18 May 2006 17:43:39 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060518214339.DA22653013@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26156 Modified Files: lisp-syntax.lisp Log Message: Fixed symbol finding code and removed deprecated string indentation rule. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/16 21:36:29 1.73 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/18 21:43:39 1.74 @@ -1999,7 +1999,7 @@ (multiple-value-bind (symbol status) (when package (find-symbol symbol-name package)) - (if symbol + (if (or symbol package) (values symbol status) (values (make-symbol symbol-name) nil)))))) @@ -2196,9 +2196,6 @@ ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))))) -(defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) - (values tree 1)) - (defmethod indent-form ((syntax lisp-syntax) (tree token-form) path) (values tree 0)) From thenriksen at common-lisp.net Fri May 19 11:09:11 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 19 May 2006 07:09:11 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060519110911.641E168003@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2122 Modified Files: lisp-syntax.lisp Log Message: Fixed: use status, not package. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/18 21:43:39 1.74 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/19 11:09:11 1.75 @@ -1999,7 +1999,7 @@ (multiple-value-bind (symbol status) (when package (find-symbol symbol-name package)) - (if (or symbol package) + (if (or symbol status) (values symbol status) (values (make-symbol symbol-name) nil)))))) From thenriksen at common-lisp.net Sat May 20 19:21:26 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 20 May 2006 15:21:26 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060520192126.7C09344080@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5854 Modified Files: lisp-syntax.lisp Log Message: Cleaned the indentation functions for reader-conditionals and slightly optimized a redisplay funtion to make fewer generic function calls. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/19 11:09:11 1.75 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/20 19:21:26 1.76 @@ -916,8 +916,9 @@ ;;;;;;;;;;;;;;;; Reader conditionals ;;; parse trees -(defclass reader-conditional-positive-form (form) ()) -(defclass reader-conditional-negative-form (form) ()) +(defclass reader-conditional-form (form) ()) +(defclass reader-conditional-positive-form (reader-conditional-form) ()) +(defclass reader-conditional-negative-form (reader-conditional-form) ()) (define-parser-state |#+ | (form-may-follow) ()) (define-parser-state |#+ form | (form-may-follow) ()) @@ -1428,13 +1429,17 @@ (defmethod display-parse-tree :around (parse-symbol syntax pane) (with-slots (top bot) pane (when (and (start-offset parse-symbol) - (mark< (start-offset parse-symbol) bot) - (mark> (end-offset parse-symbol) top)) + (mark< (start-offset parse-symbol) bot) + (mark> (end-offset parse-symbol) top)) (call-next-method)))) (defmethod display-parse-tree (parse-symbol syntax pane) - (loop for child in (children parse-symbol) - do (display-parse-tree child syntax pane))) + (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)))) (defmethod display-parse-tree ((parse-symbol error-symbol) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) @@ -2147,6 +2152,8 @@ ;;; ;;; indentation +(defgeneric indent-form (syntax tree path)) + (defmethod indent-form ((syntax lisp-syntax) (tree form*) path) (cond ((or (null path) (and (null (cdr path)) (zerop (car path)))) @@ -2158,24 +2165,12 @@ (defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) (values (form-toplevel tree syntax) 0)) -;; FIXME: The next two methods are basically identical to the above definition, -;; something should be done about this duplication. - -(defmethod indent-form ((syntax lisp-syntax) (tree reader-conditional-positive-form) path) - (cond ((or (null path) - (and (null (cdr path)) (zerop (car path)))) - (values tree 0)) - ((null (cdr path)) - (values (elt-noncomment (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) - -(defmethod indent-form ((syntax lisp-syntax) (tree reader-conditional-negative-form) path) +(defmethod indent-form ((syntax lisp-syntax) (tree reader-conditional-form) path) (cond ((or (null path) (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt-noncomment (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) + (values (first-form (children tree)) 0)))) (defmethod indent-form ((syntax lisp-syntax) (tree list-form) path) (if (= (car path) 1) From thenriksen at common-lisp.net Mon May 22 18:23:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 22 May 2006 14:23:03 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060522182303.4F1462009@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11076 Modified Files: lisp-syntax.lisp Log Message: Added indentation method for function-forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/20 19:21:26 1.76 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/22 18:23:03 1.77 @@ -2206,6 +2206,11 @@ (defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) +(defmethod indent-form ((syntax lisp-syntax) (tree function-form) path) + (if (null (cdr path)) + (values tree 0) + (indent-form syntax (elt-form (children tree) 0) (cdr path)))) + (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) ;; top level From crhodes at common-lisp.net Wed May 24 08:38:37 2006 From: crhodes at common-lisp.net (crhodes) Date: Wed, 24 May 2006 04:38:37 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060524083837.1746059080@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv21300 Modified Files: esa-command-parser.lisp Log Message: Accept the status quo behaviour for esa-parse-one-arg, writing a comment explaining the issue. Also use do* as I should have done in the first place. --- /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/16 14:45:58 1.2 +++ /project/climacs/cvsroot/esa/esa-command-parser.lisp 2006/05/24 08:38:36 1.3 @@ -20,8 +20,13 @@ (in-package :esa) -(defun esa-parse-one-arg (stream name ptype accept-args - &optional (default *unsupplied-argument-marker*)) +;;; There is an ambiguity over what to do for parsing partial commands +;;; with certain values filled in, as might occur for keyboard +;;; shortcuts. Either the supplied arguments should be treated as +;;; gospel and not even mentioned to the user, as we do now; or they +;;; should be treated as the default, but the user should be prompted +;;; to confirm, as we used to do. +(defun esa-parse-one-arg (stream name ptype accept-args) (declare (ignore name)) ;; this conditional doesn't feel entirely happy. The issue is that ;; we could be called either recursively from an outer call to @@ -36,26 +41,22 @@ stream))) (apply #'accept (eval ptype) :stream stream - (append - (unless (eq default *unsupplied-argument-marker*) - ;; adjust to taste. - `(:default ,default :insert-default nil :display-default t)) - ;; This is fucking nuts. FIXME: the clim spec says - ;; ":GESTURE is not evaluated at all". Um, but how are - ;; you meant to tell if a keyword argument is :GESTURE, - ;; then? The following does not actually allow variable - ;; keys: anyone who writes (DEFINE-COMMAND FOO ((BAR - ;; 'PATHNAME *RANDOM-ARG* ""))) and expects it to work - ;; deserves to lose. - ;; - ;; FIXME: this will do the wrong thing on malformed accept - ;; arguments, such improper lists or those with an odd - ;; number of keyword arguments. I doubt that - ;; DEFINE-COMMAND is checking the syntax, so we probably - ;; should. - (loop for (key val) on accept-args by #'cddr - unless (eq key :gesture) - collect key and collect (eval val)))))) + ;; This is fucking nuts. FIXME: the clim spec says + ;; ":GESTURE is not evaluated at all". Um, but how are you + ;; meant to tell if a keyword argument is :GESTURE, then? + ;; The following does not actually allow variable keys: + ;; anyone who writes (DEFINE-COMMAND FOO ((BAR 'PATHNAME + ;; *RANDOM-ARG* ""))) and expects it to work deserves to + ;; lose. + ;; + ;; FIXME: this will do the wrong thing on malformed accept + ;; arguments, such improper lists or those with an odd + ;; number of keyword arguments. I doubt that + ;; DEFINE-COMMAND is checking the syntax, so we probably + ;; should. + (loop for (key val) on accept-args by #'cddr + unless (eq key :gesture) + collect key and collect (eval val))))) (defun esa-command-parser (command-table stream) (let ((command-name nil)) @@ -107,14 +108,14 @@ (declare (ignore keyword-args)) (let (result) ;; only required args for now. - (do ((required-args required-args (cdr required-args)) - (arg (car required-args) (cadr required-args)) - (command-args command-args (cdr command-args)) - (command-arg (car command-args) (cadr command-args))) - ((null required-args) (cons command-name (nreverse result))) + (do* ((required-args required-args (cdr required-args)) + (arg (car required-args) (car required-args)) + (command-args command-args (cdr command-args)) + (command-arg (car command-args) (car command-args))) + ((null required-args) (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg (push (if (eq command-arg *unsupplied-argument-marker*) - (esa-parse-one-arg stream name ptype args command-arg) + (esa-parse-one-arg stream name ptype args) command-arg) result) (maybe-clear-input))))))))) From dmurray at common-lisp.net Fri May 26 22:41:54 2006 From: dmurray at common-lisp.net (dmurray) Date: Fri, 26 May 2006 18:41:54 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060526224154.62EE65402B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12813 Modified Files: search-commands.lisp Log Message: Added . (replace and exit) and ! (replace all without asking) keys to Query Replace and Multiple Query Replace. Added Replace String (without querying) command. Added (hackishly) entry to the String Search and Reverse String Search commands by typing #\Newline with an empty isearch string (e.g. C-s starts String Search). Added some case-sensitivity logic to searches (a search-string with no upper-case characters searches case-insensitively). Added some preliminary whitespace logic to Regex searches. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/17 06:33:12 1.5 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/26 22:41:54 1.6 @@ -35,25 +35,49 @@ ((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 (define-command (com-string-search :name t :command-table search-table) - ((string 'string :prompt "Search string")) + ((string 'string :prompt "String Search")) "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))) + (search-forward point string :test (case-relevant-test string)))) (define-command (com-reverse-string-search :name t :command-table search-table) - ((string 'string :prompt "Search string")) + ((string 'string :prompt "Reverse String Search")) "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))) + (search-backward point string :test (case-relevant-test string)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -98,31 +122,27 @@ ((setf (isearch-mode pane) nil))))) (defun isearch-from-mark (pane mark string forwardp) - (flet ((object-equal (x y) - (if (characterp x) - (and (characterp y) (char-equal x y)) - (eql x y)))) - (let* ((point (point pane)) - (mark2 (clone-mark mark)) - (success (funcall (if forwardp #'search-forward #'search-backward) - mark2 - string - :test #'object-equal))) - (when success - (setf (offset point) (offset mark2) - (offset mark) (if forwardp - (- (offset mark2) (length string)) - (+ (offset mark2) (length string))))) - (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" - success forwardp (display-string string)) - (push (make-instance 'isearch-state - :search-string string - :search-mark mark - :search-forward-p forwardp - :search-success-p success) - (isearch-states pane)) - (unless success - (beep))))) + (let* ((point (point pane)) + (mark2 (clone-mark mark)) + (success (funcall (if forwardp #'search-forward #'search-backward) + mark2 + string + :test (case-relevant-test string)))) + (when success + (setf (offset point) (offset mark2) + (offset mark) (if forwardp + (- (offset mark2) (length string)) + (+ (offset mark2) (length string))))) + (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" + success forwardp (display-string string)) + (push (make-instance 'isearch-state + :search-string string + :search-mark mark + :search-forward-p forwardp + :search-success-p success) + (isearch-states pane)) + (unless success + (beep)))) (define-command (com-isearch-forward :name t :command-table search-table) () (display-message "Isearch: ") @@ -167,13 +187,15 @@ (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) (funcall movement-function point) - (let ((string (concatenate 'string - (search-string (first states)) - (buffer-substring buffer - (offset start) - (offset point))))) + (let* ((start-offset (offset start)) + (point-offset (offset point)) + (string (concatenate 'string + (search-string (first states)) + (buffer-substring buffer + start-offset + point-offset)))) (unless (or forwardp (end-of-buffer-p mark)) - (incf (offset mark))) + (incf (offset mark) (- point-offset start-offset))) (isearch-from-mark pane mark string forwardp)))) (define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) () @@ -185,13 +207,14 @@ (define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (states (isearch-states pane)) + (yank (kill-ring-yank *kill-ring*)) (string (concatenate 'string (search-string (first states)) - (kill-ring-yank *kill-ring*))) + yank)) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) (unless (or forwardp (end-of-buffer-p mark)) - (incf (offset mark))) + (incf (offset mark) (length yank))) (isearch-from-mark pane mark string forwardp))) (define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) () @@ -236,7 +259,21 @@ (isearch-from-mark pane mark string nil))) (define-command (com-isearch-exit :name t :command-table isearch-climacs-table) () - (setf (isearch-mode (current-window)) nil)) + (let* ((pane (current-window)) + (states (isearch-states pane)) + (string (search-string (first states))) + (search-forward-p (search-forward-p (first states)))) + (setf (isearch-mode pane) nil) + (when (string= string "") + (execute-frame-command *application-frame* + (funcall + *partial-command-parser* + (frame-command-table *application-frame*) + (frame-standard-input *application-frame*) + (if search-forward-p + `(com-string-search ,*unsupplied-argument-marker*) + `(com-reverse-string-search ,*unsupplied-argument-marker*)) + 0))))) (defun isearch-set-key (gesture command) (add-command-to-command-table command 'isearch-climacs-table @@ -256,18 +293,55 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Unconditional replace + +(defun replace-one-string (mark length newstring &optional (use-region-case t)) + "Replace LENGTH objects at MARK with NEWSTRING, +using the case of those objects if USE-REGION-CASE is true." + (let* ((start (offset mark)) + (end (+ start length)) + (region-case (and use-region-case + (buffer-region-case (buffer mark) + start + end)))) + (delete-range mark length) + (insert-sequence mark newstring) + (when (and use-region-case region-case) + (let ((buffer (buffer mark)) + (end2 (+ start (length newstring)))) + (funcall (case region-case + (:upper-case #'upcase-buffer-region) + (:lower-case #'downcase-buffer-region) + (:capitalized #'capitalize-buffer-region)) + buffer + start + end2))))) + +(define-command (com-replace-string :name t :command-table search-table) + () + "Replace all occurrences of `string' with `newstring'." + ;; We have to do it this way if we want to refer to STRING in NEWSTRING + (let* ((string (accept 'string :prompt "Replace String")) + (newstring (accept'string :prompt (format nil "Replace ~A with" string)))) + (loop with point = (point (current-window)) + with length = (length string) + with use-region-case = (no-upper-p string) + for occurrences from 0 + while (query-replace-find-next-match point string) + do (backward-object point length) + (replace-one-string point length newstring use-region-case) + finally (display-message "Replaced ~A occurrence~:P" occurrences)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Query replace (make-command-table 'query-replace-climacs-table :errorp nil) (defun query-replace-find-next-match (mark string) - (flet ((object-equal (x y) - (and (characterp x) - (characterp y) - (char-equal x y)))) - (let ((offset-before (offset mark))) - (search-forward mark string :test #'object-equal) - (/= (offset mark) offset-before)))) + (let ((offset-before (offset mark))) + (search-forward mark string :test (case-relevant-test string)) + (/= (offset mark) offset-before))) (define-command (com-query-replace :name t :command-table search-table) () (let* ((pane (current-window)) @@ -319,26 +393,42 @@ (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) (point (point pane)) - (buffer (buffer pane)) (string1-length (length string1))) (backward-object point string1-length) - (let* ((offset1 (offset point)) - (offset2 (+ offset1 string1-length)) - (region-case (buffer-region-case buffer offset1 offset2))) - (delete-range point string1-length) - (insert-sequence point string2) - (setf offset2 (+ offset1 (length string2))) - (unless (find-if #'upper-case-p string1) - (case region-case - (:upper-case (upcase-buffer-region buffer offset1 offset2)) - (:lower-case (downcase-buffer-region buffer offset1 offset2)) - (:capitalized (capitalize-buffer-region buffer offset1 offset2))))) + (replace-one-string point string1-length string2 (no-upper-p string1)) (incf occurrences) (if (query-replace-find-next-match point string1) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))) +(define-command (com-query-replace-replace-and-quit + :name t + :command-table query-replace-climacs-table) + () + (declare (special string1 string2 occurrences)) + (let* ((pane (current-window)) + (point (point pane)) + (string1-length (length string1))) + (backward-object point string1-length) + (replace-one-string point string1-length string2 (no-upper-p string1)) + (incf occurrences) + (setf (query-replace-mode pane) nil))) + +(define-command (com-query-replace-replace-all + :name t + :command-table query-replace-climacs-table) + () + (declare (special string1 string2 occurrences)) + (let* ((pane (current-window)) + (point (point pane)) + (string1-length (length string1))) + (loop do (backward-object point string1-length) + (replace-one-string point string1-length string2 (no-upper-p string1)) + (incf occurrences) + while (query-replace-find-next-match point string1) + finally (setf (query-replace-mode pane) nil)))) + (define-command (com-query-replace-skip :name t :command-table query-replace-climacs-table) () (declare (special string1 string2)) (let* ((pane (current-window)) @@ -362,24 +452,50 @@ (query-replace-set-key '(#\q) 'com-query-replace-exit) (query-replace-set-key '(#\y) 'com-query-replace-replace) (query-replace-set-key '(#\n) 'com-query-replace-skip) +(query-replace-set-key '(#\.) 'com-query-replace-replace-and-quit) +(query-replace-set-key '(#\!) 'com-query-replace-replace-all) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Regex search +(defparameter *whitespace-regex* (format nil "[~@{~A~}]+" #\Space #\Tab)) + +(defun normalise-minibuffer-regex (string) + "Massages the regex STRING given to the minibuffer." + (with-output-to-string (result) + (loop for char across string + if (char= char #\Space) + do (princ *whitespace-regex* result) + else + do (princ char result)))) + (define-command (com-regex-search-forward :name t :command-table search-table) () (let ((string (accept 'string :prompt "RE search" :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (re-search-forward (point (current-window)) string))) + (re-search-forward + (point (current-window)) + (normalise-minibuffer-regex string)))) (define-command (com-regex-search-backward :name t :command-table search-table) () (let ((string (accept 'string :prompt "RE search backward" :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (re-search-backward (point (current-window)) string))) + (re-search-backward + (point (current-window)) + (normalise-minibuffer-regex string)))) + +(define-command (com-how-many :name t :command-table search-table) + ((regex 'string :prompt "How many matches for")) + (let* ((re (normalise-minibuffer-regex regex)) + (mark (clone-mark (point (current-window)))) + (occurrences (loop for count from 0 + while (re-search-forward mark re) + finally (return count)))) + (display-message "~A occurrence~:P" occurrences))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -475,23 +591,14 @@ :name t :command-table multiple-query-replace-climacs-table) () - (declare (special strings occurrences re)) + (declare (special strings occurrences re)) (let* ((pane (current-window)) - (point (point pane)) - (buffer (buffer pane)) + (point (point pane)) (state (query-replace-state pane)) - (string1-length (length (string1 state)))) + (string1 (string1 state)) + (string1-length (length string1))) (backward-object point string1-length) - (let* ((offset1 (offset point)) - (offset2 (+ offset1 string1-length)) - (region-case (buffer-region-case buffer offset1 offset2))) - (delete-range point string1-length) - (insert-sequence point (string2 state)) - (let ((new-offset2 (+ offset1 (length (string2 state))))) - (case region-case - (:upper-case (upcase-buffer-region buffer offset1 new-offset2)) - (:lower-case (downcase-buffer-region buffer offset1 new-offset2)) - (:capitalized (capitalize-buffer-region buffer offset1 new-offset2))))) + (replace-one-string point string1-length (string2 state) (no-upper-p string1)) (incf occurrences) (let ((found (multiple-query-replace-find-next-match point @@ -506,6 +613,50 @@ (string1 (query-replace-state pane)) (string2 (query-replace-state pane)))))))) + +(define-command (com-multiple-query-replace-replace-and-quit + :name t + :command-table multiple-query-replace-climacs-table) + () + (declare (special strings occurrences)) + (let* ((pane (current-window)) + (point (point pane)) + (state (query-replace-state pane)) + (string1 (string1 state)) + (string1-length (length string1))) + (backward-object point string1-length) + (replace-one-string point string1-length (string2 state) (no-upper-p string1)) + (incf occurrences) + (setf (query-replace-mode pane) nil))) + +(define-command (com-multiple-query-replace-replace-all + :name t + :command-table multiple-query-replace-climacs-table) + () + (declare (special strings occurrences re)) + (let* ((pane (current-window)) + (point (point pane)) + (found nil)) + (loop for state = (query-replace-state pane) [29 lines skipped] From thenriksen at common-lisp.net Sun May 28 15:58:24 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 28 May 2006 11:58:24 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060528155824.E98683035@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv21618 Modified Files: packages.lisp Log Message: Added `current-buffer' to list of exported symbols. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/05/14 20:35:44 1.96 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/28 15:58:24 1.97 @@ -177,6 +177,7 @@ ;; GUI functions follow. :climacs-rv ; Entry point with alternate colors. :current-window + :current-buffer :point :syntax :mark From thenriksen at common-lisp.net Wed May 31 13:55:15 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 31 May 2006 09:55:15 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060531135515.3C7544D00B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17530 Modified Files: lisp-syntax.lisp Log Message: Added :read keyword parameter to `token-to-object'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/22 18:23:03 1.77 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/31 13:55:15 1.78 @@ -2015,13 +2015,13 @@ :case case :no-error t)) -(defgeneric token-to-object (syntax token &rest args &key no-error package quote &allow-other-keys) +(defgeneric token-to-object (syntax token &rest args &key no-error package quote read &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax token &rest args &key no-error package quote) + (:method :around (syntax token &rest args &key no-error package quote read) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) @@ -2033,11 +2033,13 @@ package (find-package package))) (find-package :common-lisp))))) - (if quote - (progn - (setf (getf args :quote) nil) - `',(call-next-method)) - (call-next-method))) + (cond (read + (read-from-string (token-string syntax token))) + (quote + (setf (getf args :quote) nil) + `',(call-next-method)) + (t + (call-next-method)))) (t () ;; Needs more usable error. (unless no-error From thenriksen at common-lisp.net Wed May 31 14:47:29 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 31 May 2006 10:47:29 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060531144729.19B4931090@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24920 Modified Files: lisp-syntax.lisp Log Message: Added `symbol-at-mark' function. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/31 13:55:15 1.78 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/31 14:47:28 1.79 @@ -1362,6 +1362,17 @@ returned." (form-toplevel (expression-at-mark mark syntax) syntax)) +(defun symbol-at-mark (mark syntax) + "Return a symbol token at mark. This function will \"unwrap\" + quote-forms in order to return the symbol token. If no symbol + token can be found, NIL will be returned." + (labels ((unwrap-form (form) + (cond ((typep form 'quote-form) + (unwrap-form (first-form (children form)))) + ((typep form 'complete-token-lexeme) + form)))) + (unwrap-form (expression-at-mark mark syntax)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display