From dmurray at common-lisp.net Mon Aug 1 21:42:31 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 1 Aug 2005 23:42:31 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20050801214231.D59AF8815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8015 Modified Files: esa.lisp Log Message: Fix numeric arguments Date: Mon Aug 1 23:42:29 2005 Author: dmurray Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.11 climacs/esa.lisp:1.12 --- climacs/esa.lisp:1.11 Mon Jul 25 05:41:13 2005 +++ climacs/esa.lisp Mon Aug 1 23:42:28 2005 @@ -105,10 +105,12 @@ (defparameter *current-gesture* nil) +(defparameter *meta-digit-table* + (loop for i from 0 to 9 + collect (list :keyboard (digit-char i) (make-modifier-state :meta)))) + (defun meta-digit (gesture) - (position gesture - '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta) - (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) + (position gesture *meta-digit-table* :test #'event-matches-gesture-name-p)) (defun esa-read-gesture () @@ -145,12 +147,12 @@ (let ((gesture (esa-read-gesture))) (cond ((event-matches-gesture-name-p gesture - '(:keyboard #\u (make-modifier-state :control))) + `(:keyboard #\u ,(make-modifier-state :control))) (let ((numarg 4)) (loop for gesture = (esa-read-gesture) while (event-matches-gesture-name-p gesture - '(:keyboard #\u (make-modifier-state :control))) + `(:keyboard #\u ,(make-modifier-state :control))) do (setf numarg (* 4 numarg)) finally (esa-unread-gesture gesture stream)) (let ((gesture (esa-read-gesture))) From dmurray at common-lisp.net Mon Aug 1 21:53:39 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 1 Aug 2005 23:53:39 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050801215339.BC7458815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8968 Modified Files: gui.lisp Log Message: Added Mark Word, Mark Whole Buffer, Mark Paragraph and Mark Expression commands. Date: Mon Aug 1 23:53:39 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.167 climacs/gui.lisp:1.168 --- climacs/gui.lisp:1.167 Thu Jul 28 22:36:36 2005 +++ climacs/gui.lisp Mon Aug 1 23:53:38 2005 @@ -357,6 +357,14 @@ (define-named-command com-delete-word ((count 'integer :prompt "Number of words")) (delete-word (point (current-window)) count)) +(define-named-command com-mark-word ((count 'integer :prompt "Number of words")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (mark pane))) + (unless (eq (previous-command pane) 'com-mark-word) + (setf (offset mark) (offset point))) + (forward-word mark count))) + (define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words")) (backward-delete-word (point (current-window)) count)) @@ -684,6 +692,10 @@ (define-named-command com-end-of-buffer () (end-of-buffer (point (current-window)))) +(define-named-command com-mark-whole-buffer () + (beginning-of-buffer (point (current-window))) + (end-of-buffer (mark (current-window)))) + (define-named-command com-back-to-indentation () (let ((point (point (current-window)))) (beginning-of-line point) @@ -1168,6 +1180,16 @@ (syntax (syntax (buffer pane)))) (end-of-paragraph point syntax))) +(define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (mark pane)) + (syntax (syntax (buffer pane)))) + (unless (eq (previous-command pane) 'com-mark-paragraph) + (setf (offset mark) (offset point)) + (beginning-of-paragraph point syntax)) + (dotimes (i count) (end-of-paragraph mark syntax)))) + (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?")) (let* ((*package* (find-package :climacs-gui)) (string (handler-case (accept 'string :prompt "Eval") @@ -1212,6 +1234,16 @@ (syntax (syntax (buffer pane)))) (forward-expression point syntax))) +(define-named-command com-mark-expression ((count 'integer :prompt "Number of expressions")) + (declare (ignore count)) + (let* ((pane (current-window)) + (point (point pane)) + (mark (mark pane)) + (syntax (syntax (buffer pane)))) + (unless (eq (previous-command pane) 'com-mark-expression) + (setf (offset mark) (offset point))) + (forward-expression mark syntax))) + (define-named-command com-eval-defun () (let* ((pane (current-window)) (point (point pane)) @@ -1290,6 +1322,7 @@ (global-set-key '(#\w :control) 'com-cut-out) (global-set-key '(#\e :meta) `(com-forward-expression ,*numeric-argument-marker*)) (global-set-key '(#\a :meta) `(com-backward-expression ,*numeric-argument-marker*)) +(global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*)) (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*)) (global-set-key '(#\t :meta) 'com-transpose-words) @@ -1308,9 +1341,11 @@ (global-set-key '(#\q :meta) 'com-fill-paragraph) (global-set-key '(#\d :meta) `(com-delete-word ,*numeric-argument-marker*)) (global-set-key '(#\Backspace :meta) `(com-backward-delete-word ,*numeric-argument-marker*)) +(global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*)) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph) (global-set-key '(#\e :control :meta) 'com-end-of-paragraph) +(global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*)) (global-set-key '(#\s :control) 'com-isearch-mode-forward) (global-set-key '(#\r :control) 'com-isearch-mode-backward) (global-set-key '(#\_ :shift :meta) 'com-redo) @@ -1358,6 +1393,7 @@ (c-x-set-key '(#\3) 'com-split-window-horizontally) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\f :control) 'com-find-file) +(c-x-set-key '(#\h) 'com-mark-whole-buffer) (c-x-set-key '(#\i) 'com-insert-file) (c-x-set-key '(#\k) 'com-kill-buffer) (c-x-set-key '(#\l :control) 'com-load-file) From rstrandh at common-lisp.net Thu Aug 4 01:10:50 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 4 Aug 2005 03:10:50 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp climacs/packages.lisp climacs/syntax.lisp Message-ID: <20050804011050.CEE2A88544@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16780 Modified Files: gui.lisp lisp-syntax.lisp packages.lisp syntax.lisp Log Message: Implemented comment-region and uncomment region as syntax-dependent generic functions. Need to figure out how a command that is not invoked by keystrokes can determine whether it was called with a numeric argument. Date: Thu Aug 4 03:10:49 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.168 climacs/gui.lisp:1.169 --- climacs/gui.lisp:1.168 Mon Aug 1 23:53:38 2005 +++ climacs/gui.lisp Thu Aug 4 03:10:45 2005 @@ -1207,6 +1207,18 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Commenting + +;;; figure out how to make commands without key bindings accept numeric arguments. +(define-named-command com-comment-region () + (let* ((pane (current-window)) + (point (point pane)) + (mark (mark pane)) + (syntax (syntax (buffer pane)))) + (comment-region syntax point mark))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; For testing purposes (define-named-command com-reset-profile () Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.18 climacs/lisp-syntax.lisp:1.19 --- climacs/lisp-syntax.lisp:1.18 Thu Jul 28 22:36:36 2005 +++ climacs/lisp-syntax.lisp Thu Aug 4 03:10:45 2005 @@ -1676,3 +1676,17 @@ (setf (offset mark) (start-offset tree)) (+ (real-column-number mark tab-width) offset))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Commenting + +(defmethod syntax-line-comment-string ((syntax lisp-syntax)) + ";;; ") + +(defmethod comment-region ((syntax lisp-syntax) mark1 mark2) + (line-comment-region syntax mark1 mark2)) + +(defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) + (line-uncomment-region syntax mark1 mark2)) + Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.71 climacs/packages.lisp:1.72 --- climacs/packages.lisp:1.71 Thu Jul 28 22:36:36 2005 +++ climacs/packages.lisp Thu Aug 4 03:10:45 2005 @@ -108,7 +108,10 @@ #:forward-expression #:backward-expression #:eval-defun #:redisplay-pane-with-syntax - #:beginning-of-paragraph #:end-of-paragraph)) + #:beginning-of-paragraph #:end-of-paragraph + #:syntax-line-comment-string + #:line-comment-region #:comment-region + #:line-uncomment-region #:uncomment-region)) (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.53 climacs/syntax.lisp:1.54 --- climacs/syntax.lisp:1.53 Mon Jul 4 15:55:56 2005 +++ climacs/syntax.lisp Thu Aug 4 03:10:45 2005 @@ -57,6 +57,60 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Commenting + +(defgeneric syntax-line-comment-string (syntax) + (:documentation "string to use at the beginning of a line to +indicate a line comment")) + +(defgeneric line-comment-region (syntax mark1 mark2) + (:documentation "inset a line comment string at the beginning of +every line in the region")) + +(defmethod line-comment-region (syntax mark1 mark2) + (when (mark< mark2 mark1) + (rotatef mark1 mark2)) + (let ((mark (clone-mark mark1))) + (unless (beginning-of-line-p mark) + (end-of-line mark) + (unless (end-of-buffer-p mark) + (forward-object mark))) + (loop while (mark< mark mark2) + do (insert-sequence mark (syntax-line-comment-string syntax)) + (end-of-line mark) + (unless (end-of-buffer-p mark) + (forward-object mark))))) + +(defgeneric line-uncomment-region (syntax mark1 mark2) + (:documentation "inset a line comment string at the beginning of +every line in the region")) + +(defmethod line-uncomment-region (syntax mark1 mark2) + (when (mark< mark2 mark1) + (rotatef mark1 mark2)) + (let ((mark (clone-mark mark1))) + (unless (beginning-of-line-p mark) + (end-of-line mark) + (unless (end-of-buffer-p mark) + (forward-object mark))) + (loop while (mark< mark mark2) + do (when (looking-at mark (syntax-line-comment-string syntax)) + (delete-range mark (length (syntax-line-comment-string syntax)))) + (end-of-line mark) + (unless (end-of-buffer-p mark) + (forward-object mark))))) + +(defgeneric comment-region (syntax mark1 mark2) + (:documentation "turn the region between the two marks into a comment +in the specific syntax.") + (:method (syntax mark1 mark2) nil)) + +(defgeneric uncomment-region (syntax mark1 mark2) + (:documentation "remove comment around region") + (:method (syntax mark1 mark2) nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Syntax completion (defparameter *syntaxes* '()) From abakic at common-lisp.net Thu Aug 4 22:04:30 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Fri, 5 Aug 2005 00:04:30 +0200 (CEST) Subject: [climacs-cvs] CVS update: Directory change: climacs/cl-automaton Message-ID: <20050804220430.CFBC68815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs/cl-automaton In directory common-lisp.net:/tmp/cvs-serv5124/cl-automaton Log Message: Directory /project/climacs/cvsroot/climacs/cl-automaton added to the repository Date: Fri Aug 5 00:04:29 2005 Author: abakic New directory climacs/cl-automaton added From abakic at common-lisp.net Thu Aug 4 22:07:53 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Fri, 5 Aug 2005 00:07:53 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/cl-automaton/automaton-package.lisp climacs/cl-automaton/automaton-test-package.lisp climacs/cl-automaton/automaton-test.asd climacs/cl-automaton/automaton-test.lisp climacs/cl-automaton/automaton.asd climacs/cl-automaton/automaton.lisp climacs/cl-automaton/eqv-hash-test.lisp climacs/cl-automaton/eqv-hash.lisp climacs/cl-automaton/eqv-hash.txt climacs/cl-automaton/regexp-test.lisp climacs/cl-automaton/regexp.lisp climacs/cl-automaton/state-and-transition-test.lisp climacs/cl-automaton/state-and-transition.lisp Message-ID: <20050804220753.F2E9388544@common-lisp.net> Update of /project/climacs/cvsroot/climacs/cl-automaton In directory common-lisp.net:/tmp/cvs-serv5255/cl-automaton Added Files: automaton-package.lisp automaton-test-package.lisp automaton-test.asd automaton-test.lisp automaton.asd automaton.lisp eqv-hash-test.lisp eqv-hash.lisp eqv-hash.txt regexp-test.lisp regexp.lisp state-and-transition-test.lisp state-and-transition.lisp Log Message: Added cl-automaton module and support for regexp searches. Below are some notes. Also modified one constituentp-related test. Instead of having module "cl-automaton" within the :climacs defsystem, the module could be turned into a dependence on :automaton, defined in cl-automaton/automaton.asd. Similarly for cl-automaton/automaton-test.asd. For slower buffer implementations, a buffer iterator is needed for higher performance of regexp searches. Greedy matching should be improved (see automaton::run-to-first-unmatch). Perhaps, fast (tabular) automaton representation should be implemented, unless it would be taking way too much space. Incremental regexp search needs to be done. Date: Fri Aug 5 00:07:49 2005 Author: abakic From abakic at common-lisp.net Thu Aug 4 22:07:49 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Fri, 5 Aug 2005 00:07:49 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/base-test.lisp climacs/base.lisp climacs/buffer-test.lisp climacs/climacs.asd climacs/packages.lisp Message-ID: <20050804220749.67FCF8815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5255 Modified Files: base-test.lisp base.lisp buffer-test.lisp climacs.asd packages.lisp Log Message: Added cl-automaton module and support for regexp searches. Below are some notes. Also modified one constituentp-related test. Instead of having module "cl-automaton" within the :climacs defsystem, the module could be turned into a dependence on :automaton, defined in cl-automaton/automaton.asd. Similarly for cl-automaton/automaton-test.asd. For slower buffer implementations, a buffer iterator is needed for higher performance of regexp searches. Greedy matching should be improved (see automaton::run-to-first-unmatch). Perhaps, fast (tabular) automaton representation should be implemented, unless it would be taking way too much space. Incremental regexp search needs to be done. Date: Fri Aug 5 00:07:45 2005 Author: abakic Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.14 climacs/base-test.lisp:1.15 --- climacs/base-test.lisp:1.14 Sun Jul 17 19:20:27 2005 +++ climacs/base-test.lisp Fri Aug 5 00:07:44 2005 @@ -457,7 +457,7 @@ (constituentp #\Tab) (constituentp "a") (constituentp #\Null)) - t nil nil nil nil nil) + t nil nil nil nil #-sbcl nil #+sbcl t) (defmultitest whitespacep.test-1 (values @@ -779,7 +779,7 @@ (defmultitest tabify-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "c l im acs") - (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8) + (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8) (buffer-sequence buffer 0 (size buffer))) "c l im acs") @@ -1103,6 +1103,36 @@ (buffer-search-backward buffer 1 ""))) 3 3 0 8 nil nil 0 1) +(defmultitest buffer-re-search-forward.test-1 + (let ((buffer (make-instance %%buffer)) + (a1 (automaton::determinize + (regexp-automaton (string-regexp "i[mac]+s")))) + (a2 (automaton::determinize + (regexp-automaton (string-regexp "[^aeiou][aeiou]"))))) + (insert-buffer-sequence buffer 0 " +climacs") + (values + (buffer-re-search-forward a1 buffer 0) + (buffer-re-search-forward a2 buffer 1) + (buffer-re-search-forward a1 buffer 4) + (buffer-re-search-forward a2 buffer 6))) + 3 2 nil nil) + +(defmultitest buffer-re-search-backward.test-1 + (let ((buffer (make-instance %%buffer)) + (a1 (climacs-base::reversed-deterministic-automaton + (regexp-automaton (string-regexp "i[ma]+c")))) + (a2 (climacs-base::reversed-deterministic-automaton + (regexp-automaton (string-regexp "[^aeiou][aeiou]"))))) + (insert-buffer-sequence buffer 0 " +climacs") + (values + (buffer-re-search-backward a1 buffer 7) + (buffer-re-search-backward a2 buffer 7) + (buffer-re-search-backward a1 buffer 5) + (buffer-re-search-backward a2 buffer 2))) + 3 4 nil nil) + (defmultitest search-forward.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " @@ -1156,6 +1186,62 @@ (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 3) (search-backward m "klimaks") + (offset m))) + 3) + +(defmultitest re-search-forward.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 " +climacs") + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 0) + (re-search-forward m "[mac]{3}") + (offset m))) + 7) + +(defmultitest re-search-forward.test-2 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) + (re-search-forward m "[mac]{3}") + (offset m))) + 6) + +(defmultitest re-search-forward.test-3 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) + (re-search-forward m "klimaks") + (offset m))) + 3) + +(defmultitest re-search-backward.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs +") + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 8) + (re-search-backward m "[mac]{3}") + (offset m))) + 3) + +(defmultitest re-search-backward.test-2 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 6) + (re-search-backward m "[mac]{3}") + (offset m))) + 3) + +(defmultitest re-search-backward.test-3 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) + (re-search-backward m "klimaks") (offset m))) 3) Index: climacs/base.lisp diff -u climacs/base.lisp:1.39 climacs/base.lisp:1.40 --- climacs/base.lisp:1.39 Mon May 30 11:09:48 2005 +++ climacs/base.lisp Fri Aug 5 00:07:44 2005 @@ -608,6 +608,62 @@ return i finally (return nil))) +(defun non-greedy-match-forward (a buffer i) + (let ((p (automaton::initial a))) + (loop for j from i below (size buffer) + for q = (automaton::sstep p (buffer-object buffer j)) do + (unless q + (return nil)) + (if (automaton::accept q) + (return (1+ j)) + (setq p q)) + finally (return nil)))) + +(defun buffer-re-search-forward (a buffer offset) + "Returns as the first value the smallest offset of BUFFER >= OFFSET +with contents accepted by deterministic automaton A; otherwise, +returns nil. If the first value is non-nil, the second value is the +offset after the matched contents." + (if (automaton::singleton a) + (buffer-search-forward buffer offset (automaton::singleton a)) + (loop for i from offset below (size buffer) do + (let ((j (non-greedy-match-forward a buffer i))) + (when j (return (values i j)))) + finally (return nil)))) + +(defun reversed-deterministic-automaton (a) + "Reverses and determinizes A, then returns it." + (if (automaton::singleton a) + (progn + (setf (automaton::singleton a) (reverse (automaton::singleton a))) + a) + (automaton::determinize2 + a + (make-instance 'automaton::state-set :ht (automaton::areverse a))))) + +(defun non-greedy-match-backward (a buffer i) + (let ((p (automaton::initial a))) + (loop for j downfrom i to 0 + for q = (automaton::sstep p (buffer-object buffer j)) do + (unless q + (return nil)) + (if (automaton::accept q) + (return j) + (setq p q)) + finally (return nil)))) + +(defun buffer-re-search-backward (a buffer offset) + "Returns as the first value the largest offset of BUFFER <= OFFSET +with contents accepted by (reversed) deterministic automaton A; +otherwise, returns nil. If the first value is non-nil, the second +value is the offset after the matched contents." + (if (automaton::singleton a) + (buffer-search-backward buffer offset (automaton::singleton a)) + (loop for i downfrom (min offset (1- (size buffer))) to 0 do + (let ((j (non-greedy-match-backward a buffer i))) + (when j (return (values j i)))) + finally (return nil)))) + (defun search-forward (mark vector &key (test #'eql)) "move MARK forward after the first occurence of VECTOR after MARK" (let ((offset (buffer-search-forward @@ -621,6 +677,29 @@ (buffer mark) (offset mark) vector :test test))) (when offset (setf (offset mark) offset)))) + +(defun re-search-forward (mark re) + "move MARK forward after the first occurence of string matching RE +after MARK" + (let ((a (automaton::determinize + (automaton::regexp-automaton + (automaton::string-regexp re))))) + (multiple-value-bind (i j) + (buffer-re-search-forward a (buffer mark) (offset mark)) + (when i + (setf (offset mark) j))))) + +(defun re-search-backward (mark re) + "move MARK backward before the first occurence of string matching RE +before MARK" + (let ((a (reversed-deterministic-automaton + (automaton::regexp-automaton + (automaton::string-regexp re))))) + (multiple-value-bind (i j) + (buffer-re-search-backward a (buffer mark) (offset mark)) + (declare (ignorable j)) + (when i + (setf (offset mark) i))))) (defun buffer-search-word-backward (buffer offset word &key (test #'eql)) "return the largest offset of BUFFER <= (- OFFSET (length WORD)) Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.20 climacs/buffer-test.lisp:1.21 --- climacs/buffer-test.lisp:1.20 Tue Mar 15 19:41:18 2005 +++ climacs/buffer-test.lisp Fri Aug 5 00:07:44 2005 @@ -4,7 +4,7 @@ ;;; (cl:defpackage :climacs-tests - (:use :cl :rtest :climacs-buffer :climacs-base)) + (:use :cl :rtest :climacs-buffer :climacs-base :automaton)) (cl:in-package :climacs-tests) Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.35 climacs/climacs.asd:1.36 --- climacs/climacs.asd:1.35 Sun Jul 24 18:44:48 2005 +++ climacs/climacs.asd Fri Aug 5 00:07:45 2005 @@ -30,13 +30,19 @@ (defsystem :climacs :depends-on (:mcclim :flexichain) :components - ((:module "Persistent" + ((:module "cl-automaton" + :components ((:file "automaton-package") + (:file "eqv-hash" :depends-on ("automaton-package")) + (:file "state-and-transition" :depends-on ("eqv-hash")) + (:file "automaton" :depends-on ("state-and-transition" "eqv-hash")) + (:file "regexp" :depends-on ("automaton")))) + (:module "Persistent" :components ((:file "binseq-package") (:file "binseq" :depends-on ("binseq-package")) (:file "obinseq" :depends-on ("binseq-package" "binseq")) (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq")))) - (:file "packages" :depends-on ("Persistent")) + (:file "packages" :depends-on ("cl-automaton" "Persistent")) (:file "buffer" :depends-on ("packages")) (:file "persistent-buffer" :pathname #p"Persistent/persistent-buffer.lisp" @@ -74,7 +80,22 @@ :components ((:file "rt" :pathname #p"testing/rt.lisp") (:file "buffer-test" :depends-on ("rt")) - (:file "base-test" :depends-on ("rt")))) + (:file "base-test" :depends-on ("rt")) + (:file "automaton-test-package" + :pathname #P"cl-automaton/automaton-test-package.lisp" + :depends-on ("rt")) + (:file "eqv-hash-test" + :pathname #P"cl-automaton/eqv-hash-test.lisp" + :depends-on ("rt" "automaton-test-package")) + (:file "state-and-transition-test" + :pathname #P"cl-automaton/state-and-transition-test.lisp" + :depends-on ("rt" "automaton-test-package")) + (:file "automaton-test" + :pathname #P"cl-automaton/automaton-test.lisp" + :depends-on ("rt" "automaton-test-package")) + (:file "regexp-test" + :pathname #P"cl-automaton/regexp-test.lisp" + :depends-on ("rt" "automaton-test-package")))) #+asdf (defmethod asdf:perform :around ((o asdf:compile-op) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.72 climacs/packages.lisp:1.73 --- climacs/packages.lisp:1.72 Thu Aug 4 03:10:45 2005 +++ climacs/packages.lisp Fri Aug 5 00:07:45 2005 @@ -79,7 +79,9 @@ #:name-mixin #:name #:buffer-looking-at #:looking-at #:buffer-search-forward #:buffer-search-backward - #:search-forward #:search-backward)) + #:buffer-re-search-forward #:buffer-re-search-backward + #:search-forward #:search-backward + #:re-search-forward #:re-search-backward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) From dmurray at common-lisp.net Fri Aug 5 08:07:18 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Fri, 5 Aug 2005 10:07:18 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp climacs/packages.lisp Message-ID: <20050805080718.0CF9788542@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12106 Modified Files: lisp-syntax.lisp packages.lisp Log Message: Additional commands. Date: Fri Aug 5 10:07:17 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.19 climacs/lisp-syntax.lisp:1.20 --- climacs/lisp-syntax.lisp:1.19 Thu Aug 4 03:10:45 2005 +++ climacs/lisp-syntax.lisp Fri Aug 5 10:07:17 2005 @@ -850,7 +850,8 @@ ;;;;;;;;;;;;;;;; pathname -;;; FIXME: #P _must_ be followed by a string +;;; NB: #P need not be followed by a string, +;;; as it could be followed by a #. construct instead (or some other reader macro) ;;; parse trees (defclass pathname-form (form) ()) @@ -1309,6 +1310,30 @@ (end-offset form)) 'string))))))) +(defmethod beginning-of-definition (mark (syntax lisp-syntax)) + (with-slots (stack-top) syntax + (loop for form in (children stack-top) + with last-toplevel-list = nil + when (and (typep form 'list-form) + (mark< mark (end-offset form))) + do (if (mark< (start-offset form) mark) + (setf (offset mark) (start-offset form)) + (when last-toplevel-list form + (setf (offset mark) (start-offset last-toplevel-list)))) + (return t) + when (typep form 'list-form) + do (setf last-toplevel-list form) + finally (when last-toplevel-list form + (setf (offset mark) (start-offset last-toplevel-list)))))) + +(defmethod end-of-definition (mark (syntax lisp-syntax)) + (with-slots (stack-top) syntax + (loop for form in (children stack-top) + when (and (typep form 'list-form) + (mark< mark (end-offset form))) + do (setf (offset mark) (end-offset form)) + (loop-finish)))) + ;;; shamelessly stolen from SWANK (defconstant keyword-package (find-package :keyword) @@ -1495,6 +1520,9 @@ (defmethod indent-form ((syntax lisp-syntax) (tree token-form) path) (values tree 0)) +(defmethod indent-form ((syntax lisp-syntax) (tree error-symbol) path) + (values tree 0)) + (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) ;; top level @@ -1690,3 +1718,4 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) +>>>>>>> 1.19 Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.73 climacs/packages.lisp:1.74 --- climacs/packages.lisp:1.73 Fri Aug 5 00:07:45 2005 +++ climacs/packages.lisp Fri Aug 5 10:07:17 2005 @@ -109,8 +109,10 @@ #:syntax-line-indentation #:forward-expression #:backward-expression #:eval-defun + #:beginning-of-definition #:end-of-definition #:redisplay-pane-with-syntax - #:beginning-of-paragraph #:end-of-paragraph + #:backward-paragraph #:forward-paragraph + #:backward-sentence #:forward-sentence #:syntax-line-comment-string #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region)) @@ -119,7 +121,8 @@ (:use :clim-lisp :flexichain) (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size #:reset-yank-position #:rotate-yank-position #:kill-ring-yank - #:kill-ring-standard-push #:kill-ring-concatenating-push)) + #:kill-ring-standard-push #:kill-ring-concatenating-push + #:kill-ring-reverse-concatenating-push)) (defpackage :undo (:use :common-lisp) From dmurray at common-lisp.net Fri Aug 5 08:21:04 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Fri, 5 Aug 2005 10:21:04 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050805082104.F1E5D88542@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13074 Modified Files: lisp-syntax.lisp Log Message: Removing diff crud Date: Fri Aug 5 10:21:04 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.20 climacs/lisp-syntax.lisp:1.21 --- climacs/lisp-syntax.lisp:1.20 Fri Aug 5 10:07:17 2005 +++ climacs/lisp-syntax.lisp Fri Aug 5 10:21:04 2005 @@ -1718,4 +1718,3 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) ->>>>>>> 1.19 From dmurray at common-lisp.net Fri Aug 5 12:41:00 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Fri, 5 Aug 2005 14:41:00 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/kill-ring.lisp climacs/syntax.lisp Message-ID: <20050805124100.D2EF988545@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32127 Modified Files: base.lisp gui.lisp kill-ring.lisp syntax.lisp Log Message: Added and altered various commands. #\Page added to whitespacep for non-sbcl Added com-not-modified (M-~), com-set-fill-column (C-x f), com-kill-word (M-d), com-backward-kill-word (M-Backspace), com-backward-sentence (M-a), com-forward-sentence (M-e_, com-forward-page (C-x ]), com-backward-page (C-x [), com-count-lines-page (C-x l), com-beginning-of-definition (M-C-a), com-end-of-definition (M-C-e), com-mark-definition (M-C-h). Changed com-goto-line to be 1-based, not 0-based. Renamed com-cut-out -> com-kill-region, com-copy-out -> com-copy-region, com-beginning-of-paragraph -> com-backward-paragraph, com-end-of-paragraph -> com-forward-paragraph. Date: Fri Aug 5 14:40:57 2005 Author: dmurray Index: climacs/base.lisp diff -u climacs/base.lisp:1.40 climacs/base.lisp:1.41 --- climacs/base.lisp:1.40 Fri Aug 5 00:07:44 2005 +++ climacs/base.lisp Fri Aug 5 14:40:55 2005 @@ -186,7 +186,7 @@ "A predicate to ensure that an object is a whitespace character." (and (characterp obj) #+sbcl (sb-impl::whitespacep obj) - #-sbcl (member obj '(#\Space #\Tab #\Newline)))) + #-sbcl (member obj '(#\Space #\Tab #\Newline #\Page)))) (defun forward-to-word-boundary (mark) "Move the mark forward to the beginning of the next word." Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.169 climacs/gui.lisp:1.170 --- climacs/gui.lisp:1.169 Thu Aug 4 03:10:45 2005 +++ climacs/gui.lisp Fri Aug 5 14:40:56 2005 @@ -130,15 +130,6 @@ (defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) -(defun meta-digit (gesture) - (position gesture - '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta) - (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) - :test #'event-matches-gesture-name-p)) - -(defun substitute-numeric-argument-p (command numargp) - (substitute numargp *numeric-argument-p* command :test #'eq)) - (defmethod execute-frame-command :around ((frame climacs) command) (handler-case (with-undo ((buffer (current-window))) @@ -171,6 +162,14 @@ (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) +(define-named-command com-not-modified () + (setf (needs-saving (buffer (current-window))) nil)) + +(define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:")) + (if (> column 1) + (setf (auto-fill-column (current-window)) column) + (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) + (defun possibly-fill-line () (let* ((pane (current-window)) (buffer (buffer pane))) @@ -357,6 +356,36 @@ (define-named-command com-delete-word ((count 'integer :prompt "Number of words")) (delete-word (point (current-window)) count)) +(define-named-command com-kill-word ((count 'integer :prompt "Number of words")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (offset point))) + (loop repeat count + until (end-of-buffer-p point) + do (forward-word point)) + (unless (mark= point mark) + (if (eq (previous-command pane) 'com-kill-word) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence mark point)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mark point))) + (delete-region mark point)))) + +(define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (offset point))) + (loop repeat count + until (end-of-buffer-p point) + do (backward-word point)) + (unless (mark= point mark) + (if (eq (previous-command pane) 'com-backward-kill-word) + (kill-ring-reverse-concatenating-push *kill-ring* + (region-to-sequence mark point)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mark point))) + (delete-region mark point)))) + (define-named-command com-mark-word ((count 'integer :prompt "Number of words")) (let* ((pane (current-window)) (point (point pane)) @@ -435,9 +464,9 @@ (begin-mark (clone-mark point)) (end-mark (clone-mark point))) (unless (eql (object-before begin-mark) #\Newline) - (beginning-of-paragraph begin-mark syntax)) + (backward-paragraph begin-mark syntax)) (unless (eql (object-after end-mark) #\Newline) - (end-of-paragraph end-mark syntax)) + (forward-paragraph end-mark syntax)) (do-buffer-region (object offset buffer (offset begin-mark) (offset end-mark)) (when (eql object #\Newline) @@ -718,10 +747,10 @@ m) do (end-of-line mark) until (end-of-buffer-p mark) - repeat (handler-case (accept 'integer :prompt "Goto Line") + repeat (1- (handler-case (accept 'integer :prompt "Goto Line") (error () (progn (beep) (display-message "Not a valid line number") - (return-from com-goto-line nil)))) + (return-from com-goto-line nil))))) do (incf (offset mark)) (end-of-line mark) finally (beginning-of-line mark) @@ -882,14 +911,14 @@ (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))) ;; Destructively cut a given buffer region into the kill-ring -(define-named-command com-cut-out () +(define-named-command com-kill-region () (let ((pane (current-window))) (kill-ring-standard-push *kill-ring* (region-to-sequence (mark pane) (point pane))) (delete-region (mark pane) (point pane)))) ;; Non destructively copies in buffer region to the kill ring -(define-named-command com-copy-out () +(define-named-command com-copy-region () (let ((pane (current-window))) (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane))))) @@ -1168,17 +1197,17 @@ (setf (offset dabbrev-expansion-mark) offset)))) (move)))))))) -(define-named-command com-beginning-of-paragraph () +(define-named-command com-backward-paragraph () (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (beginning-of-paragraph point syntax))) + (backward-paragraph point syntax))) -(define-named-command com-end-of-paragraph () +(define-named-command com-forward-paragraph () (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (end-of-paragraph point syntax))) + (forward-paragraph point syntax))) (define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) @@ -1187,8 +1216,55 @@ (syntax (syntax (buffer pane)))) (unless (eq (previous-command pane) 'com-mark-paragraph) (setf (offset mark) (offset point)) - (beginning-of-paragraph point syntax)) - (dotimes (i count) (end-of-paragraph mark syntax)))) + (backward-paragraph point syntax)) + (loop repeat count do (forward-paragraph mark syntax)))) + +(define-named-command com-backward-sentence () + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (backward-sentence point syntax))) + +(define-named-command com-forward-sentence () + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (forward-sentence point syntax))) + +(defun forward-page (mark &optional (count 1)) + (loop repeat count + unless (search-forward mark (coerce (list #\Newline #\Page) 'vector)) + do (end-of-buffer mark) + (loop-finish))) + +(define-named-command com-forward-page ((count 'integer :prompt "Number of pages")) + (let* ((pane (current-window)) + (point (point pane))) + (forward-page point count))) + +(defun backward-page (mark &optional (count 1)) + (loop repeat count + when (search-backward mark (coerce (list #\Newline #\Page) 'vector)) + do (forward-object mark) + else do (beginning-of-buffer mark) + (loop-finish))) + +(define-named-command com-backward-page ((count 'integer :prompt "Number of pages")) + (let* ((pane (current-window)) + (point (point pane))) + (backward-page point count))) + +(define-named-command com-count-lines-page () + (let* ((pane (current-window)) + (point (point pane)) + (start (clone-mark point)) + (end (clone-mark point))) + (backward-page start) + (forward-page end) + (let ((total (number-of-lines-in-region start end)) + (before (number-of-lines-in-region start point)) + (after (number-of-lines-in-region point end))) + (display-message "Page has ~A lines (~A + ~A)" total before after)))) (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?")) (let* ((*package* (find-package :climacs-gui)) @@ -1262,6 +1338,28 @@ (syntax (syntax (buffer pane)))) (eval-defun point syntax))) +(define-named-command com-beginning-of-definition () + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (beginning-of-definition point syntax))) + +(define-named-command com-end-of-definition () + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (end-of-definition point syntax))) + +(define-named-command com-mark-definition () + (let* ((pane (current-window)) + (point (point pane)) + (mark (mark pane)) + (syntax (syntax (buffer pane)))) + (unless (eq (previous-command pane) 'com-mark-definition) + (beginning-of-definition point syntax) + (setf (offset mark) (offset point))) + (end-of-definition mark syntax))) + (define-named-command com-package () (let* ((pane (current-window)) (syntax (syntax (buffer pane))) @@ -1331,9 +1429,9 @@ (global-set-key '(#\t :control) 'com-transpose-objects) (global-set-key '(#\Space :control) 'com-set-mark) (global-set-key '(#\y :control) 'com-yank) -(global-set-key '(#\w :control) 'com-cut-out) -(global-set-key '(#\e :meta) `(com-forward-expression ,*numeric-argument-marker*)) -(global-set-key '(#\a :meta) `(com-backward-expression ,*numeric-argument-marker*)) +(global-set-key '(#\w :control) 'com-kill-region) +(global-set-key '(#\e :meta) 'com-forward-sentence) +(global-set-key '(#\a :meta) 'com-backward-sentence) (global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*)) (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*)) @@ -1343,7 +1441,7 @@ (global-set-key '(#\c :meta) 'com-capitalize-word) (global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\z :meta) 'com-zap-to-character) -(global-set-key '(#\w :meta) 'com-copy-out) +(global-set-key '(#\w :meta) 'com-copy-region) (global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\v :meta) 'com-page-up) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) @@ -1351,12 +1449,12 @@ (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\^ :shift :meta) 'com-delete-indentation) (global-set-key '(#\q :meta) 'com-fill-paragraph) -(global-set-key '(#\d :meta) `(com-delete-word ,*numeric-argument-marker*)) -(global-set-key '(#\Backspace :meta) `(com-backward-delete-word ,*numeric-argument-marker*)) +(global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*)) +(global-set-key '(#\Backspace :meta) `(com-backward-kill-word ,*numeric-argument-marker*)) (global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*)) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) -(global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph) -(global-set-key '(#\e :control :meta) 'com-end-of-paragraph) +(global-set-key '(#\{ :meta :shift) 'com-backward-paragraph) +(global-set-key '(#\} :meta :shift) 'com-forward-paragraph) (global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*)) (global-set-key '(#\s :control) 'com-isearch-mode-forward) (global-set-key '(#\r :control) 'com-isearch-mode-backward) @@ -1380,11 +1478,14 @@ (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*)) (global-set-key '(:insert) 'com-toggle-overwrite-mode) +(global-set-key '(#\~ :meta :shift) 'com-not-modified) (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*)) -(global-set-key '(#\x :control :meta) '(com-eval-defun)) - +(global-set-key '(#\x :control :meta) 'com-eval-defun) +(global-set-key '(#\a :control :meta) 'com-beginning-of-definition) +(global-set-key '(#\e :control :meta) 'com-end-of-definition) +(global-set-key '(#\h :control :meta) 'com-mark-definition) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; C-x command table @@ -1405,13 +1506,16 @@ (c-x-set-key '(#\3) 'com-split-window-horizontally) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\f :control) 'com-find-file) +(c-x-set-key '(#\f) `(com-set-fill-column ,*numeric-argument-marker*)) (c-x-set-key '(#\h) 'com-mark-whole-buffer) (c-x-set-key '(#\i) 'com-insert-file) (c-x-set-key '(#\k) 'com-kill-buffer) -(c-x-set-key '(#\l :control) 'com-load-file) (c-x-set-key '(#\o) 'com-other-window) (c-x-set-key '(#\r) 'com-redo) (c-x-set-key '(#\u) 'com-undo) +(c-x-set-key '(#\]) `(com-forward-page ,*numeric-argument-marker*)) +(c-x-set-key '(#\[) `(com-backward-page ,*numeric-argument-marker*)) +(c-x-set-key '(#\l) 'com-count-lines-page) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.6 climacs/kill-ring.lisp:1.7 --- climacs/kill-ring.lisp:1.6 Sun Feb 27 19:52:01 2005 +++ climacs/kill-ring.lisp Fri Aug 5 14:40:56 2005 @@ -74,6 +74,11 @@ of the current contents of the top of the kill ring. If the kill ring is empty the a new entry is pushed.")) +(defgeneric kill-ring-reverse-concatenating-push (kr vector) + (:documentation "Concatenates the contents of vector onto the front +of the current contents of the top of the kill ring. If the kill ring +is empty a new entry is pushed.")) + (defgeneric kill-ring-yank (kr &optional reset) (:documentation "Returns the vector of objects currently pointed to by the cursor. If reset is T, a call to @@ -128,6 +133,15 @@ (pop-start chain) vector)))) (reset-yank-position kr)) + +(defmethod kill-ring-reverse-concatenating-push ((kr kill-ring) vector) + (let ((chain (kill-ring-chain kr))) + (if (zerop (kill-ring-length kr)) + (push-start chain vector) + (push-start chain + (concatenate 'vector + vector + (pop-start chain)))))) (defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL)) (if reset (reset-yank-position kr)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.54 climacs/syntax.lisp:1.55 --- climacs/syntax.lisp:1.54 Thu Aug 4 03:10:45 2005 +++ climacs/syntax.lisp Fri Aug 5 14:40:56 2005 @@ -55,6 +55,18 @@ (defgeneric eval-defun (mark syntax)) +(defgeneric beginning-of-definition (mark syntax)) + +(defgeneric end-of-definition (mark syntax)) + +(defgeneric backward-paragraph (mark syntax)) + +(defgeneric forward-paragraph (mark syntax)) + +(defgeneric backward-sentence (mark syntax)) + +(defgeneric forward-sentence (mark syntax)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting @@ -208,6 +220,24 @@ (error 'no-such-operation)) (defmethod eval-defun (mark syntax) + (error 'no-such-operation)) + +(defmethod beginning-of-defintion (mark syntax) + (error 'no-such-operation)) + +(defmethod end-of-definition (mark syntax) + (error 'no-such-operation)) + +(defmethod backward-paragraph (mark syntax) + (error 'no-such-operation)) + +(defmethod forward-paragraph (mark syntax) + (error 'no-such-operation)) + +(defmethod backward-sentence (mark syntax) + (error 'no-such-operation)) + +(defmethod forward-sentence (mark syntax) (error 'no-such-operation)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From dmurray at common-lisp.net Sat Aug 6 20:51:21 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sat, 6 Aug 2005 22:51:21 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/text-syntax.lisp climacs/gui.lisp climacs/esa.lisp Message-ID: <20050806205121.BEA0288542@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30622 Modified Files: text-syntax.lisp gui.lisp esa.lisp Log Message: Mainly numeric argument additions. Altered numeric argument reading to accept negative arguments, and made consequent changes to commands (e.g. com-self-insert now accepts numeric arguments, com-forward-object goes backwards with negative prefix argument etc.). Also, ensure initial *scratch* buffer is on application buffer list Date: Sat Aug 6 22:51:20 2005 Author: dmurray Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.8 climacs/text-syntax.lisp:1.9 --- climacs/text-syntax.lisp:1.8 Wed Jul 20 11:41:06 2005 +++ climacs/text-syntax.lisp Sat Aug 6 22:51:19 2005 @@ -148,11 +148,7 @@ (incf pos1)) (t nil)))))))) - - -(defgeneric beginning-of-paragraph (mark text-syntax)) - -(defmethod beginning-of-paragraph (mark (syntax text-syntax)) +(defmethod backward-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax (let ((pos1 (index-of-mark-after-offset paragraphs (offset mark)))) (when (> pos1 0) @@ -161,9 +157,7 @@ (offset (element* paragraphs (- pos1 2))) (offset (element* paragraphs (1- pos1))))))))) -(defgeneric end-of-paragraph (mark text-syntax)) - -(defmethod end-of-paragraph (mark (syntax text-syntax)) +(defmethod forward-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax (let ((pos1 (index-of-mark-after-offset paragraphs @@ -176,18 +170,14 @@ (offset (element* paragraphs (1+ pos1))) (offset (element* paragraphs pos1)))))))) - - (defgeneric backward-expression (mark text-syntax)) - - (defmethod backward-expression (mark (syntax text-syntax)) + (defmethod backward-sentence (mark (syntax text-syntax)) (with-slots (sentence-beginnings) syntax (let ((pos1 (index-of-mark-after-offset sentence-beginnings (offset mark)))) (when (> pos1 0) (setf (offset mark) (offset (element* sentence-beginnings (1- pos1)))))))) - (defgeneric forward-expression (mark text-syntax)) - (defmethod forward-expression (mark (syntax text-syntax)) + (defmethod forward-sentence (mark (syntax text-syntax)) (with-slots (sentence-endings) syntax (let ((pos1 (index-of-mark-after-offset sentence-endings Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.170 climacs/gui.lisp:1.171 --- climacs/gui.lisp:1.170 Fri Aug 5 14:40:56 2005 +++ climacs/gui.lisp Sat Aug 6 22:51:19 2005 @@ -66,7 +66,9 @@ (make-pane 'climacs-info-pane :master-pane extended-pane :width 900))) - (setf (windows *application-frame*) (list extended-pane)) + (setf (windows *application-frame*) (list extended-pane) + (buffers *application-frame*) (list (buffer extended-pane))) + (vertically () (scrolling () extended-pane) @@ -200,8 +202,8 @@ (insert-object point char)) (insert-object point char)))) -(define-command com-self-insert () - (insert-character *current-gesture*)) +(define-command com-self-insert ((count 'integer)) + (loop repeat count do (insert-character *current-gesture*))) (define-named-command com-beginning-of-line () (beginning-of-line (point (current-window)))) @@ -209,8 +211,25 @@ (define-named-command com-end-of-line () (end-of-line (point (current-window)))) -(define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")) - (delete-range (point (current-window)) count)) +(define-named-command com-delete-object ((count 'integer :prompt "Number of Objects") + (killp 'boolean :prompt "Kill?")) + (let* ((point (point (current-window))) + (mark (clone-mark point))) + (forward-object mark count) + (when killp + (kill-ring-standard-push *kill-ring* + (region-to-sequence point mark))) + (delete-region point mark))) + +(define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects") + (killp 'boolean :prompt "Kill?")) + (let* ((point (point (current-window))) + (mark (clone-mark point))) + (backward-object mark count) + (when killp + (kill-ring-standard-push *kill-ring* + (region-to-sequence mark point))) + (delete-region mark point))) (define-named-command com-zap-to-object () (let* ((item (handler-case (accept 't :prompt "Zap to Object") @@ -238,9 +257,6 @@ (search-forward item-mark item) (delete-range current-point (- (offset item-mark) current-offset)))) -(define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")) - (delete-range (point (current-window)) (- count))) - (define-named-command com-transpose-objects () (let* ((point (point (current-window)))) (unless (beginning-of-buffer-p point) @@ -311,7 +327,9 @@ (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) (setf (slot-value win 'goal-column) (column-number point))) - (previous-line point (slot-value win 'goal-column) numarg))) + (if (plusp numarg) + (previous-line point (slot-value win 'goal-column) numarg) + (next-line point (slot-value win 'goal-column) (- numarg))))) (define-named-command com-next-line ((numarg 'integer :prompt "How many lines?")) (let* ((win (current-window)) @@ -319,7 +337,9 @@ (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) (setf (slot-value win 'goal-column) (column-number point))) - (next-line point (slot-value win 'goal-column) numarg))) + (if (plusp numarg) + (next-line point (slot-value win 'goal-column) numarg) + (previous-line point (slot-value win 'goal-column) (- numarg))))) (define-named-command com-open-line ((numarg 'integer :prompt "How many lines?")) (open-line (point (current-window)) numarg)) @@ -329,7 +349,15 @@ (let* ((pane (current-window)) (point (point pane)) (mark (offset point))) - (cond ((or numargp (> numarg 1)) + (cond ((= 0 numarg) + (beginning-of-line point)) + ((< numarg 0) + (loop repeat (- numarg) + until (beginning-of-buffer-p point) + do (beginning-of-line point) + until (beginning-of-buffer-p point) + do (backward-object point))) + ((or numargp (> numarg 1)) (loop repeat numarg until (end-of-buffer-p point) do (end-of-line point) @@ -348,7 +376,9 @@ (delete-region mark point)))) (define-named-command com-forward-word ((count 'integer :prompt "Number of words")) - (forward-word (point (current-window)) count)) + (if (plusp count) + (forward-word (point (current-window)) count) + (backward-word (point (current-window)) (- count)))) (define-named-command com-backward-word ((count 'integer :prompt "Number of words")) (backward-word (point (current-window)) count)) @@ -392,7 +422,9 @@ (mark (mark pane))) (unless (eq (previous-command pane) 'com-mark-word) (setf (offset mark) (offset point))) - (forward-word mark count))) + (if (plusp count) + (forward-word mark count) + (backward-word mark (- count))))) (define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words")) (backward-delete-word (point (current-window)) count)) @@ -1197,17 +1229,21 @@ (setf (offset dabbrev-expansion-mark) offset)))) (move)))))))) -(define-named-command com-backward-paragraph () +(define-named-command com-backward-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (backward-paragraph point syntax))) + (if (plusp count) + (loop repeat count do (backward-paragraph point syntax)) + (loop repeat (- count) do (forward-paragraph point syntax))))) -(define-named-command com-forward-paragraph () +(define-named-command com-forward-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (forward-paragraph point syntax))) + (if (plusp count) + (loop repeat count do (forward-paragraph point syntax)) + (loop repeat (- count) do (backward-paragraph point syntax))))) (define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) @@ -1216,20 +1252,28 @@ (syntax (syntax (buffer pane)))) (unless (eq (previous-command pane) 'com-mark-paragraph) (setf (offset mark) (offset point)) - (backward-paragraph point syntax)) - (loop repeat count do (forward-paragraph mark syntax)))) + (if (plusp count) + (backward-paragraph point syntax) + (forward-paragraph point syntax))) + (if (plusp count) + (loop repeat count do (forward-paragraph mark syntax)) + (loop repeat (- count) do (backward-paragraph mark syntax))))) -(define-named-command com-backward-sentence () +(define-named-command com-backward-sentence ((count 'integer :prompt "Number of sentences")) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (backward-sentence point syntax))) + (if (plusp count) + (loop repeat count do (backward-sentence point syntax)) + (loop repeat (- count) do (forward-sentence point syntax))))) -(define-named-command com-forward-sentence () +(define-named-command com-forward-sentence ((count 'integer :prompt "Number of sentences")) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (forward-sentence point syntax))) + (if (plusp count) + (loop repeat count do (forward-sentence point syntax)) + (loop repeat (- count) do (backward-sentence point syntax))))) (defun forward-page (mark &optional (count 1)) (loop repeat count @@ -1240,7 +1284,9 @@ (define-named-command com-forward-page ((count 'integer :prompt "Number of pages")) (let* ((pane (current-window)) (point (point pane))) - (forward-page point count))) + (if (plusp count) + (forward-page point count) + (backward-page point count)))) (defun backward-page (mark &optional (count 1)) (loop repeat count @@ -1252,7 +1298,9 @@ (define-named-command com-backward-page ((count 'integer :prompt "Number of pages")) (let* ((pane (current-window)) (point (point pane))) - (backward-page point count))) + (if (plusp count) + (backward-page point count) + (forward-page point count)))) (define-named-command com-count-lines-page () (let* ((pane (current-window)) @@ -1309,28 +1357,29 @@ (asdf:operate 'asdf:load-op :climacs)) (define-named-command com-backward-expression ((count 'integer :prompt "Number of expressions")) - (declare (ignore count)) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (backward-expression point syntax))) + (if (plusp count) + (loop repeat count do (backward-expression point syntax)) + (loop repeat (- count) do (forward-expression point syntax))))) (define-named-command com-forward-expression ((count 'integer :prompt "Number of expresssions")) - (declare (ignore count)) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (forward-expression point syntax))) + (if (plusp count) + (loop repeat count do (forward-expression point syntax)) + (loop repeat (- count) do (backward-expression point syntax))))) (define-named-command com-mark-expression ((count 'integer :prompt "Number of expressions")) - (declare (ignore count)) (let* ((pane (current-window)) (point (point pane)) (mark (mark pane)) (syntax (syntax (buffer pane)))) (unless (eq (previous-command pane) 'com-mark-expression) (setf (offset mark) (offset point))) - (forward-expression mark syntax))) + (loop repeat count do (forward-expression mark syntax)))) (define-named-command com-eval-defun () (let* ((pane (current-window)) @@ -1338,17 +1387,21 @@ (syntax (syntax (buffer pane)))) (eval-defun point syntax))) -(define-named-command com-beginning-of-definition () +(define-named-command com-beginning-of-definition ((count 'integer :prompt "Number of definitions")) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (beginning-of-definition point syntax))) + (if (plusp count) + (loop repeat count do (beginning-of-definition point syntax)) + (loop repeat (- count) do (end-of-definition point syntax))))) -(define-named-command com-end-of-definition () +(define-named-command com-end-of-definition ((count 'integer :prompt "Number of definitions")) (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) - (end-of-definition point syntax))) + (if (plusp count) + (loop repeat count do (end-of-definition point syntax)) + (loop repeat (- count) do (beginning-of-definition point syntax))))) (define-named-command com-mark-definition () (let* ((pane (current-window)) @@ -1409,9 +1462,9 @@ (dead-escape-set-key (remove :meta gesture) command))) (loop for code from (char-code #\Space) to (char-code #\~) - do (global-set-key (code-char code) 'com-self-insert)) + do (global-set-key (code-char code) `(com-self-insert ,*numeric-argument-marker*))) -(global-set-key #\Newline 'com-self-insert) +(global-set-key #\Newline `(com-self-insert ,*numeric-argument-marker*)) (global-set-key #\Tab 'com-indent-line) (global-set-key '(#\i :control) 'com-indent-line) (global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*)) @@ -1420,7 +1473,7 @@ (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) (global-set-key '(#\a :control) 'com-beginning-of-line) (global-set-key '(#\e :control) 'com-end-of-line) -(global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*)) +(global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*)) (global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*)) (global-set-key '(#\l :control) 'com-full-redisplay) (global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*)) @@ -1430,8 +1483,8 @@ (global-set-key '(#\Space :control) 'com-set-mark) (global-set-key '(#\y :control) 'com-yank) (global-set-key '(#\w :control) 'com-kill-region) -(global-set-key '(#\e :meta) 'com-forward-sentence) -(global-set-key '(#\a :meta) 'com-backward-sentence) +(global-set-key '(#\e :meta) `(com-forward-sentence ,*numeric-argument-marker*)) +(global-set-key '(#\a :meta) `(com-backward-sentence ,*numeric-argument-marker*)) (global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*)) (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*)) @@ -1453,8 +1506,8 @@ (global-set-key '(#\Backspace :meta) `(com-backward-kill-word ,*numeric-argument-marker*)) (global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*)) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) -(global-set-key '(#\{ :meta :shift) 'com-backward-paragraph) -(global-set-key '(#\} :meta :shift) 'com-forward-paragraph) +(global-set-key '(#\{ :meta :shift) `(com-backward-paragraph ,*numeric-argument-marker*)) +(global-set-key '(#\} :meta :shift) `(com-forward-paragraph ,*numeric-argument-marker*)) (global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*)) (global-set-key '(#\s :control) 'com-isearch-mode-forward) (global-set-key '(#\r :control) 'com-isearch-mode-backward) @@ -1474,8 +1527,8 @@ (global-set-key '(:next) 'com-page-down) (global-set-key '(:home :control) 'com-beginning-of-buffer) (global-set-key '(:end :control) 'com-end-of-buffer) -(global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*)) -(global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*)) +(global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*)) +(global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*)) (global-set-key '(:insert) 'com-toggle-overwrite-mode) (global-set-key '(#\~ :meta :shift) 'com-not-modified) @@ -1483,8 +1536,8 @@ (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*)) (global-set-key '(#\x :control :meta) 'com-eval-defun) -(global-set-key '(#\a :control :meta) 'com-beginning-of-definition) -(global-set-key '(#\e :control :meta) 'com-end-of-definition) +(global-set-key '(#\a :control :meta) `(com-beginning-of-definition ,*numeric-argument-marker*)) +(global-set-key '(#\e :control :meta) `(com-end-of-definition ,*numeric-argument-marker*)) (global-set-key '(#\h :control :meta) 'com-mark-definition) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.12 climacs/esa.lisp:1.13 --- climacs/esa.lisp:1.12 Mon Aug 1 23:42:28 2005 +++ climacs/esa.lisp Sat Aug 6 22:51:20 2005 @@ -143,39 +143,65 @@ (t (unread-gesture gesture :stream stream)))) +(define-gesture-name universal-argument :keyboard (#\u :control)) + +(define-gesture-name meta-minus :keyboard (#\- :meta)) + (defun read-numeric-argument (&key (stream *standard-input*)) + "Reads gestures returning two values: prefix-arg and whether prefix given. +Accepts: EITHER C-u, optionally followed by other C-u's, optionally followed +by a minus sign, optionally followed by decimal digits; +OR An optional M-minus, optionally followed by M-decimal-digits. +You cannot mix C-u and M-digits. +C-u gives a numarg of 4. Additional C-u's multiply by 4 (e.g. C-u C-u C-u = 64). +After C-u you can enter decimal digits, possibly preceded by a minus (but not +a plus) sign. C-u 3 4 = 34, C-u - 3 4 = -34. Note that C-u 3 - prints 3 '-'s. +M-1 M-2 = 12. M-- M-1 M-2 = -12. As a special case, C-u - and M-- = -1. +In the absence of a prefix arg returns 1 (and nil)." (let ((gesture (esa-read-gesture))) (cond ((event-matches-gesture-name-p - gesture - `(:keyboard #\u ,(make-modifier-state :control))) + gesture 'universal-argument) (let ((numarg 4)) (loop for gesture = (esa-read-gesture) while (event-matches-gesture-name-p - gesture - `(:keyboard #\u ,(make-modifier-state :control))) + gesture 'universal-argument) do (setf numarg (* 4 numarg)) finally (esa-unread-gesture gesture stream)) - (let ((gesture (esa-read-gesture))) + (let ((gesture (esa-read-gesture)) + (sign +1)) + (when (and (characterp gesture) + (char= gesture #\-)) + (setf gesture (esa-read-gesture) + sign -1)) (cond ((and (characterp gesture) (digit-char-p gesture 10)) - (setf numarg (- (char-code gesture) (char-code #\0))) + (setf numarg (digit-char-p gesture 10)) (loop for gesture = (esa-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) - (- (char-code gesture) (char-code #\0)))) + (digit-char-p gesture 10))) finally (esa-unread-gesture gesture stream) - (return (values numarg t)))) + (return (values (* numarg sign) t)))) (t (esa-unread-gesture gesture stream) - (values numarg t)))))) - ((meta-digit gesture) - (let ((numarg (meta-digit gesture))) + (values (if (minusp sign) -1 numarg) t)))))) + ((or (meta-digit gesture) + (event-matches-gesture-name-p + gesture 'meta-minus)) + (let ((numarg 0) + (sign +1)) + (cond ((meta-digit gesture) + (setf numarg (meta-digit gesture))) + (t (setf sign -1))) (loop for gesture = (esa-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) finally (esa-unread-gesture gesture stream) - (return (values numarg t))))) + (return (values (if (and (= sign -1) (= numarg 0)) + -1 + (* sign numarg)) + t))))) (t (esa-unread-gesture gesture stream) (values 1 nil))))) From dmurray at common-lisp.net Mon Aug 8 08:53:33 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 8 Aug 2005 10:53:33 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050808085333.6774C88525@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11688 Modified Files: lisp-syntax.lisp Log Message: Added greying-out of readmacro conditionalized forms. Also added *climacs-features*, which is initialized from *features*, and which lives (for the moment) in the climacs-gui package, so Eval Expression can easily manipulate it. Date: Mon Aug 8 10:53:30 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.21 climacs/lisp-syntax.lisp:1.22 --- climacs/lisp-syntax.lisp:1.21 Fri Aug 5 10:21:04 2005 +++ climacs/lisp-syntax.lisp Mon Aug 8 10:53:30 2005 @@ -1183,7 +1183,56 @@ (defmethod display-parse-tree ((parse-symbol long-comment-form) (syntax lisp-syntax) pane) (with-drawing-options (pane :ink +maroon+) (call-next-method))) - + +(defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) + (syntax lisp-syntax) pane) + (let ((conditional (second (children parse-symbol)))) + (if (eval-feature-conditional conditional syntax) + (call-next-method) + (with-drawing-options (pane :ink +gray50+) + (call-next-method))))) + +(defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) + (syntax lisp-syntax) pane) + (let ((conditional (second (children parse-symbol)))) + (if (eval-feature-conditional conditional syntax) + (with-drawing-options (pane :ink +gray50+) + (call-next-method)) + (call-next-method)))) + +(defparameter climacs-gui::*climacs-features* (copy-list *features*)) + +(defgeneric eval-feature-conditional (conditional-form syntax)) + +;; Adapted from slime.el + +(defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) + (let* ((string (coerce (buffer-sequence (buffer syntax) + (start-offset conditional) + (end-offset conditional)) + 'string)) + (symbol (parse-symbol string keyword-package))) + (member symbol climacs-gui::*climacs-features*))) + +(defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) + (let ((children (children conditional))) + (when (third children) + (flet ((eval-fc (conditional) + (funcall #'eval-feature-conditional conditional syntax))) + (let* ((type (second children)) + (conditionals (butlast (nthcdr 2 children))) + (type-string (coerce (buffer-sequence (buffer syntax) + (start-offset type) + (end-offset type)) + 'string)) + (type-symbol (parse-symbol type-string keyword-package))) + (case type-symbol + (:and (funcall #'every #'eval-fc conditionals)) + (:or (funcall #'some #'eval-fc conditionals)) + (:not (when conditionals + (funcall #'(lambda (f l) (not (apply f l))) + #'eval-fc conditionals))))))))) + (defmethod display-parse-tree ((parse-symbol complete-list-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) (if (= (end-offset parse-symbol) (offset (point pane))) From dmurray at common-lisp.net Mon Aug 8 12:15:08 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 8 Aug 2005 14:15:08 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050808121508.4E4B388542@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25288 Modified Files: gui.lisp Log Message: Added com-count-lines-region (M-=) and com-what-cursor-position (C-x =). (Also altered com-browse-url to actually run on my iBook.) Date: Mon Aug 8 14:15:06 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.171 climacs/gui.lisp:1.172 --- climacs/gui.lisp:1.171 Sat Aug 6 22:51:19 2005 +++ climacs/gui.lisp Mon Aug 8 14:15:05 2005 @@ -790,7 +790,9 @@ (offset mark)))) (define-named-command com-browse-url () - (accept 'url :prompt "Browse URL")) + (let ((url (accept 'url :prompt "Browse URL"))) + #+ (and sbcl darwin) + (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)))) (define-named-command com-set-mark () (let ((pane (current-window))) @@ -1314,6 +1316,26 @@ (after (number-of-lines-in-region point end))) (display-message "Page has ~A lines (~A + ~A)" total before after)))) +(define-named-command com-count-lines-region () + (let* ((pane (current-window)) + (point (point pane)) + (mark (mark pane)) + (lines (number-of-lines-in-region point mark)) + (chars (abs (- (offset point) (offset mark))))) + (display-message "Region has ~D line~:P, ~D character~:P." lines chars))) + +(define-named-command com-what-cursor-position () + (let* ((pane (current-window)) + (point (point pane)) + (buffer (buffer pane)) + (offset (offset point)) + (size (size buffer)) + (char (object-after point)) + (column (column-number point))) + (display-message "Char: ~:C (#o~O ~:*~D ~:*#x~X) point=~D of ~D (~D%) column ~D" + char (char-code char) offset size + (round (* 100 (/ offset size))) column))) + (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?")) (let* ((*package* (find-package :climacs-gui)) (string (handler-case (accept 'string :prompt "Eval") @@ -1432,7 +1454,7 @@ (define-named-command com-accept-string () (display-message (format nil "~s" (accept 'string)))) - + (define-named-command com-accept-symbol () (display-message (format nil "~s" (accept 'symbol)))) @@ -1514,7 +1536,7 @@ (global-set-key '(#\_ :shift :meta) 'com-redo) (global-set-key '(#\_ :shift :control) 'com-undo) (global-set-key '(#\% :shift :meta) 'com-query-replace) - +(global-set-key '(#\= :meta) 'com-count-lines-region) (global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*)) (global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*)) (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*)) @@ -1573,6 +1595,7 @@ (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark) +(c-x-set-key '(#\=) 'com-what-cursor-position) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From dmurray at common-lisp.net Mon Aug 8 14:48:23 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 8 Aug 2005 16:48:23 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050808144823.403F288542@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3963 Modified Files: gui.lisp Log Message: Added new commands. com-delete-horizontal-space (M-\), com-scroll-other-window (M-C-v), com-kill-sentence (M-k), com-backward-kill-sentence (C-x Backspace), com-mark-page (C-x C-p). Date: Mon Aug 8 16:48:22 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.172 climacs/gui.lisp:1.173 --- climacs/gui.lisp:1.172 Mon Aug 8 14:15:05 2005 +++ climacs/gui.lisp Mon Aug 8 16:48:21 2005 @@ -764,6 +764,20 @@ while (whitespacep (object-after point)) do (incf (offset point))))) +(define-named-command com-delete-horizontal-space ((backward-only-p + 'boolean :prompt "Delete backwards only?")) + (let* ((point (point (current-window))) + (mark (clone-mark point))) + (loop until (beginning-of-line-p point) + while (whitespacep (object-before point)) + do (backward-object point)) + (unless backward-only-p + (loop until (end-of-line-p mark) + while (whitespacep (object-after mark)) + do (forward-object mark))) + (delete-region point mark))) + + (define-named-command com-goto-position () (setf (offset (point (current-window))) (handler-case (accept 'integer :prompt "Goto Position") @@ -909,7 +923,11 @@ (cadr (windows *application-frame*))) (com-delete-window)) (setf *standard-output* (car (windows *application-frame*)))) - + +(define-named-command com-scroll-other-window () + (let ((other-window (second (windows *application-frame*)))) + (when other-window + (page-down other-window)))) (define-named-command com-delete-window () (unless (null (cdr (windows *application-frame*))) @@ -1277,6 +1295,28 @@ (loop repeat count do (forward-sentence point syntax)) (loop repeat (- count) do (backward-sentence point syntax))))) +(define-named-command com-kill-sentence ((count 'integer :prompt "Number of sentences")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (clone-mark point)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (forward-sentence point syntax)) + (loop repeat (- count) do (backward-sentence point syntax))) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-region point mark)))) + +(define-named-command com-backward-kill-sentence ((count 'integer :prompt "Number of sentences")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (clone-mark point)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (backward-sentence point syntax)) + (loop repeat (- count) do (forward-sentence point syntax))) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-region point mark))) + (defun forward-page (mark &optional (count 1)) (loop repeat count unless (search-forward mark (coerce (list #\Newline #\Page) 'vector)) @@ -1304,6 +1344,19 @@ (backward-page point count) (forward-page point count)))) +(define-named-command com-mark-page ((count 'integer :prompt "Move how many pages") + (numargp 'boolean :prompt "Move to another page?")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (mark pane))) + (cond ((and numargp (/= 0 count)) + (if (plusp count) + (forward-page point count) + (backward-page point (1+ count)))) + (t (backward-page point count))) + (setf (offset mark) (offset point)) + (forward-page mark 1))) + (define-named-command com-count-lines-page () (let* ((pane (current-window)) (point (point pane)) @@ -1507,6 +1560,7 @@ (global-set-key '(#\w :control) 'com-kill-region) (global-set-key '(#\e :meta) `(com-forward-sentence ,*numeric-argument-marker*)) (global-set-key '(#\a :meta) `(com-backward-sentence ,*numeric-argument-marker*)) +(global-set-key '(#\k :meta) `(com-kill-sentence ,*numeric-argument-marker*)) (global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*)) (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*)) @@ -1519,9 +1573,11 @@ (global-set-key '(#\w :meta) 'com-copy-region) (global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\v :meta) 'com-page-up) +(global-set-key '(#\v :control :meta) 'com-scroll-other-window) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\m :meta) 'com-back-to-indentation) +(global-set-key '(#\\ :meta) `(com-delete-horizontal-space ,*numeric-argument-p*)) (global-set-key '(#\^ :shift :meta) 'com-delete-indentation) (global-set-key '(#\q :meta) 'com-fill-paragraph) (global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*)) @@ -1590,12 +1646,14 @@ (c-x-set-key '(#\u) 'com-undo) (c-x-set-key '(#\]) `(com-forward-page ,*numeric-argument-marker*)) (c-x-set-key '(#\[) `(com-backward-page ,*numeric-argument-marker*)) +(c-x-set-key '(#\p :control) `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*)) (c-x-set-key '(#\l) 'com-count-lines-page) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark) (c-x-set-key '(#\=) 'com-what-cursor-position) +(c-x-set-key '(#\Backspace) `(com-backward-kill-sentence ,*numeric-argument-marker*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From crhodes at common-lisp.net Mon Aug 8 18:32:05 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 8 Aug 2005 20:32:05 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050808183205.8F10D88542@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18876 Modified Files: gui.lisp Log Message: delete a couple of stray extra parens Date: Mon Aug 8 20:32:02 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.173 climacs/gui.lisp:1.174 --- climacs/gui.lisp:1.173 Mon Aug 8 16:48:21 2005 +++ climacs/gui.lisp Mon Aug 8 20:32:02 2005 @@ -806,7 +806,7 @@ (define-named-command com-browse-url () (let ((url (accept 'url :prompt "Browse URL"))) #+ (and sbcl darwin) - (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)))) + (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil))) (define-named-command com-set-mark () (let ((pane (current-window))) @@ -1304,7 +1304,7 @@ (loop repeat count do (forward-sentence point syntax)) (loop repeat (- count) do (backward-sentence point syntax))) (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (delete-region point mark)))) + (delete-region point mark))) (define-named-command com-backward-kill-sentence ((count 'integer :prompt "Number of sentences")) (let* ((pane (current-window)) From dmurray at common-lisp.net Tue Aug 9 15:18:29 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Tue, 9 Aug 2005 17:18:29 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/base.lisp Message-ID: <20050809151829.2F05788540@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6292 Modified Files: base.lisp Log Message: Removed sb-impl::whitespacep, which is disappearing. Date: Tue Aug 9 17:18:28 2005 Author: dmurray Index: climacs/base.lisp diff -u climacs/base.lisp:1.41 climacs/base.lisp:1.42 --- climacs/base.lisp:1.41 Fri Aug 5 14:40:55 2005 +++ climacs/base.lisp Tue Aug 9 17:18:25 2005 @@ -185,8 +185,7 @@ (defun whitespacep (obj) "A predicate to ensure that an object is a whitespace character." (and (characterp obj) - #+sbcl (sb-impl::whitespacep obj) - #-sbcl (member obj '(#\Space #\Tab #\Newline #\Page)))) + (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))) (defun forward-to-word-boundary (mark) "Move the mark forward to the beginning of the next word." From dmurray at common-lisp.net Tue Aug 9 15:21:08 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Tue, 9 Aug 2005 17:21:08 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050809152108.899F888540@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6379 Modified Files: lisp-syntax.lisp Log Message: Added support for ,@ and ,. forms, and some rudimentary 'face' code. Now colours most reader-conditionals appropriately. Work still needed. Date: Tue Aug 9 17:21:07 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.22 climacs/lisp-syntax.lisp:1.23 --- climacs/lisp-syntax.lisp:1.22 Mon Aug 8 10:53:30 2005 +++ climacs/lisp-syntax.lisp Tue Aug 9 17:21:07 2005 @@ -169,6 +169,8 @@ (defclass quote-lexeme (lisp-lexeme) ()) (defclass backquote-lexeme (lisp-lexeme) ()) (defclass comma-lexeme (lisp-lexeme) ()) +(defclass comma-at-lexeme (lisp-lexeme) ()) +(defclass comma-dot-lexeme (lisp-lexeme) ()) (defclass form-lexeme (form lisp-lexeme) ()) (defclass character-lexeme (form-lexeme) ()) (defclass function-lexeme (lisp-lexeme) ()) @@ -230,7 +232,14 @@ (make-instance 'line-comment-start-lexeme)) (#\" (fo) (make-instance 'string-start-lexeme)) (#\` (fo) (make-instance 'backquote-lexeme)) - (#\, (fo) (make-instance 'comma-lexeme)) + (#\, (fo) + (cond ((end-of-buffer-p scan) + (make-instance 'error-lexeme)) + (t + (case (object-after scan) + (#\@ (fo) (make-instance 'comma-at-lexeme)) + (#\. (fo) (make-instance 'comma-dot-lexeme)) + (t (make-instance 'comma-lexeme)))))) (#\# (fo) (cond ((end-of-buffer-p scan) (make-instance 'error-lexeme)) @@ -718,6 +727,8 @@ (define-parser-state |, form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow comma-lexeme) |, |) +(define-new-lisp-state (form-may-follow comma-at-lexeme) |, |) +(define-new-lisp-state (form-may-follow comma-dot-lexeme) |, |) (define-new-lisp-state (|, | form) |, form |) ;;; reduce according to the rule form -> , form @@ -1040,6 +1051,35 @@ (defvar *cursor-positions* nil) (defvar *current-line* 0) +(defparameter *standard-faces* + `((:error ,+red+ nil) + (:string ,+foreground-ink+ ,(make-text-style nil :italic nil)) + (:keyword ,+dark-violet+ nil) + (:lambda-list-keyword ,+dark-green+ nil) + (:comment ,+maroon+ nil) + (:reader-conditional ,+gray50+ nil))) + +(defparameter *reader-conditional-faces* + `((:error ,+red+ nil) + (:string ,+foreground-ink+ ,(make-text-style nil :italic nil)) + (:keyword ,+gray50+ nil) + (:lambda-list-keyword ,+gray50+ nil) + (:comment ,+maroon+ nil) + (:reader-conditional ,+gray50+ nil))) + +(defvar *current-faces* nil) + +(defun face-colour (type) + (first (cdr (assoc type *current-faces*)))) + +(defun face-style (type) + (second (cdr (assoc type *current-faces*)))) + +(defmacro with-face ((face) &body body) + `(with-drawing-options (pane :ink (face-colour ,face) + :text-style (face-style ,face)) + , at body)) + (defun handle-whitespace (pane buffer start end) (let ((space-width (space-width pane)) (tab-width (tab-width pane))) @@ -1081,12 +1121,12 @@ (if (and (null (cdr children)) (not (typep (parser-state parse-symbol) 'error-state))) (display-parse-tree (car children) syntax pane) - (with-drawing-options (pane :ink +red+) + (with-face (:error) (loop for child in children do (display-parse-tree child syntax pane)))))) (defmethod display-parse-tree ((parse-symbol error-lexeme) (syntax lisp-syntax) pane) - (with-drawing-options (pane :ink +red+) + (with-face (:error) (call-next-method))) (define-presentation-type unknown-symbol () :inherit-from 'symbol @@ -1107,10 +1147,10 @@ (pane (if status symbol string) (if status 'symbol 'unknown-symbol) :single-box :highlighting) (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) - (with-drawing-options (pane :ink +dark-violet+) + (with-face (:keyword) (call-next-method))) ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) - (with-drawing-options (pane :ink +dark-green+) + (with-face (:lambda-list-keyword) (call-next-method))) (t (call-next-method))) ))) @@ -1154,8 +1194,8 @@ (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) (display-parse-tree (pop children) syntax pane) - (with-text-face (pane :italic) - (loop until (null (cdr children)) + (with-face (:string) + (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) @@ -1171,17 +1211,17 @@ (with-output-as-presentation (pane string 'lisp-string :single-box :highlighting) (display-parse-tree (pop children) syntax pane) - (with-text-face (pane :italic) + (with-face (:string) (loop until (null children) do (display-parse-tree (pop children) syntax pane))))) (display-parse-tree (pop children) syntax pane)))) (defmethod display-parse-tree ((parse-symbol line-comment-form) (syntax lisp-syntax) pane) - (with-drawing-options (pane :ink +maroon+) + (with-face (:comment) (call-next-method))) (defmethod display-parse-tree ((parse-symbol long-comment-form) (syntax lisp-syntax) pane) - (with-drawing-options (pane :ink +maroon+) + (with-face (:comment) (call-next-method))) (defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) @@ -1189,21 +1229,26 @@ (let ((conditional (second (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) (call-next-method) - (with-drawing-options (pane :ink +gray50+) - (call-next-method))))) + (let ((*current-faces* *reader-conditional-faces*)) + (with-face (:reader-conditional) + (call-next-method)))))) (defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) (syntax lisp-syntax) pane) (let ((conditional (second (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) - (with-drawing-options (pane :ink +gray50+) - (call-next-method)) + (let ((*current-faces* *reader-conditional-faces*)) + (with-face (:reader-conditional) + (call-next-method))) (call-next-method)))) (defparameter climacs-gui::*climacs-features* (copy-list *features*)) (defgeneric eval-feature-conditional (conditional-form syntax)) +(defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) + nil) + ;; Adapted from slime.el (defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) @@ -1249,8 +1294,9 @@ *current-line* 0 (aref *cursor-positions* 0) (stream-cursor-position pane)) (setf *white-space-start* (offset top))) - (with-slots (stack-top) syntax - (display-parse-tree stack-top syntax pane)) + (let ((*current-faces* *standard-faces*)) + (with-slots (stack-top) syntax + (display-parse-tree stack-top syntax pane))) (with-slots (top) pane (let* ((cursor-line (number-of-lines-in-region top (point pane))) (style (medium-text-style pane)) From dmurray at common-lisp.net Tue Aug 9 22:12:18 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Wed, 10 Aug 2005 00:12:18 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050809221218.E8F168852B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2549 Modified Files: lisp-syntax.lisp Log Message: Move defconstant to before first use. Also, introduce indententation rule for long comments (to prevent error). Date: Wed Aug 10 00:12:18 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.23 climacs/lisp-syntax.lisp:1.24 --- climacs/lisp-syntax.lisp:1.23 Tue Aug 9 17:21:07 2005 +++ climacs/lisp-syntax.lisp Wed Aug 10 00:12:17 2005 @@ -1251,6 +1251,9 @@ ;; Adapted from slime.el +(defconstant keyword-package (find-package :keyword) + "The KEYWORD package.") + (defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) (let* ((string (coerce (buffer-sequence (buffer syntax) (start-offset conditional) @@ -1429,11 +1432,6 @@ do (setf (offset mark) (end-offset form)) (loop-finish)))) -;;; shamelessly stolen from SWANK - -(defconstant keyword-package (find-package :keyword) - "The KEYWORD package.") - ;;; 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 @@ -1616,6 +1614,9 @@ (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree error-symbol) path) + (values tree 0)) + +(defmethod indent-form ((syntax lisp-syntax) (tree long-comment-form) path) (values tree 0)) (defmethod indent-binding ((syntax lisp-syntax) tree path) From dmurray at common-lisp.net Wed Aug 10 16:38:47 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Wed, 10 Aug 2005 18:38:47 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050810163847.16E8B880DE@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14383 Modified Files: lisp-syntax.lisp Log Message: Reworked parser to treat comments differently from other forms. This needs to be taken advantage of in e.g. indentation code. But now e.g. #-sbcl ;; a comment (this form will be will grayed out) works. Date: Wed Aug 10 18:38:45 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.24 climacs/lisp-syntax.lisp:1.25 --- climacs/lisp-syntax.lisp:1.24 Wed Aug 10 00:12:17 2005 +++ climacs/lisp-syntax.lisp Wed Aug 10 18:38:45 2005 @@ -158,6 +158,8 @@ (defclass form (lisp-nonterminal) ()) (defclass incomplete-form-mixin () ()) +(defclass comment (lisp-nonterminal) ()) + (defclass lisp-lexeme (lexeme) ((ink) (face))) @@ -544,6 +546,7 @@ (define-parser-state |initial-state | (form-may-follow) ()) (define-new-lisp-state (|initial-state | form) |initial-state |) +(define-new-lisp-state (|initial-state | comment) |initial-state |) (define-lisp-action (|initial-state | (eql nil)) (reduce-all form*)) @@ -569,6 +572,7 @@ (define-new-lisp-state (form-may-follow left-parenthesis-lexeme) |( form* |) (define-new-lisp-state (|( form* | form) |( form* |) +(define-new-lisp-state (|( form* | comment) |( form* |) (define-new-lisp-state (|( form* | right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ( form* ) @@ -591,6 +595,7 @@ (define-new-lisp-state (form-may-follow simple-vector-start-lexeme) |#( form* |) (define-new-lisp-state (|#( form* | form) |#( form* |) +(define-new-lisp-state (|#( form* | comment) |#( form* |) (define-new-lisp-state (|#( form* | right-parenthesis-lexeme) |#( form* ) |) ;;; reduce according to the rule form -> #( form* ) @@ -627,7 +632,7 @@ ;;;;;;;;;;;;;;;; Line comment ;;; parse trees -(defclass line-comment-form (form) ()) +(defclass line-comment-form (comment) ()) (define-parser-state |; word* | (lexer-line-comment-state parser-state) ()) (define-parser-state |; word* NL | (lexer-toplevel-state parser-state) ()) @@ -644,7 +649,7 @@ ;;;;;;;;;;;;;;;; Long comment ;;; parse trees -(defclass long-comment-form (form) ()) +(defclass long-comment-form (comment) ()) (defclass complete-long-comment-form (long-comment-form) ()) (defclass incomplete-long-comment-form (long-comment-form incomplete-form-mixin) ()) @@ -698,10 +703,12 @@ (define-new-lisp-state (form-may-follow quote-lexeme) |' |) (define-new-lisp-state (|' | form) |' form |) +(define-new-lisp-state (|' | comment) |' |) + ;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) - (reduce-fixed-number quote-form 2)) + (reduce-until-type quote-form quote-lexeme)) ;;;;;;;;;;;;;;;; Backquote @@ -713,27 +720,43 @@ (define-new-lisp-state (form-may-follow backquote-lexeme) |` |) (define-new-lisp-state (|` | form) |` form |) +(define-new-lisp-state (|` | comment) |` |) ;;; reduce according to the rule form -> ` form (define-lisp-action (|` form | t) - (reduce-fixed-number backquote-form 2)) + (reduce-until-type backquote-form backquote-lexeme)) ;;;;;;;;;;;;;;;; Comma ;;; parse trees (defclass comma-form (form) ()) +(defclass comma-at-form (form) ()) +(defclass comma-dot-form (form) ()) (define-parser-state |, | (form-may-follow) ()) (define-parser-state |, form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |,@ | (form-may-follow) ()) +(define-parser-state |,@ form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |,. | (form-may-follow) ()) +(define-parser-state |,. form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow comma-lexeme) |, |) -(define-new-lisp-state (form-may-follow comma-at-lexeme) |, |) -(define-new-lisp-state (form-may-follow comma-dot-lexeme) |, |) +(define-new-lisp-state (form-may-follow comma-at-lexeme) |,@ |) +(define-new-lisp-state (form-may-follow comma-dot-lexeme) |,. |) (define-new-lisp-state (|, | form) |, form |) +(define-new-lisp-state (|, | comment) |, |) +(define-new-lisp-state (|,@ | form) |,@ form |) +(define-new-lisp-state (|,@ | comment) |,@ |) +(define-new-lisp-state (|,. | form) |,. form |) +(define-new-lisp-state (|,. | comment) |,. |) ;;; reduce according to the rule form -> , form (define-lisp-action (|, form | t) - (reduce-fixed-number backquote-form 2)) + (reduce-until-type comma-form comma-lexeme)) +(define-lisp-action (|,@ form | t) + (reduce-until-type comma-at-form comma-at-lexeme)) +(define-lisp-action (|,. form | t) + (reduce-until-type comma-dot-form comma-dot-lexeme)) ;;;;;;;;;;;;;;;; Function @@ -745,10 +768,11 @@ (define-new-lisp-state (form-may-follow function-lexeme) |#' |) (define-new-lisp-state (|#' | form) |#' form |) +(define-new-lisp-state (|#' | comment) |#' |) ;;; reduce according to the rule form -> #' form (define-lisp-action (|#' form | t) - (reduce-fixed-number function-form 2)) + (reduce-until-type function-form function-lexeme)) ;;;;;;;;;;;;;;;; Reader conditionals @@ -766,15 +790,19 @@ (define-new-lisp-state (form-may-follow reader-conditional-positive-lexeme) |#+ |) (define-new-lisp-state (|#+ | form) |#+ form |) (define-new-lisp-state (|#+ form | form) |#+ form form |) +(define-new-lisp-state (|#+ | comment) |#+ |) +(define-new-lisp-state (|#+ form | comment) |#+ form |) (define-new-lisp-state (form-may-follow reader-conditional-negative-lexeme) |#- |) (define-new-lisp-state (|#- | form) |#- form |) (define-new-lisp-state (|#- form | form) |#- form form |) +(define-new-lisp-state (|#- | comment) |#- |) +(define-new-lisp-state (|#- form | comment) |#- form |) (define-lisp-action (|#+ form form | t) - (reduce-fixed-number reader-conditional-positive-form 3)) + (reduce-until-type reader-conditional-positive-form reader-conditional-positive-lexeme)) (define-lisp-action (|#- form form | t) - (reduce-fixed-number reader-conditional-negative-form 3)) + (reduce-until-type reader-conditional-negative-form reader-conditional-negative-lexeme)) ;;;;;;;;;;;;;;;; uninterned symbol @@ -784,7 +812,7 @@ (define-parser-state |#: | (form-may-follow) ()) (define-parser-state |#: form | (lexer-toplevel-state parser-state) ()) -(define-new-lisp-state (form-may-follow uninterned-symbol-lexeme) |' |) +(define-new-lisp-state (form-may-follow uninterned-symbol-lexeme) |#: |) (define-new-lisp-state (|#: | form) |#: form |) ;;; reduce according to the rule form -> #: form @@ -799,12 +827,13 @@ (define-parser-state |#. | (form-may-follow) ()) (define-parser-state |#. form | (lexer-toplevel-state parser-state) ()) -(define-new-lisp-state (form-may-follow readtime-evaluation-lexeme) |' |) +(define-new-lisp-state (form-may-follow readtime-evaluation-lexeme) |#. |) (define-new-lisp-state (|#. | form) |#. form |) +(define-new-lisp-state (|#. | comment) |#. |) ;;; reduce according to the rule form -> #. form (define-lisp-action (|#. form | t) - (reduce-fixed-number readtime-evaluation-form 2)) + (reduce-until-type readtime-evaluation-form readtime-evaluation-lexeme)) ;;;;;;;;;;;;;;;; sharpsign equals @@ -814,12 +843,13 @@ (define-parser-state |#= | (form-may-follow) ()) (define-parser-state |#= form | (lexer-toplevel-state parser-state) ()) -(define-new-lisp-state (form-may-follow sharpsign-equals-lexeme) |' |) +(define-new-lisp-state (form-may-follow sharpsign-equals-lexeme) |#= |) (define-new-lisp-state (|#= | form) |#= form |) +(define-new-lisp-state (|#= | comment) |#= |) ;;; reduce according to the rule form -> #= form (define-lisp-action (|#= form | t) - (reduce-fixed-number sharpsign-equals-form 2)) + (reduce-until-type sharpsign-equals-form sharpsign-equals-lexeme)) ;;;;;;;;;;;;;;;; array @@ -829,12 +859,13 @@ (define-parser-state |#A | (form-may-follow) ()) (define-parser-state |#A form | (lexer-toplevel-state parser-state) ()) -(define-new-lisp-state (form-may-follow array-start-lexeme) |' |) +(define-new-lisp-state (form-may-follow array-start-lexeme) |#A |) (define-new-lisp-state (|#A | form) |#A form |) +(define-new-lisp-state (|#A | comment) |#A |) ;;; reduce according to the rule form -> #A form (define-lisp-action (|#A form | t) - (reduce-fixed-number array-start-form 2)) + (reduce-until-type array-start-form array-start-lexeme)) ;;;;;;;;;;;;;;;; structure @@ -870,12 +901,13 @@ (define-parser-state |#P | (form-may-follow) ()) (define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) -(define-new-lisp-state (form-may-follow pathname-start-lexeme) |' |) +(define-new-lisp-state (form-may-follow pathname-start-lexeme) |#P |) (define-new-lisp-state (|#P | form) |#P form |) +(define-new-lisp-state (|#P | comment) |#P |) ;;; reduce according to the rule form -> #P form (define-lisp-action (|#P form | t) - (reduce-fixed-number pathname-start-form 2)) + (reduce-until-type pathname-form pathname-start-lexeme)) ;;;;;;;;;;;;;;;; undefined reader macro @@ -885,12 +917,12 @@ (define-parser-state |# | (form-may-follow) ()) (define-parser-state |# form | (lexer-toplevel-state parser-state) ()) -(define-new-lisp-state (form-may-follow undefined-reader-macro-lexeme) |' |) +(define-new-lisp-state (form-may-follow undefined-reader-macro-lexeme) |# |) (define-new-lisp-state (|# | form) |# form |) -;;; reduce according to the rule form -> #: form -(define-lisp-action (|#: form | t) - (reduce-fixed-number uninterned-symbol-form 2)) +;;; reduce according to the rule form -> # form +(define-lisp-action (|# form | t) + (reduce-fixed-number undefined-reader-macro-form 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1061,10 +1093,10 @@ (defparameter *reader-conditional-faces* `((:error ,+red+ nil) - (:string ,+foreground-ink+ ,(make-text-style nil :italic nil)) + (:string ,+gray50+ ,(make-text-style nil :italic nil)) (:keyword ,+gray50+ nil) (:lambda-list-keyword ,+gray50+ nil) - (:comment ,+maroon+ nil) + (:comment ,+gray50+ nil) (:reader-conditional ,+gray50+ nil))) (defvar *current-faces* nil) From afuchs at common-lisp.net Fri Aug 12 21:15:28 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Fri, 12 Aug 2005 23:15:28 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/climacs.asd Message-ID: <20050812211528.4221D88540@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32243 Modified Files: climacs.asd Log Message: Add gui.lisp to climacs-gui's dependency list. Thanks to Taylor R. Campbell for the diagnosis. Date: Fri Aug 12 23:15:27 2005 Author: afuchs Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.36 climacs/climacs.asd:1.37 --- climacs/climacs.asd:1.36 Fri Aug 5 00:07:45 2005 +++ climacs/climacs.asd Fri Aug 12 23:15:26 2005 @@ -73,7 +73,7 @@ (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "esa" "kill-ring" "io" "text-syntax" "abbrev")) (:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane")) - (:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax")))) + (:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax" "gui")))) (defsystem :climacs.tests :depends-on (:climacs) From dmurray at common-lisp.net Sat Aug 13 18:33:11 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sat, 13 Aug 2005 20:33:11 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050813183311.8C50A88545@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21006 Modified Files: lisp-syntax.lisp Log Message: Small changes to movement by expression and display of reader conditionals to exploit new handling of comments. Date: Sat Aug 13 20:33:11 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.25 climacs/lisp-syntax.lisp:1.26 --- climacs/lisp-syntax.lisp:1.25 Wed Aug 10 18:38:45 2005 +++ climacs/lisp-syntax.lisp Sat Aug 13 20:33:10 2005 @@ -1076,6 +1076,30 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; accessing parser forms + +(defun first-form (list) + "Returns the first non-comment in list." + (find-if-not #'(lambda (item) (typep item 'comment)) list)) + +(defun nth-form (n list) + "Returns the nth non-comment in list." + (loop for item in list + count (not (typep item 'comment)) + into forms + until (= forms n) + finally (return item))) + +(defun second-form (list) + "Returns the second non-comment in list." + (nth-form 2 list)) + +(defun third-form (list) + "Returns the third non-comment in list." + (nth-form 3 list)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; display (defvar *white-space-start* nil) @@ -1258,7 +1282,7 @@ (defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) (syntax lisp-syntax) pane) - (let ((conditional (second (children parse-symbol)))) + (let ((conditional (second-form (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) (call-next-method) (let ((*current-faces* *reader-conditional-faces*)) @@ -1267,7 +1291,7 @@ (defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) (syntax lisp-syntax) pane) - (let ((conditional (second (children parse-symbol)))) + (let ((conditional (second-form (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) (let ((*current-faces* *reader-conditional-faces*)) (with-face (:reader-conditional) @@ -1296,11 +1320,16 @@ (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) (let ((children (children conditional))) - (when (third children) + (when (third-form children) (flet ((eval-fc (conditional) (funcall #'eval-feature-conditional conditional syntax))) - (let* ((type (second children)) - (conditionals (butlast (nthcdr 2 children))) + (let* ((type (second-form children)) + (conditionals (butlast + (nthcdr + 2 + (remove-if + #'(lambda (child) (typep child 'comment)) + children)))) (type-string (coerce (buffer-sequence (buffer syntax) (start-offset type) (end-offset type)) @@ -1355,14 +1384,15 @@ ;;; exploit the parse (defun form-before-in-children (children offset) - (loop for (first second) on children + (loop for (first . rest) on children + unless (typep first 'comment) do (cond ((< (start-offset first) offset (end-offset first)) (return (if (null (children first)) nil (form-before-in-children (children first) offset)))) ((and (>= offset (end-offset first)) - (or (null second) - (<= offset (start-offset second)))) + (or (null rest) + (<= offset (start-offset (first-form rest))))) (return (let ((potential-form (form-before-in-children (children first) offset))) (or potential-form (when (typep first 'form) @@ -1378,16 +1408,17 @@ (defun form-after-in-children (children offset) (loop for child in children - do (cond ((< (start-offset child) offset (end-offset child)) - (return (if (null (children child)) - nil - (form-after-in-children (children child) offset)))) - ((<= offset (start-offset child)) - (return (let ((potential-form (form-after-in-children (children child) offset))) - (or potential-form - (when (typep child 'form) - child))))) - (t nil)))) + unless (typep child 'comment) + do (cond ((< (start-offset child) offset (end-offset child)) + (return (if (null (children child)) + nil + (form-after-in-children (children child) offset)))) + ((<= offset (start-offset child)) + (return (let ((potential-form (form-after-in-children (children child) offset))) + (or potential-form + (when (typep child 'form) + child))))) + (t nil)))) (defun form-after (syntax offset) (with-slots (stack-top) syntax @@ -1398,6 +1429,7 @@ (defun form-around-in-children (children offset) (loop for child in children + unless (typep child 'comment) do (cond ((< (start-offset child) offset (end-offset child)) (return (if (null (children child)) (when (typep child 'form) @@ -1444,14 +1476,14 @@ (with-slots (stack-top) syntax (loop for form in (children stack-top) with last-toplevel-list = nil - when (and (typep form 'list-form) + when (and (typep form 'form) (mark< mark (end-offset form))) do (if (mark< (start-offset form) mark) (setf (offset mark) (start-offset form)) (when last-toplevel-list form (setf (offset mark) (start-offset last-toplevel-list)))) (return t) - when (typep form 'list-form) + when (typep form 'form) do (setf last-toplevel-list form) finally (when last-toplevel-list form (setf (offset mark) (start-offset last-toplevel-list)))))) @@ -1459,7 +1491,7 @@ (defmethod end-of-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) - when (and (typep form 'list-form) + when (and (typep form 'form) (mark< mark (end-offset form))) do (setf (offset mark) (end-offset form)) (loop-finish)))) From crhodes at common-lisp.net Sat Aug 13 20:26:45 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sat, 13 Aug 2005 22:26:45 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050813202645.40AE68854C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27817 Modified Files: lisp-syntax.lisp Log Message: implement a bunch of indentation methods for various lisp forms. Date: Sat Aug 13 22:26:44 2005 Author: crhodes Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.26 climacs/lisp-syntax.lisp:1.27 --- climacs/lisp-syntax.lisp:1.26 Sat Aug 13 20:33:10 2005 +++ climacs/lisp-syntax.lisp Sat Aug 13 22:26:44 2005 @@ -1683,6 +1683,9 @@ (defmethod indent-form ((syntax lisp-syntax) (tree long-comment-form) path) (values tree 0)) +(defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) + (indent-form syntax (elt (children tree) (car path)) (cdr path))) + (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) ;; top level @@ -1736,7 +1739,12 @@ ;;; for now the same as indent-list, but try to do better with ;;; optional parameters with default values -(define-list-indentor indent-lambda-list indent-list) +(define-list-indentor indent-ordinary-lambda-list indent-list) +;;; again, can do better +(define-list-indentor indent-macro-lambda-list indent-list) +;;; FIXME: also BOA, DEFSETF, DEFTYPE, SPECIALIZED, GENERIC-FUNCTION, +;;; DESTRUCTURING, DEFINE-MODIFY-MACRO and +;;; DEFINE-METHOD-COMBINATION-ARGUMENTS (defmacro define-simple-indentor (template) `(defmethod compute-list-indentation @@ -1748,14 +1756,25 @@ collect `((= (car path) ,i) (,fun syntax (elt (children tree) ,i) (cdr path)))) (t (indent-form syntax (elt (children tree) (car path)) (cdr path)))))) +(define-simple-indentor (progn)) (define-simple-indentor (prog1 indent-form)) +(define-simple-indentor (prog2 indent-form indent-form)) +(define-simple-indentor (locally)) (define-simple-indentor (let indent-bindings)) (define-simple-indentor (let* indent-bindings)) -(define-simple-indentor (defun indent-list indent-lambda-list)) -(define-simple-indentor (defmacro indent-list indent-lambda-list)) -(define-simple-indentor (with-slots indent-list)) +(define-simple-indentor (multiple-value-bind indent-list indent-form)) +(define-simple-indentor (defun indent-list indent-ordinary-lambda-list)) +(define-simple-indentor (defmacro indent-list indent-macro-lambda-list)) +(define-simple-indentor (with-slots indent-bindings indent-form)) +(define-simple-indentor (with-accessors indent-bindings indent-form)) (define-simple-indentor (when indent-form)) (define-simple-indentor (unless indent-form)) +(define-simple-indentor (print-unreadable-object indent-list)) +(define-simple-indentor (defvar indent-form)) +(define-simple-indentor (defparameter indent-form)) +(define-simple-indentor (defconstant indent-form)) + +;;; non-simple-cases: LOOP, MACROLET, FLET, LABELS ;;; do this better (define-list-indentor indent-slot-specs indent-list) @@ -1810,7 +1829,14 @@ (t (indent-form syntax (elt (children tree) (car path)) (cdr path)))))) -(define-list-indentor indent-clause indent-form) +(defun indent-clause (syntax tree path) + (if (null (cdr path)) + ;; top level + (case (car path) + (1 (values tree 1)) + (2 (values tree 1)) + (t (values (elt (children tree) 2) 0))) + (indent-form syntax (elt (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'cond)) tree path) @@ -1823,6 +1849,35 @@ (values (elt (children tree) 2) 0)) ;; inside a clause (indent-clause syntax (elt (children tree) (car path)) (cdr path)))) + +(macrolet ((def (symbol) + `(defmethod compute-list-indentation + ((syntax lisp-syntax) (symbol (eql ',symbol)) tree path) + (if (null (cdr path)) + (case (car path) + (2 (values tree 4)) + (3 (values tree 2)) + (t (values (elt (children tree) 3) 0))) + (indent-clause syntax (elt (children tree) (car path)) (cdr path)))))) + (def case) + (def ccase) + (def ecase) + (def typecase) + (def ctypecase) + (def etypecase)) + +(defmethod compute-list-indentation + ((syntax lisp-syntax) (symbol (eql 'tagbody)) tree path) + (if (null (cdr path)) + ;; this TOKEN-MIXIN test is not quite right. It should be a + ;; test for symbolness of the token, but it shouldn't depend on + ;; the symbol existing in the current image. (Arguably, too, + ;; this is a broken indentation form because it doesn't carry + ;; over to the implicit tagbodies in macros such as DO. + (if (typep (elt (children tree) (car path)) 'token-mixin) + (values tree 2) + (values tree 4)) + (indent-form syntax (elt (children tree) (car path)) (cdr path)))) (defun compute-path-in-trees (trees n offset) (cond ((or (null trees) From dmurray at common-lisp.net Sun Aug 14 08:57:00 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sun, 14 Aug 2005 10:57:00 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050814085700.3A722880DD@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10993 Modified Files: lisp-syntax.lisp Log Message: Some list movement commands (forward- backward- up- backward-up- down-list). Date: Sun Aug 14 10:56:59 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.27 climacs/lisp-syntax.lisp:1.28 --- climacs/lisp-syntax.lisp:1.27 Sat Aug 13 22:26:44 2005 +++ climacs/lisp-syntax.lisp Sun Aug 14 10:56:58 2005 @@ -1461,6 +1461,72 @@ (setf (offset mark) (end-offset potential-form)) (error 'no-expression)))) +(defmethod forward-list (mark (syntax lisp-syntax)) + (loop for start = (offset mark) + then (end-offset potential-form) + for potential-form = (or (form-after syntax start) + (form-around syntax start)) + until (null potential-form) + when (typep potential-form 'list-form) + do (setf (offset mark) (end-offset potential-form)) + (return) + finally (error 'no-expression))) + +(defmethod backward-list (mark (syntax lisp-syntax)) + (loop for start = (offset mark) + then (start-offset potential-form) + for potential-form = (or (form-before syntax start) + (form-around syntax start)) + until (null potential-form) + when (typep potential-form 'list-form) + do (setf (offset mark) (start-offset potential-form)) + (return) + finally (error 'no-expression))) + +(defmethod down-list (mark (syntax lisp-syntax)) + (loop for start = (offset mark) + then (end-offset potential-form) + for potential-form = (or (form-after syntax start) + (form-around syntax start)) + until (null potential-form) + when (typep potential-form 'list-form) + do (setf (offset mark) (1+ (start-offset potential-form))) + (return) + finally (error 'no-expression))) + +(defmethod backward-down-list (mark (syntax lisp-syntax)) + (loop for start = (offset mark) + then (start-offset potential-form) + for potential-form = (or (form-before syntax start) + (form-around syntax start)) + until (null potential-form) + when (typep potential-form 'list-form) + do (setf (offset mark) (1- (end-offset potential-form))) + (return) + finally (error 'no-expression))) + +(defmethod backward-up-list (mark (syntax lisp-syntax)) + (let ((form (or (form-around syntax (offset mark)) + (form-before syntax (offset mark)) + (form-after syntax (offset mark))))) + (if form + (let ((parent (parent form))) + (if (typep parent 'list-form) + (setf (offset mark) (start-offset parent)) + (error 'no-expression))) + (error 'no-expression)))) + +(defmethod up-list (mark (syntax lisp-syntax)) + (let ((form (or (form-around syntax (offset mark)) + (form-before syntax (offset mark)) + (form-after syntax (offset mark))))) + (if form + (let ((parent (parent form))) + (if (typep parent 'list-form) + (setf (offset mark) (end-offset parent)) + (error 'no-expression))) + (error 'no-expression)))) + (defmethod eval-defun (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) From dmurray at common-lisp.net Sun Aug 14 12:11:21 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sun, 14 Aug 2005 14:11:21 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050814121121.0BDB288032@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24094 Modified Files: gui.lisp Log Message: Added com-backward-kill-expression (M-C-Backspace), com-kill-expression (M-C-k), com-forward-list (M-C-n), com-backward-list (M-C-p), com-down-list (M-C-d), com-backward-up-list (M-C-u), com-up-list, com-backward-down-list. Also a (currently empty) C-c command table, and a hacky way of choosing my favourite look over the standard look (by setting climacs-gui::*with-scrollbars* to nil before starting). Date: Sun Aug 14 14:11:21 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.174 climacs/gui.lisp:1.175 --- climacs/gui.lisp:1.174 Mon Aug 8 20:32:02 2005 +++ climacs/gui.lisp Sun Aug 14 14:11:21 2005 @@ -49,6 +49,9 @@ (:default-initargs :height 20 :max-height 20 :min-height 20)) +(defparameter *with-scrollbars* t + "If T, classic look and feel. If NIL, stripped-down look (:") + (define-application-frame climacs (standard-application-frame esa-frame-mixin) ((buffers :initform '() :accessor buffers)) @@ -70,8 +73,10 @@ (buffers *application-frame*) (list (buffer extended-pane))) (vertically () - (scrolling () - extended-pane) + (if *with-scrollbars* + (scrolling () + extended-pane) + extended-pane) info-pane))) (int (make-pane 'climacs-minibuffer-pane :width 900))) (:layouts @@ -103,9 +108,24 @@ (declare (ignore frame)) (let* ((master-pane (master-pane pane)) (buf (buffer master-pane)) - (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a" + (size (size buf)) + (top (top master-pane)) + (bot (bot master-pane)) + (name-info (format nil " ~a ~a~:[~30t~a~;~*~] ~:[(~;Syntax: ~]~a~a~a~a~:[)~;~] ~a" (if (needs-saving buf) "**" "--") (name buf) + *with-scrollbars* + (cond ((and (mark= size bot) + (mark= 0 top)) + "") + ((mark= size bot) + "Bot") + ((mark= 0 top) + "Top") + (t (format nil "~a%" + (round (* 100 (/ (offset top) + size)))))) + *with-scrollbars* (name (syntax buf)) (if (slot-value master-pane 'overwrite-mode) " Ovwrt" @@ -116,6 +136,7 @@ (if (isearch-mode master-pane) " Isearch" "") + *with-scrollbars* (if (recordingp *application-frame*) "Def" "")))) @@ -585,7 +606,6 @@ (multiple-value-bind (pathname success string) (complete-input stream #'filename-completer - :partial-completers '(#\Space) :allow-any-input t) (declare (ignore success)) (or pathname string))) @@ -842,9 +862,9 @@ (sheet-disown-child parent constellation) (let ((new (if vertical-p (vertically () - constellation adjust additional-constellation) + (1/2 constellation) adjust (1/2 additional-constellation)) (horizontally () - constellation adjust additional-constellation)))) + (1/2 constellation) adjust (1/2 additional-constellation))))) (sheet-adopt-child parent new) (reorder-sheets parent (if (eq constellation first) @@ -862,7 +882,9 @@ "make a vbox containing a scroller pane as its first child and an info pane as its second child. The scroller pane contains a viewport which contains an extended pane. Return the vbox and the extended pane -as two values" +as two values. +If *with-scrollbars nil, omit the scroller." + (let* ((extended-pane (make-pane 'extended-pane :width 900 :height 400 @@ -873,7 +895,10 @@ :command-table 'global-climacs-table)) (vbox (vertically () - (scrolling () extended-pane) + (if *with-scrollbars* + (scrolling () + extended-pane) + extended-pane) (make-pane 'climacs-info-pane :master-pane extended-pane :width 900)))) @@ -884,7 +909,9 @@ ((frame-manager *application-frame*) *application-frame*) (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) - (constellation-root (parent3 current-window))) + (constellation-root (if *with-scrollbars* + (parent3 current-window) + (sheet-parent current-window)))) (setf (offset (point (buffer current-window))) (offset (point current-window)) (buffer new-pane) (buffer current-window) (auto-fill-mode new-pane) (auto-fill-mode current-window) @@ -900,7 +927,9 @@ ((frame-manager *application-frame*) *application-frame*) (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) - (constellation-root (parent3 current-window))) + (constellation-root (if *with-scrollbars* + (parent3 current-window) + (sheet-parent current-window)))) (setf (offset (point (buffer current-window))) (offset (point current-window)) (buffer new-pane) (buffer current-window) (auto-fill-mode new-pane) (auto-fill-mode current-window) @@ -931,7 +960,9 @@ (define-named-command com-delete-window () (unless (null (cdr (windows *application-frame*))) - (let* ((constellation (parent3 (current-window))) + (let* ((constellation (if *with-scrollbars* + (parent3 (current-window)) + (sheet-parent (current-window)))) (box (sheet-parent constellation)) (box-children (sheet-children box)) (other (if (eq constellation (first box-children)) @@ -1449,12 +1480,85 @@ (define-named-command com-mark-expression ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) - (point (point pane)) - (mark (mark pane)) - (syntax (syntax (buffer pane)))) - (unless (eq (previous-command pane) 'com-mark-expression) - (setf (offset mark) (offset point))) - (loop repeat count do (forward-expression mark syntax)))) + (point (point pane)) + (mark (mark pane)) + (syntax (syntax (buffer pane)))) + (unless (eq (previous-command pane) 'com-mark-expression) + (setf (offset mark) (offset point))) + (if (plusp count) + (loop repeat count do (forward-expression mark syntax)) + (loop repeat (- count) do (backward-expression mark syntax))))) + +(define-named-command com-kill-expression ((count 'integer :prompt "Number of expressions")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (clone-mark point)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (forward-expression mark syntax)) + (loop repeat (- count) do (backward-expression mark syntax))) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-region mark point))) + +(define-named-command com-backward-kill-expression + ((count 'integer :prompt "Number of expressions")) + (let* ((pane (current-window)) + (point (point pane)) + (mark (clone-mark point)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (backward-expression mark syntax)) + (loop repeat (- count) do (forward-expression mark syntax))) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-region mark point))) + +(define-named-command com-forward-list ((count 'integer :prompt "Number of lists")) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (forward-list point syntax)) + (loop repeat (- count) do (backward-list point syntax))))) + +(define-named-command com-backward-list ((count 'integer :prompt "Number of lists")) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (backward-list point syntax)) + (loop repeat (- count) do (forward-list point syntax))))) + +(define-named-command com-down-list ((count 'integer :prompt "Number of lists")) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (down-list point syntax)) + (loop repeat (- count) do (backward-down-list point syntax))))) + +(define-named-command com-backward-down-list ((count 'integer :prompt "Number of lists")) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (backward-down-list point syntax)) + (loop repeat (- count) do (down-list point syntax))))) + +(define-named-command com-backward-up-list ((count 'integer :prompt "Number of lists")) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (backward-up-list point syntax)) + (loop repeat (- count) do (up-list point syntax))))) + +(define-named-command com-up-list ((count 'integer :prompt "Number of lists")) + (let* ((pane (current-window)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (if (plusp count) + (loop repeat count do (up-list point syntax)) + (loop repeat (- count) do (backward-up-list point syntax))))) (define-named-command com-eval-defun () (let* ((pane (current-window)) @@ -1613,6 +1717,12 @@ (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*)) +(global-set-key '(#\Backspace :control :meta) `(com-backward-kill-expression ,*numeric-argument-marker*)) +(global-set-key '(#\k :control :meta) `(com-kill-expression ,*numeric-argument-marker*)) +(global-set-key '(#\n :control :meta) `(com-forward-list ,*numeric-argument-marker*)) +(global-set-key '(#\p :control :meta) `(com-backward-list ,*numeric-argument-marker*)) +(global-set-key '(#\d :control :meta) `(com-down-list ,*numeric-argument-marker*)) +(global-set-key '(#\u :control :meta) `(com-backward-up-list ,*numeric-argument-marker*)) (global-set-key '(#\x :control :meta) 'com-eval-defun) (global-set-key '(#\a :control :meta) `(com-beginning-of-definition ,*numeric-argument-marker*)) (global-set-key '(#\e :control :meta) `(com-end-of-definition ,*numeric-argument-marker*)) @@ -1849,3 +1959,18 @@ (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) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; C-c command table + +(make-command-table 'c-c-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "C-c" + :menu 'c-c-climacs-table + :keystroke '(#\c :control)) + +(defun c-c-set-key (gesture command) + (add-command-to-command-table command 'c-c-climacs-table + :keystroke gesture :errorp nil)) + From dmurray at common-lisp.net Sun Aug 14 12:12:36 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sun, 14 Aug 2005 14:12:36 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp climacs/packages.lisp Message-ID: <20050814121236.7CD1A88032@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24141 Modified Files: syntax.lisp packages.lisp Log Message: The other parts of the list movement commands. Date: Sun Aug 14 14:12:35 2005 Author: dmurray Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.55 climacs/syntax.lisp:1.56 --- climacs/syntax.lisp:1.55 Fri Aug 5 14:40:56 2005 +++ climacs/syntax.lisp Sun Aug 14 14:12:35 2005 @@ -67,6 +67,31 @@ (defgeneric forward-sentence (mark syntax)) +(defgeneric forward-list (mark syntax) + (:method (mark syntax) + (error 'no-such-operation))) + +(defgeneric backward-list (mark syntax) + (:method (mark syntax) + (error 'no-such-operation))) + +(defgeneric down-list (mark syntax) + (:method (mark syntax) + (error 'no-such-operation))) + +(defgeneric backward-down-list (mark syntax) + (:method (mark syntax) + (error 'no-such-operation))) + +(defgeneric backward-up-list (mark syntax) + (:method (mark syntax) + (error 'no-such-operation))) + +(defgeneric up-list (mark syntax) + (:method (mark syntax) + (error 'no-such-operation))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.74 climacs/packages.lisp:1.75 --- climacs/packages.lisp:1.74 Fri Aug 5 10:07:17 2005 +++ climacs/packages.lisp Sun Aug 14 14:12:35 2005 @@ -113,6 +113,9 @@ #:redisplay-pane-with-syntax #:backward-paragraph #:forward-paragraph #:backward-sentence #:forward-sentence + #:forward-list #:backward-list + #:down-list #:up-list + #:backward-down-list #:backward-up-list #:syntax-line-comment-string #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region)) From dmurray at common-lisp.net Sun Aug 14 18:09:43 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sun, 14 Aug 2005 20:09:43 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/packages.lisp climacs/lisp-syntax.lisp climacs/kill-ring.lisp climacs/gui.lisp Message-ID: <20050814180943.8F25788545@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16088 Modified Files: packages.lisp lisp-syntax.lisp kill-ring.lisp gui.lisp Log Message: Added com-just-one-space (M-Space), com-scroll-other-window-up (C-M-V), com-append-next-kill (M-C-w). Also, I think I've fixed expression-navigation funkiness. Date: Sun Aug 14 20:09:42 2005 Author: dmurray Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.75 climacs/packages.lisp:1.76 --- climacs/packages.lisp:1.75 Sun Aug 14 14:12:35 2005 +++ climacs/packages.lisp Sun Aug 14 20:09:42 2005 @@ -122,7 +122,8 @@ (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) - (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size + (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size + #:append-next-p #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push #:kill-ring-reverse-concatenating-push)) Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.28 climacs/lisp-syntax.lisp:1.29 --- climacs/lisp-syntax.lisp:1.28 Sun Aug 14 10:56:58 2005 +++ climacs/lisp-syntax.lisp Sun Aug 14 20:09:42 2005 @@ -1393,7 +1393,9 @@ ((and (>= offset (end-offset first)) (or (null rest) (<= offset (start-offset (first-form rest))))) - (return (let ((potential-form (form-before-in-children (children first) offset))) + (return (let ((potential-form + (when (typep first 'list-form) + (form-before-in-children (children first) offset)))) (or potential-form (when (typep first 'form) first))))) @@ -1438,7 +1440,7 @@ ((<= offset (start-offset child)) (return nil)) (t nil)))) - + (defun form-around (syntax offset) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.7 climacs/kill-ring.lisp:1.8 --- climacs/kill-ring.lisp:1.7 Fri Aug 5 14:40:56 2005 +++ climacs/kill-ring.lisp Sun Aug 14 20:09:42 2005 @@ -31,7 +31,9 @@ :accessor kill-ring-chain :initform (make-instance 'standard-cursorchain)) (yankpoint :type left-sticky-flexicursor - :accessor kill-ring-cursor)) + :accessor kill-ring-cursor) + (append-next-p :type boolean :initform nil + :accessor append-next-p)) (:documentation "A class for all kill rings")) (defmethod initialize-instance :after((kr kill-ring) &rest args) @@ -115,14 +117,17 @@ (setf (cursor-pos curs) pos)))) (defmethod kill-ring-standard-push ((kr kill-ring) vector) - (let ((chain (kill-ring-chain kr))) - (if (>= (kill-ring-length kr) - (kill-ring-max-size kr)) - (progn - (pop-end chain) - (push-start chain vector)) - (push-start chain vector))) - (reset-yank-position kr)) + (cond ((append-next-p kr) + (kill-ring-concatenating-push kr vector) + (setf (append-next-p kr) nil)) + (t (let ((chain (kill-ring-chain kr))) + (if (>= (kill-ring-length kr) + (kill-ring-max-size kr)) + (progn + (pop-end chain) + (push-start chain vector)) + (push-start chain vector))) + (reset-yank-position kr)))) (defmethod kill-ring-concatenating-push ((kr kill-ring) vector) (let ((chain (kill-ring-chain kr))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.175 climacs/gui.lisp:1.176 --- climacs/gui.lisp:1.175 Sun Aug 14 14:11:21 2005 +++ climacs/gui.lisp Sun Aug 14 20:09:42 2005 @@ -797,6 +797,20 @@ do (forward-object mark))) (delete-region point mark))) +(define-named-command com-just-one-space ((count 'integer :prompt "Number of spaces")) + (let ((point (point (current-window))) + offset) + (loop until (beginning-of-line-p point) + while (whitespacep (object-before point)) + do (backward-object point)) + (loop until (end-of-line-p point) + while (whitespacep (object-after point)) + repeat count do (forward-object point) + finally (setf offset (offset point))) + (loop until (end-of-line-p point) + while (whitespacep (object-after point)) + do (forward-object point)) + (delete-region offset point))) (define-named-command com-goto-position () (setf (offset (point (current-window))) @@ -958,6 +972,11 @@ (when other-window (page-down other-window)))) +(define-named-command com-scroll-other-window-up () + (let ((other-window (second (windows *application-frame*)))) + (when other-window + (page-up other-window)))) + (define-named-command com-delete-window () (unless (null (cdr (windows *application-frame*))) (let* ((constellation (if *with-scrollbars* @@ -1023,6 +1042,9 @@ (return-from com-resize-kill-ring nil)))))) (setf (kill-ring-max-size *kill-ring*) size))) +(define-named-command com-append-next-kill () + (setf (append-next-p *kill-ring*) t)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Incremental search @@ -1662,6 +1684,7 @@ (global-set-key '(#\Space :control) 'com-set-mark) (global-set-key '(#\y :control) 'com-yank) (global-set-key '(#\w :control) 'com-kill-region) +(global-set-key '(#\w :control :meta) 'com-append-next-kill) (global-set-key '(#\e :meta) `(com-forward-sentence ,*numeric-argument-marker*)) (global-set-key '(#\a :meta) `(com-backward-sentence ,*numeric-argument-marker*)) (global-set-key '(#\k :meta) `(com-kill-sentence ,*numeric-argument-marker*)) @@ -1678,10 +1701,12 @@ (global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\v :meta) 'com-page-up) (global-set-key '(#\v :control :meta) 'com-scroll-other-window) +(global-set-key '(#\V :control :meta :shift) 'com-scroll-other-window-up) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\\ :meta) `(com-delete-horizontal-space ,*numeric-argument-p*)) +(global-set-key '(#\Space :meta) `(com-just-one-space ,*numeric-argument-marker*)) (global-set-key '(#\^ :shift :meta) 'com-delete-indentation) (global-set-key '(#\q :meta) 'com-fill-paragraph) (global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*)) From dmurray at common-lisp.net Mon Aug 15 15:52:57 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 15 Aug 2005 17:52:57 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050815155257.26FDE88546@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6465 Modified Files: lisp-syntax.lisp Log Message: Indentation code now 'ignores' comments. That is: (defun ;comment foo ;comment () nil) indents correctly. Indentation code should now use first-form, rest-forms, elt-form on lists of tokens (such as children of trees) instead of car, cdr and elt. See patches - this is a simple textual substitution. Date: Mon Aug 15 17:52:56 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.29 climacs/lisp-syntax.lisp:1.30 --- climacs/lisp-syntax.lisp:1.29 Sun Aug 14 20:09:42 2005 +++ climacs/lisp-syntax.lisp Mon Aug 15 17:52:55 2005 @@ -1082,21 +1082,34 @@ "Returns the first non-comment in list." (find-if-not #'(lambda (item) (typep item 'comment)) list)) +(defun rest-forms (list) + "Returns the remainder of the list after the first non-comment, +stripping leading comments." + (loop for rest on list + count (not (typep (car rest) 'comment)) + into forms + until (= forms 2) + finally (return rest))) + (defun nth-form (n list) "Returns the nth non-comment in list." (loop for item in list count (not (typep item 'comment)) into forms - until (= forms n) + until (> forms n) finally (return item))) +(defun elt-form (list n) + "Returns the nth non-comment in list." + (nth-form n list)) + (defun second-form (list) "Returns the second non-comment in list." - (nth-form 2 list)) + (nth-form 1 list)) (defun third-form (list) "Returns the third non-comment in list." - (nth-form 3 list)) + (nth-form 2 list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1717,14 +1730,14 @@ (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt (children tree) (car path)) (cdr path))))) + (values (elt-form (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) (defmethod indent-form ((syntax lisp-syntax) (tree list-form) path) (if (= (car path) 1) ;; before first element (values tree 1) - (let ((first-child (elt (children tree) 1))) + (let ((first-child (elt-form (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)) @@ -1732,12 +1745,12 @@ ;; top level (if (= (car path) 2) ;; indent like first element - (values (elt (children tree) 1) 0) + (values (elt-form (children tree) 1) 0) ;; indent like second element - (values (elt (children tree) 2) 0))) + (values (elt-form (children tree) 2) 0))) (t ;; inside a subexpression - (indent-form syntax (elt (children tree) (car path)) (cdr path))))))) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))))) (defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) (values tree 1)) @@ -1751,8 +1764,11 @@ (defmethod indent-form ((syntax lisp-syntax) (tree long-comment-form) path) (values tree 0)) +(defmethod indent-form ((syntax lisp-syntax) (tree quote-form) path) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path))) + (defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) - (indent-form syntax (elt (children tree) (car path)) (cdr path))) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path))) (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) @@ -1762,11 +1778,11 @@ (values tree 1)) ((= (car path) 2) ;; between variable and value - (values (elt (children tree) 1) 0)) + (values (elt-form (children tree) 1) 0)) (t ;; after value - (values (elt (children tree) 2) 0))) - (indent-form syntax (elt (children tree) (car path)) (cdr path)))) + (values (elt-form (children tree) 2) 0))) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) (defmethod indent-bindings ((syntax lisp-syntax) tree path) (if (null (cdr path)) @@ -1775,20 +1791,20 @@ ;; before first binding, indent 1 (values tree 1) ;; after some bindings, align with first binding - (values (elt (children tree) 1) 0)) + (values (elt-form (children tree) 1) 0)) ;; inside a bind form - (indent-binding syntax (elt (children tree) (car path)) (cdr path)))) + (indent-binding syntax (elt-form (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level (if (= (car path) 2) ;; indent like first child - (values (elt (children tree) 1) 0) + (values (elt-form (children tree) 1) 0) ;; indent like second child - (values (elt (children tree) 2) 0)) + (values (elt-form (children tree) 2) 0)) ;; inside a subexpression - (indent-form syntax (elt (children tree) (car path)) (cdr path)))) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) (defmacro define-list-indentor (name element-indentor) `(defun ,name (syntax tree path) @@ -1798,9 +1814,9 @@ ;; indent one more than the list (values tree 1) ;; indent like the first element - (values (elt (children tree) 1) 0)) + (values (elt-form (children tree) 1) 0)) ;; inside an element - (,element-indentor syntax (elt (children tree) (car path)) (cdr path))))) + (,element-indentor syntax (elt-form (children tree) (car path)) (cdr path))))) ;;; line up the elements vertically (define-list-indentor indent-list indent-list) @@ -1821,8 +1837,9 @@ (values tree (if (<= (car path) ,(length template)) 4 2))) ,@(loop for fun in (cdr template) for i from 2 - collect `((= (car path) ,i) (,fun syntax (elt (children tree) ,i) (cdr path)))) - (t (indent-form syntax (elt (children tree) (car path)) (cdr path)))))) + collect `((= (car path) ,i) + (,fun syntax (elt-form (children tree) ,i) (cdr path)))) + (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))))) (define-simple-indentor (progn)) (define-simple-indentor (prog1 indent-form)) @@ -1855,13 +1872,13 @@ (case (car path) ((2 3) ;; in the class name or superclasses respectively - (indent-list syntax (elt (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-form (children tree) (car path)) (cdr path))) (4 ;; in the slot specs - (indent-slot-specs syntax (elt (children tree) 4) (cdr path))) + (indent-slot-specs syntax (elt-form (children tree) 4) (cdr path))) (t ;; this is an approximation, might want to do better - (indent-list syntax (elt (children tree) (car path)) (cdr path)))))) + (indent-list syntax (elt-form (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defgeneric)) tree path) @@ -1871,18 +1888,19 @@ (case (car path) (2 ;; in the function name - (indent-list syntax (elt (children tree) 2) (cdr path))) + (indent-list syntax (elt-form (children tree) 2) (cdr path))) (3 ;; in the lambda-list - (indent-lambda-list syntax (elt (children tree) 3) (cdr path))) + (indent-lambda-list syntax (elt-form (children tree) 3) (cdr path))) (t ;; in the options or method specifications - (indent-list syntax (elt (children tree) (car path)) (cdr path)))))) + (indent-list syntax (elt-form (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defmethod)) tree path) (let ((lambda-list-pos (position-if (lambda (x) (typep x 'list-form)) - (children tree)))) + (remove-if + (lambda (x) (typep x 'comment)) (children tree))))) (cond ((null (cdr path)) ;; top level (values tree (if (or (null lambda-list-pos) @@ -1891,11 +1909,11 @@ 2))) ((or (null lambda-list-pos) (< (car path) lambda-list-pos)) - (indent-list syntax (elt (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-form (children tree) (car path)) (cdr path))) ((= (car path) lambda-list-pos) - (indent-lambda-list syntax (elt (children tree) (car path)) (cdr path))) + (indent-lambda-list syntax (elt-form (children tree) (car path)) (cdr path))) (t - (indent-form syntax (elt (children tree) (car path)) (cdr path)))))) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))))) (defun indent-clause (syntax tree path) (if (null (cdr path)) @@ -1903,8 +1921,8 @@ (case (car path) (1 (values tree 1)) (2 (values tree 1)) - (t (values (elt (children tree) 2) 0))) - (indent-form syntax (elt (children tree) (car path)) (cdr path)))) + (t (values (elt-form (children tree) 2) 0))) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'cond)) tree path) @@ -1914,9 +1932,9 @@ ;; after `cond' (values tree 2) ;; indent like the first clause - (values (elt (children tree) 2) 0)) + (values (elt-form (children tree) 2) 0)) ;; inside a clause - (indent-clause syntax (elt (children tree) (car path)) (cdr path)))) + (indent-clause syntax (elt-form (children tree) (car path)) (cdr path)))) (macrolet ((def (symbol) `(defmethod compute-list-indentation @@ -1925,8 +1943,8 @@ (case (car path) (2 (values tree 4)) (3 (values tree 2)) - (t (values (elt (children tree) 3) 0))) - (indent-clause syntax (elt (children tree) (car path)) (cdr path)))))) + (t (values (elt-form (children tree) 3) 0))) + (indent-clause syntax (elt-form (children tree) (car path)) (cdr path)))))) (def case) (def ccase) (def ecase) @@ -1942,19 +1960,19 @@ ;; the symbol existing in the current image. (Arguably, too, ;; this is a broken indentation form because it doesn't carry ;; over to the implicit tagbodies in macros such as DO. - (if (typep (elt (children tree) (car path)) 'token-mixin) + (if (typep (elt-form (children tree) (car path)) 'token-mixin) (values tree 2) (values tree 4)) - (indent-form syntax (elt (children tree) (car path)) (cdr path)))) + (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) (defun compute-path-in-trees (trees n offset) (cond ((or (null trees) - (>= (start-offset (car trees)) offset)) + (>= (start-offset (first-form trees)) offset)) (list n)) - ((or (< (start-offset (car trees)) offset (end-offset (car trees))) - (typep (car trees) 'incomplete-form-mixin)) - (cons n (compute-path-in-tree (car trees) offset))) - (t (compute-path-in-trees (cdr trees) (1+ n) offset)))) + ((or (< (start-offset (first-form trees)) offset (end-offset (first-form trees))) + (typep (first-form trees) 'incomplete-form-mixin)) + (cons n (compute-path-in-tree (first-form trees) offset))) + (t (compute-path-in-trees (rest-forms trees) (1+ n) offset)))) (defun compute-path-in-tree (tree offset) (if (null (children tree)) From dmurray at common-lisp.net Mon Aug 15 21:24:56 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 15 Aug 2005 23:24:56 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050815212456.08A2388546@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29381 Modified Files: lisp-syntax.lisp Log Message: Changed a couple of indent-lambda-lists to indent-ordinary-lambda-list. Date: Mon Aug 15 23:24:56 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.30 climacs/lisp-syntax.lisp:1.31 --- climacs/lisp-syntax.lisp:1.30 Mon Aug 15 17:52:55 2005 +++ climacs/lisp-syntax.lisp Mon Aug 15 23:24:55 2005 @@ -1891,7 +1891,7 @@ (indent-list syntax (elt-form (children tree) 2) (cdr path))) (3 ;; in the lambda-list - (indent-lambda-list syntax (elt-form (children tree) 3) (cdr path))) + (indent-ordinary-lambda-list syntax (elt-form (children tree) 3) (cdr path))) (t ;; in the options or method specifications (indent-list syntax (elt-form (children tree) (car path)) (cdr path)))))) @@ -1911,7 +1911,7 @@ (< (car path) lambda-list-pos)) (indent-list syntax (elt-form (children tree) (car path)) (cdr path))) ((= (car path) lambda-list-pos) - (indent-lambda-list syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-ordinary-lambda-list syntax (elt-form (children tree) (car path)) (cdr path))) (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))))) From dmurray at common-lisp.net Mon Aug 15 23:31:25 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Tue, 16 Aug 2005 01:31:25 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/ttcn3-syntax.lisp climacs/slidemacs.lisp climacs/prolog-syntax.lisp climacs/pane.lisp climacs/packages.lisp climacs/lisp-syntax.lisp climacs/html-syntax.lisp climacs/gui.lisp climacs/fundamental-syntax.lisp climacs/cl-syntax.lisp Message-ID: <20050815233125.68CF788546@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6402 Modified Files: ttcn3-syntax.lisp slidemacs.lisp prolog-syntax.lisp pane.lisp packages.lisp lisp-syntax.lisp html-syntax.lisp gui.lisp fundamental-syntax.lisp cl-syntax.lisp Log Message: Factored out cursor display from syntaxes to a display-cursor method on basic-syntax. Also added a display-mark method, a mark-visible-p slot on climacs-pane, and a command com-toggle-visible-mark to turn display of the mark on and off - useful for developing marking commands. Date: Tue Aug 16 01:31:22 2005 Author: dmurray Index: climacs/ttcn3-syntax.lisp diff -u climacs/ttcn3-syntax.lisp:1.2 climacs/ttcn3-syntax.lisp:1.3 --- climacs/ttcn3-syntax.lisp:1.2 Thu May 26 10:31:53 2005 +++ climacs/ttcn3-syntax.lisp Tue Aug 16 01:31:22 2005 @@ -442,15 +442,6 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) - (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) - (cursor-column (column-number (point pane))) - (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink (if current-p - (make-rgb-color 0.7 0.7 0.7) +blue+)))))) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p))) Index: climacs/slidemacs.lisp diff -u climacs/slidemacs.lisp:1.6 climacs/slidemacs.lisp:1.7 --- climacs/slidemacs.lisp:1.6 Tue Jun 21 18:51:05 2005 +++ climacs/slidemacs.lisp Tue Aug 16 01:31:22 2005 @@ -444,14 +444,5 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) - (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) - (cursor-column (column-number (point pane))) - (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink (if current-p - (make-rgb-color 0.7 0.7 0.7) +blue+)))))) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p))) Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.21 climacs/prolog-syntax.lisp:1.22 --- climacs/prolog-syntax.lisp:1.21 Fri May 27 15:25:01 2005 +++ climacs/prolog-syntax.lisp Tue Aug 16 01:31:22 2005 @@ -1265,20 +1265,8 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) - (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) - (cursor-column - ;; FIXME: surely this should be more abstracted? - (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)))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink (if current-p +red+ +blue+)))))) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p))) #| (climacs-gui::define-named-command com-inspect-lex () Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.28 climacs/pane.lisp:1.29 --- climacs/pane.lisp:1.28 Mon Jul 18 00:40:37 2005 +++ climacs/pane.lisp Tue Aug 16 01:31:22 2005 @@ -231,6 +231,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) (full-redisplay-p :initform nil :accessor full-redisplay-p) (cache :initform (let ((cache (make-instance 'standard-flexichain))) (insert* cache 0 nil) @@ -460,37 +461,31 @@ (beginning-of-line (point pane)) (empty-cache cache))))) -(defun display-cache (pane cursor-ink) - (let* ((medium (sheet-medium pane)) - (style (medium-text-style medium)) - (height (text-style-height style medium))) - (with-slots (top bot scan cache cursor-x cursor-y) pane - (loop with start-offset = (offset top) - for id from 0 below (nb-elements cache) - do (setf scan start-offset) - (updating-output - (pane :unique-id (element* cache id) - :cache-value (if (<= start-offset - (offset (point pane)) - (+ start-offset (length (element* cache id)))) - (cons nil nil) - (element* cache id)) - :cache-test #'eq) - (display-line pane (element* cache id) start-offset - (syntax (buffer pane)) (stream-default-view pane))) - (incf start-offset (1+ (length (element* cache id))))) - (when (mark= scan (point pane)) - (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x x - cursor-y y))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink cursor-ink))))) +(defun display-cache (pane) + (with-slots (top bot scan cache cursor-x cursor-y) pane + (loop with start-offset = (offset top) + for id from 0 below (nb-elements cache) + do (setf scan start-offset) + (updating-output + (pane :unique-id (element* cache id) + :cache-value (if (<= start-offset + (offset (point pane)) + (+ start-offset (length (element* cache id)))) + (cons nil nil) + (element* cache id)) + :cache-test #'eq) + (display-line pane (element* cache id) start-offset + (syntax (buffer pane)) (stream-default-view pane))) + (incf start-offset (1+ (length (element* cache id))))) + (when (mark= scan (point pane)) + (multiple-value-bind (x y) (stream-cursor-position pane) + (setf cursor-x x + cursor-y y))))) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p) - (display-cache pane (if current-p +red+ +blue+))) + (display-cache pane) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p)) (defgeneric redisplay-pane (pane current-p)) @@ -508,3 +503,47 @@ (defmethod full-redisplay ((pane climacs-pane)) (setf (full-redisplay-p pane) t)) + +(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)))) + (updating-output (pane :unique-id -1) + (draw-rectangle* pane + (1- cursor-x) cursor-y + (+ cursor-x 2) (+ cursor-y ascent descent) + :ink (if current-p +red+ +blue+)))))) + +(defgeneric display-mark (pane syntax)) + +(defmethod display-mark ((pane climacs-pane) (syntax basic-syntax)) + (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 Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.76 climacs/packages.lisp:1.77 --- climacs/packages.lisp:1.76 Sun Aug 14 20:09:42 2005 +++ climacs/packages.lisp Tue Aug 16 01:31:22 2005 @@ -141,6 +141,8 @@ (:export #:climacs-buffer #:needs-saving #:filepath #:climacs-pane #:point #:mark #:redisplay-pane #:full-redisplay + #:display-cursor + #:display-mark #:page-down #:page-up #:top #:bot #:tab-space-count #:space-width #:tab-width @@ -151,6 +153,7 @@ #:isearch-mode #:isearch-states #:isearch-previous-string #:query-replace-state #:string1 #:string2 #:query-replace-mode + #:mark-visible-p #:with-undo #:url)) Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.31 climacs/lisp-syntax.lisp:1.32 --- climacs/lisp-syntax.lisp:1.31 Mon Aug 15 23:24:55 2005 +++ climacs/lisp-syntax.lisp Tue Aug 16 01:31:22 2005 @@ -1374,23 +1374,8 @@ (let ((*current-faces* *standard-faces*)) (with-slots (stack-top) syntax (display-parse-tree stack-top syntax pane))) - (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)))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) cursor-y - (+ cursor-x 2) (+ cursor-y ascent descent) - :ink (if current-p +red+ +blue+)))))) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.31 climacs/html-syntax.lisp:1.32 --- climacs/html-syntax.lisp:1.31 Thu May 26 10:31:53 2005 +++ climacs/html-syntax.lisp Tue Aug 16 01:31:22 2005 @@ -798,14 +798,6 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) - (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) - (cursor-column (column-number (point pane))) - (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink (if current-p +red+ +blue+)))))) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.176 climacs/gui.lisp:1.177 --- climacs/gui.lisp:1.176 Sun Aug 14 20:09:42 2005 +++ climacs/gui.lisp Tue Aug 16 01:31:22 2005 @@ -1640,6 +1640,9 @@ (define-named-command com-accept-lisp-string () (display-message (format nil "~s" (accept 'lisp-string)))) +(define-named-command com-toggle-visible-mark () + (setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dead-escape command tables Index: climacs/fundamental-syntax.lisp diff -u climacs/fundamental-syntax.lisp:1.1 climacs/fundamental-syntax.lisp:1.2 --- climacs/fundamental-syntax.lisp:1.1 Tue Jul 19 12:02:02 2005 +++ climacs/fundamental-syntax.lisp Tue Aug 16 01:31:22 2005 @@ -108,23 +108,6 @@ pane (- tab-width (mod x tab-width)) 0)))) (incf start)))) - -(defun display-cursor (pane current-p) - (with-slots (top) pane - (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) - (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)))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink (if current-p +red+ +blue+)))))) - (defmethod display-line (pane mark) (setf mark (clone-mark mark)) (let ((saved-offset nil) @@ -202,7 +185,8 @@ :cache-value line :cache-test #'eq) (display-line pane (start-mark (element* lines i)))))))))) - (display-cursor pane current-p)) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.14 climacs/cl-syntax.lisp:1.15 --- climacs/cl-syntax.lisp:1.14 Thu May 26 10:31:53 2005 +++ climacs/cl-syntax.lisp Tue Aug 16 01:31:22 2005 @@ -1125,17 +1125,8 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) - (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) - (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) - (cursor-column (column-number (point pane))) - (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink (if current-p - (make-rgb-color 0.7 0.7 0.7) +blue+)))))) + (when (mark-visible-p pane) (display-mark pane syntax)) + (display-cursor pane syntax current-p))) From dmurray at common-lisp.net Tue Aug 16 23:10:32 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Wed, 17 Aug 2005 01:10:32 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp climacs/packages.lisp climacs/gui.lisp Message-ID: <20050816231032.D9D728852B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5492 Modified Files: syntax.lisp packages.lisp gui.lisp Log Message: Various refactoring to allow non-interactive access to functionality. Checks to see that buffers aren't written to, or attempted to be read from, directories. com-load-file now on C-c C-l. Also some rearrangement of stuff in gui.lisp. Date: Wed Aug 17 01:10:30 2005 Author: dmurray Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.56 climacs/syntax.lisp:1.57 --- climacs/syntax.lisp:1.56 Sun Aug 14 14:12:35 2005 +++ climacs/syntax.lisp Wed Aug 17 01:10:29 2005 @@ -216,6 +216,13 @@ (declare (ignore success string)) object)) +(defun syntax-from-name (syntax) + (let ((description (find syntax *syntaxes* + :key #'syntax-description-name + :test #'string-equal))) + (when description + (find-class (syntax-description-class-name description))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Basic syntax Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.77 climacs/packages.lisp:1.78 --- climacs/packages.lisp:1.77 Tue Aug 16 01:31:22 2005 +++ climacs/packages.lisp Wed Aug 17 01:10:29 2005 @@ -92,6 +92,7 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax + #:syntax-from-name #:basic-syntax #:update-syntax #:update-syntax-for-display #:grammar #:grammar-rule #:add-rule Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.177 climacs/gui.lisp:1.178 --- climacs/gui.lisp:1.177 Tue Aug 16 01:31:22 2005 +++ climacs/gui.lisp Wed Aug 17 01:10:29 2005 @@ -189,6 +189,9 @@ (setf (needs-saving (buffer (current-window))) nil)) (define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:")) + (set-fill-column column)) + +(defun set-fill-column (column) (if (> column 1) (setf (auto-fill-column (current-window)) column) (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) @@ -279,15 +282,17 @@ (delete-range current-point (- (offset item-mark) current-offset)))) (define-named-command com-transpose-objects () - (let* ((point (point (current-window)))) - (unless (beginning-of-buffer-p point) - (when (end-of-line-p point) - (backward-object point)) - (let ((object (object-after point))) - (delete-range point) - (backward-object point) - (insert-object point object) - (forward-object point))))) + (transpose-objects (point (current-window)))) + +(defun transpose-objects (mark) + (unless (beginning-of-buffer-p mark) + (when (end-of-line-p mark) + (backward-object mark)) + (let ((object (object-after mark))) + (delete-range mark) + (backward-object mark) + (insert-object mark object) + (forward-object mark)))) (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects")) (backward-object (point (current-window)) count)) @@ -296,51 +301,55 @@ (forward-object (point (current-window)) count)) (define-named-command com-transpose-words () - (let* ((point (point (current-window)))) - (let (bw1 bw2 ew1 ew2) - (backward-word point) - (setf bw1 (offset point)) - (forward-word point) - (setf ew1 (offset point)) - (forward-word point) - (when (= (offset point) ew1) - ;; this is emacs' message in the minibuffer - (error "Don't have two things to transpose")) - (setf ew2 (offset point)) - (backward-word point) - (setf bw2 (offset point)) - (let ((w2 (buffer-sequence (buffer point) bw2 ew2)) - (w1 (buffer-sequence (buffer point) bw1 ew1))) - (delete-word point) - (insert-sequence point w1) - (backward-word point) - (backward-word point) - (delete-word point) - (insert-sequence point w2) - (forward-word point))))) + (transpose-words (point (current-window)))) + +(defun transpose-words (mark) + (let (bw1 bw2 ew1 ew2) + (backward-word mark) + (setf bw1 (offset mark)) + (forward-word mark) + (setf ew1 (offset mark)) + (forward-word mark) + (when (= (offset mark) ew1) + ;; this is emacs' message in the minibuffer + (error "Don't have two things to transpose")) + (setf ew2 (offset mark)) + (backward-word mark) + (setf bw2 (offset mark)) + (let ((w2 (buffer-sequence (buffer mark) bw2 ew2)) + (w1 (buffer-sequence (buffer mark) bw1 ew1))) + (delete-word mark) + (insert-sequence mark w1) + (backward-word mark) + (backward-word mark) + (delete-word mark) + (insert-sequence mark w2) + (forward-word mark)))) (define-named-command com-transpose-lines () - (let ((point (point (current-window)))) - (beginning-of-line point) - (unless (beginning-of-buffer-p point) - (previous-line point)) - (let* ((bol (offset point)) - (eol (progn (end-of-line point) - (offset point))) - (line (buffer-sequence (buffer point) bol eol))) - (delete-region bol point) - ;; Remove newline at end of line as well. - (unless (end-of-buffer-p point) - (delete-range point)) - ;; If the current line is at the end of the buffer, we want to - ;; be able to insert past it, so we need to get an extra line - ;; at the end. - (end-of-line point) - (when (end-of-buffer-p point) - (insert-object point #\Newline)) - (next-line point 0) - (insert-sequence point line) - (insert-object point #\Newline)))) + (transpose-lines (point (current-window)))) + +(defun transpose-lines (mark) + (beginning-of-line mark) + (unless (beginning-of-buffer-p mark) + (previous-line mark)) + (let* ((bol (offset mark)) + (eol (progn (end-of-line mark) + (offset mark))) + (line (buffer-sequence (buffer mark) bol eol))) + (delete-region bol mark) + ;; Remove newline at end of line as well. + (unless (end-of-buffer-p mark) + (delete-range mark)) + ;; If the current line is at the end of the buffer, we want to + ;; be able to insert past it, so we need to get an extra line + ;; at the end. + (end-of-line mark) + (when (end-of-buffer-p mark) + (insert-object mark #\Newline)) + (next-line mark 0) + (insert-sequence mark line) + (insert-object mark #\Newline))) (define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?")) (let* ((win (current-window)) @@ -365,36 +374,40 @@ (define-named-command com-open-line ((numarg 'integer :prompt "How many lines?")) (open-line (point (current-window)) numarg)) +(defun kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil)) + (let ((start (offset mark))) + (cond ((= 0 count) + (beginning-of-line mark)) + ((< count 0) + (loop repeat (- count) + until (beginning-of-buffer-p mark) + do (beginning-of-line mark) + until (beginning-of-buffer-p mark) + do (backward-object mark))) + ((or whole-lines-p (> count 1)) + (loop repeat count + until (end-of-buffer-p mark) + do (end-of-line mark) + until (end-of-buffer-p mark) + do (forward-object mark))) + (t + (cond ((end-of-buffer-p mark) nil) + ((end-of-line-p mark)(forward-object mark)) + (t (end-of-line mark))))) + (unless (mark= mark start) + (if concatenate-p + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence start mark)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence start mark))) + (delete-region start mark)))) + (define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?") (numargp 'boolean :prompt "Kill entire lines?")) (let* ((pane (current-window)) (point (point pane)) - (mark (offset point))) - (cond ((= 0 numarg) - (beginning-of-line point)) - ((< numarg 0) - (loop repeat (- numarg) - until (beginning-of-buffer-p point) - do (beginning-of-line point) - until (beginning-of-buffer-p point) - do (backward-object point))) - ((or numargp (> numarg 1)) - (loop repeat numarg - until (end-of-buffer-p point) - do (end-of-line point) - until (end-of-buffer-p point) - do (forward-object point))) - (t - (cond ((end-of-buffer-p point) nil) - ((end-of-line-p point)(forward-object point)) - (t (end-of-line point))))) - (unless (mark= point mark) - (if (eq (previous-command pane) 'com-kill-line) - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mark point)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point)))) + (concatenate-p (eq (previous-command pane) 'com-kill-line))) + (kill-line point numarg numargp concatenate-p))) (define-named-command com-forward-word ((count 'integer :prompt "Number of words")) (if (plusp count) @@ -407,35 +420,37 @@ (define-named-command com-delete-word ((count 'integer :prompt "Number of words")) (delete-word (point (current-window)) count)) +(defun kill-word (mark &optional (count 1) (concatenate-p nil)) + (let ((start (offset mark))) + (if (plusp count) + (loop repeat count + until (end-of-buffer-p mark) + do (forward-word mark)) + (loop repeat (- count) + until (beginning-of-buffer-p mark) + do (backward-word mark))) + (unless (mark= mark start) + (if concatenate-p + (if (plusp count) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence start mark)) + (kill-ring-reverse-concatenating-push *kill-ring* + (region-to-sequence start mark))) + (kill-ring-standard-push *kill-ring* + (region-to-sequence start mark))) + (delete-region start mark)))) + (define-named-command com-kill-word ((count 'integer :prompt "Number of words")) (let* ((pane (current-window)) (point (point pane)) - (mark (offset point))) - (loop repeat count - until (end-of-buffer-p point) - do (forward-word point)) - (unless (mark= point mark) - (if (eq (previous-command pane) 'com-kill-word) - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mark point)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point)))) + (concatenate-p (eq (previous-command pane) 'com-kill-word))) + (kill-word point count concatenate-p))) (define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words")) (let* ((pane (current-window)) (point (point pane)) - (mark (offset point))) - (loop repeat count - until (end-of-buffer-p point) - do (backward-word point)) - (unless (mark= point mark) - (if (eq (previous-command pane) 'com-backward-kill-word) - (kill-ring-reverse-concatenating-push *kill-ring* - (region-to-sequence mark point)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point)))) + (concatenate-p (eq (previous-command pane) 'com-backward-kill-word))) + (kill-word point (- count) concatenate-p))) (define-named-command com-mark-word ((count 'integer :prompt "Number of words")) (let* ((pane (current-window)) @@ -546,18 +561,18 @@ (full-so-far (concatenate 'string directory-prefix so-far)) (pathnames (loop with length = (length full-so-far) - and wildcard = (concatenate 'string (remove-trail so-far) "*.*") - for path in - #+(or sbcl cmu lispworks) (directory wildcard) - #+openmcl (directory wildcard :directories t) - #+allegro (directory wildcard :directories-are-files nil) - #+cormanlisp (nconc (directory wildcard) + and wildcard = (concatenate 'string (remove-trail so-far) "*.*") + for path in + #+(or sbcl cmu lispworks) (directory wildcard) + #+openmcl (directory wildcard :directories t) + #+allegro (directory wildcard :directories-are-files nil) + #+cormanlisp (nconc (directory wildcard) (cl::directory-subdirs dirname)) - #-(or sbcl cmu lispworks openmcl allegro cormanlisp) - (directory wildcard) - when (let ((mismatch (mismatch (namestring path) full-so-far))) - (or (null mismatch) (= mismatch length))) - collect path)) + #-(or sbcl cmu lispworks openmcl allegro cormanlisp) + (directory wildcard) + when (let ((mismatch (mismatch (namestring path) full-so-far))) + (or (null mismatch) (= mismatch length))) + collect path)) (strings (mapcar #'namestring pathnames)) (first-string (car strings)) (length-common-prefix nil) @@ -607,9 +622,13 @@ (complete-input stream #'filename-completer :allow-any-input t) - (declare (ignore success)) - (or pathname string))) +; (declare (ignore success)) +; (or pathname string))) + (if success + (values pathname 'pathname) + (values string 'string)))) + (defun filepath-filename (pathname) (if (null (pathname-type pathname)) (pathname-name pathname) @@ -622,33 +641,44 @@ (pathname-name filepath)) climacs-syntax::*syntaxes* :test (lambda (x y) - (member x y :test #'string=)) + (member x y :test #'string-equal)) :key #'climacs-syntax::syntax-description-pathname-types)) 'basic-syntax)) +;; Adapted from cl-fad/PCL +(defun directory-pathname-p (pathspec) + "Returns NIL if PATHSPEC does not designate a directory." + (let ((name (pathname-name pathspec)) + (type (pathname-type pathspec))) + (and (or (null name) (eql name :unspecific)) + (or (null type) (eql type :unspecific))))) + (define-named-command com-find-file () (let ((filepath (accept 'completable-pathname - :prompt "Find File")) - (buffer (make-instance 'climacs-buffer)) - (pane (current-window))) - (setf (offset (point (buffer pane))) (offset (point pane))) - (push buffer (buffers *application-frame*)) - (setf (buffer (current-window)) buffer) - (setf (syntax buffer) - (make-instance - (syntax-class-name-for-filepath filepath) - :buffer (buffer (point pane)))) - ;; 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 (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil) - (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*))) + :prompt "Find File"))) + (cond ((directory-pathname-p filepath) + (display-message "~A is a directory name." filepath) + (beep)) + (t + (let ((buffer (make-instance 'climacs-buffer)) + (pane (current-window))) + (setf (offset (point (buffer pane))) (offset (point pane))) + (push buffer (buffers *application-frame*)) + (setf (buffer (current-window)) buffer) + (setf (syntax buffer) + (make-instance (syntax-class-name-for-filepath filepath) + :buffer (buffer (point pane)))) + ;; 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 (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (needs-saving buffer) nil) + (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*)))))) (define-named-command com-insert-file () (let ((filename (accept 'completable-pathname @@ -668,12 +698,17 @@ (let ((filepath (or (filepath buffer) (accept 'completable-pathname :prompt "Save Buffer to File")))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" (filepath buffer)) - (setf (needs-saving buffer) nil))) + (cond + ((directory-pathname-p filepath) + (display-message "~A is a directory." filepath) + (beep)) + (t + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (output-to-stream stream buffer 0 (size buffer))) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) + (setf (needs-saving buffer) nil))))) (define-named-command com-save-buffer () (let ((buffer (buffer (current-window)))) @@ -704,12 +739,16 @@ (let ((filepath (accept 'completable-pathname :prompt "Write Buffer to File")) (buffer (buffer (current-window)))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil) - (display-message "Wrote: ~a" (filepath buffer)))) + (cond + ((directory-pathname-p filepath) + (display-message "~A is a directory name." filepath)) + (t + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (output-to-stream stream buffer 0 (size buffer))) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (needs-saving buffer) nil) + (display-message "Wrote: ~a" (filepath buffer)))))) (define-presentation-method accept ((type buffer) stream (view textual-view) &key) @@ -723,41 +762,82 @@ :partial-completers '(#\Space) :allow-any-input t) (declare (ignore success)) - (or object - (car (push (make-instance 'climacs-buffer :name string) - (buffers *application-frame*)))))) + (or object string))) -(define-named-command com-switch-to-buffer () - (let ((buffer (accept 'buffer - :prompt "Switch to buffer")) - (pane (current-window))) +(defgeneric switch-to-buffer (buffer)) + +(defmethod switch-to-buffer ((buffer climacs-buffer)) + (let* ((buffers (buffers *application-frame*)) + (position (position buffer buffers)) + (pane (current-window))) + (if position + (rotatef (car buffers) (nth position buffers)) + (push buffer buffers)) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer pane) buffer) (full-redisplay pane))) -(define-named-command com-kill-buffer () +(defmethod switch-to-buffer ((name string)) + (let ((buffer (find name (buffers *application-frame*) + :key #'name :test #'string=))) + (switch-to-buffer (or buffer + (make-instance 'climacs-buffer :name name))))) + +;;placeholder +(defmethod switch-to-buffer ((symbol (eql 'nil))) + (switch-to-buffer (second (buffers *application-frame*)))) + +(define-named-command com-switch-to-buffer () + (let ((buffer (accept 'buffer + :prompt "Switch to buffer"))) + (switch-to-buffer buffer))) + +(defgeneric kill-buffer (buffer)) + +(defmethod kill-buffer ((buffer climacs-buffer)) (with-slots (buffers) *application-frame* - (let ((buffer (buffer (current-window)))) - (when (and (needs-saving buffer) - (handler-case (accept 'boolean :prompt "Save buffer first?") - (error () (progn (beep) - (display-message "Invalid answer") - (return-from com-kill-buffer nil))))) - (com-save-buffer)) - (setf buffers (remove buffer buffers)) - ;; Always need one buffer. - (when (null buffers) - (push (make-instance 'climacs-buffer :name "*scratch*") - buffers)) - (setf (buffer (current-window)) (car buffers))))) + (when (and (needs-saving buffer) + (handler-case (accept 'boolean :prompt "Save buffer first?") + (error () (progn (beep) + (display-message "Invalid answer") + (return-from kill-buffer nil))))) + (com-save-buffer)) + (setf buffers (remove buffer buffers)) + ;; Always need one buffer. + (when (null buffers) + (push (make-instance 'climacs-buffer :name "*scratch*") + buffers)) + (setf (buffer (current-window)) (car buffers)))) + +(defmethod kill-buffer ((name string)) + (let ((buffer (find name (buffers *application-frame*) + :key #'name :test #'string=))) + (when buffer (kill-buffer buffer)))) + +(defmethod kill-buffer ((symbol (eql 'nil))) + (kill-buffer (buffer (current-window)))) + +(define-named-command com-kill-buffer () + (kill-buffer (buffer (current-window)))) (define-named-command com-full-redisplay () (full-redisplay (current-window))) +(defun load-file (file-name) + (cond ((directory-pathname-p file-name) + (display-message "~A is a directory name." file-name) + (beep)) + (t + (cond ((probe-file file-name) + (load file-name)) + (t + (display-message "No such file: ~A" file-name) + (beep)))))) + (define-named-command com-load-file () (let ((filepath (accept 'completable-pathname :prompt "Load File"))) - (load filepath))) + (load-file filepath))) (define-named-command com-beginning-of-buffer () (beginning-of-buffer (point (current-window)))) @@ -777,65 +857,76 @@ (beginning-of-buffer (point (current-window))) (end-of-buffer (mark (current-window)))) +(defun back-to-indentation (mark) + (beginning-of-line mark) + (loop until (end-of-line-p mark) + while (whitespacep (object-after mark)) + do (forward-object mark))) + (define-named-command com-back-to-indentation () - (let ((point (point (current-window)))) - (beginning-of-line point) - (loop until (end-of-line-p point) - while (whitespacep (object-after point)) - do (incf (offset point))))) + (back-to-indentation (point (current-window)))) + +(defun delete-horizontal-space (mark &optional (backward-only-p nil)) + (let ((mark2 (clone-mark mark))) + (loop until (beginning-of-line-p mark) + while (whitespacep (object-before mark)) + do (backward-object mark)) + (unless backward-only-p + (loop until (end-of-line-p mark2) + while (whitespacep (object-after mark2)) + do (forward-object mark2))) + (delete-region mark mark2))) (define-named-command com-delete-horizontal-space ((backward-only-p 'boolean :prompt "Delete backwards only?")) - (let* ((point (point (current-window))) - (mark (clone-mark point))) - (loop until (beginning-of-line-p point) - while (whitespacep (object-before point)) - do (backward-object point)) - (unless backward-only-p - (loop until (end-of-line-p mark) - while (whitespacep (object-after mark)) - do (forward-object mark))) - (delete-region point mark))) + (delete-horizontal-space (point (current-window)) backward-only-p)) + +(defun just-one-space (mark count) + (let (offset) + (loop until (beginning-of-line-p mark) + while (whitespacep (object-before mark)) + do (backward-object mark)) + (loop until (end-of-line-p mark) + while (whitespacep (object-after mark)) + repeat count do (forward-object mark) + finally (setf offset (offset mark))) + (loop until (end-of-line-p mark) + while (whitespacep (object-after mark)) + do (forward-object mark)) + (delete-region offset mark))) (define-named-command com-just-one-space ((count 'integer :prompt "Number of spaces")) - (let ((point (point (current-window))) - offset) - (loop until (beginning-of-line-p point) - while (whitespacep (object-before point)) - do (backward-object point)) - (loop until (end-of-line-p point) - while (whitespacep (object-after point)) - repeat count do (forward-object point) - finally (setf offset (offset point))) - (loop until (end-of-line-p point) - while (whitespacep (object-after point)) - do (forward-object point)) - (delete-region offset point))) + (just-one-space (point (current-window)) count)) + +(defun goto-position (mark pos) + (setf (offset mark) pos)) (define-named-command com-goto-position () - (setf (offset (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)))))) + (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)))))) + +(defun goto-line (mark line-number) + (loop with m = (clone-mark (low-mark (buffer mark)) + :right) + initially (beginning-of-buffer m) + do (end-of-line m) + until (end-of-buffer-p m) + repeat (1- line-number) + do (incf (offset m)) + (end-of-line m) + finally (beginning-of-line m) + (setf (offset mark) (offset m)))) (define-named-command com-goto-line () - (loop with mark = (let ((m (clone-mark - (low-mark (buffer (current-window))) - :right))) - (beginning-of-buffer m) - m) - do (end-of-line mark) - until (end-of-buffer-p mark) - repeat (1- (handler-case (accept 'integer :prompt "Goto Line") + (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))))) - do (incf (offset mark)) - (end-of-line mark) - finally (beginning-of-line mark) - (setf (offset (point (current-window))) - (offset mark)))) + (return-from com-goto-line nil)))))) (define-named-command com-browse-url () (let ((url (accept 'url :prompt "Browse URL"))) @@ -851,15 +942,28 @@ (psetf (offset (mark pane)) (offset (point pane)) (offset (point pane)) (offset (mark pane))))) +(defgeneric set-syntax (buffer syntax)) + +(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax)) + (setf (syntax buffer) syntax)) + +;;FIXME - what should this specialise on? +(defmethod set-syntax ((buffer climacs-buffer) syntax) + (set-syntax buffer (make-instance syntax :buffer buffer))) + +(defmethod set-syntax ((buffer climacs-buffer) (syntax string)) + (let ((syntax-class (syntax-from-name syntax))) + (cond (syntax-class + (set-syntax buffer (make-instance syntax-class + :buffer buffer))) + (t + (beep) + (display-message "No such syntax: ~A." syntax))))) + (define-named-command com-set-syntax () (let* ((pane (current-window)) (buffer (buffer pane))) - (setf (syntax buffer) - (make-instance (or (accept 'syntax :prompt "Set Syntax") - (progn (beep) - (display-message "No such syntax") - (return-from com-set-syntax nil))) - :buffer (buffer (point pane)))))) + (set-syntax buffer (accept 'syntax :prompt "Set Syntax")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -897,7 +1001,7 @@ info pane as its second child. The scroller pane contains a viewport which contains an extended pane. Return the vbox and the extended pane as two values. -If *with-scrollbars nil, omit the scroller." +If *with-scrollbars* nil, omit the scroller." (let* ((extended-pane (make-pane 'extended-pane @@ -918,11 +1022,11 @@ :width 900)))) (values vbox extended-pane))) -(define-named-command com-split-window-vertically () +(defun split-window-vertically (&optional (pane (current-window))) (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) (multiple-value-bind (vbox new-pane) (make-pane-constellation) - (let* ((current-window (current-window)) + (let* ((current-window pane) (constellation-root (if *with-scrollbars* (parent3 current-window) (sheet-parent current-window)))) @@ -934,13 +1038,17 @@ (setf *standard-output* new-pane) (replace-constellation constellation-root vbox t) (full-redisplay current-window) - (full-redisplay new-pane))))) + (full-redisplay new-pane) + new-pane)))) -(define-named-command com-split-window-horizontally () +(define-named-command com-split-window-vertically () + (split-window-vertically)) + +(defun split-window-horizontally (&optional (pane (current-window))) (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) (multiple-value-bind (vbox new-pane) (make-pane-constellation) - (let* ((current-window (current-window)) + (let* ((current-window pane) (constellation-root (if *with-scrollbars* (parent3 current-window) (sheet-parent current-window)))) @@ -952,21 +1060,31 @@ (setf *standard-output* new-pane) (replace-constellation constellation-root vbox nil) (full-redisplay current-window) - (full-redisplay new-pane))))) + (full-redisplay new-pane) + new-pane)))) -(define-named-command com-other-window () +(define-named-command com-split-window-horizontally () + (split-window-horizontally)) + +(defun other-window () (setf (windows *application-frame*) (append (cdr (windows *application-frame*)) (list (car (windows *application-frame*))))) (setf *standard-output* (car (windows *application-frame*)))) -(define-named-command com-single-window () +(define-named-command com-other-window () + (other-window)) + +(defun single-window () (loop until (null (cdr (windows *application-frame*))) do (rotatef (car (windows *application-frame*)) (cadr (windows *application-frame*))) (com-delete-window)) (setf *standard-output* (car (windows *application-frame*)))) +(define-named-command com-single-window () + (single-window)) + (define-named-command com-scroll-other-window () (let ((other-window (second (windows *application-frame*)))) (when other-window @@ -977,11 +1095,11 @@ (when other-window (page-up other-window)))) -(define-named-command com-delete-window () +(defun delete-window (&optional (window (current-window))) (unless (null (cdr (windows *application-frame*))) (let* ((constellation (if *with-scrollbars* - (parent3 (current-window)) - (sheet-parent (current-window)))) + (parent3 window) + (sheet-parent window))) (box (sheet-parent constellation)) (box-children (sheet-children box)) (other (if (eq constellation (first box-children)) @@ -992,7 +1110,8 @@ (first (first children)) (second (second children)) (third (third children))) - (pop (windows *application-frame*)) + (setf (windows *application-frame*) + (remove window (windows *application-frame*))) (setf *standard-output* (car (windows *application-frame*))) (sheet-disown-child box other) (sheet-disown-child parent box) @@ -1005,6 +1124,9 @@ (list first second other) (list first other))))))) +(define-named-command com-delete-window () + (delete-window)) + ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -1019,7 +1141,7 @@ *kill-ring* (region-to-sequence (mark pane) (point pane))) (delete-region (mark pane) (point pane)))) -;; Non destructively copies in buffer region to the kill ring +;; Non destructively copies buffer region to the kill ring (define-named-command com-copy-region () (let ((pane (current-window))) (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane))))) @@ -1049,6 +1171,8 @@ ;;; ;;; Incremental search +(make-command-table 'isearch-climacs-table :errorp nil) + (defun isearch-command-loop (pane forwardp) (let ((point (point pane))) (unless (endp (isearch-states pane)) @@ -1092,15 +1216,15 @@ (unless success (beep))))) -(define-named-command com-isearch-mode-forward () +(define-named-command com-isearch-forward () (display-message "Isearch: ") (isearch-command-loop (current-window) t)) -(define-named-command com-isearch-mode-backward () +(define-named-command com-isearch-backward () (display-message "Isearch backward: ") (isearch-command-loop (current-window) nil)) -(define-named-command com-isearch-append-char () +(define-command (com-append-char :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (states (isearch-states pane)) (string (concatenate 'string @@ -1112,7 +1236,7 @@ (incf (offset mark))) (isearch-from-mark pane mark string forwardp))) -(define-named-command com-isearch-delete-char () +(define-command (com-delete-char :name t :command-table isearch-climacs-table) () (let* ((pane (current-window))) (cond ((null (second (isearch-states pane))) (display-message "Isearch: ") @@ -1133,7 +1257,7 @@ (search-forward-p state) (search-string state))))))) -(define-named-command com-isearch-forward () +(define-command (com-forward :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (point (point pane)) (states (isearch-states pane)) @@ -1143,7 +1267,7 @@ (mark (clone-mark point))) (isearch-from-mark pane mark string t))) -(define-named-command com-isearch-backward () +(define-command (com-backward :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (point (point pane)) (states (isearch-states pane)) @@ -1153,13 +1277,27 @@ (mark (clone-mark point))) (isearch-from-mark pane mark string nil))) -(define-named-command com-isearch-exit () +(define-command (com-exit :name t :command-table isearch-climacs-table) () (setf (isearch-mode (current-window)) nil)) +(defun isearch-set-key (gesture command) + (add-command-to-command-table command 'isearch-climacs-table + :keystroke gesture :errorp nil)) + +(loop for code from (char-code #\Space) to (char-code #\~) + do (isearch-set-key (code-char code) 'com-append-char)) + +(isearch-set-key '(#\Newline) 'com-exit) +(isearch-set-key '(#\Backspace) 'com-delete-char) +(isearch-set-key '(#\s :control) 'com-forward) +(isearch-set-key '(#\r :control) 'com-backward) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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) @@ -1211,7 +1349,7 @@ ((setf (query-replace-mode pane) nil)))) (display-message "Replaced ~A occurrence~:P" occurrences))) -(define-named-command com-query-replace-replace () +(define-command (com-replace :name t :command-table query-replace-climacs-table) () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) (point (point pane)) @@ -1235,7 +1373,7 @@ string1 string2) (setf (query-replace-mode pane) nil)))) -(define-named-command com-query-replace-skip () +(define-command (com-skip :name t :command-table query-replace-climacs-table) () (declare (special string1 string2)) (let* ((pane (current-window)) (point (point pane))) @@ -1244,9 +1382,21 @@ string1 string2) (setf (query-replace-mode pane) nil)))) -(define-named-command com-query-replace-exit () +(define-command (com-exit :name t :command-table query-replace-climacs-table) () (setf (query-replace-mode (current-window)) nil)) +(defun query-replace-set-key (gesture command) + (add-command-to-command-table command 'query-replace-climacs-table + :keystroke gesture :errorp nil)) + +(query-replace-set-key '(#\Newline) 'com-exit) +(query-replace-set-key '(#\Space) 'com-replace) +(query-replace-set-key '(#\Backspace) 'com-skip) +(query-replace-set-key '(#\Rubout) 'com-skip) +(query-replace-set-key '(#\q) 'com-exit) +(query-replace-set-key '(#\y) 'com-replace) +(query-replace-set-key '(#\n) 'com-skip) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Undo/redo @@ -1301,7 +1451,8 @@ (region-to-sequence offset dabbrev-expansion-mark) (setf (offset dabbrev-expansion-mark) offset)))) (move)))))))) - + + (define-named-command com-backward-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) (point (point pane)) @@ -1448,11 +1599,12 @@ (error () (progn (beep) (display-message "Empty string") (return-from com-eval-expression nil))))) - (result (format nil "~a" - (handler-case (eval (read-from-string string)) - (error (condition) (progn (beep) - (display-message "~a" condition) - (return-from com-eval-expression nil))))))) + (values (multiple-value-list + (handler-case (eval (read-from-string string)) + (error (condition) (progn (beep) + (display-message "~a" condition) + (return-from com-eval-expression nil)))))) + (result (format nil "~:[; No values~;~:*~{~S~^,~}~]" values))) (if insertp (insert-sequence (point (current-window)) result) (display-message result)))) @@ -1469,21 +1621,6 @@ (syntax (syntax (buffer pane)))) (comment-region syntax point mark))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; For testing purposes - -(define-named-command com-reset-profile () - #+sbcl (sb-profile:reset) - #-sbcl nil) - -(define-named-command com-report-profile () - #+sbcl (sb-profile:report) - #-sbcl nil) - -(define-named-command com-recompile () - (asdf:operate 'asdf:load-op :climacs)) - (define-named-command com-backward-expression ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) (point (point pane)) @@ -1620,6 +1757,22 @@ (package (climacs-lisp-syntax::package-of syntax))) (display-message (format nil "~s" package)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; For testing purposes + +(define-named-command com-reset-profile () + #+sbcl (sb-profile:reset) + #-sbcl nil) + +(define-named-command com-report-profile () + #+sbcl (sb-profile:report) + #-sbcl nil) + +(define-named-command com-recompile () + (asdf:operate 'asdf:load-op :climacs)) + + (define-gesture-name :select-other :pointer-button-press (:left :meta) :unique nil) (define-presentation-translator lisp-string-to-string @@ -1719,8 +1872,8 @@ (global-set-key '(#\{ :meta :shift) `(com-backward-paragraph ,*numeric-argument-marker*)) (global-set-key '(#\} :meta :shift) `(com-forward-paragraph ,*numeric-argument-marker*)) (global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*)) -(global-set-key '(#\s :control) 'com-isearch-mode-forward) -(global-set-key '(#\r :control) 'com-isearch-mode-backward) +(global-set-key '(#\s :control) 'com-isearch-forward) +(global-set-key '(#\r :control) 'com-isearch-backward) (global-set-key '(#\_ :shift :meta) 'com-redo) (global-set-key '(#\_ :shift :control) 'com-undo) (global-set-key '(#\% :shift :meta) 'com-query-replace) @@ -1952,41 +2105,6 @@ (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251)) (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Isearch command table - -(make-command-table 'isearch-climacs-table :errorp nil) - -(defun isearch-set-key (gesture command) - (add-command-to-command-table command 'isearch-climacs-table - :keystroke gesture :errorp nil)) - -(loop for code from (char-code #\Space) to (char-code #\~) - do (isearch-set-key (code-char code) 'com-isearch-append-char)) - -(isearch-set-key '(#\Newline) 'com-isearch-exit) -(isearch-set-key '(#\Backspace) 'com-isearch-delete-char) -(isearch-set-key '(#\s :control) 'com-isearch-forward) -(isearch-set-key '(#\r :control) 'com-isearch-backward) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Query replace command table - -(make-command-table 'query-replace-climacs-table :errorp nil) - -(defun query-replace-set-key (gesture command) - (add-command-to-command-table command 'query-replace-climacs-table - :keystroke gesture :errorp nil)) - -(query-replace-set-key '(#\Newline) 'com-query-replace-exit) -(query-replace-set-key '(#\Space) 'com-query-replace-replace) -(query-replace-set-key '(#\Backspace) 'com-query-replace-skip) -(query-replace-set-key '(#\Rubout) 'com-query-replace-skip) -(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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -2002,3 +2120,4 @@ (add-command-to-command-table command 'c-c-climacs-table :keystroke gesture :errorp nil)) +(c-c-set-key '(#\l :control) 'com-load-file) From dmurray at common-lisp.net Thu Aug 18 19:49:03 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Thu, 18 Aug 2005 21:49:03 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050818194903.E466A8852B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv26118 Modified Files: lisp-syntax.lisp Log Message: Fixed small bug in reparsing algorithm. Date: Thu Aug 18 21:49:02 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.32 climacs/lisp-syntax.lisp:1.33 --- climacs/lisp-syntax.lisp:1.32 Tue Aug 16 01:31:22 2005 +++ climacs/lisp-syntax.lisp Thu Aug 18 21:49:01 2005 @@ -979,9 +979,9 @@ (find-first-potentially-valid-lexeme (cdr parse-trees) offset)) ((not (typep (car parse-trees) 'lexeme)) (find-first-potentially-valid-lexeme (children (car parse-trees)) offset)) - ((< (start-offset (car parse-trees)) offset) + ((<= (start-offset (car parse-trees)) offset) (loop with tree = (next-tree (car parse-trees)) - until (or (null tree) (>= (start-offset tree) offset)) + until (or (null tree) (> (start-offset tree) offset)) do (setf tree (next-tree tree)) finally (return tree))) (t (car parse-trees)))) @@ -990,7 +990,7 @@ (and (eq (class-of tree1) (class-of tree2)) (eq (parser-state tree1) (parser-state tree2)) (= (end-offset tree1) (end-offset tree2)))) - + (defmethod print-object ((mark mark) stream) (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) From dmurray at common-lisp.net Thu Aug 18 20:44:51 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Thu, 18 Aug 2005 22:44:51 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050818204451.32C7D8852B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29204 Modified Files: gui.lisp Log Message: Add com-set-visited-file-name, com-revert-buffer, backups ("file.foo~") when saving existing files, some more file/directory checks. Also fixed some problems I introduced last time. (erase-buffer is v. slow.) Date: Thu Aug 18 22:44:48 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.178 climacs/gui.lisp:1.179 --- climacs/gui.lisp:1.178 Wed Aug 17 01:10:29 2005 +++ climacs/gui.lisp Thu Aug 18 22:44:48 2005 @@ -622,12 +622,9 @@ (complete-input stream #'filename-completer :allow-any-input t) -; (declare (ignore success)) -; (or pathname string))) (if success - (values pathname 'pathname) + (values pathname 'completable-pathname) (values string 'string)))) - (defun filepath-filename (pathname) (if (null (pathname-type pathname)) @@ -653,6 +650,12 @@ (and (or (null name) (eql name :unspecific)) (or (null type) (eql type :unspecific))))) +(defun make-buffer (&optional name) + (let ((buffer (make-instance 'climacs-buffer))) + (when name (setf (name buffer) name)) + (push buffer (buffers *application-frame*)) + buffer)) + (define-named-command com-find-file () (let ((filepath (accept 'completable-pathname :prompt "Find File"))) @@ -660,10 +663,9 @@ (display-message "~A is a directory name." filepath) (beep)) (t - (let ((buffer (make-instance 'climacs-buffer)) + (let ((buffer (make-buffer)) (pane (current-window))) (setf (offset (point (buffer pane))) (offset (point pane))) - (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath) @@ -680,6 +682,15 @@ ;; resets the low and high marks after redisplay (redisplay-frame-panes *application-frame*)))))) +(defun set-visited-file-name (filename buffer) + (setf (filepath buffer) filename + (name buffer) (filepath-filename filename) + (needs-saving buffer) t)) + +(define-named-command com-set-visited-file-name () + (let ((filename (accept 'completable-pathname :prompt "New file name"))) + (set-visited-file-name filename (buffer (current-window))))) + (define-named-command com-insert-file () (let ((filename (accept 'completable-pathname :prompt "Insert File")) @@ -694,6 +705,40 @@ (offset (point pane)) (offset (mark pane)))) (redisplay-frame-panes *application-frame*))) +(defgeneric erase-buffer (buffer)) + +(defmethod erase-buffer ((buffer string)) + (let ((b (find buffer (buffers *application-frame*) + :key #'name :test #'string=))) + (when b (erase-buffer b)))) + +(defmethod erase-buffer ((buffer climacs-buffer)) + (let* ((point (point buffer)) + (mark (clone-mark point))) + (beginning-of-buffer mark) + (end-of-buffer point) + (delete-region mark point))) + +(define-named-command com-revert-buffer () + (let* ((pane (current-window)) + (buffer (buffer pane)) + (filepath (filepath buffer)) + (save (offset (point pane)))) + (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?" + (filepath buffer))) + (cond ((directory-pathname-p filepath) + (display-message "~A is a directory name." filepath) + (beep)) + ((probe-file filepath) + (erase-buffer buffer) + (with-open-file (stream filepath :direction :input) + (input-from-stream stream buffer 0)) + (setf (offset (point pane)) + (min (size buffer) save))) + (t + (display-message "No file ~A" filepath) + (beep)))))) + (defun save-buffer (buffer) (let ((filepath (or (filepath buffer) (accept 'completable-pathname @@ -703,6 +748,11 @@ (display-message "~A is a directory." filepath) (beep)) (t + (when (probe-file filepath) + (let ((backup-name (pathname-name filepath)) + (backup-type (concatenate 'string (pathname-type filepath) "~"))) + (rename-file filepath (make-pathname :name backup-name + :type backup-type)))) (with-open-file (stream filepath :direction :output :if-exists :supersede) (output-to-stream stream buffer 0 (size buffer))) (setf (filepath buffer) filepath @@ -772,7 +822,7 @@ (pane (current-window))) (if position (rotatef (car buffers) (nth position buffers)) - (push buffer buffers)) + (push buffer (buffers *application-frame*))) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer pane) buffer) (full-redisplay pane))) @@ -781,7 +831,7 @@ (let ((buffer (find name (buffers *application-frame*) :key #'name :test #'string=))) (switch-to-buffer (or buffer - (make-instance 'climacs-buffer :name name))))) + (make-buffer name))))) ;;placeholder (defmethod switch-to-buffer ((symbol (eql 'nil))) @@ -805,8 +855,7 @@ (setf buffers (remove buffer buffers)) ;; Always need one buffer. (when (null buffers) - (push (make-instance 'climacs-buffer :name "*scratch*") - buffers)) + (make-buffer "*scratch*")) (setf (buffer (current-window)) (car buffers)))) (defmethod kill-buffer ((name string)) @@ -1224,7 +1273,7 @@ (display-message "Isearch backward: ") (isearch-command-loop (current-window) nil)) -(define-command (com-append-char :name t :command-table isearch-climacs-table) () +(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (states (isearch-states pane)) (string (concatenate 'string @@ -1236,7 +1285,7 @@ (incf (offset mark))) (isearch-from-mark pane mark string forwardp))) -(define-command (com-delete-char :name t :command-table isearch-climacs-table) () +(define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) () (let* ((pane (current-window))) (cond ((null (second (isearch-states pane))) (display-message "Isearch: ") @@ -1257,7 +1306,7 @@ (search-forward-p state) (search-string state))))))) -(define-command (com-forward :name t :command-table isearch-climacs-table) () +(define-command (com-isearch-search-forward :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (point (point pane)) (states (isearch-states pane)) @@ -1267,7 +1316,7 @@ (mark (clone-mark point))) (isearch-from-mark pane mark string t))) -(define-command (com-backward :name t :command-table isearch-climacs-table) () +(define-command (com-isearch-search-backward :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (point (point pane)) (states (isearch-states pane)) @@ -1277,7 +1326,7 @@ (mark (clone-mark point))) (isearch-from-mark pane mark string nil))) -(define-command (com-exit :name t :command-table isearch-climacs-table) () +(define-command (com-isearch-exit :name t :command-table isearch-climacs-table) () (setf (isearch-mode (current-window)) nil)) (defun isearch-set-key (gesture command) @@ -1287,10 +1336,10 @@ (loop for code from (char-code #\Space) to (char-code #\~) do (isearch-set-key (code-char code) 'com-append-char)) -(isearch-set-key '(#\Newline) 'com-exit) -(isearch-set-key '(#\Backspace) 'com-delete-char) -(isearch-set-key '(#\s :control) 'com-forward) -(isearch-set-key '(#\r :control) 'com-backward) +(isearch-set-key '(#\Newline) 'com-isearch-exit) +(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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1349,7 +1398,7 @@ ((setf (query-replace-mode pane) nil)))) (display-message "Replaced ~A occurrence~:P" occurrences))) -(define-command (com-replace :name t :command-table query-replace-climacs-table) () +(define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) (point (point pane)) @@ -1373,7 +1422,7 @@ string1 string2) (setf (query-replace-mode pane) nil)))) -(define-command (com-skip :name t :command-table query-replace-climacs-table) () +(define-command (com-query-replace-skip :name t :command-table query-replace-climacs-table) () (declare (special string1 string2)) (let* ((pane (current-window)) (point (point pane))) @@ -1382,20 +1431,20 @@ string1 string2) (setf (query-replace-mode pane) nil)))) -(define-command (com-exit :name t :command-table query-replace-climacs-table) () +(define-command (com-query-replace-exit :name t :command-table query-replace-climacs-table) () (setf (query-replace-mode (current-window)) nil)) (defun query-replace-set-key (gesture command) (add-command-to-command-table command 'query-replace-climacs-table :keystroke gesture :errorp nil)) -(query-replace-set-key '(#\Newline) 'com-exit) -(query-replace-set-key '(#\Space) 'com-replace) -(query-replace-set-key '(#\Backspace) 'com-skip) -(query-replace-set-key '(#\Rubout) 'com-skip) -(query-replace-set-key '(#\q) 'com-exit) -(query-replace-set-key '(#\y) 'com-replace) -(query-replace-set-key '(#\n) 'com-skip) +(query-replace-set-key '(#\Newline) 'com-query-replace-exit) +(query-replace-set-key '(#\Space) 'com-query-replace-replace) +(query-replace-set-key '(#\Backspace) 'com-query-replace-skip) +(query-replace-set-key '(#\Rubout) 'com-query-replace-skip) +(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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -2121,3 +2170,4 @@ :keystroke gesture :errorp nil)) (c-c-set-key '(#\l :control) 'com-load-file) + From dmurray at common-lisp.net Fri Aug 19 09:12:50 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Fri, 19 Aug 2005 11:12:50 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/pane.lisp climacs/packages.lisp climacs/gui.lisp Message-ID: <20050819091250.A50A48815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14566 Modified Files: pane.lisp packages.lisp gui.lisp Log Message: Added read-only buffers, com-find-file-read-only (C-x C-r), com-toggle-read-only (C-x C-q) and "%%" display in mode line. Date: Fri Aug 19 11:12:49 2005 Author: dmurray Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.29 climacs/pane.lisp:1.30 --- climacs/pane.lisp:1.29 Tue Aug 16 01:31:22 2005 +++ climacs/pane.lisp Fri Aug 19 11:12:48 2005 @@ -176,6 +176,47 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Readonly + +(defclass read-only-mixin () + ((read-only-p :initform nil :accessor read-only-p))) + +(define-condition buffer-read-only (simple-error) + ((buffer :reader condition-buffer :initarg :buffer)) + (:report (lambda (condition stream) + (format stream "Attempt to change read only buffer: ~a" + (condition-buffer condition)))) + (:documentation "This condition is signalled whenever an attempt +is made to alter a buffer which has been set read only.")) + +(defmethod insert-buffer-object ((buffer read-only-mixin) offset object) + (if (read-only-p buffer) + (error 'buffer-read-only :buffer buffer) + (call-next-method))) + +(defmethod insert-buffer-sequence ((buffer read-only-mixin) offset sequence) + (if (read-only-p buffer) + (error 'buffer-read-only :buffer buffer) + (call-next-method))) + +(defmethod delete-buffer-range ((buffer read-only-mixin) offset n) + (if (read-only-p buffer) + (error 'buffer-read-only :buffer buffer) + (call-next-method))) + +(defmethod (setf buffer-object) (object (buffer read-only-mixin) offset) + (if (read-only-p buffer) + (error 'buffer-read-only :buffer buffer) + (call-next-method))) + +(defmethod read-only-p ((buffer delegating-buffer)) + (read-only-p (implementation buffer))) + +(defmethod (setf read-only-p) (flag (buffer delegating-buffer)) + (setf (read-only-p (implementation buffer)) flag)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; View (defclass climacs-textual-view (textual-view tabify-mixin) @@ -186,10 +227,10 @@ ;(defgeneric indent-tabs-mode (climacs-buffer)) -(defclass extended-standard-buffer (standard-buffer undo-mixin abbrev-mixin) () +(defclass extended-standard-buffer (read-only-mixin standard-buffer undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks.")) -(defclass extended-binseq2-buffer (binseq2-buffer p-undo-mixin abbrev-mixin) () +(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) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.78 climacs/packages.lisp:1.79 --- climacs/packages.lisp:1.78 Wed Aug 17 01:10:29 2005 +++ climacs/packages.lisp Fri Aug 19 11:12:48 2005 @@ -140,6 +140,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :flexichain :undo) (:export #:climacs-buffer #:needs-saving #:filepath + #:read-only-p #:buffer-read-only #:climacs-pane #:point #:mark #:redisplay-pane #:full-redisplay #:display-cursor Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.179 climacs/gui.lisp:1.180 --- climacs/gui.lisp:1.179 Thu Aug 18 22:44:48 2005 +++ climacs/gui.lisp Fri Aug 19 11:12:48 2005 @@ -112,7 +112,9 @@ (top (top master-pane)) (bot (bot master-pane)) (name-info (format nil " ~a ~a~:[~30t~a~;~*~] ~:[(~;Syntax: ~]~a~a~a~a~:[)~;~] ~a" - (if (needs-saving buf) "**" "--") + (cond ((needs-saving buf) "**") + ((read-only-p buf) "%%") + (t "--")) (name buf) *with-scrollbars* (cond ((and (mark= size bot) @@ -168,7 +170,9 @@ (no-expression () (beep) (display-message "No expression around point")) (no-such-operation () - (beep) (display-message "Operation unavailable for syntax")))) + (beep) (display-message "Operation unavailable for syntax")) + (buffer-read-only () + (beep) (display-message "Buffer is read only")))) (defmethod execute-frame-command :after ((frame climacs) command) (loop for buffer in (buffers frame) @@ -656,31 +660,80 @@ (push buffer (buffers *application-frame*)) buffer)) +(defun find-file (filepath) + (cond ((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 existing-buffer + (switch-to-buffer existing-buffer) + (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)))) + ;; 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 (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (needs-saving buffer) nil) + (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)))))) + (define-named-command com-find-file () (let ((filepath (accept 'completable-pathname :prompt "Find File"))) - (cond ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath) - (beep)) - (t - (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)))) - ;; 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 (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil) - (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*)))))) + (find-file filepath))) + +(defun find-file-read-only (filepath) + (cond ((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-named-command com-find-file-read-only () + (let ((filepath (accept 'completable-pathname :Prompt "Find file read only"))) + (find-file-read-only filepath))) + +(define-named-command com-toggle-read-only () + (let ((buffer (buffer (current-window)))) + (setf (read-only-p buffer) (not (read-only-p buffer))))) (defun set-visited-file-name (filename buffer) (setf (filepath buffer) filename @@ -825,7 +878,8 @@ (push buffer (buffers *application-frame*))) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer pane) buffer) - (full-redisplay pane))) + (full-redisplay pane) + buffer)) (defmethod switch-to-buffer ((name string)) (let ((buffer (find name (buffers *application-frame*) @@ -1977,6 +2031,8 @@ (c-x-set-key '(#\3) 'com-split-window-horizontally) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\f :control) 'com-find-file) +(c-x-set-key '(#\r :control) 'com-find-file-read-only) +(c-x-set-key '(#\q :control) 'com-toggle-read-only) (c-x-set-key '(#\f) `(com-set-fill-column ,*numeric-argument-marker*)) (c-x-set-key '(#\h) 'com-mark-whole-buffer) (c-x-set-key '(#\i) 'com-insert-file) From dmurray at common-lisp.net Sat Aug 20 19:44:09 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sat, 20 Aug 2005 21:44:09 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050820194409.9FF988854A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv22657 Modified Files: gui.lisp Log Message: Fix isearch bug (introduced earlier), futzed with modeline format string, added default to Kill Buffer. Date: Sat Aug 20 21:44:09 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.180 climacs/gui.lisp:1.181 --- climacs/gui.lisp:1.180 Fri Aug 19 11:12:48 2005 +++ climacs/gui.lisp Sat Aug 20 21:44:08 2005 @@ -111,8 +111,18 @@ (size (size buf)) (top (top master-pane)) (bot (bot master-pane)) - (name-info (format nil " ~a ~a~:[~30t~a~;~*~] ~:[(~;Syntax: ~]~a~a~a~a~:[)~;~] ~a" - (cond ((needs-saving buf) "**") + (name-info (format nil "~3T~A~ + ~3 at T~A~ + ~:[~30T~A~;~*~]~ + ~3 at T~:[(~;Syntax: ~]~ + ~A~ + ~{~:[~*~; ~A~]~}~ + ~:[)~;~]~ + ~3 at T~A" + (cond ((and (needs-saving buf) + (read-only-p buf) + "%*")) + ((needs-saving buf) "**") ((read-only-p buf) "%%") (t "--")) (name buf) @@ -129,15 +139,13 @@ size)))))) *with-scrollbars* (name (syntax buf)) - (if (slot-value master-pane 'overwrite-mode) - " Ovwrt" - "") - (if (auto-fill-mode master-pane) - " Fill" - "") - (if (isearch-mode master-pane) - " Isearch" - "") + (list + (slot-value master-pane 'overwrite-mode) + "Ovwrt" + (auto-fill-mode master-pane) + "Fill" + (isearch-mode master-pane) + "Isearch") *with-scrollbars* (if (recordingp *application-frame*) "Def" @@ -620,15 +628,25 @@ collect (list (subseq (namestring name) length nil) name)))))))) +(define-presentation-method present (object (type completable-pathname) + stream (view textual-view) + &key acceptably for-context-type) + (declare (ignore acceptably for-context-type)) + (princ (namestring object) stream)) + (define-presentation-method accept - ((type completable-pathname) stream (view textual-view) &key) + ((type completable-pathname) stream (view textual-view) &key (default nil defaultp) + (default-type type)) (multiple-value-bind (pathname success string) (complete-input stream #'filename-completer :allow-any-input t) - (if success - (values pathname 'completable-pathname) - (values string 'string)))) + (cond (success + (values pathname type)) + ((and (zerop (length string)) + defaultp) + (values default default-type)) + (t (values string 'string))))) (defun filepath-filename (pathname) (if (null (pathname-type pathname)) @@ -661,7 +679,10 @@ buffer)) (defun find-file (filepath) - (cond ((directory-pathname-p 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 @@ -690,17 +711,20 @@ buffer)))))) (define-named-command com-find-file () - (let ((filepath (accept 'completable-pathname - :prompt "Find File"))) + (let* ((filepath (accept 'completable-pathname + :prompt "Find File"))) (find-file filepath))) (defun find-file-read-only (filepath) - (cond ((directory-pathname-p 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))) + :key #'filepath :test #'equal))) (if (and existing-buffer (read-only-p existing-buffer)) (switch-to-buffer existing-buffer) (if (probe-file filepath) @@ -853,8 +877,16 @@ (needs-saving buffer) nil) (display-message "Wrote: ~a" (filepath buffer)))))) +(define-presentation-method present (object (type buffer) + stream + (view textual-view) + &key acceptably for-context-type) + (declare (ignore acceptably for-context-type)) + (princ (name object) stream)) + (define-presentation-method accept - ((type buffer) stream (view textual-view) &key) + ((type buffer) stream (view textual-view) &key (default nil defaultp) + (default-type type)) (multiple-value-bind (object success string) (complete-input stream (lambda (so-far action) @@ -864,8 +896,11 @@ :value-key #'identity)) :partial-completers '(#\Space) :allow-any-input t) - (declare (ignore success)) - (or object string))) + (cond (success + (values object type)) + ((and (zerop (length string)) defaultp) + (values default default-type)) + (t (values string 'string))))) (defgeneric switch-to-buffer (buffer)) @@ -893,7 +928,9 @@ (define-named-command com-switch-to-buffer () (let ((buffer (accept 'buffer - :prompt "Switch to buffer"))) + :prompt "Switch to buffer" + :default (second (buffers *application-frame*)) + :default-type 'buffer))) (switch-to-buffer buffer))) (defgeneric kill-buffer (buffer)) @@ -921,7 +958,13 @@ (kill-buffer (buffer (current-window)))) (define-named-command com-kill-buffer () - (kill-buffer (buffer (current-window)))) + (let ((buffer (accept 'buffer + :prompt "Kill buffer" + :default (buffer (current-window)) + :default-type 'buffer))) + (format *trace-output* "Here: ~a~%" buffer) (finish-output *trace-output*) + (kill-buffer buffer))) + (define-named-command com-full-redisplay () (full-redisplay (current-window))) @@ -1388,7 +1431,7 @@ :keystroke gesture :errorp nil)) (loop for code from (char-code #\Space) to (char-code #\~) - do (isearch-set-key (code-char code) 'com-append-char)) + do (isearch-set-key (code-char code) 'com-isearch-append-char)) (isearch-set-key '(#\Newline) 'com-isearch-exit) (isearch-set-key '(#\Backspace) 'com-isearch-delete-char) From dmurray at common-lisp.net Thu Aug 25 07:48:14 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Thu, 25 Aug 2005 09:48:14 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/delegating-buffer.lisp climacs/base.lisp Message-ID: <20050825074814.DA28F88546@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6818 Modified Files: gui.lisp delegating-buffer.lisp base.lisp Log Message: Added dead-escape #\x back to global-climacs-table. Added com-regex-search and com-regex-search-forward to let people experiment with the cl-automaton regex facility. Date: Thu Aug 25 09:48:13 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.181 climacs/gui.lisp:1.182 --- climacs/gui.lisp:1.181 Sat Aug 20 21:44:08 2005 +++ climacs/gui.lisp Thu Aug 25 09:48:13 2005 @@ -1956,6 +1956,8 @@ (add-command-to-command-table command 'dead-escape-climacs-table :keystroke gesture :errorp nil)) +(dead-escape-set-key '(#\x) 'esa::com-extended-command) + (defun global-set-key (gesture command) (add-command-to-command-table command 'global-climacs-table :keystroke gesture :errorp nil) @@ -2270,3 +2272,16 @@ (c-c-set-key '(#\l :control) 'com-load-file) +(define-named-command com-regex-search-forward () + (let ((string (accept 'string :prompt "RE search" + :delimiter-gestures nil + :activation-gestures + '(:newline :return)))) + (re-search-forward (point (current-window)) string))) + +(define-named-command com-regex-search-backward () + (let ((string (accept 'string :prompt "RE search backward" + :delimiter-gestures nil + :activation-gestures + '(:newline :return)))) + (re-search-backward (point (current-window)) string))) Index: climacs/delegating-buffer.lisp diff -u climacs/delegating-buffer.lisp:1.4 climacs/delegating-buffer.lisp:1.5 --- climacs/delegating-buffer.lisp:1.4 Sun Feb 27 22:21:51 2005 +++ climacs/delegating-buffer.lisp Thu Aug 25 09:48:13 2005 @@ -69,4 +69,4 @@ (buffer-line-number (implementation buffer) offset)) (defmethod buffer-column-number ((buffer delegating-buffer) offset) - (buffer-column-number (implementation buffer) offset)) \ No newline at end of file + (buffer-column-number (implementation buffer) offset)) Index: climacs/base.lisp diff -u climacs/base.lisp:1.42 climacs/base.lisp:1.43 --- climacs/base.lisp:1.42 Tue Aug 9 17:18:25 2005 +++ climacs/base.lisp Thu Aug 25 09:48:13 2005 @@ -624,11 +624,12 @@ returns nil. If the first value is non-nil, the second value is the offset after the matched contents." (if (automaton::singleton a) - (buffer-search-forward buffer offset (automaton::singleton a)) + (let ((result (buffer-search-forward buffer offset (automaton::singleton a)))) + (values result (+ result (length (automaton::singleton a))))) (loop for i from offset below (size buffer) do - (let ((j (non-greedy-match-forward a buffer i))) - (when j (return (values i j)))) - finally (return nil)))) + (let ((j (non-greedy-match-forward a buffer i))) + (when j (return (values i j)))) + finally (return nil)))) (defun reversed-deterministic-automaton (a) "Reverses and determinizes A, then returns it." @@ -657,11 +658,13 @@ otherwise, returns nil. If the first value is non-nil, the second value is the offset after the matched contents." (if (automaton::singleton a) - (buffer-search-backward buffer offset (automaton::singleton a)) + (let ((result (buffer-search-backward buffer offset + (nreverse (automaton::singleton a))))) + (values result result)) (loop for i downfrom (min offset (1- (size buffer))) to 0 do - (let ((j (non-greedy-match-backward a buffer i))) - (when j (return (values j i)))) - finally (return nil)))) + (let ((j (non-greedy-match-backward a buffer i))) + (when j (return (values j i)))) + finally (return nil)))) (defun search-forward (mark vector &key (test #'eql)) "move MARK forward after the first occurence of VECTOR after MARK" From dmurray at common-lisp.net Thu Aug 25 08:43:55 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Thu, 25 Aug 2005 10:43:55 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050825084355.0ADDA88559@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9849 Modified Files: gui.lisp Log Message: Removed debugging message. Date: Thu Aug 25 10:43:55 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.182 climacs/gui.lisp:1.183 --- climacs/gui.lisp:1.182 Thu Aug 25 09:48:13 2005 +++ climacs/gui.lisp Thu Aug 25 10:43:55 2005 @@ -962,9 +962,7 @@ :prompt "Kill buffer" :default (buffer (current-window)) :default-type 'buffer))) - (format *trace-output* "Here: ~a~%" buffer) (finish-output *trace-output*) (kill-buffer buffer))) - (define-named-command com-full-redisplay () (full-redisplay (current-window))) From abakic at common-lisp.net Sat Aug 27 20:29:09 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sat, 27 Aug 2005 22:29:09 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/base.lisp Message-ID: <20050827202909.C9E7C8855A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3005 Modified Files: base.lisp Log Message: A minor bug fix. Date: Sat Aug 27 22:29:09 2005 Author: abakic Index: climacs/base.lisp diff -u climacs/base.lisp:1.43 climacs/base.lisp:1.44 --- climacs/base.lisp:1.43 Thu Aug 25 09:48:13 2005 +++ climacs/base.lisp Sat Aug 27 22:29:08 2005 @@ -625,7 +625,8 @@ offset after the matched contents." (if (automaton::singleton a) (let ((result (buffer-search-forward buffer offset (automaton::singleton a)))) - (values result (+ result (length (automaton::singleton a))))) + (when result + (values result (+ result (length (automaton::singleton a)))))) (loop for i from offset below (size buffer) do (let ((j (non-greedy-match-forward a buffer i))) (when j (return (values i j)))) From abakic at common-lisp.net Sat Aug 27 22:07:52 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 28 Aug 2005 00:07:52 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/base-test.lisp climacs/base.lisp Message-ID: <20050827220752.A0AA08855A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10228 Modified Files: base-test.lisp base.lisp Log Message: A few more com-re-search* related bug fixes. Date: Sun Aug 28 00:07:48 2005 Author: abakic Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.15 climacs/base-test.lisp:1.16 --- climacs/base-test.lisp:1.15 Fri Aug 5 00:07:44 2005 +++ climacs/base-test.lisp Sun Aug 28 00:07:45 2005 @@ -1108,30 +1108,38 @@ (a1 (automaton::determinize (regexp-automaton (string-regexp "i[mac]+s")))) (a2 (automaton::determinize - (regexp-automaton (string-regexp "[^aeiou][aeiou]"))))) + (regexp-automaton (string-regexp "[^aeiou][aeiou]")))) + (a3 (regexp-automaton (string-regexp "imacs")))) (insert-buffer-sequence buffer 0 " climacs") - (values - (buffer-re-search-forward a1 buffer 0) - (buffer-re-search-forward a2 buffer 1) - (buffer-re-search-forward a1 buffer 4) - (buffer-re-search-forward a2 buffer 6))) - 3 2 nil nil) + (multiple-value-call + #'list + (buffer-re-search-forward a1 buffer 0) + (buffer-re-search-forward a2 buffer 1) + (buffer-re-search-forward a3 buffer 1) + (buffer-re-search-forward a1 buffer 4) + (buffer-re-search-forward a2 buffer 6) + (buffer-re-search-forward a3 buffer 6))) + (3 8 2 4 3 8 nil nil nil)) (defmultitest buffer-re-search-backward.test-1 (let ((buffer (make-instance %%buffer)) (a1 (climacs-base::reversed-deterministic-automaton (regexp-automaton (string-regexp "i[ma]+c")))) (a2 (climacs-base::reversed-deterministic-automaton - (regexp-automaton (string-regexp "[^aeiou][aeiou]"))))) + (regexp-automaton (string-regexp "[^aeiou][aeiou]")))) + (a3 (regexp-automaton (string-regexp "cami")))) (insert-buffer-sequence buffer 0 " climacs") - (values - (buffer-re-search-backward a1 buffer 7) - (buffer-re-search-backward a2 buffer 7) - (buffer-re-search-backward a1 buffer 5) - (buffer-re-search-backward a2 buffer 2))) - 3 4 nil nil) + (multiple-value-call + #'list + (buffer-re-search-backward a1 buffer 7) + (buffer-re-search-backward a2 buffer 7) + (buffer-re-search-backward a3 buffer 7) + (buffer-re-search-backward a1 buffer 5) + (buffer-re-search-backward a2 buffer 2) + (buffer-re-search-backward a3 buffer 5))) + (3 7 4 6 3 7 nil nil nil)) (defmultitest search-forward.test-1 (let ((buffer (make-instance %%buffer))) Index: climacs/base.lisp diff -u climacs/base.lisp:1.44 climacs/base.lisp:1.45 --- climacs/base.lisp:1.44 Sat Aug 27 22:29:08 2005 +++ climacs/base.lisp Sun Aug 28 00:07:45 2005 @@ -624,13 +624,14 @@ returns nil. If the first value is non-nil, the second value is the offset after the matched contents." (if (automaton::singleton a) - (let ((result (buffer-search-forward buffer offset (automaton::singleton a)))) + (let ((result (buffer-search-forward + buffer offset (automaton::singleton a)))) (when result (values result (+ result (length (automaton::singleton a)))))) (loop for i from offset below (size buffer) do (let ((j (non-greedy-match-forward a buffer i))) (when j (return (values i j)))) - finally (return nil)))) + finally (return nil)))) (defun reversed-deterministic-automaton (a) "Reverses and determinizes A, then returns it." @@ -659,13 +660,14 @@ otherwise, returns nil. If the first value is non-nil, the second value is the offset after the matched contents." (if (automaton::singleton a) - (let ((result (buffer-search-backward buffer offset - (nreverse (automaton::singleton a))))) - (values result result)) + (let ((result (buffer-search-backward + buffer offset (nreverse (automaton::singleton a))))) + (when result + (values result (+ result (length (automaton::singleton a)))))) (loop for i downfrom (min offset (1- (size buffer))) to 0 do (let ((j (non-greedy-match-backward a buffer i))) - (when j (return (values j i)))) - finally (return nil)))) + (when j (return (values j (1+ i))))) + finally (return nil)))) (defun search-forward (mark vector &key (test #'eql)) "move MARK forward after the first occurence of VECTOR after MARK" @@ -699,7 +701,7 @@ (automaton::regexp-automaton (automaton::string-regexp re))))) (multiple-value-bind (i j) - (buffer-re-search-backward a (buffer mark) (offset mark)) + (buffer-re-search-backward a (buffer mark) (1- (offset mark))) (declare (ignorable j)) (when i (setf (offset mark) i))))) From dmurray at common-lisp.net Sun Aug 28 13:57:35 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sun, 28 Aug 2005 15:57:35 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/pane.lisp Message-ID: <20050828135735.437AF880DD@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9146 Modified Files: pane.lisp Log Message: Fixed off-by-one error in mark-display drawing. Date: Sun Aug 28 15:57:34 2005 Author: dmurray Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.30 climacs/pane.lisp:1.31 --- climacs/pane.lisp:1.30 Fri Aug 19 11:12:48 2005 +++ climacs/pane.lisp Sun Aug 28 15:57:33 2005 @@ -571,7 +571,7 @@ (defmethod display-mark ((pane climacs-pane) (syntax basic-syntax)) (with-slots (top bot) pane (let ((mark (mark pane))) - (when (< (offset top) (offset mark) (offset bot)) + (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)) From dmurray at common-lisp.net Tue Aug 30 17:28:57 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Tue, 30 Aug 2005 19:28:57 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/slidemacs-gui.lisp climacs/gui.lisp climacs/esa.lisp Message-ID: <20050830172857.D86E98815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29630 Modified Files: slidemacs-gui.lisp gui.lisp esa.lisp Log Message: Changed ESA's set-key to automatically create dead-escape equivalents to :meta commands. Changed all global-set-keys to use set-key instead. Now key-chords are assigned next to the command definitions. All commands currently in global-climacs-table. The next task is to redistribute them among relevant groupings of tables. Date: Tue Aug 30 19:28:53 2005 Author: dmurray Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.16 climacs/slidemacs-gui.lisp:1.17 --- climacs/slidemacs-gui.lisp:1.16 Wed Jun 22 20:36:13 2005 +++ climacs/slidemacs-gui.lisp Tue Aug 30 19:28:52 2005 @@ -543,13 +543,27 @@ (setf (syntax buffer) (make-instance 'slidemacs-gui-syntax :buffer buffer)))))) -(climacs-gui::global-set-key '(#\= :control) 'com-next-talking-point) -(climacs-gui::global-set-key '(#\- :control) 'com-previous-talking-point) -(climacs-gui::global-set-key '(#\= :meta) 'com-increase-presentation-font-sizes) -(climacs-gui::global-set-key '(#\- :meta) 'com-decrease-presentation-font-sizes) -(climacs-gui::global-set-key '(#\= :control :meta) 'com-last-talking-point) -(climacs-gui::global-set-key '(#\- :control :meta) 'com-first-talking-point) -(climacs-gui::global-set-key '(#\s :control :meta) 'com-flip-slidemacs-syntax) +(esa:set-key 'com-next-talking-point + 'climacs-gui::global-climacs-table + '((#\= :control))) +(esa:set-key 'com-previous-talking-point + 'climacs-gui::global-climacs-table + '((#\- :control))) +(esa:set-key 'com-increase-presentation-font-sizes + 'climacs-gui::global-climacs-table + '((#\= :meta))) +(esa:set-key 'com-decrease-presentation-font-sizes + 'climacs-gui::global-climacs-table + '((#\- :meta))) +(esa:set-key 'com-last-talking-point + 'climacs-gui::global-climacs-table + '((#\= :control :meta))) +(esa:set-key 'com-first-talking-point + 'climacs-gui::global-climacs-table + '((#\- :control :meta))) +(esa:set-key 'com-flip-slidemacs-syntax + 'climacs-gui::global-climacs-table + '((#\s :control :meta))) (climacs-gui::define-named-command com-postscript-print-presentation () (let ((pane (climacs-gui::current-window))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.183 climacs/gui.lisp:1.184 --- climacs/gui.lisp:1.183 Thu Aug 25 10:43:55 2005 +++ climacs/gui.lisp Tue Aug 30 19:28:52 2005 @@ -197,12 +197,21 @@ (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) +(set-key 'com-toggle-overwrite-mode 'global-climacs-table + '((:insert))) + (define-named-command com-not-modified () (setf (needs-saving (buffer (current-window))) nil)) +(set-key 'com-not-modified 'global-climacs-table + '((#\~ :meta :shift))) + (define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:")) (set-fill-column column)) +(set-key `(com-set-fill-column ,*numeric-argument-marker*) 'global-climacs-table + '((#\x :control) (#\f))) + (defun set-fill-column (column) (if (> column 1) (setf (auto-fill-column (current-window)) column) @@ -244,9 +253,21 @@ (define-named-command com-beginning-of-line () (beginning-of-line (point (current-window)))) +(set-key 'com-beginning-of-line 'global-climacs-table + '((:home))) + +(set-key 'com-beginning-of-line 'global-climacs-table + '((#\a :control))) + (define-named-command com-end-of-line () (end-of-line (point (current-window)))) +(set-key 'com-end-of-line 'global-climacs-table + '((#\e :control))) + +(set-key 'com-end-of-line 'global-climacs-table + '((:end))) + (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects") (killp 'boolean :prompt "Kill?")) (let* ((point (point (current-window))) @@ -257,6 +278,16 @@ (region-to-sequence point mark))) (delete-region point mark))) +(set-key `(com-delete-object ,*numeric-argument-marker* + ,*numeric-argument-p*) + 'global-climacs-table + '(#\Rubout)) + +(set-key `(com-delete-object ,*numeric-argument-marker* + ,*numeric-argument-p*) + 'global-climacs-table + '((#\d :control))) + (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects") (killp 'boolean :prompt "Kill?")) (let* ((point (point (current-window))) @@ -267,6 +298,11 @@ (region-to-sequence mark point))) (delete-region mark point))) +(set-key `(com-backward-delete-object ,*numeric-argument-marker* + ,*numeric-argument-p*) + 'global-climacs-table + '(#\Backspace)) + (define-named-command com-zap-to-object () (let* ((item (handler-case (accept 't :prompt "Zap to Object") (error () (progn (beep) @@ -293,27 +329,46 @@ (search-forward item-mark item) (delete-range current-point (- (offset item-mark) current-offset)))) -(define-named-command com-transpose-objects () - (transpose-objects (point (current-window)))) +(set-key 'com-zap-to-character 'global-climacs-table + '((#\z :meta))) (defun transpose-objects (mark) (unless (beginning-of-buffer-p mark) - (when (end-of-line-p mark) - (backward-object mark)) - (let ((object (object-after mark))) - (delete-range mark) - (backward-object mark) - (insert-object mark object) - (forward-object mark)))) + (when (end-of-line-p mark) + (backward-object mark)) + (let ((object (object-after mark))) + (delete-range mark) + (backward-object mark) + (insert-object mark object) + (forward-object mark)))) + +(define-named-command com-transpose-objects () + (transpose-objects (point (current-window)))) + +(set-key 'com-transponse-objects 'global-climacs-table + '((#\t :control))) (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects")) (backward-object (point (current-window)) count)) +(set-key `(com-backward-object ,*numeric-argument-marker*) + 'global-climacs-table + '((#\b :control))) + +(set-key `(com-backward-object ,*numeric-argument-marker*) + 'global-climacs-table + '((:left))) + (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects")) (forward-object (point (current-window)) count)) -(define-named-command com-transpose-words () - (transpose-words (point (current-window)))) +(set-key `(com-forward-object ,*numeric-argument-marker*) + 'global-climacs-table + '((#\f :control))) + +(set-key `(com-forward-object ,*numeric-argument-marker*) + 'global-climacs-table + '((:right))) (defun transpose-words (mark) (let (bw1 bw2 ew1 ew2) @@ -338,8 +393,11 @@ (insert-sequence mark w2) (forward-word mark)))) -(define-named-command com-transpose-lines () - (transpose-lines (point (current-window)))) +(define-named-command com-transpose-words () + (transpose-words (point (current-window)))) + +(set-key 'com-transpose-words 'global-climacs-table + '((#\t :meta))) (defun transpose-lines (mark) (beginning-of-line mark) @@ -363,6 +421,12 @@ (insert-sequence mark line) (insert-object mark #\Newline))) +(define-named-command com-transpose-lines () + (transpose-lines (point (current-window)))) + +(set-key 'com-transpose-lines 'global-climacs-table + '((#\x :control) (#\t :control))) + (define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?")) (let* ((win (current-window)) (point (point win))) @@ -373,6 +437,14 @@ (previous-line point (slot-value win 'goal-column) numarg) (next-line point (slot-value win 'goal-column) (- numarg))))) +(set-key `(com-previous-line ,*numeric-argument-marker*) + 'global-climacs-table + '((#\p :control))) + +(set-key `(com-previous-line ,*numeric-argument-marker*) + 'global-climacs-table + '((:up))) + (define-named-command com-next-line ((numarg 'integer :prompt "How many lines?")) (let* ((win (current-window)) (point (point win))) @@ -383,9 +455,21 @@ (next-line point (slot-value win 'goal-column) numarg) (previous-line point (slot-value win 'goal-column) (- numarg))))) +(set-key `(com-next-line ,*numeric-argument-marker*) + 'global-climacs-table + '((#\n :control))) + +(set-key `(com-next-line ,*numeric-argument-marker*) + 'global-climacs-table + '((:down))) + (define-named-command com-open-line ((numarg 'integer :prompt "How many lines?")) (open-line (point (current-window)) numarg)) +(set-key `(com-open-line ,*numeric-argument-marker*) + 'global-climacs-table + '((#\o :control))) + (defun kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil)) (let ((start (offset mark))) (cond ((= 0 count) @@ -421,14 +505,34 @@ (concatenate-p (eq (previous-command pane) 'com-kill-line))) (kill-line point numarg numargp concatenate-p))) +(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*) + 'global-climacs-table + '((#\k :control))) + (define-named-command com-forward-word ((count 'integer :prompt "Number of words")) (if (plusp count) (forward-word (point (current-window)) count) (backward-word (point (current-window)) (- count)))) +(set-key `(com-forward-word ,*numeric-argument-marker*) + 'global-climacs-table + '((#\f :meta))) + +(set-key `(com-forward-word ,*numeric-argument-marker*) + 'global-climacs-table + '((:right :control))) + (define-named-command com-backward-word ((count 'integer :prompt "Number of words")) (backward-word (point (current-window)) count)) +(set-key `(com-backward-word ,*numeric-argument-marker*) + 'global-climacs-table + '((#\b :meta))) + +(set-key `(com-backward-word ,*numeric-argument-marker*) + 'global-climacs-table + '((:left :control))) + (define-named-command com-delete-word ((count 'integer :prompt "Number of words")) (delete-word (point (current-window)) count)) @@ -458,12 +562,20 @@ (concatenate-p (eq (previous-command pane) 'com-kill-word))) (kill-word point count concatenate-p))) +(set-key `(com-kill-word ,*numeric-argument-marker*) + 'global-climacs-table + '((#\d :meta))) + (define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words")) (let* ((pane (current-window)) (point (point pane)) (concatenate-p (eq (previous-command pane) 'com-backward-kill-word))) (kill-word point (- count) concatenate-p))) +(set-key `(com-backward-kill-word ,*numeric-argument-marker*) + 'global-climacs-table + '((#\Backspace :meta))) + (define-named-command com-mark-word ((count 'integer :prompt "Number of words")) (let* ((pane (current-window)) (point (point pane)) @@ -474,6 +586,10 @@ (forward-word mark count) (backward-word mark (- count))))) +(set-key `(com-mark-word ,*numeric-argument-marker*) + 'global-climacs-table + '((#\@ :meta :shift))) + (define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words")) (backward-delete-word (point (current-window)) count)) @@ -492,12 +608,21 @@ (define-named-command com-upcase-word () (upcase-word (point (current-window)))) +(set-key 'com-upcase-word 'global-climacs-table + '((#\u :meta))) + (define-named-command com-downcase-word () (downcase-word (point (current-window)))) +(set-key 'com-downcase-word 'global-climacs-table + '((#\l :meta))) + (define-named-command com-capitalize-word () (capitalize-word (point (current-window)))) +(set-key 'com-capitalize-word 'global-climacs-table + '((#\c :meta))) + (define-named-command com-tabify-region () (let ((pane (current-window))) (tabify-region @@ -523,15 +648,27 @@ (point (point pane))) (indent-current-line pane point))) +(set-key 'com-indent-line 'global-climacs-table + '((#\Tab))) + +(set-key 'com-indent-line 'global-climacs-table + '((#\i :control))) + (define-named-command com-newline-and-indent () (let* ((pane (current-window)) (point (point pane))) (insert-object point #\Newline) (indent-current-line pane point))) +(set-key 'com-newline-and-indent 'global-climacs-table + '((#\j :control))) + (define-named-command com-delete-indentation () (delete-indentation (point (current-window)))) +(set-key 'com-delete-indentation 'global-climacs-table + '((#\^ :shift :meta))) + (define-named-command com-auto-fill-mode () (let ((pane (current-window))) (setf (auto-fill-mode pane) (not (auto-fill-mode pane))))) @@ -556,6 +693,9 @@ (possibly-fill-line) (setf (offset point) (offset point-backup))))) +(set-key 'com-fill-paragraph 'global-climacs-table + '((#\q :meta))) + (eval-when (:compile-toplevel :load-toplevel) (define-presentation-type completable-pathname () :inherit-from 'pathname)) @@ -715,6 +855,9 @@ :prompt "Find File"))) (find-file filepath))) +(set-key 'com-find-file 'global-climacs-table + '((#\x :control) (#\f :control))) + (defun find-file-read-only (filepath) (cond ((null filepath) (display-message "No file name given.") @@ -755,10 +898,16 @@ (let ((filepath (accept 'completable-pathname :Prompt "Find file read only"))) (find-file-read-only filepath))) +(set-key 'com-find-file-read-only 'global-climacs-table + '((#\x :control) (#\r :control))) + (define-named-command com-toggle-read-only () (let ((buffer (buffer (current-window)))) (setf (read-only-p buffer) (not (read-only-p buffer))))) +(set-key 'com-toggle-read-only 'global-climacs-table + '((#\x :control) (#\q :control))) + (defun set-visited-file-name (filename buffer) (setf (filepath buffer) filename (name buffer) (filepath-filename filename) @@ -782,6 +931,9 @@ (offset (point pane)) (offset (mark pane)))) (redisplay-frame-panes *application-frame*))) +(set-key 'com-insert-file 'global-climacs-table + '((#\x :control) (#\i :control))) + (defgeneric erase-buffer (buffer)) (defmethod erase-buffer ((buffer string)) @@ -844,6 +996,9 @@ (save-buffer buffer) (display-message "No changes need to be saved from ~a" (name buffer))))) +(set-key 'com-save-buffer 'global-climacs-table + '((#\x :control) (#\s :control))) + (defmethod frame-exit :around ((frame climacs)) (loop for buffer in (buffers frame) when (and (needs-saving buffer) @@ -877,6 +1032,9 @@ (needs-saving buffer) nil) (display-message "Wrote: ~a" (filepath buffer)))))) +(set-key 'com-write-buffer 'global-climacs-table + '((#\x :control) (#\w :control))) + (define-presentation-method present (object (type buffer) stream (view textual-view) @@ -933,6 +1091,9 @@ :default-type 'buffer))) (switch-to-buffer buffer))) +(set-key 'com-switch-to-buffer 'global-climacs-table + '((#\x :control) (#\b))) + (defgeneric kill-buffer (buffer)) (defmethod kill-buffer ((buffer climacs-buffer)) @@ -964,9 +1125,15 @@ :default-type 'buffer))) (kill-buffer buffer))) +(set-key 'com-kill-buffer 'global-climacs-table + '((#\x :control) (#\k))) + (define-named-command com-full-redisplay () (full-redisplay (current-window))) +(set-key 'com-full-redisplay 'global-climacs-table + '((#\l :control))) + (defun load-file (file-name) (cond ((directory-pathname-p file-name) (display-message "~A is a directory name." file-name) @@ -983,24 +1150,54 @@ :prompt "Load File"))) (load-file filepath))) +(set-key 'com-load-file 'global-climacs-table + '((#\c :control) (#\l :control))) + (define-named-command com-beginning-of-buffer () (beginning-of-buffer (point (current-window)))) +(set-key 'com-beginning-of-buffer 'global-climacs-table + '((#\< :shift :meta))) + +(set-key 'com-beginning-of-buffer 'global-climacs-table + '((:home :control))) + (define-named-command com-page-down () (let ((pane (current-window))) (page-down pane))) +(set-key 'com-page-down 'global-climacs-table + '((#\v :control))) + +(set-key 'com-page-down 'global-climacs-table + '((:next))) + (define-named-command com-page-up () (let ((pane (current-window))) (page-up pane))) +(set-key 'com-page-up 'global-climacs-table + '((#\v :meta))) + +(set-key 'com-page-up 'global-climacs-table + '((:prior))) + (define-named-command com-end-of-buffer () (end-of-buffer (point (current-window)))) +(set-key 'com-end-of-buffer 'global-climacs-table + '((#\> :shift :meta))) + +(set-key 'com-end-of-buffer 'global-climacs-table + '((:end :control))) + (define-named-command com-mark-whole-buffer () (beginning-of-buffer (point (current-window))) (end-of-buffer (mark (current-window)))) +(set-key 'com-mark-whole-buffer 'global-climacs-table + '((#\x :control) (#\h))) + (defun back-to-indentation (mark) (beginning-of-line mark) (loop until (end-of-line-p mark) @@ -1010,6 +1207,9 @@ (define-named-command com-back-to-indentation () (back-to-indentation (point (current-window)))) +(set-key 'com-back-to-indentation 'global-climacs-table + '((#\m :meta))) + (defun delete-horizontal-space (mark &optional (backward-only-p nil)) (let ((mark2 (clone-mark mark))) (loop until (beginning-of-line-p mark) @@ -1025,6 +1225,10 @@ 'boolean :prompt "Delete backwards only?")) (delete-horizontal-space (point (current-window)) backward-only-p)) +(set-key `(com-delete-horizontal-space ,*numeric-argument-p*) + 'global-climacs-table + '((#\\ :meta))) + (defun just-one-space (mark count) (let (offset) (loop until (beginning-of-line-p mark) @@ -1042,6 +1246,10 @@ (define-named-command com-just-one-space ((count 'integer :prompt "Number of spaces")) (just-one-space (point (current-window)) count)) +(set-key `(com-just-one-space ,*numeric-argument-marker*) + 'global-climacs-table + '((#\Space :meta))) + (defun goto-position (mark pos) (setf (offset mark) pos)) @@ -1081,11 +1289,17 @@ (let ((pane (current-window))) (setf (mark pane) (clone-mark (point pane))))) +(set-key 'com-set-mark 'global-climacs-table + '((#\Space :control))) + (define-named-command com-exchange-point-and-mark () (let ((pane (current-window))) (psetf (offset (mark pane)) (offset (point pane)) (offset (point pane)) (offset (mark pane))))) +(set-key 'com-exchange-point-and-mark 'global-climacs-table + '((#\x :control) (#\x :control))) + (defgeneric set-syntax (buffer syntax)) (defmethod set-syntax ((buffer climacs-buffer) (syntax syntax)) @@ -1188,6 +1402,9 @@ (define-named-command com-split-window-vertically () (split-window-vertically)) +(set-key 'com-split-window-vertically 'global-climacs-table + '((#\x :control) (#\2))) + (defun split-window-horizontally (&optional (pane (current-window))) (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) @@ -1210,6 +1427,9 @@ (define-named-command com-split-window-horizontally () (split-window-horizontally)) +(set-key 'com-split-window-horizontally 'global-climacs-table + '((#\x :control) (#\3))) + (defun other-window () (setf (windows *application-frame*) (append (cdr (windows *application-frame*)) @@ -1219,6 +1439,9 @@ (define-named-command com-other-window () (other-window)) +(set-key 'com-other-window 'global-climacs-table + '((#\x :control) (#\o))) + (defun single-window () (loop until (null (cdr (windows *application-frame*))) do (rotatef (car (windows *application-frame*)) @@ -1229,16 +1452,25 @@ (define-named-command com-single-window () (single-window)) +(set-key 'com-single-window 'global-climacs-table + '((#\x :control) (#\1))) + (define-named-command com-scroll-other-window () (let ((other-window (second (windows *application-frame*)))) (when other-window (page-down other-window)))) +(set-key 'com-scroll-other-window 'global-climacs-table + '((#\v :control :meta))) + (define-named-command com-scroll-other-window-up () (let ((other-window (second (windows *application-frame*)))) (when other-window (page-up other-window)))) +(set-key 'com-scroll-other-window-up 'global-climacs-table + '((#\V :control :meta :shift))) + (defun delete-window (&optional (window (current-window))) (unless (null (cdr (windows *application-frame*))) (let* ((constellation (if *with-scrollbars* @@ -1271,6 +1503,9 @@ (define-named-command com-delete-window () (delete-window)) +(set-key 'com-delete-window 'global-climacs-table + '((#\x :control) (#\0))) + ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -1278,6 +1513,9 @@ (define-named-command com-yank () (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))) +(set-key 'com-yank 'global-climacs-table + '((#\y :control))) + ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-kill-region () (let ((pane (current-window))) @@ -1285,11 +1523,17 @@ *kill-ring* (region-to-sequence (mark pane) (point pane))) (delete-region (mark pane) (point pane)))) +(set-key 'com-kill-region 'global-climacs-table + '((#\w :control))) + ;; Non destructively copies buffer region to the kill ring (define-named-command com-copy-region () (let ((pane (current-window))) (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane))))) +(set-key 'com-copy-region 'global-climacs-table + '((#\w :control))) + (define-named-command com-rotate-yank () (let* ((pane (current-window)) (point (point pane)) @@ -1301,6 +1545,9 @@ (rotate-yank-position *kill-ring*))) (insert-sequence point (kill-ring-yank *kill-ring*)))) +(set-key 'com-rotate-yank 'global-climacs-table + '((#\y :meta))) + (define-named-command com-resize-kill-ring () (let ((size (handler-case (accept 'integer :prompt "New kill ring size") (error () (progn (beep) @@ -1311,6 +1558,9 @@ (define-named-command com-append-next-kill () (setf (append-next-p *kill-ring*) t)) +(set-key 'com-append-next-kill 'global-climacs-table + '((#\w :control :meta))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Incremental search @@ -1364,10 +1614,16 @@ (display-message "Isearch: ") (isearch-command-loop (current-window) t)) +(set-key 'com-isearch-forward 'global-climacs-table + '((#\s :control))) + (define-named-command com-isearch-backward () (display-message "Isearch backward: ") (isearch-command-loop (current-window) nil)) +(set-key 'com-isearch-backward 'global-climacs-table + '((#\r :control))) + (define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (states (isearch-states pane)) @@ -1493,6 +1749,9 @@ ((setf (query-replace-mode pane) nil)))) (display-message "Replaced ~A occurrence~:P" occurrences))) +(set-key 'com-query-replace 'global-climacs-table + '((#\% :shift :meta))) + (define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) @@ -1550,11 +1809,23 @@ (no-more-undo () (beep) (display-message "No more undo"))) (full-redisplay (current-window))) +(set-key 'com-undo 'global-climacs-table + '((#\_ :shift :control))) + +(set-key 'com-undo 'global-climacs-table + '((#\x :control) (#\u))) + (define-named-command com-redo () (handler-case (redo (undo-tree (buffer (current-window)))) (no-more-undo () (beep) (display-message "No more redo"))) (full-redisplay (current-window))) +(set-key 'com-redo 'global-climacs-table + '((#\_ :shift :meta))) + +(set-key 'com-redo 'global-climacs-table + '((#\x :control) (#\r :control))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dynamic abbrevs @@ -1596,6 +1867,8 @@ (setf (offset dabbrev-expansion-mark) offset)))) (move)))))))) +(set-key 'com-dabbrev-expand 'global-climacs-table + '((#\/ :meta))) (define-named-command com-backward-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) @@ -1605,6 +1878,10 @@ (loop repeat count do (backward-paragraph point syntax)) (loop repeat (- count) do (forward-paragraph point syntax))))) +(set-key `(com-backward-paragraph ,*numeric-argument-marker*) + 'global-climacs-table + '((#\{ :shift :meta))) + (define-named-command com-forward-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) (point (point pane)) @@ -1613,6 +1890,10 @@ (loop repeat count do (forward-paragraph point syntax)) (loop repeat (- count) do (backward-paragraph point syntax))))) +(set-key `(com-forward-paragraph ,*numeric-argument-marker*) + 'global-climacs-table + '((#\} :shift :meta))) + (define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs")) (let* ((pane (current-window)) (point (point pane)) @@ -1627,6 +1908,10 @@ (loop repeat count do (forward-paragraph mark syntax)) (loop repeat (- count) do (backward-paragraph mark syntax))))) +(set-key `(com-mark-paragraph ,*numeric-argument-marker*) + 'global-climacs-table + '((#\h :meta))) + (define-named-command com-backward-sentence ((count 'integer :prompt "Number of sentences")) (let* ((pane (current-window)) (point (point pane)) @@ -1635,6 +1920,10 @@ (loop repeat count do (backward-sentence point syntax)) (loop repeat (- count) do (forward-sentence point syntax))))) +(set-key `(com-backward-sentence ,*numeric-argument-marker*) + 'global-climacs-table + '((#\a :meta))) + (define-named-command com-forward-sentence ((count 'integer :prompt "Number of sentences")) (let* ((pane (current-window)) (point (point pane)) @@ -1643,6 +1932,10 @@ (loop repeat count do (forward-sentence point syntax)) (loop repeat (- count) do (backward-sentence point syntax))))) +(set-key `(com-forward-sentence ,*numeric-argument-marker*) + 'global-climacs-table + '((#\e :meta))) + (define-named-command com-kill-sentence ((count 'integer :prompt "Number of sentences")) (let* ((pane (current-window)) (point (point pane)) @@ -1654,6 +1947,10 @@ (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) (delete-region point mark))) +(set-key `(com-kill-sentence *numeric-argument-marker*) + 'global-climacs-table + '((#\k :meta))) + (define-named-command com-backward-kill-sentence ((count 'integer :prompt "Number of sentences")) (let* ((pane (current-window)) (point (point pane)) @@ -1665,6 +1962,10 @@ (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) (delete-region point mark))) +(set-key `(com-backward-kill-sentence ,*numeric-argument-marker*) + 'global-climacs-table + '((#\x :control) (#\Backspace))) + (defun forward-page (mark &optional (count 1)) (loop repeat count unless (search-forward mark (coerce (list #\Newline #\Page) 'vector)) @@ -1678,6 +1979,10 @@ (forward-page point count) (backward-page point count)))) +(set-key `(com-forward-page ,*numeric-argument-marker*) + 'global-climacs-table + '((#\x :control) (#\]))) + (defun backward-page (mark &optional (count 1)) (loop repeat count when (search-backward mark (coerce (list #\Newline #\Page) 'vector)) @@ -1692,6 +1997,9 @@ (backward-page point count) (forward-page point count)))) +(set-key 'com-backward-page 'global-climacs-table + '((#\x :control) (#\[))) + (define-named-command com-mark-page ((count 'integer :prompt "Move how many pages") (numargp 'boolean :prompt "Move to another page?")) (let* ((pane (current-window)) @@ -1705,6 +2013,10 @@ (setf (offset mark) (offset point)) (forward-page mark 1))) +(set-key `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*) + 'global-climacs-table + '((#\x :control) (#\p :control))) + (define-named-command com-count-lines-page () (let* ((pane (current-window)) (point (point pane)) @@ -1717,6 +2029,9 @@ (after (number-of-lines-in-region point end))) (display-message "Page has ~A lines (~A + ~A)" total before after)))) +(set-key 'com-count-lines-page 'global-climacs-table + '((#\x :control) (#\l))) + (define-named-command com-count-lines-region () (let* ((pane (current-window)) (point (point pane)) @@ -1725,6 +2040,9 @@ (chars (abs (- (offset point) (offset mark))))) (display-message "Region has ~D line~:P, ~D character~:P." lines chars))) +(set-key 'com-count-lines-region 'global-climacs-table + '((#\= :meta))) + (define-named-command com-what-cursor-position () (let* ((pane (current-window)) (point (point pane)) @@ -1737,6 +2055,9 @@ char (char-code char) offset size (round (* 100 (/ offset size))) column))) +(set-key 'com-what-cursor-position 'global-climacs-table + '((#\x :control) (#\=))) + (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?")) (let* ((*package* (find-package :climacs-gui)) (string (handler-case (accept 'string :prompt "Eval") @@ -1753,6 +2074,10 @@ (insert-sequence (point (current-window)) result) (display-message result)))) +(set-key `(com-eval-expression ,*numeric-argument-p*) + 'global-climacs-table + '((#\: :shift :meta))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting @@ -1773,6 +2098,10 @@ (loop repeat count do (backward-expression point syntax)) (loop repeat (- count) do (forward-expression point syntax))))) +(set-key `(com-backward-expression ,*numeric-argument-marker*) + 'global-climacs-table + '((#\b :control :meta))) + (define-named-command com-forward-expression ((count 'integer :prompt "Number of expresssions")) (let* ((pane (current-window)) (point (point pane)) @@ -1781,6 +2110,10 @@ (loop repeat count do (forward-expression point syntax)) (loop repeat (- count) do (backward-expression point syntax))))) +(set-key `(com-forward-expression ,*numeric-argument-marker*) + 'global-climacs-table + '((#\f :control :meta))) + (define-named-command com-mark-expression ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) (point (point pane)) @@ -1792,6 +2125,10 @@ (loop repeat count do (forward-expression mark syntax)) (loop repeat (- count) do (backward-expression mark syntax))))) +(set-key `(com-mark-expression ,*numeric-argument-marker*) + 'global-climacs-table + '((#\@ :shift :control :meta))) + (define-named-command com-kill-expression ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) (point (point pane)) @@ -1803,6 +2140,10 @@ (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) (delete-region mark point))) +(set-key `(com-kill-expression ,*numeric-argument-marker*) + 'global-climacs-table + '((#\k :control :meta))) + (define-named-command com-backward-kill-expression ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) @@ -1815,6 +2156,10 @@ (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) (delete-region mark point))) +(set-key `(com-backward-kill-expression ,*numeric-argument-marker*) + 'global-climacs-table + '((#\Backspace :control :meta))) + (define-named-command com-forward-list ((count 'integer :prompt "Number of lists")) (let* ((pane (current-window)) (point (point pane)) @@ -1823,6 +2168,10 @@ (loop repeat count do (forward-list point syntax)) (loop repeat (- count) do (backward-list point syntax))))) +(set-key `(com-forward-list ,*numeric-argument-marker*) + 'global-climacs-table + '((#\n :control :meta))) + (define-named-command com-backward-list ((count 'integer :prompt "Number of lists")) (let* ((pane (current-window)) (point (point pane)) @@ -1831,6 +2180,10 @@ (loop repeat count do (backward-list point syntax)) (loop repeat (- count) do (forward-list point syntax))))) +(set-key `(com-backward-list ,*numeric-argument-marker*) + 'global-climacs-table + '((#\p :control :meta))) + (define-named-command com-down-list ((count 'integer :prompt "Number of lists")) (let* ((pane (current-window)) (point (point pane)) @@ -1839,6 +2192,10 @@ (loop repeat count do (down-list point syntax)) (loop repeat (- count) do (backward-down-list point syntax))))) +(set-key `(com-down-list ,*numeric-argument-marker*) + 'global-climacs-table + '((#\d :control :meta))) + (define-named-command com-backward-down-list ((count 'integer :prompt "Number of lists")) (let* ((pane (current-window)) (point (point pane)) @@ -1855,6 +2212,10 @@ (loop repeat count do (backward-up-list point syntax)) (loop repeat (- count) do (up-list point syntax))))) +(set-key `(com-backward-up-list ,*numeric-argument-marker*) + 'global-climacs-table + '((#\u :control :meta))) + (define-named-command com-up-list ((count 'integer :prompt "Number of lists")) (let* ((pane (current-window)) (point (point pane)) @@ -1869,6 +2230,9 @@ (syntax (syntax (buffer pane)))) (eval-defun point syntax))) +(set-key 'com-eval-defun 'global-climacs-table + '((#\x :control :meta))) + (define-named-command com-beginning-of-definition ((count 'integer :prompt "Number of definitions")) (let* ((pane (current-window)) (point (point pane)) @@ -1877,6 +2241,10 @@ (loop repeat count do (beginning-of-definition point syntax)) (loop repeat (- count) do (end-of-definition point syntax))))) +(set-key `(com-beginning-of-definition ,*numeric-argument-marker*) + 'global-climacs-table + '((#\a :control :meta))) + (define-named-command com-end-of-definition ((count 'integer :prompt "Number of definitions")) (let* ((pane (current-window)) (point (point pane)) @@ -1885,6 +2253,10 @@ (loop repeat count do (end-of-definition point syntax)) (loop repeat (- count) do (beginning-of-definition point syntax))))) +(set-key `(com-end-of-definition ,*numeric-argument-marker*) + 'global-climacs-table + '((#\e :control :meta))) + (define-named-command com-mark-definition () (let* ((pane (current-window)) (point (point pane)) @@ -1895,6 +2267,9 @@ (setf (offset mark) (offset point))) (end-of-definition mark syntax))) +(set-key 'com-mark-definition 'global-climacs-table + '((#\h :control :meta))) + (define-named-command com-package () (let* ((pane (current-window)) (syntax (syntax (buffer pane))) @@ -1940,159 +2315,14 @@ (define-named-command com-toggle-visible-mark () (setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Dead-escape command tables - -(make-command-table 'dead-escape-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "dead-escape" - :menu 'dead-escape-climacs-table - :keystroke '(:escape)) - -(defun dead-escape-set-key (gesture command) - (add-command-to-command-table command 'dead-escape-climacs-table - :keystroke gesture :errorp nil)) - -(dead-escape-set-key '(#\x) 'esa::com-extended-command) - -(defun global-set-key (gesture command) - (add-command-to-command-table command 'global-climacs-table - :keystroke gesture :errorp nil) - (when (and - (listp gesture) - (find :meta gesture)) - (dead-escape-set-key (remove :meta gesture) command))) - (loop for code from (char-code #\Space) to (char-code #\~) - do (global-set-key (code-char code) `(com-self-insert ,*numeric-argument-marker*))) - -(global-set-key #\Newline `(com-self-insert ,*numeric-argument-marker*)) -(global-set-key #\Tab 'com-indent-line) -(global-set-key '(#\i :control) 'com-indent-line) -(global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*)) -(global-set-key '(#\j :control) 'com-newline-and-indent) -(global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) -(global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) -(global-set-key '(#\a :control) 'com-beginning-of-line) -(global-set-key '(#\e :control) 'com-end-of-line) -(global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*)) -(global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*)) -(global-set-key '(#\l :control) 'com-full-redisplay) -(global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*)) -(global-set-key '(#\o :control) `(com-open-line ,*numeric-argument-marker*)) -(global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*)) -(global-set-key '(#\t :control) 'com-transpose-objects) -(global-set-key '(#\Space :control) 'com-set-mark) -(global-set-key '(#\y :control) 'com-yank) -(global-set-key '(#\w :control) 'com-kill-region) -(global-set-key '(#\w :control :meta) 'com-append-next-kill) -(global-set-key '(#\e :meta) `(com-forward-sentence ,*numeric-argument-marker*)) -(global-set-key '(#\a :meta) `(com-backward-sentence ,*numeric-argument-marker*)) -(global-set-key '(#\k :meta) `(com-kill-sentence ,*numeric-argument-marker*)) -(global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*)) -(global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*)) -(global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*)) -(global-set-key '(#\t :meta) 'com-transpose-words) -(global-set-key '(#\u :meta) 'com-upcase-word) -(global-set-key '(#\l :meta) 'com-downcase-word) -(global-set-key '(#\c :meta) 'com-capitalize-word) -(global-set-key '(#\y :meta) 'com-rotate-yank) -(global-set-key '(#\z :meta) 'com-zap-to-character) -(global-set-key '(#\w :meta) 'com-copy-region) -(global-set-key '(#\v :control) 'com-page-down) -(global-set-key '(#\v :meta) 'com-page-up) -(global-set-key '(#\v :control :meta) 'com-scroll-other-window) -(global-set-key '(#\V :control :meta :shift) 'com-scroll-other-window-up) -(global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) -(global-set-key '(#\> :shift :meta) 'com-end-of-buffer) -(global-set-key '(#\m :meta) 'com-back-to-indentation) -(global-set-key '(#\\ :meta) `(com-delete-horizontal-space ,*numeric-argument-p*)) -(global-set-key '(#\Space :meta) `(com-just-one-space ,*numeric-argument-marker*)) -(global-set-key '(#\^ :shift :meta) 'com-delete-indentation) -(global-set-key '(#\q :meta) 'com-fill-paragraph) -(global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*)) -(global-set-key '(#\Backspace :meta) `(com-backward-kill-word ,*numeric-argument-marker*)) -(global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*)) -(global-set-key '(#\/ :meta) 'com-dabbrev-expand) -(global-set-key '(#\{ :meta :shift) `(com-backward-paragraph ,*numeric-argument-marker*)) -(global-set-key '(#\} :meta :shift) `(com-forward-paragraph ,*numeric-argument-marker*)) -(global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*)) -(global-set-key '(#\s :control) 'com-isearch-forward) -(global-set-key '(#\r :control) 'com-isearch-backward) -(global-set-key '(#\_ :shift :meta) 'com-redo) -(global-set-key '(#\_ :shift :control) 'com-undo) -(global-set-key '(#\% :shift :meta) 'com-query-replace) -(global-set-key '(#\= :meta) 'com-count-lines-region) -(global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*)) -(global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*)) -(global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*)) -(global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*)) -(global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*)) -(global-set-key '(:right :control) `(com-forward-word ,*numeric-argument-marker*)) -(global-set-key '(:home) 'com-beginning-of-line) -(global-set-key '(:end) 'com-end-of-line) -(global-set-key '(:prior) 'com-page-up) -(global-set-key '(:next) 'com-page-down) -(global-set-key '(:home :control) 'com-beginning-of-buffer) -(global-set-key '(:end :control) 'com-end-of-buffer) -(global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*)) -(global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*)) - -(global-set-key '(:insert) 'com-toggle-overwrite-mode) -(global-set-key '(#\~ :meta :shift) 'com-not-modified) - -(global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*)) -(global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*)) -(global-set-key '(#\Backspace :control :meta) `(com-backward-kill-expression ,*numeric-argument-marker*)) -(global-set-key '(#\k :control :meta) `(com-kill-expression ,*numeric-argument-marker*)) -(global-set-key '(#\n :control :meta) `(com-forward-list ,*numeric-argument-marker*)) -(global-set-key '(#\p :control :meta) `(com-backward-list ,*numeric-argument-marker*)) -(global-set-key '(#\d :control :meta) `(com-down-list ,*numeric-argument-marker*)) -(global-set-key '(#\u :control :meta) `(com-backward-up-list ,*numeric-argument-marker*)) -(global-set-key '(#\x :control :meta) 'com-eval-defun) -(global-set-key '(#\a :control :meta) `(com-beginning-of-definition ,*numeric-argument-marker*)) -(global-set-key '(#\e :control :meta) `(com-end-of-definition ,*numeric-argument-marker*)) -(global-set-key '(#\h :control :meta) 'com-mark-definition) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; C-x command table - -(make-command-table 'c-x-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "C-x" - :menu 'c-x-climacs-table - :keystroke '(#\x :control)) - -(defun c-x-set-key (gesture command) - (add-command-to-command-table command 'c-x-climacs-table - :keystroke gesture :errorp nil)) - -(c-x-set-key '(#\0) 'com-delete-window) -(c-x-set-key '(#\1) 'com-single-window) -(c-x-set-key '(#\2) 'com-split-window-vertically) -(c-x-set-key '(#\3) 'com-split-window-horizontally) -(c-x-set-key '(#\b) 'com-switch-to-buffer) -(c-x-set-key '(#\f :control) 'com-find-file) -(c-x-set-key '(#\r :control) 'com-find-file-read-only) -(c-x-set-key '(#\q :control) 'com-toggle-read-only) -(c-x-set-key '(#\f) `(com-set-fill-column ,*numeric-argument-marker*)) -(c-x-set-key '(#\h) 'com-mark-whole-buffer) -(c-x-set-key '(#\i) 'com-insert-file) -(c-x-set-key '(#\k) 'com-kill-buffer) -(c-x-set-key '(#\o) 'com-other-window) -(c-x-set-key '(#\r) 'com-redo) -(c-x-set-key '(#\u) 'com-undo) -(c-x-set-key '(#\]) `(com-forward-page ,*numeric-argument-marker*)) -(c-x-set-key '(#\[) `(com-backward-page ,*numeric-argument-marker*)) -(c-x-set-key '(#\p :control) `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*)) -(c-x-set-key '(#\l) 'com-count-lines-page) -(c-x-set-key '(#\s :control) 'com-save-buffer) -(c-x-set-key '(#\t :control) 'com-transpose-lines) -(c-x-set-key '(#\w :control) 'com-write-buffer) -(c-x-set-key '(#\x :control) 'com-exchange-point-and-mark) -(c-x-set-key '(#\=) 'com-what-cursor-position) -(c-x-set-key '(#\Backspace) `(com-backward-kill-sentence ,*numeric-argument-marker*)) + do (set-key `(com-self-insert ,*numeric-argument-marker*) + 'global-climacs-table + (list (list (code-char code))))) + +(set-key `(com-self-insert ,*numeric-argument-marker*) + 'global-climacs-table + '((#\Newline))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -2101,174 +2331,78 @@ (define-named-command com-insert-charcode ((code 'integer :prompt "Code point")) (insert-object (point (current-window)) (code-char code))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Dead-acute command table - -(make-command-table 'dead-acute-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "dead-acute" - :menu 'dead-acute-climacs-table - :keystroke '(:dead--acute)) - -(defun dead-acute-set-key (gesture command) - (add-command-to-command-table command 'dead-acute-climacs-table - :keystroke gesture :errorp nil)) - -(dead-acute-set-key '(#\A) '(com-insert-charcode 193)) -(dead-acute-set-key '(#\E) '(com-insert-charcode 201)) -(dead-acute-set-key '(#\I) '(com-insert-charcode 205)) -(dead-acute-set-key '(#\O) '(com-insert-charcode 211)) -(dead-acute-set-key '(#\U) '(com-insert-charcode 218)) -(dead-acute-set-key '(#\Y) '(com-insert-charcode 221)) -(dead-acute-set-key '(#\a) '(com-insert-charcode 225)) -(dead-acute-set-key '(#\e) '(com-insert-charcode 233)) -(dead-acute-set-key '(#\i) '(com-insert-charcode 237)) -(dead-acute-set-key '(#\o) '(com-insert-charcode 243)) -(dead-acute-set-key '(#\u) '(com-insert-charcode 250)) -(dead-acute-set-key '(#\y) '(com-insert-charcode 253)) -(dead-acute-set-key '(#\C) '(com-insert-charcode 199)) -(dead-acute-set-key '(#\c) '(com-insert-charcode 231)) -(dead-acute-set-key '(#\x) '(com-insert-charcode 215)) -(dead-acute-set-key '(#\-) '(com-insert-charcode 247)) -(dead-acute-set-key '(#\T) '(com-insert-charcode 222)) -(dead-acute-set-key '(#\t) '(com-insert-charcode 254)) -(dead-acute-set-key '(#\s) '(com-insert-charcode 223)) -(dead-acute-set-key '(#\Space) '(com-insert-charcode 39)) - -(make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute" - :menu 'dead-acute-dead-accute-climacs-table - :keystroke '(:dead--acute)) - -(defun dead-acute-dead-accute-set-key (gesture command) - (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table - :keystroke gesture :errorp nil)) - -(dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197)) -(dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Dead-grave command table - -(make-command-table 'dead-grave-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "dead-grave" - :menu 'dead-grave-climacs-table - :keystroke '(:dead--grave)) - -(defun dead-grave-set-key (gesture command) - (add-command-to-command-table command 'dead-grave-climacs-table - :keystroke gesture :errorp nil)) - -(dead-grave-set-key '(#\A) '(com-insert-charcode 192)) -(dead-grave-set-key '(#\E) '(com-insert-charcode 200)) -(dead-grave-set-key '(#\I) '(com-insert-charcode 204)) -(dead-grave-set-key '(#\O) '(com-insert-charcode 210)) -(dead-grave-set-key '(#\U) '(com-insert-charcode 217)) -(dead-grave-set-key '(#\a) '(com-insert-charcode 224)) -(dead-grave-set-key '(#\e) '(com-insert-charcode 232)) -(dead-grave-set-key '(#\i) '(com-insert-charcode 236)) -(dead-grave-set-key '(#\o) '(com-insert-charcode 242)) -(dead-grave-set-key '(#\u) '(com-insert-charcode 249)) -(dead-grave-set-key '(#\Space) '(com-insert-charcode 96)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Dead-diaeresis command table - -(make-command-table 'dead-diaeresis-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis" - :menu 'dead-diaeresis-climacs-table - :keystroke '(:dead--diaeresis :shift)) - -(defun dead-diaeresis-set-key (gesture command) - (add-command-to-command-table command 'dead-diaeresis-climacs-table - :keystroke gesture :errorp nil)) - -(dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196)) -(dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203)) -(dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207)) -(dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214)) -(dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220)) -(dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228)) -(dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235)) -(dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239)) -(dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246)) -(dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252)) -(dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255)) -(dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Dead-tilde command table - -(make-command-table 'dead-tilde-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "dead-tilde" - :menu 'dead-tilde-climacs-table - :keystroke '(:dead--tilde :shift)) - -(defun dead-tilde-set-key (gesture command) - (add-command-to-command-table command 'dead-tilde-climacs-table - :keystroke gesture :errorp nil)) - -(dead-tilde-set-key '(#\A) '(com-insert-charcode 195)) -(dead-tilde-set-key '(#\N) '(com-insert-charcode 209)) -(dead-tilde-set-key '(#\a) '(com-insert-charcode 227)) -(dead-tilde-set-key '(#\n) '(com-insert-charcode 241)) -(dead-tilde-set-key '(#\E) '(com-insert-charcode 198)) -(dead-tilde-set-key '(#\e) '(com-insert-charcode 230)) -(dead-tilde-set-key '(#\D) '(com-insert-charcode 208)) -(dead-tilde-set-key '(#\d) '(com-insert-charcode 240)) -(dead-tilde-set-key '(#\O) '(com-insert-charcode 216)) -(dead-tilde-set-key '(#\o) '(com-insert-charcode 248)) -(dead-tilde-set-key '(#\Space) '(com-insert-charcode 126)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Dead-circumflex command table - -(make-command-table 'dead-circumflex-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "dead-circumflex" - :menu 'dead-circumflex-climacs-table - :keystroke '(:dead--circumflex :shift)) - -(defun dead-circumflex-set-key (gesture command) - (add-command-to-command-table command 'dead-circumflex-climacs-table - :keystroke gesture :errorp nil)) - -(dead-circumflex-set-key '(#\A) '(com-insert-charcode 194)) -(dead-circumflex-set-key '(#\E) '(com-insert-charcode 202)) -(dead-circumflex-set-key '(#\I) '(com-insert-charcode 206)) -(dead-circumflex-set-key '(#\O) '(com-insert-charcode 212)) -(dead-circumflex-set-key '(#\U) '(com-insert-charcode 219)) -(dead-circumflex-set-key '(#\a) '(com-insert-charcode 226)) -(dead-circumflex-set-key '(#\e) '(com-insert-charcode 234)) -(dead-circumflex-set-key '(#\i) '(com-insert-charcode 238)) -(dead-circumflex-set-key '(#\o) '(com-insert-charcode 244)) -(dead-circumflex-set-key '(#\u) '(com-insert-charcode 251)) -(dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; C-c command table - -(make-command-table 'c-c-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "C-c" - :menu 'c-c-climacs-table - :keystroke '(#\c :control)) - -(defun c-c-set-key (gesture command) - (add-command-to-command-table command 'c-c-climacs-table - :keystroke gesture :errorp nil)) - -(c-c-set-key '(#\l :control) 'com-load-file) +(set-key '(com-insert-charcode 193) 'global-climacs-table '((:dead--acute)(#\A))) +(set-key '(com-insert-charcode 201) 'global-climacs-table '((:dead--acute)(#\E))) +(set-key '(com-insert-charcode 205) 'global-climacs-table '((:dead--acute)(#\I))) +(set-key '(com-insert-charcode 211) 'global-climacs-table '((:dead--acute)(#\O))) +(set-key '(com-insert-charcode 218) 'global-climacs-table '((:dead--acute)(#\U))) +(set-key '(com-insert-charcode 221) 'global-climacs-table '((:dead--acute)(#\Y))) +(set-key '(com-insert-charcode 225) 'global-climacs-table '((:dead--acute)(#\a))) +(set-key '(com-insert-charcode 233) 'global-climacs-table '((:dead--acute)(#\e))) +(set-key '(com-insert-charcode 237) 'global-climacs-table '((:dead--acute)(#\i))) +(set-key '(com-insert-charcode 243) 'global-climacs-table '((:dead--acute)(#\o))) +(set-key '(com-insert-charcode 250) 'global-climacs-table '((:dead--acute)(#\u))) +(set-key '(com-insert-charcode 253) 'global-climacs-table '((:dead--acute)(#\y))) +(set-key '(com-insert-charcode 199) 'global-climacs-table '((:dead--acute)(#\C))) +(set-key '(com-insert-charcode 231) 'global-climacs-table '((:dead--acute)(#\c))) +(set-key '(com-insert-charcode 215) 'global-climacs-table '((:dead--acute)(#\x))) +(set-key '(com-insert-charcode 247) 'global-climacs-table '((:dead--acute)(#\-))) +(set-key '(com-insert-charcode 222) 'global-climacs-table '((:dead--acute)(#\T))) +(set-key '(com-insert-charcode 254) 'global-climacs-table '((:dead--acute)(#\t))) +(set-key '(com-insert-charcode 223) 'global-climacs-table '((:dead--acute)(#\s))) +(set-key '(com-insert-charcode 39) 'global-climacs-table '((:dead--acute)(#\Space))) + +(set-key '(com-insert-charcode 197) 'global-climacs-table '((:dead--acute)(:dead--acute)(#\A))) +(set-key '(com-insert-charcode 229) 'global-climacs-table '((:dead--acute)(:dead--acute)(#\a))) + +(set-key '(com-insert-charcode 192) 'global-climacs-table '((:dead--grave)(#\A))) +(set-key '(com-insert-charcode 200) 'global-climacs-table '((:dead--grave)(#\E))) +(set-key '(com-insert-charcode 204) 'global-climacs-table '((:dead--grave)(#\I))) +(set-key '(com-insert-charcode 210) 'global-climacs-table '((:dead--grave)(#\O))) +(set-key '(com-insert-charcode 217) 'global-climacs-table '((:dead--grave)(#\U))) +(set-key '(com-insert-charcode 224) 'global-climacs-table '((:dead--grave)(#\a))) +(set-key '(com-insert-charcode 232) 'global-climacs-table '((:dead--grave)(#\e))) +(set-key '(com-insert-charcode 236) 'global-climacs-table '((:dead--grave)(#\i))) +(set-key '(com-insert-charcode 242) 'global-climacs-table '((:dead--grave)(#\o))) +(set-key '(com-insert-charcode 249) 'global-climacs-table '((:dead--grave)(#\u))) +(set-key '(com-insert-charcode 96) 'global-climacs-table '((:dead--grave)(#\Space))) + +(set-key '(com-insert-charcode 196) 'global-climacs-table '((:dead--diaeresis :shift)(#\A))) +(set-key '(com-insert-charcode 203) 'global-climacs-table '((:dead--diaeresis :shift)(#\E))) +(set-key '(com-insert-charcode 207) 'global-climacs-table '((:dead--diaeresis :shift)(#\I))) +(set-key '(com-insert-charcode 214) 'global-climacs-table '((:dead--diaeresis :shift)(#\O))) +(set-key '(com-insert-charcode 220) 'global-climacs-table '((:dead--diaeresis :shift)(#\U))) +(set-key '(com-insert-charcode 228) 'global-climacs-table '((:dead--diaeresis :shift)(#\a))) +(set-key '(com-insert-charcode 235) 'global-climacs-table '((:dead--diaeresis :shift)(#\e))) +(set-key '(com-insert-charcode 239) 'global-climacs-table '((:dead--diaeresis :shift)(#\i))) +(set-key '(com-insert-charcode 246) 'global-climacs-table '((:dead--diaeresis :shift)(#\o))) +(set-key '(com-insert-charcode 252) 'global-climacs-table '((:dead--diaeresis :shift)(#\u))) +(set-key '(com-insert-charcode 255) 'global-climacs-table '((:dead--diaeresis :shift)(#\y))) +(set-key '(com-insert-charcode 34) 'global-climacs-table '((:dead--diaeresis :shift)(#\Space))) + +(set-key '(com-insert-charcode 195) 'global-climacs-table '((:dead--tilde :shift)(#\A))) +(set-key '(com-insert-charcode 209) 'global-climacs-table '((:dead--tilde :shift)(#\N))) +(set-key '(com-insert-charcode 227) 'global-climacs-table '((:dead--tilde :shift)(#\a))) +(set-key '(com-insert-charcode 241) 'global-climacs-table '((:dead--tilde :shift)(#\n))) +(set-key '(com-insert-charcode 198) 'global-climacs-table '((:dead--tilde :shift)(#\E))) +(set-key '(com-insert-charcode 230) 'global-climacs-table '((:dead--tilde :shift)(#\e))) +(set-key '(com-insert-charcode 208) 'global-climacs-table '((:dead--tilde :shift)(#\D))) +(set-key '(com-insert-charcode 240) 'global-climacs-table '((:dead--tilde :shift)(#\d))) +(set-key '(com-insert-charcode 216) 'global-climacs-table '((:dead--tilde :shift)(#\O))) +(set-key '(com-insert-charcode 248) 'global-climacs-table '((:dead--tilde :shift)(#\o))) +(set-key '(com-insert-charcode 126) 'global-climacs-table '((:dead--tilde :shift)(#\Space))) + +(set-key '(com-insert-charcode 194) 'global-climacs-table '((:dead--circumflex :shift)(#\A))) +(set-key '(com-insert-charcode 202) 'global-climacs-table '((:dead--circumflex :shift)(#\E))) +(set-key '(com-insert-charcode 206) 'global-climacs-table '((:dead--circumflex :shift)(#\I))) +(set-key '(com-insert-charcode 212) 'global-climacs-table '((:dead--circumflex :shift)(#\O))) +(set-key '(com-insert-charcode 219) 'global-climacs-table '((:dead--circumflex :shift)(#\U))) +(set-key '(com-insert-charcode 226) 'global-climacs-table '((:dead--circumflex :shift)(#\a))) +(set-key '(com-insert-charcode 234) 'global-climacs-table '((:dead--circumflex :shift)(#\e))) +(set-key '(com-insert-charcode 238) 'global-climacs-table '((:dead--circumflex :shift)(#\i))) +(set-key '(com-insert-charcode 244) 'global-climacs-table '((:dead--circumflex :shift)(#\o))) +(set-key '(com-insert-charcode 251) 'global-climacs-table '((:dead--circumflex :shift)(#\u))) +(set-key '(com-insert-charcode 94) 'global-climacs-table '((:dead--circumflex :shift)(#\Space))) (define-named-command com-regex-search-forward () (let ((string (accept 'string :prompt "RE search" Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.13 climacs/esa.lisp:1.14 --- climacs/esa.lisp:1.13 Sat Aug 6 22:51:20 2005 +++ climacs/esa.lisp Tue Aug 30 19:28:52 2005 @@ -301,7 +301,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; comand table manipulation +;;; command table manipulation (defun ensure-subtable (table gesture) (let* ((event (make-instance @@ -319,15 +319,18 @@ (command-menu-item-value (find-keystroke-item event table :errorp nil)))) - (defun set-key (command table gestures) - (if (null (cdr gestures)) - (add-command-to-command-table - command table :keystroke (car gestures) :errorp nil) - (set-key command - (ensure-subtable table (car gestures)) - (cdr gestures)))) - + (let ((gesture (car gestures))) + (cond ((null (cdr gestures)) + (add-command-to-command-table + command table :keystroke gesture :errorp nil) + (when (and (listp gesture) + (find :meta gesture)) + (set-key command table (list (list :escape) (remove :meta gesture))))) + (t (set-key command + (ensure-subtable table gesture) + (cdr gestures)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; standard key bindings