/[climacs]/climacs/gui.lisp
ViewVC logotype

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.177 - (hide annotations)
Mon Aug 15 23:31:22 2005 UTC (8 years, 8 months ago) by dmurray
Branch: MAIN
Changes since 1.176: +3 -0 lines
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.
1 ejohnson 1.27 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2    
3 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
4 ejohnson 1.27 ;;; Robert Strandh (strandh@labri.fr)
5 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
6 ejohnson 1.27 ;;; Elliott Johnson (ejohnson@fasl.info)
7 mvilleneuve 1.65 ;;; (c) copyright 2005 by
8     ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 abakic 1.68 ;;; (c) copyright 2005 by
10     ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11 ejohnson 1.27
12     ;;; This library is free software; you can redistribute it and/or
13     ;;; modify it under the terms of the GNU Library General Public
14     ;;; License as published by the Free Software Foundation; either
15     ;;; version 2 of the License, or (at your option) any later version.
16     ;;;
17     ;;; This library is distributed in the hope that it will be useful,
18     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20     ;;; Library General Public License for more details.
21     ;;;
22     ;;; You should have received a copy of the GNU Library General Public
23     ;;; License along with this library; if not, write to the
24     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25     ;;; Boston, MA 02111-1307 USA.
26    
27     ;;; GUI for the Climacs editor.
28    
29     (in-package :climacs-gui)
30    
31 rstrandh 1.160 (defclass extended-pane (climacs-pane esa-pane-mixin)
32     (;; for next-line and previous-line commands
33 rstrandh 1.49 (goal-column :initform nil)
34     ;; for dynamic abbrev expansion
35     (original-prefix :initform nil)
36     (prefix-start-offset :initform nil)
37 abakic 1.68 (dabbrev-expansion-mark :initform nil)
38     (overwrite-mode :initform nil)))
39 ejohnson 1.27
40 rstrandh 1.151 (defclass climacs-info-pane (info-pane)
41     ()
42     (:default-initargs
43     :height 20 :max-height 20 :min-height 20
44     :display-function 'display-info
45     :incremental-redisplay t))
46    
47     (defclass climacs-minibuffer-pane (minibuffer-pane)
48     ()
49     (:default-initargs
50     :height 20 :max-height 20 :min-height 20))
51    
52 dmurray 1.175 (defparameter *with-scrollbars* t
53     "If T, classic look and feel. If NIL, stripped-down look (:")
54    
55 rstrandh 1.152 (define-application-frame climacs (standard-application-frame
56 rstrandh 1.161 esa-frame-mixin)
57     ((buffers :initform '() :accessor buffers))
58 dmurray 1.167 (:command-table (global-climacs-table :inherit-from (global-esa-table)))
59     (:menu-bar nil)
60 ejohnson 1.27 (:panes
61 rstrandh 1.81 (win (let* ((extended-pane
62     (make-pane 'extended-pane
63     :width 900 :height 400
64 rstrandh 1.114 :end-of-line-action :scroll
65 rstrandh 1.81 :incremental-redisplay t
66 rstrandh 1.164 :display-function 'display-win
67     :command-table 'global-climacs-table))
68 rstrandh 1.81 (info-pane
69 rstrandh 1.151 (make-pane 'climacs-info-pane
70     :master-pane extended-pane
71     :width 900)))
72 dmurray 1.171 (setf (windows *application-frame*) (list extended-pane)
73     (buffers *application-frame*) (list (buffer extended-pane)))
74    
75 rstrandh 1.81 (vertically ()
76 dmurray 1.175 (if *with-scrollbars*
77     (scrolling ()
78     extended-pane)
79     extended-pane)
80 rstrandh 1.81 info-pane)))
81 rstrandh 1.151 (int (make-pane 'climacs-minibuffer-pane :width 900)))
82 ejohnson 1.27 (:layouts
83     (default
84     (vertically (:scroll-bars nil)
85 rstrandh 1.77 win
86 rstrandh 1.80 int)))
87 rstrandh 1.161 (:top-level (esa-top-level)))
88 ejohnson 1.27
89 rstrandh 1.153 (defun current-window ()
90     (car (windows *application-frame*)))
91 rstrandh 1.80
92     (defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
93 rstrandh 1.70 (declare (ignore args))
94 rstrandh 1.83 (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
95     (loop for buffer in buffers
96     do (update-syntax buffer (syntax buffer)))
97 rstrandh 1.80 (call-next-method)
98 rstrandh 1.83 (loop for buffer in buffers
99     do (clear-modify buffer))))
100 rstrandh 1.28
101 rstrandh 1.151 (defun climacs (&key (width 900) (height 400))
102 ejohnson 1.27 "Starts up a climacs session"
103 rstrandh 1.161 (let ((frame (make-application-frame
104 rstrandh 1.164 'climacs :width width :height height)))
105 ejohnson 1.27 (run-frame-top-level frame)))
106    
107     (defun display-info (frame pane)
108 rstrandh 1.81 (declare (ignore frame))
109 rstrandh 1.161 (let* ((master-pane (master-pane pane))
110     (buf (buffer master-pane))
111 dmurray 1.175 (size (size buf))
112     (top (top master-pane))
113     (bot (bot master-pane))
114     (name-info (format nil " ~a ~a~:[~30t~a~;~*~] ~:[(~;Syntax: ~]~a~a~a~a~:[)~;~] ~a"
115 rstrandh 1.161 (if (needs-saving buf) "**" "--")
116     (name buf)
117 dmurray 1.175 *with-scrollbars*
118     (cond ((and (mark= size bot)
119     (mark= 0 top))
120     "")
121     ((mark= size bot)
122     "Bot")
123     ((mark= 0 top)
124     "Top")
125     (t (format nil "~a%"
126     (round (* 100 (/ (offset top)
127     size))))))
128     *with-scrollbars*
129 rstrandh 1.161 (name (syntax buf))
130     (if (slot-value master-pane 'overwrite-mode)
131     " Ovwrt"
132     "")
133     (if (auto-fill-mode master-pane)
134     " Fill"
135     "")
136     (if (isearch-mode master-pane)
137     " Isearch"
138     "")
139 dmurray 1.175 *with-scrollbars*
140 rstrandh 1.161 (if (recordingp *application-frame*)
141     "Def"
142     ""))))
143     (princ name-info pane)))
144 ejohnson 1.27
145     (defun display-win (frame pane)
146     "The display function used by the climacs application frame."
147     (declare (ignore frame))
148 rstrandh 1.127 (redisplay-pane pane (eq pane (current-window))))
149 ejohnson 1.27
150 rstrandh 1.113 (defmethod handle-repaint :before ((pane extended-pane) region)
151     (declare (ignore region))
152 crhodes 1.149 (redisplay-frame-pane *application-frame* pane))
153 rstrandh 1.113
154 ejohnson 1.50 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
155 ejohnson 1.27
156 rstrandh 1.152 (defmethod execute-frame-command :around ((frame climacs) command)
157     (handler-case
158 abakic 1.156 (with-undo ((buffer (current-window)))
159     (call-next-method))
160 rstrandh 1.152 (offset-before-beginning ()
161     (beep) (display-message "Beginning of buffer"))
162     (offset-after-end ()
163     (beep) (display-message "End of buffer"))
164     (motion-before-beginning ()
165     (beep) (display-message "Beginning of buffer"))
166     (motion-after-end ()
167     (beep) (display-message "End of buffer"))
168     (no-expression ()
169     (beep) (display-message "No expression around point"))
170     (no-such-operation ()
171     (beep) (display-message "Operation unavailable for syntax"))))
172    
173 rstrandh 1.157 (defmethod execute-frame-command :after ((frame climacs) command)
174     (loop for buffer in (buffers frame)
175     do (when (modified-p buffer)
176     (setf (needs-saving buffer) t))))
177 mvilleneuve 1.100
178 abridgewater 1.34 (defmacro define-named-command (command-name args &body body)
179 rstrandh 1.164 `(define-command ,(if (listp command-name)
180     `(,@command-name :name t :command-table global-climacs-table)
181     `(,command-name :name t :command-table global-climacs-table))
182     ,args ,@body))
183 abridgewater 1.34
184 abakic 1.58 (define-named-command com-toggle-overwrite-mode ()
185 abakic 1.87 (with-slots (overwrite-mode) (current-window)
186     (setf overwrite-mode (not overwrite-mode))))
187 abakic 1.58
188 dmurray 1.170 (define-named-command com-not-modified ()
189     (setf (needs-saving (buffer (current-window))) nil))
190    
191     (define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:"))
192     (if (> column 1)
193     (setf (auto-fill-column (current-window)) column)
194     (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
195    
196 mvilleneuve 1.89 (defun possibly-fill-line ()
197 mvilleneuve 1.86 (let* ((pane (current-window))
198     (buffer (buffer pane)))
199 mvilleneuve 1.92 (when (auto-fill-mode pane)
200 mvilleneuve 1.95 (let* ((fill-column (auto-fill-column pane))
201 mvilleneuve 1.86 (point (point pane))
202     (offset (offset point))
203     (tab-width (tab-space-count (stream-default-view pane)))
204     (syntax (syntax buffer)))
205     (when (>= (buffer-display-column buffer offset tab-width)
206 mvilleneuve 1.95 (1- fill-column))
207 mvilleneuve 1.86 (fill-line point
208     (lambda (mark)
209     (syntax-line-indentation mark tab-width syntax))
210     fill-column
211 mvilleneuve 1.89 tab-width))))))
212    
213     (defun insert-character (char)
214     (let* ((win (current-window))
215     (point (point win)))
216     (unless (constituentp char)
217     (possibly-expand-abbrev point))
218     (when (whitespacep char)
219     (possibly-fill-line))
220     (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
221     (progn
222     (delete-range point)
223     (insert-object point char))
224     (insert-object point char))))
225    
226 dmurray 1.171 (define-command com-self-insert ((count 'integer))
227     (loop repeat count do (insert-character *current-gesture*)))
228 ejohnson 1.27
229 abridgewater 1.34 (define-named-command com-beginning-of-line ()
230 rstrandh 1.80 (beginning-of-line (point (current-window))))
231 ejohnson 1.27
232 abridgewater 1.34 (define-named-command com-end-of-line ()
233 rstrandh 1.80 (end-of-line (point (current-window))))
234 ejohnson 1.27
235 dmurray 1.171 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")
236     (killp 'boolean :prompt "Kill?"))
237     (let* ((point (point (current-window)))
238     (mark (clone-mark point)))
239     (forward-object mark count)
240     (when killp
241     (kill-ring-standard-push *kill-ring*
242     (region-to-sequence point mark)))
243     (delete-region point mark)))
244    
245     (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")
246     (killp 'boolean :prompt "Kill?"))
247     (let* ((point (point (current-window)))
248     (mark (clone-mark point)))
249     (backward-object mark count)
250     (when killp
251     (kill-ring-standard-push *kill-ring*
252     (region-to-sequence mark point)))
253     (delete-region mark point)))
254 ejohnson 1.27
255 dholman 1.159 (define-named-command com-zap-to-object ()
256     (let* ((item (handler-case (accept 't :prompt "Zap to Object")
257     (error () (progn (beep)
258     (display-message "Not a valid object")
259     (return-from com-zap-to-object nil)))))
260     (current-point (point (current-window)))
261     (item-mark (clone-mark current-point))
262     (current-offset (offset current-point)))
263     (search-forward item-mark (vector item))
264     (delete-range current-point (- (offset item-mark) current-offset))))
265    
266     (define-named-command com-zap-to-character ()
267     (let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d. (or 'string 'character)?
268     (error () (progn (beep)
269     (display-message "Not a valid string. ")
270     (return-from com-zap-to-character nil)))))
271     (item (subseq item-string 0 1))
272     (current-point (point (current-window)))
273     (item-mark (clone-mark current-point))
274    
275     (current-offset (offset current-point)))
276     (if (> (length item-string) 1)
277     (display-message "Using just the first character"))
278     (search-forward item-mark item)
279     (delete-range current-point (- (offset item-mark) current-offset))))
280    
281 rstrandh 1.42 (define-named-command com-transpose-objects ()
282 rstrandh 1.80 (let* ((point (point (current-window))))
283 rstrandh 1.42 (unless (beginning-of-buffer-p point)
284     (when (end-of-line-p point)
285 rstrandh 1.43 (backward-object point))
286     (let ((object (object-after point)))
287     (delete-range point)
288     (backward-object point)
289     (insert-object point object)
290     (forward-object point)))))
291    
292 rstrandh 1.62 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
293 rstrandh 1.80 (backward-object (point (current-window)) count))
294 rstrandh 1.43
295 rstrandh 1.62 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
296 rstrandh 1.80 (forward-object (point (current-window)) count))
297 rstrandh 1.43
298     (define-named-command com-transpose-words ()
299 rstrandh 1.80 (let* ((point (point (current-window))))
300 rstrandh 1.43 (let (bw1 bw2 ew1 ew2)
301     (backward-word point)
302     (setf bw1 (offset point))
303     (forward-word point)
304     (setf ew1 (offset point))
305     (forward-word point)
306     (when (= (offset point) ew1)
307     ;; this is emacs' message in the minibuffer
308     (error "Don't have two things to transpose"))
309     (setf ew2 (offset point))
310     (backward-word point)
311     (setf bw2 (offset point))
312     (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
313     (w1 (buffer-sequence (buffer point) bw1 ew1)))
314     (delete-word point)
315     (insert-sequence point w1)
316     (backward-word point)
317     (backward-word point)
318     (delete-word point)
319     (insert-sequence point w2)
320     (forward-word point)))))
321 rstrandh 1.42
322 rstrandh 1.45 (define-named-command com-transpose-lines ()
323 rstrandh 1.80 (let ((point (point (current-window))))
324 rstrandh 1.45 (beginning-of-line point)
325     (unless (beginning-of-buffer-p point)
326     (previous-line point))
327     (let* ((bol (offset point))
328     (eol (progn (end-of-line point)
329     (offset point)))
330     (line (buffer-sequence (buffer point) bol eol)))
331     (delete-region bol point)
332     ;; Remove newline at end of line as well.
333     (unless (end-of-buffer-p point)
334     (delete-range point))
335     ;; If the current line is at the end of the buffer, we want to
336     ;; be able to insert past it, so we need to get an extra line
337     ;; at the end.
338 abakic 1.82 (end-of-line point)
339     (when (end-of-buffer-p point)
340 rstrandh 1.45 (insert-object point #\Newline))
341 abakic 1.82 (next-line point 0)
342 rstrandh 1.45 (insert-sequence point line)
343     (insert-object point #\Newline))))
344    
345 rstrandh 1.111 (define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?"))
346 rstrandh 1.80 (let* ((win (current-window))
347 rstrandh 1.49 (point (point win)))
348     (unless (or (eq (previous-command win) 'com-previous-line)
349     (eq (previous-command win) 'com-next-line))
350     (setf (slot-value win 'goal-column) (column-number point)))
351 dmurray 1.171 (if (plusp numarg)
352     (previous-line point (slot-value win 'goal-column) numarg)
353     (next-line point (slot-value win 'goal-column) (- numarg)))))
354 ejohnson 1.27
355 rstrandh 1.111 (define-named-command com-next-line ((numarg 'integer :prompt "How many lines?"))
356 rstrandh 1.80 (let* ((win (current-window))
357 rstrandh 1.49 (point (point win)))
358     (unless (or (eq (previous-command win) 'com-previous-line)
359     (eq (previous-command win) 'com-next-line))
360     (setf (slot-value win 'goal-column) (column-number point)))
361 dmurray 1.171 (if (plusp numarg)
362     (next-line point (slot-value win 'goal-column) numarg)
363     (previous-line point (slot-value win 'goal-column) (- numarg)))))
364 ejohnson 1.27
365 rstrandh 1.112 (define-named-command com-open-line ((numarg 'integer :prompt "How many lines?"))
366     (open-line (point (current-window)) numarg))
367 ejohnson 1.27
368 rstrandh 1.110 (define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
369     (numargp 'boolean :prompt "Kill entire lines?"))
370 rstrandh 1.80 (let* ((pane (current-window))
371 ejohnson 1.54 (point (point pane))
372     (mark (offset point)))
373 dmurray 1.171 (cond ((= 0 numarg)
374     (beginning-of-line point))
375     ((< numarg 0)
376     (loop repeat (- numarg)
377     until (beginning-of-buffer-p point)
378     do (beginning-of-line point)
379     until (beginning-of-buffer-p point)
380     do (backward-object point)))
381     ((or numargp (> numarg 1))
382 rstrandh 1.110 (loop repeat numarg
383     until (end-of-buffer-p point)
384     do (end-of-line point)
385     until (end-of-buffer-p point)
386     do (forward-object point)))
387 ejohnson 1.56 (t
388 rstrandh 1.110 (cond ((end-of-buffer-p point) nil)
389     ((end-of-line-p point)(forward-object point))
390     (t (end-of-line point)))))
391     (unless (mark= point mark)
392     (if (eq (previous-command pane) 'com-kill-line)
393     (kill-ring-concatenating-push *kill-ring*
394     (region-to-sequence mark point))
395     (kill-ring-standard-push *kill-ring*
396     (region-to-sequence mark point)))
397     (delete-region mark point))))
398 ejohnson 1.27
399 rstrandh 1.102 (define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
400 dmurray 1.171 (if (plusp count)
401     (forward-word (point (current-window)) count)
402     (backward-word (point (current-window)) (- count))))
403 ejohnson 1.27
404 rstrandh 1.102 (define-named-command com-backward-word ((count 'integer :prompt "Number of words"))
405     (backward-word (point (current-window)) count))
406 ejohnson 1.27
407 rstrandh 1.103 (define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
408     (delete-word (point (current-window)) count))
409 rstrandh 1.32
410 dmurray 1.170 (define-named-command com-kill-word ((count 'integer :prompt "Number of words"))
411     (let* ((pane (current-window))
412     (point (point pane))
413     (mark (offset point)))
414     (loop repeat count
415     until (end-of-buffer-p point)
416     do (forward-word point))
417     (unless (mark= point mark)
418     (if (eq (previous-command pane) 'com-kill-word)
419     (kill-ring-concatenating-push *kill-ring*
420     (region-to-sequence mark point))
421     (kill-ring-standard-push *kill-ring*
422     (region-to-sequence mark point)))
423     (delete-region mark point))))
424    
425     (define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words"))
426     (let* ((pane (current-window))
427     (point (point pane))
428     (mark (offset point)))
429     (loop repeat count
430     until (end-of-buffer-p point)
431     do (backward-word point))
432     (unless (mark= point mark)
433     (if (eq (previous-command pane) 'com-backward-kill-word)
434     (kill-ring-reverse-concatenating-push *kill-ring*
435     (region-to-sequence mark point))
436     (kill-ring-standard-push *kill-ring*
437     (region-to-sequence mark point)))
438     (delete-region mark point))))
439    
440 dmurray 1.168 (define-named-command com-mark-word ((count 'integer :prompt "Number of words"))
441     (let* ((pane (current-window))
442     (point (point pane))
443     (mark (mark pane)))
444     (unless (eq (previous-command pane) 'com-mark-word)
445     (setf (offset mark) (offset point)))
446 dmurray 1.171 (if (plusp count)
447     (forward-word mark count)
448     (backward-word mark (- count)))))
449 dmurray 1.168
450 rstrandh 1.103 (define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words"))
451     (backward-delete-word (point (current-window)) count))
452 rstrandh 1.32
453 mvilleneuve 1.64 (define-named-command com-upcase-region ()
454 abakic 1.101 (let ((cw (current-window)))
455     (upcase-region (mark cw) (point cw))))
456 mvilleneuve 1.64
457     (define-named-command com-downcase-region ()
458 abakic 1.101 (let ((cw (current-window)))
459     (downcase-region (mark cw) (point cw))))
460 mvilleneuve 1.64
461     (define-named-command com-capitalize-region ()
462 abakic 1.101 (let ((cw (current-window)))
463     (capitalize-region (mark cw) (point cw))))
464 mvilleneuve 1.64
465 rstrandh 1.60 (define-named-command com-upcase-word ()
466 rstrandh 1.80 (upcase-word (point (current-window))))
467 rstrandh 1.60
468     (define-named-command com-downcase-word ()
469 rstrandh 1.80 (downcase-word (point (current-window))))
470 rstrandh 1.60
471     (define-named-command com-capitalize-word ()
472 rstrandh 1.80 (capitalize-word (point (current-window))))
473 rstrandh 1.60
474 mvilleneuve 1.69 (define-named-command com-tabify-region ()
475 rstrandh 1.80 (let ((pane (current-window)))
476 abakic 1.125 (tabify-region
477     (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
478 mvilleneuve 1.69
479     (define-named-command com-untabify-region ()
480 rstrandh 1.80 (let ((pane (current-window)))
481 abakic 1.125 (untabify-region
482     (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
483 mvilleneuve 1.69
484 mvilleneuve 1.79 (defun indent-current-line (pane point)
485     (let* ((buffer (buffer pane))
486     (view (stream-default-view pane))
487     (tab-space-count (tab-space-count view))
488     (indentation (syntax-line-indentation point
489     tab-space-count
490     (syntax buffer))))
491     (indent-line point indentation (and (indent-tabs-mode buffer)
492     tab-space-count))))
493    
494     (define-named-command com-indent-line ()
495 rstrandh 1.80 (let* ((pane (current-window))
496 mvilleneuve 1.79 (point (point pane)))
497     (indent-current-line pane point)))
498    
499     (define-named-command com-newline-and-indent ()
500 rstrandh 1.80 (let* ((pane (current-window))
501 mvilleneuve 1.79 (point (point pane)))
502     (insert-object point #\Newline)
503     (indent-current-line pane point)))
504    
505 mvilleneuve 1.72 (define-named-command com-delete-indentation ()
506 rstrandh 1.80 (delete-indentation (point (current-window))))
507 ejohnson 1.27
508 mvilleneuve 1.86 (define-named-command com-auto-fill-mode ()
509 mvilleneuve 1.92 (let ((pane (current-window)))
510     (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
511 mvilleneuve 1.86
512 mvilleneuve 1.90 (define-named-command com-fill-paragraph ()
513     (let* ((pane (current-window))
514     (buffer (buffer pane))
515     (syntax (syntax buffer))
516     (point (point pane))
517     (begin-mark (clone-mark point))
518     (end-mark (clone-mark point)))
519     (unless (eql (object-before begin-mark) #\Newline)
520 dmurray 1.170 (backward-paragraph begin-mark syntax))
521 mvilleneuve 1.90 (unless (eql (object-after end-mark) #\Newline)
522 dmurray 1.170 (forward-paragraph end-mark syntax))
523 mvilleneuve 1.90 (do-buffer-region (object offset buffer
524     (offset begin-mark) (offset end-mark))
525     (when (eql object #\Newline)
526     (setf object #\Space)))
527     (let ((point-backup (clone-mark point)))
528     (setf (offset point) (offset end-mark))
529     (possibly-fill-line)
530     (setf (offset point) (offset point-backup)))))
531    
532 rstrandh 1.41 (eval-when (:compile-toplevel :load-toplevel)
533 ejohnson 1.35 (define-presentation-type completable-pathname ()
534     :inherit-from 'pathname))
535 ejohnson 1.27
536     (defun filename-completer (so-far mode)
537     (flet ((remove-trail (s)
538     (subseq s 0 (let ((pos (position #\/ s :from-end t)))
539     (if pos (1+ pos) 0)))))
540     (let* ((directory-prefix
541     (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
542     ""
543 rstrandh 1.78 (namestring #+sbcl *default-pathname-defaults*
544     #+cmu (ext:default-directory)
545     #-(or sbcl cmu) *default-pathname-defaults*)))
546 ejohnson 1.27 (full-so-far (concatenate 'string directory-prefix so-far))
547     (pathnames
548     (loop with length = (length full-so-far)
549 abakic 1.129 and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
550     for path in
551     #+(or sbcl cmu lispworks) (directory wildcard)
552     #+openmcl (directory wildcard :directories t)
553     #+allegro (directory wildcard :directories-are-files nil)
554     #+cormanlisp (nconc (directory wildcard)
555     (cl::directory-subdirs dirname))
556     #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
557     (directory wildcard)
558     when (let ((mismatch (mismatch (namestring path) full-so-far)))
559     (or (null mismatch) (= mismatch length)))
560     collect path))
561 ejohnson 1.27 (strings (mapcar #'namestring pathnames))
562     (first-string (car strings))
563     (length-common-prefix nil)
564     (completed-string nil)
565     (full-completed-string nil))
566     (unless (null pathnames)
567     (setf length-common-prefix
568     (loop with length = (length first-string)
569     for string in (cdr strings)
570     do (setf length (min length (or (mismatch string first-string) length)))
571     finally (return length))))
572     (unless (null pathnames)
573     (setf completed-string
574     (subseq first-string (length directory-prefix)
575     (if (null (cdr pathnames)) nil length-common-prefix)))
576     (setf full-completed-string
577     (concatenate 'string directory-prefix completed-string)))
578     (case mode
579     ((:complete-limited :complete-maximal)
580     (cond ((null pathnames)
581     (values so-far nil nil 0 nil))
582     ((null (cdr pathnames))
583     (values completed-string t (car pathnames) 1 nil))
584     (t
585     (values completed-string nil nil (length pathnames) nil))))
586     (:complete
587     (cond ((null pathnames)
588     (values so-far t so-far 1 nil))
589     ((null (cdr pathnames))
590     (values completed-string t (car pathnames) 1 nil))
591     ((find full-completed-string strings :test #'string-equal)
592     (let ((pos (position full-completed-string strings :test #'string-equal)))
593     (values completed-string
594     t (elt pathnames pos) (length pathnames) nil)))
595     (t
596     (values completed-string nil nil (length pathnames) nil))))
597     (:possibilities
598     (values nil nil nil (length pathnames)
599     (loop with length = (length directory-prefix)
600     for name in pathnames
601     collect (list (subseq (namestring name) length nil)
602     name))))))))
603    
604     (define-presentation-method accept
605     ((type completable-pathname) stream (view textual-view) &key)
606     (multiple-value-bind (pathname success string)
607     (complete-input stream
608     #'filename-completer
609     :allow-any-input t)
610     (declare (ignore success))
611     (or pathname string)))
612    
613 abakic 1.134 (defun filepath-filename (pathname)
614 ejohnson 1.27 (if (null (pathname-type pathname))
615     (pathname-name pathname)
616     (concatenate 'string (pathname-name pathname)
617     "." (pathname-type pathname))))
618    
619 crhodes 1.140 (defun syntax-class-name-for-filepath (filepath)
620     (or (climacs-syntax::syntax-description-class-name
621     (find (or (pathname-type filepath)
622     (pathname-name filepath))
623     climacs-syntax::*syntaxes*
624     :test (lambda (x y)
625     (member x y :test #'string=))
626     :key #'climacs-syntax::syntax-description-pathname-types))
627     'basic-syntax))
628    
629 abridgewater 1.34 (define-named-command com-find-file ()
630 abakic 1.134 (let ((filepath (accept 'completable-pathname
631 rstrandh 1.70 :prompt "Find File"))
632     (buffer (make-instance 'climacs-buffer))
633 rstrandh 1.80 (pane (current-window)))
634 dmurray 1.158 (setf (offset (point (buffer pane))) (offset (point pane)))
635 rstrandh 1.75 (push buffer (buffers *application-frame*))
636 rstrandh 1.80 (setf (buffer (current-window)) buffer)
637 crhodes 1.140 (setf (syntax buffer)
638     (make-instance
639     (syntax-class-name-for-filepath filepath)
640     :buffer (buffer (point pane))))
641 rstrandh 1.84 ;; Don't want to create the file if it doesn't exist.
642 abakic 1.134 (when (probe-file filepath)
643     (with-open-file (stream filepath :direction :input)
644 rstrandh 1.84 (input-from-stream stream buffer 0)))
645 abakic 1.134 (setf (filepath buffer) filepath
646     (name buffer) (filepath-filename filepath)
647 rstrandh 1.70 (needs-saving buffer) nil)
648     (beginning-of-buffer (point pane))
649     ;; this one is needed so that the buffer modification protocol
650     ;; resets the low and high marks after redisplay
651     (redisplay-frame-panes *application-frame*)))
652 ejohnson 1.27
653 crhodes 1.139 (define-named-command com-insert-file ()
654     (let ((filename (accept 'completable-pathname
655     :prompt "Insert File"))
656     (pane (current-window)))
657     (when (probe-file filename)
658     (setf (mark pane) (clone-mark (point pane) :left))
659     (with-open-file (stream filename :direction :input)
660     (input-from-stream stream
661     (buffer pane)
662     (offset (point pane))))
663     (psetf (offset (mark pane)) (offset (point pane))
664     (offset (point pane)) (offset (mark pane))))
665     (redisplay-frame-panes *application-frame*)))
666    
667 rstrandh 1.93 (defun save-buffer (buffer)
668 abakic 1.134 (let ((filepath (or (filepath buffer)
669 rstrandh 1.93 (accept 'completable-pathname
670     :prompt "Save Buffer to File"))))
671 abakic 1.134 (with-open-file (stream filepath :direction :output :if-exists :supersede)
672 rstrandh 1.93 (output-to-stream stream buffer 0 (size buffer)))
673 abakic 1.134 (setf (filepath buffer) filepath
674     (name buffer) (filepath-filename filepath))
675     (display-message "Wrote: ~a" (filepath buffer))
676 rstrandh 1.93 (setf (needs-saving buffer) nil)))
677    
678 abridgewater 1.34 (define-named-command com-save-buffer ()
679 rstrandh 1.93 (let ((buffer (buffer (current-window))))
680 abakic 1.134 (if (or (null (filepath buffer))
681 rstrandh 1.30 (needs-saving buffer))
682 rstrandh 1.93 (save-buffer buffer)
683     (display-message "No changes need to be saved from ~a" (name buffer)))))
684    
685 rstrandh 1.164 (defmethod frame-exit :around ((frame climacs))
686     (loop for buffer in (buffers frame)
687 rstrandh 1.93 when (and (needs-saving buffer)
688 crhodes 1.138 (filepath buffer)
689 rstrandh 1.124 (handler-case (accept 'boolean
690     :prompt (format nil "Save buffer: ~a ?" (name buffer)))
691     (error () (progn (beep)
692     (display-message "Invalid answer")
693 rstrandh 1.164 (return-from frame-exit nil)))))
694 rstrandh 1.93 do (save-buffer buffer))
695 crhodes 1.138 (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
696 rstrandh 1.164 (buffers frame))
697 rstrandh 1.124 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
698     (error () (progn (beep)
699     (display-message "Invalid answer")
700 rstrandh 1.164 (return-from frame-exit nil)))))
701     (call-next-method)))
702 ejohnson 1.27
703 abridgewater 1.34 (define-named-command com-write-buffer ()
704 abakic 1.134 (let ((filepath (accept 'completable-pathname
705 ejohnson 1.27 :prompt "Write Buffer to File"))
706 rstrandh 1.80 (buffer (buffer (current-window))))
707 abakic 1.134 (with-open-file (stream filepath :direction :output :if-exists :supersede)
708 ejohnson 1.27 (output-to-stream stream buffer 0 (size buffer)))
709 abakic 1.134 (setf (filepath buffer) filepath
710     (name buffer) (filepath-filename filepath)
711 rstrandh 1.30 (needs-saving buffer) nil)
712 abakic 1.134 (display-message "Wrote: ~a" (filepath buffer))))
713 ejohnson 1.27
714 rstrandh 1.75 (define-presentation-method accept
715     ((type buffer) stream (view textual-view) &key)
716     (multiple-value-bind (object success string)
717     (complete-input stream
718     (lambda (so-far action)
719     (complete-from-possibilities
720     so-far (buffers *application-frame*) '() :action action
721     :name-key #'name
722     :value-key #'identity))
723     :partial-completers '(#\Space)
724     :allow-any-input t)
725 rstrandh 1.76 (declare (ignore success))
726     (or object
727     (car (push (make-instance 'climacs-buffer :name string)
728     (buffers *application-frame*))))))
729 rstrandh 1.75
730     (define-named-command com-switch-to-buffer ()
731     (let ((buffer (accept 'buffer
732 abakic 1.125 :prompt "Switch to buffer"))
733     (pane (current-window)))
734 dmurray 1.158 (setf (offset (point (buffer pane))) (offset (point pane)))
735 abakic 1.125 (setf (buffer pane) buffer)
736     (full-redisplay pane)))
737 rstrandh 1.75
738 rstrandh 1.91 (define-named-command com-kill-buffer ()
739     (with-slots (buffers) *application-frame*
740     (let ((buffer (buffer (current-window))))
741     (when (and (needs-saving buffer)
742 rstrandh 1.124 (handler-case (accept 'boolean :prompt "Save buffer first?")
743     (error () (progn (beep)
744     (display-message "Invalid answer")
745     (return-from com-kill-buffer nil)))))
746 rstrandh 1.91 (com-save-buffer))
747     (setf buffers (remove buffer buffers))
748     ;; Always need one buffer.
749     (when (null buffers)
750     (push (make-instance 'climacs-buffer :name "*scratch*")
751     buffers))
752     (setf (buffer (current-window)) (car buffers)))))
753    
754 rstrandh 1.75 (define-named-command com-full-redisplay ()
755 rstrandh 1.80 (full-redisplay (current-window)))
756 rstrandh 1.75
757 rstrandh 1.63 (define-named-command com-load-file ()
758 abakic 1.134 (let ((filepath (accept 'completable-pathname
759 rstrandh 1.63 :prompt "Load File")))
760 abakic 1.134 (load filepath)))
761 rstrandh 1.63
762 abridgewater 1.34 (define-named-command com-beginning-of-buffer ()
763 rstrandh 1.80 (beginning-of-buffer (point (current-window))))
764 ejohnson 1.27
765 rstrandh 1.39 (define-named-command com-page-down ()
766 rstrandh 1.80 (let ((pane (current-window)))
767 rstrandh 1.70 (page-down pane)))
768 rstrandh 1.39
769 rstrandh 1.40 (define-named-command com-page-up ()
770 rstrandh 1.80 (let ((pane (current-window)))
771 rstrandh 1.70 (page-up pane)))
772 rstrandh 1.40
773 abridgewater 1.34 (define-named-command com-end-of-buffer ()
774 rstrandh 1.80 (end-of-buffer (point (current-window))))
775 ejohnson 1.27
776 dmurray 1.168 (define-named-command com-mark-whole-buffer ()
777     (beginning-of-buffer (point (current-window)))
778     (end-of-buffer (mark (current-window))))
779    
780 abridgewater 1.34 (define-named-command com-back-to-indentation ()
781 rstrandh 1.80 (let ((point (point (current-window))))
782 rstrandh 1.32 (beginning-of-line point)
783     (loop until (end-of-line-p point)
784     while (whitespacep (object-after point))
785     do (incf (offset point)))))
786    
787 dmurray 1.173 (define-named-command com-delete-horizontal-space ((backward-only-p
788     'boolean :prompt "Delete backwards only?"))
789     (let* ((point (point (current-window)))
790     (mark (clone-mark point)))
791     (loop until (beginning-of-line-p point)
792     while (whitespacep (object-before point))
793     do (backward-object point))
794     (unless backward-only-p
795     (loop until (end-of-line-p mark)
796     while (whitespacep (object-after mark))
797     do (forward-object mark)))
798     (delete-region point mark)))
799    
800 dmurray 1.176 (define-named-command com-just-one-space ((count 'integer :prompt "Number of spaces"))
801     (let ((point (point (current-window)))
802     offset)
803     (loop until (beginning-of-line-p point)
804     while (whitespacep (object-before point))
805     do (backward-object point))
806     (loop until (end-of-line-p point)
807     while (whitespacep (object-after point))
808     repeat count do (forward-object point)
809     finally (setf offset (offset point)))
810     (loop until (end-of-line-p point)
811     while (whitespacep (object-after point))
812     do (forward-object point))
813     (delete-region offset point)))
814 dmurray 1.173
815 abridgewater 1.34 (define-named-command com-goto-position ()
816 rstrandh 1.80 (setf (offset (point (current-window)))
817 rstrandh 1.124 (handler-case (accept 'integer :prompt "Goto Position")
818     (error () (progn (beep)
819     (display-message "Not a valid position")
820     (return-from com-goto-position nil))))))
821 rstrandh 1.32
822 abridgewater 1.34 (define-named-command com-goto-line ()
823 abakic 1.125 (loop with mark = (let ((m (clone-mark
824     (low-mark (buffer (current-window)))
825     :right)))
826     (beginning-of-buffer m)
827     m)
828 rstrandh 1.32 do (end-of-line mark)
829     until (end-of-buffer-p mark)
830 dmurray 1.170 repeat (1- (handler-case (accept 'integer :prompt "Goto Line")
831 rstrandh 1.124 (error () (progn (beep)
832     (display-message "Not a valid line number")
833 dmurray 1.170 (return-from com-goto-line nil)))))
834 rstrandh 1.32 do (incf (offset mark))
835     (end-of-line mark)
836     finally (beginning-of-line mark)
837 rstrandh 1.80 (setf (offset (point (current-window)))
838 rstrandh 1.32 (offset mark))))
839    
840 abridgewater 1.34 (define-named-command com-browse-url ()
841 dmurray 1.172 (let ((url (accept 'url :prompt "Browse URL")))
842     #+ (and sbcl darwin)
843 crhodes 1.174 (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)))
844 ejohnson 1.27
845 abridgewater 1.34 (define-named-command com-set-mark ()
846 rstrandh 1.80 (let ((pane (current-window)))
847 rstrandh 1.70 (setf (mark pane) (clone-mark (point pane)))))
848 rstrandh 1.45
849     (define-named-command com-exchange-point-and-mark ()
850 rstrandh 1.80 (let ((pane (current-window)))
851 rstrandh 1.70 (psetf (offset (mark pane)) (offset (point pane))
852     (offset (point pane)) (offset (mark pane)))))
853 rstrandh 1.38
854     (define-named-command com-set-syntax ()
855 rstrandh 1.80 (let* ((pane (current-window))
856 rstrandh 1.67 (buffer (buffer pane)))
857 rstrandh 1.70 (setf (syntax buffer)
858 rstrandh 1.124 (make-instance (or (accept 'syntax :prompt "Set Syntax")
859     (progn (beep)
860     (display-message "No such syntax")
861     (return-from com-set-syntax nil)))
862 bmastenbrook 1.147 :buffer (buffer (point pane))))))
863 ejohnson 1.27
864 rstrandh 1.77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
865     ;;;
866     ;;; Commands for splitting windows
867    
868 rstrandh 1.83 (defun replace-constellation (constellation additional-constellation vertical-p)
869     (let* ((parent (sheet-parent constellation))
870     (children (sheet-children parent))
871     (first (first children))
872 rstrandh 1.117 (second (second children))
873     (third (third children))
874     (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
875 rstrandh 1.83 (assert (member constellation children))
876 rstrandh 1.117 (sheet-disown-child parent constellation)
877     (let ((new (if vertical-p
878     (vertically ()
879 dmurray 1.175 (1/2 constellation) adjust (1/2 additional-constellation))
880 rstrandh 1.117 (horizontally ()
881 dmurray 1.175 (1/2 constellation) adjust (1/2 additional-constellation)))))
882 rstrandh 1.117 (sheet-adopt-child parent new)
883     (reorder-sheets parent
884     (if (eq constellation first)
885     (if third
886     (list new second third)
887     (list new second))
888     (if third
889     (list first second new)
890     (list first new)))))))
891 rstrandh 1.83
892     (defun parent3 (sheet)
893     (sheet-parent (sheet-parent (sheet-parent sheet))))
894    
895     (defun make-pane-constellation ()
896     "make a vbox containing a scroller pane as its first child and an
897     info pane as its second child. The scroller pane contains a viewport
898     which contains an extended pane. Return the vbox and the extended pane
899 dmurray 1.175 as two values.
900     If *with-scrollbars nil, omit the scroller."
901    
902 rstrandh 1.83 (let* ((extended-pane
903     (make-pane 'extended-pane
904     :width 900 :height 400
905     :name 'win
906 rstrandh 1.114 :end-of-line-action :scroll
907 rstrandh 1.83 :incremental-redisplay t
908 rstrandh 1.164 :display-function 'display-win
909     :command-table 'global-climacs-table))
910 rstrandh 1.83 (vbox
911     (vertically ()
912 dmurray 1.175 (if *with-scrollbars*
913     (scrolling ()
914     extended-pane)
915     extended-pane)
916 rstrandh 1.151 (make-pane 'climacs-info-pane
917     :master-pane extended-pane
918     :width 900))))
919 rstrandh 1.83 (values vbox extended-pane)))
920    
921 rstrandh 1.77 (define-named-command com-split-window-vertically ()
922     (with-look-and-feel-realization
923     ((frame-manager *application-frame*) *application-frame*)
924 rstrandh 1.83 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
925     (let* ((current-window (current-window))
926 dmurray 1.175 (constellation-root (if *with-scrollbars*
927     (parent3 current-window)
928     (sheet-parent current-window))))
929 dmurray 1.158 (setf (offset (point (buffer current-window))) (offset (point current-window))
930 rstrandh 1.137 (buffer new-pane) (buffer current-window)
931 mvilleneuve 1.95 (auto-fill-mode new-pane) (auto-fill-mode current-window)
932     (auto-fill-column new-pane) (auto-fill-column current-window))
933 rstrandh 1.83 (push new-pane (windows *application-frame*))
934 rstrandh 1.155 (setf *standard-output* new-pane)
935 rstrandh 1.83 (replace-constellation constellation-root vbox t)
936     (full-redisplay current-window)
937     (full-redisplay new-pane)))))
938    
939     (define-named-command com-split-window-horizontally ()
940     (with-look-and-feel-realization
941     ((frame-manager *application-frame*) *application-frame*)
942     (multiple-value-bind (vbox new-pane) (make-pane-constellation)
943     (let* ((current-window (current-window))
944 dmurray 1.175 (constellation-root (if *with-scrollbars*
945     (parent3 current-window)
946     (sheet-parent current-window))))
947 dmurray 1.158 (setf (offset (point (buffer current-window))) (offset (point current-window))
948 rstrandh 1.137 (buffer new-pane) (buffer current-window)
949 mvilleneuve 1.95 (auto-fill-mode new-pane) (auto-fill-mode current-window)
950     (auto-fill-column new-pane) (auto-fill-column current-window))
951 rstrandh 1.83 (push new-pane (windows *application-frame*))
952 rstrandh 1.155 (setf *standard-output* new-pane)
953 rstrandh 1.83 (replace-constellation constellation-root vbox nil)
954     (full-redisplay current-window)
955     (full-redisplay new-pane)))))
956    
957     (define-named-command com-other-window ()
958     (setf (windows *application-frame*)
959     (append (cdr (windows *application-frame*))
960 rstrandh 1.155 (list (car (windows *application-frame*)))))
961     (setf *standard-output* (car (windows *application-frame*))))
962 rstrandh 1.83
963 rstrandh 1.117 (define-named-command com-single-window ()
964     (loop until (null (cdr (windows *application-frame*)))
965     do (rotatef (car (windows *application-frame*))
966     (cadr (windows *application-frame*)))
967 rstrandh 1.155 (com-delete-window))
968     (setf *standard-output* (car (windows *application-frame*))))
969 dmurray 1.173
970     (define-named-command com-scroll-other-window ()
971     (let ((other-window (second (windows *application-frame*))))
972     (when other-window
973     (page-down other-window))))
974 rstrandh 1.117
975 dmurray 1.176 (define-named-command com-scroll-other-window-up ()
976     (let ((other-window (second (windows *application-frame*))))
977     (when other-window
978     (page-up other-window))))
979    
980 rstrandh 1.83 (define-named-command com-delete-window ()
981     (unless (null (cdr (windows *application-frame*)))
982 dmurray 1.175 (let* ((constellation (if *with-scrollbars*
983     (parent3 (current-window))
984     (sheet-parent (current-window))))
985 rstrandh 1.83 (box (sheet-parent constellation))
986     (box-children (sheet-children box))
987     (other (if (eq constellation (first box-children))
988 rstrandh 1.117 (third box-children)
989 rstrandh 1.83 (first box-children)))
990     (parent (sheet-parent box))
991     (children (sheet-children parent))
992     (first (first children))
993 rstrandh 1.117 (second (second children))
994     (third (third children)))
995 rstrandh 1.83 (pop (windows *application-frame*))
996 rstrandh 1.155 (setf *standard-output* (car (windows *application-frame*)))
997 rstrandh 1.83 (sheet-disown-child box other)
998 rstrandh 1.116 (sheet-disown-child parent box)
999 rstrandh 1.117 (sheet-adopt-child parent other)
1000 rstrandh 1.116 (reorder-sheets parent (if (eq box first)
1001 rstrandh 1.117 (if third
1002     (list other second third)
1003     (list other second))
1004     (if third
1005     (list first second other)
1006     (list first other)))))))
1007 rstrandh 1.94
1008 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;
1009     ;; Kill ring commands
1010    
1011 ejohnson 1.31 ;; Copies an element from a kill-ring to a buffer at the given offset
1012 ejohnson 1.50 (define-named-command com-yank ()
1013 rstrandh 1.80 (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
1014 ejohnson 1.27
1015 ejohnson 1.31 ;; Destructively cut a given buffer region into the kill-ring
1016 dmurray 1.170 (define-named-command com-kill-region ()
1017 abakic 1.125 (let ((pane (current-window)))
1018     (kill-ring-standard-push
1019     *kill-ring* (region-to-sequence (mark pane) (point pane)))
1020     (delete-region (mark pane) (point pane))))
1021 ejohnson 1.27
1022 ejohnson 1.31 ;; Non destructively copies in buffer region to the kill ring
1023 dmurray 1.170 (define-named-command com-copy-region ()
1024 rstrandh 1.80 (let ((pane (current-window)))
1025 rstrandh 1.70 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
1026 ejohnson 1.27
1027 ejohnson 1.50 (define-named-command com-rotate-yank ()
1028 rstrandh 1.80 (let* ((pane (current-window))
1029 ejohnson 1.54 (point (point pane))
1030 ejohnson 1.50 (last-yank (kill-ring-yank *kill-ring*)))
1031 ejohnson 1.54 (if (eq (previous-command pane)
1032 ejohnson 1.50 'com-rotate-yank)
1033 ejohnson 1.54 (progn
1034     (delete-range point (* -1 (length last-yank)))
1035     (rotate-yank-position *kill-ring*)))
1036     (insert-sequence point (kill-ring-yank *kill-ring*))))
1037 ejohnson 1.27
1038 ejohnson 1.50 (define-named-command com-resize-kill-ring ()
1039 rstrandh 1.124 (let ((size (handler-case (accept 'integer :prompt "New kill ring size")
1040     (error () (progn (beep)
1041     (display-message "Not a valid kill ring size")
1042     (return-from com-resize-kill-ring nil))))))
1043 ejohnson 1.50 (setf (kill-ring-max-size *kill-ring*) size)))
1044 rstrandh 1.47
1045 dmurray 1.176 (define-named-command com-append-next-kill ()
1046     (setf (append-next-p *kill-ring*) t))
1047    
1048 mvilleneuve 1.96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1049     ;;;
1050     ;;; Incremental search
1051    
1052 mvilleneuve 1.97 (defun isearch-command-loop (pane forwardp)
1053     (let ((point (point pane)))
1054 mvilleneuve 1.96 (unless (endp (isearch-states pane))
1055     (setf (isearch-previous-string pane)
1056     (search-string (first (isearch-states pane)))))
1057     (setf (isearch-mode pane) t)
1058     (setf (isearch-states pane)
1059     (list (make-instance 'isearch-state
1060     :search-string ""
1061 mvilleneuve 1.97 :search-mark (clone-mark point)
1062 mvilleneuve 1.105 :search-forward-p forwardp
1063     :search-success-p t)))
1064 mvilleneuve 1.100 (simple-command-loop 'isearch-climacs-table
1065     (isearch-mode pane)
1066     ((setf (isearch-mode pane) nil)))))
1067 mvilleneuve 1.96
1068 mvilleneuve 1.97 (defun isearch-from-mark (pane mark string forwardp)
1069     (flet ((object-equal (x y)
1070     (if (characterp x)
1071     (and (characterp y) (char-equal x y))
1072     (eql x y))))
1073     (let* ((point (point pane))
1074     (mark2 (clone-mark mark))
1075     (success (funcall (if forwardp #'search-forward #'search-backward)
1076     mark2
1077     string
1078     :test #'object-equal)))
1079 mvilleneuve 1.105 (when success
1080     (setf (offset point) (offset mark2)
1081     (offset mark) (if forwardp
1082     (- (offset mark2) (length string))
1083     (+ (offset mark2) (length string)))))
1084 abakic 1.130 (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A"
1085     success forwardp string)
1086 mvilleneuve 1.105 (push (make-instance 'isearch-state
1087     :search-string string
1088     :search-mark mark
1089     :search-forward-p forwardp
1090     :search-success-p success)
1091     (isearch-states pane))
1092     (unless success
1093     (beep)))))
1094 mvilleneuve 1.97
1095     (define-named-command com-isearch-mode-forward ()
1096 abakic 1.130 (display-message "Isearch: ")
1097 mvilleneuve 1.97 (isearch-command-loop (current-window) t))
1098    
1099     (define-named-command com-isearch-mode-backward ()
1100 abakic 1.130 (display-message "Isearch backward: ")
1101 mvilleneuve 1.97 (isearch-command-loop (current-window) nil))
1102 mvilleneuve 1.96
1103     (define-named-command com-isearch-append-char ()
1104     (let* ((pane (current-window))
1105     (states (isearch-states pane))
1106     (string (concatenate 'string
1107     (search-string (first states))
1108     (string *current-gesture*)))
1109     (mark (clone-mark (search-mark (first states))))
1110 mvilleneuve 1.97 (forwardp (search-forward-p (first states))))
1111     (unless forwardp
1112     (incf (offset mark)))
1113     (isearch-from-mark pane mark string forwardp)))
1114 mvilleneuve 1.96
1115     (define-named-command com-isearch-delete-char ()
1116     (let* ((pane (current-window)))
1117     (cond ((null (second (isearch-states pane)))
1118 abakic 1.130 (display-message "Isearch: ")
1119 mvilleneuve 1.96 (beep))
1120     (t
1121     (pop (isearch-states pane))
1122 mvilleneuve 1.105 (loop until (endp (rest (isearch-states pane)))
1123     until (search-success-p (first (isearch-states pane)))
1124     do (pop (isearch-states pane)))
1125 mvilleneuve 1.96 (let ((state (first (isearch-states pane))))
1126     (setf (offset (point pane))
1127 mvilleneuve 1.97 (if (search-forward-p state)
1128     (+ (offset (search-mark state))
1129     (length (search-string state)))
1130     (- (offset (search-mark state))
1131 abakic 1.130 (length (search-string state)))))
1132     (display-message "Isearch~:[ backward~;~]: ~A"
1133     (search-forward-p state)
1134     (search-string state)))))))
1135 mvilleneuve 1.96
1136     (define-named-command com-isearch-forward ()
1137     (let* ((pane (current-window))
1138     (point (point pane))
1139     (states (isearch-states pane))
1140     (string (if (null (second states))
1141     (isearch-previous-string pane)
1142     (search-string (first states))))
1143 mvilleneuve 1.97 (mark (clone-mark point)))
1144     (isearch-from-mark pane mark string t)))
1145    
1146     (define-named-command com-isearch-backward ()
1147     (let* ((pane (current-window))
1148     (point (point pane))
1149     (states (isearch-states pane))
1150     (string (if (null (second states))
1151     (isearch-previous-string pane)
1152     (search-string (first states))))
1153     (mark (clone-mark point)))
1154     (isearch-from-mark pane mark string nil)))
1155 mvilleneuve 1.96
1156     (define-named-command com-isearch-exit ()
1157     (setf (isearch-mode (current-window)) nil))
1158    
1159 mvilleneuve 1.100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1160     ;;;
1161     ;;; Query replace
1162    
1163     (defun query-replace-find-next-match (mark string)
1164 mvilleneuve 1.104 (flet ((object-equal (x y)
1165     (and (characterp x)
1166     (characterp y)
1167     (char-equal x y))))
1168     (let ((offset-before (offset mark)))
1169     (search-forward mark string :test #'object-equal)
1170     (/= (offset mark) offset-before))))
1171 mvilleneuve 1.100
1172     (define-named-command com-query-replace ()
1173 abakic 1.135 (let* ((pane (current-window))
1174     (old-state (query-replace-state pane))
1175     (old-string1 (when old-state (string1 old-state)))
1176     (old-string2 (when old-state (string2 old-state)))
1177     (string1 (handler-case
1178     (if old-string1
1179     (accept 'string
1180     :prompt "Query Replace"
1181     :default old-string1
1182     :default-type 'string)
1183     (accept 'string :prompt "Query Replace"))
1184 rstrandh 1.124 (error () (progn (beep)
1185     (display-message "Empty string")
1186     (return-from com-query-replace nil)))))
1187 abakic 1.135 (string2 (handler-case
1188     (if old-string2
1189     (accept 'string
1190     :prompt (format nil "Query Replace ~A with"
1191     string1)
1192     :default old-string2
1193     :default-type 'string)
1194     (accept 'string
1195     :prompt (format nil "Query Replace ~A with" string1)))
1196 rstrandh 1.124 (error () (progn (beep)
1197     (display-message "Empty string")
1198     (return-from com-query-replace nil)))))
1199 abakic 1.135 (point (point pane))
1200     (occurrences 0))
1201     (declare (special string1 string2 occurrences))
1202 mvilleneuve 1.100 (when (query-replace-find-next-match point string1)
1203     (setf (query-replace-state pane) (make-instance 'query-replace-state
1204     :string1 string1
1205     :string2 string2)
1206     (query-replace-mode pane) t)
1207 abakic 1.135 (display-message "Query Replace ~A with ~A:"
1208     string1 string2)
1209 mvilleneuve 1.100 (simple-command-loop 'query-replace-climacs-table
1210 abakic 1.135 (query-replace-mode pane)
1211     ((setf (query-replace-mode pane) nil))))
1212     (display-message "Replaced ~A occurrence~:P" occurrences)))
1213 mvilleneuve 1.100
1214     (define-named-command com-query-replace-replace ()
1215 abakic 1.135 (declare (special string1 string2 occurrences))
1216 mvilleneuve 1.100 (let* ((pane (current-window))
1217     (point (point pane))
1218 mvilleneuve 1.104 (buffer (buffer pane))
1219 abakic 1.135 (string1-length (length string1)))
1220 mvilleneuve 1.100 (backward-object point string1-length)
1221 mvilleneuve 1.104 (let* ((offset1 (offset point))
1222     (offset2 (+ offset1 string1-length))
1223     (region-case (buffer-region-case buffer offset1 offset2)))
1224     (delete-range point string1-length)
1225 abakic 1.135 (insert-sequence point string2)
1226     (setf offset2 (+ offset1 (length string2)))
1227 mvilleneuve 1.104 (finish-output *error-output*)
1228     (case region-case
1229     (:upper-case (upcase-buffer-region buffer offset1 offset2))
1230     (:lower-case (downcase-buffer-region buffer offset1 offset2))
1231     (:capitalized (capitalize-buffer-region buffer offset1 offset2))))
1232 abakic 1.135 (incf occurrences)
1233     (if (query-replace-find-next-match point string1)
1234     (display-message "Query Replace ~A with ~A:"
1235     string1 string2)
1236     (setf (query-replace-mode pane) nil))))
1237 mvilleneuve 1.100
1238     (define-named-command com-query-replace-skip ()
1239 abakic 1.135 (declare (special string1 string2))
1240 mvilleneuve 1.100 (let* ((pane (current-window))
1241 abakic 1.135 (point (point pane)))
1242     (if (query-replace-find-next-match point string1)
1243     (display-message "Query Replace ~A with ~A:"
1244     string1 string2)
1245     (setf (query-replace-mode pane) nil))))
1246 mvilleneuve 1.100
1247     (define-named-command com-query-replace-exit ()
1248     (setf (query-replace-mode (current-window)) nil))
1249    
1250     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1251     ;;;
1252     ;;; Undo/redo
1253    
1254 rstrandh 1.98 (define-named-command com-undo ()
1255 rstrandh 1.148 (handler-case (undo (undo-tree (buffer (current-window))))
1256     (no-more-undo () (beep) (display-message "No more undo")))
1257 abakic 1.128 (full-redisplay (current-window)))
1258 rstrandh 1.98
1259     (define-named-command com-redo ()
1260 rstrandh 1.148 (handler-case (redo (undo-tree (buffer (current-window))))
1261     (no-more-undo () (beep) (display-message "No more redo")))
1262 abakic 1.128 (full-redisplay (current-window)))
1263 rstrandh 1.98
1264 mvilleneuve 1.96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1265     ;;;
1266     ;;; Dynamic abbrevs
1267 ejohnson 1.27
1268 rstrandh 1.49 (define-named-command com-dabbrev-expand ()
1269 rstrandh 1.80 (let* ((win (current-window))
1270 rstrandh 1.49 (point (point win)))
1271     (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
1272     (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
1273     (setf (offset dabbrev-expansion-mark)
1274     (offset point))
1275     (forward-word dabbrev-expansion-mark))
1276     ((mark< dabbrev-expansion-mark point)
1277     (backward-object dabbrev-expansion-mark))
1278     (t (forward-object dabbrev-expansion-mark)))))
1279     (unless (or (beginning-of-buffer-p point)
1280     (not (constituentp (object-before point))))
1281     (unless (and (eq (previous-command win) 'com-dabbrev-expand)
1282     (not (null prefix-start-offset)))
1283     (setf dabbrev-expansion-mark (clone-mark point))
1284     (backward-word dabbrev-expansion-mark)
1285     (setf prefix-start-offset (offset dabbrev-expansion-mark))
1286     (setf original-prefix (region-to-sequence prefix-start-offset point))
1287     (move))
1288     (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
1289     (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
1290     (not (constituentp (object-before dabbrev-expansion-mark))))
1291     (looking-at dabbrev-expansion-mark original-prefix)))
1292     do (move))
1293     (if (end-of-buffer-p dabbrev-expansion-mark)
1294     (progn (delete-region prefix-start-offset point)
1295     (insert-sequence point original-prefix)
1296     (setf prefix-start-offset nil))
1297     (progn (delete-region prefix-start-offset point)
1298     (insert-sequence point
1299     (let ((offset (offset dabbrev-expansion-mark)))
1300     (prog2 (forward-word dabbrev-expansion-mark)
1301     (region-to-sequence offset dabbrev-expansion-mark)
1302     (setf (offset dabbrev-expansion-mark) offset))))
1303     (move))))))))
1304    
1305 dmurray 1.171 (define-named-command com-backward-paragraph ((count 'integer :prompt "Number of paragraphs"))
1306 rstrandh 1.80 (let* ((pane (current-window))
1307 rstrandh 1.71 (point (point pane))
1308     (syntax (syntax (buffer pane))))
1309 dmurray 1.171 (if (plusp count)
1310     (loop repeat count do (backward-paragraph point syntax))
1311     (loop repeat (- count) do (forward-paragraph point syntax)))))
1312 rstrandh 1.71
1313 dmurray 1.171 (define-named-command com-forward-paragraph ((count 'integer :prompt "Number of paragraphs"))
1314 rstrandh 1.80 (let* ((pane (current-window))
1315 rstrandh 1.71 (point (point pane))
1316     (syntax (syntax (buffer pane))))
1317 dmurray 1.171 (if (plusp count)
1318     (loop repeat count do (forward-paragraph point syntax))
1319     (loop repeat (- count) do (backward-paragraph point syntax)))))
1320 rstrandh 1.106
1321 dmurray 1.168 (define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs"))
1322     (let* ((pane (current-window))
1323     (point (point pane))
1324     (mark (mark pane))
1325     (syntax (syntax (buffer pane))))
1326     (unless (eq (previous-command pane) 'com-mark-paragraph)
1327     (setf (offset mark) (offset point))
1328 dmurray 1.171 (if (plusp count)
1329     (backward-paragraph point syntax)
1330     (forward-paragraph point syntax)))
1331     (if (plusp count)
1332     (loop repeat count do (forward-paragraph mark syntax))
1333     (loop repeat (- count) do (backward-paragraph mark syntax)))))
1334 dmurray 1.170
1335 dmurray 1.171 (define-named-command com-backward-sentence ((count 'integer :prompt "Number of sentences"))
1336 dmurray 1.170 (let* ((pane (current-window))
1337     (point (point pane))
1338     (syntax (syntax (buffer pane))))
1339 dmurray 1.171 (if (plusp count)
1340     (loop repeat count do (backward-sentence point syntax))
1341     (loop repeat (- count) do (forward-sentence point syntax)))))
1342 dmurray 1.170
1343 dmurray 1.171 (define-named-command com-forward-sentence ((count 'integer :prompt "Number of sentences"))
1344 dmurray 1.170 (let* ((pane (current-window))
1345     (point (point pane))
1346     (syntax (syntax (buffer pane))))
1347 dmurray 1.171 (if (plusp count)
1348     (loop repeat count do (forward-sentence point syntax))
1349     (loop repeat (- count) do (backward-sentence point syntax)))))
1350 dmurray 1.170
1351 dmurray 1.173 (define-named-command com-kill-sentence ((count 'integer :prompt "Number of sentences"))
1352     (let* ((pane (current-window))
1353     (point (point pane))
1354     (mark (clone-mark point))
1355     (syntax (syntax (buffer pane))))
1356     (if (plusp count)
1357     (loop repeat count do (forward-sentence point syntax))
1358     (loop repeat (- count) do (backward-sentence point syntax)))
1359     (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
1360 crhodes 1.174 (delete-region point mark)))
1361 dmurray 1.173
1362     (define-named-command com-backward-kill-sentence ((count 'integer :prompt "Number of sentences"))
1363     (let* ((pane (current-window))
1364     (point (point pane))
1365     (mark (clone-mark point))
1366     (syntax (syntax (buffer pane))))
1367     (if (plusp count)
1368     (loop repeat count do (backward-sentence point syntax))
1369     (loop repeat (- count) do (forward-sentence point syntax)))
1370     (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
1371     (delete-region point mark)))
1372    
1373 dmurray 1.170 (defun forward-page (mark &optional (count 1))
1374     (loop repeat count
1375     unless (search-forward mark (coerce (list #\Newline #\Page) 'vector))
1376     do (end-of-buffer mark)
1377     (loop-finish)))
1378    
1379     (define-named-command com-forward-page ((count 'integer :prompt "Number of pages"))
1380     (let* ((pane (current-window))
1381     (point (point pane)))
1382 dmurray 1.171 (if (plusp count)
1383     (forward-page point count)
1384     (backward-page point count))))
1385 dmurray 1.170
1386     (defun backward-page (mark &optional (count 1))
1387     (loop repeat count
1388     when (search-backward mark (coerce (list #\Newline #\Page) 'vector))
1389     do (forward-object mark)
1390     else do (beginning-of-buffer mark)
1391     (loop-finish)))
1392    
1393     (define-named-command com-backward-page ((count 'integer :prompt "Number of pages"))
1394     (let* ((pane (current-window))
1395     (point (point pane)))
1396 dmurray 1.171 (if (plusp count)
1397     (backward-page point count)
1398     (forward-page point count))))
1399 dmurray 1.170
1400 dmurray 1.173 (define-named-command com-mark-page ((count 'integer :prompt "Move how many pages")
1401     (numargp 'boolean :prompt "Move to another page?"))
1402     (let* ((pane (current-window))
1403     (point (point pane))
1404     (mark (mark pane)))
1405     (cond ((and numargp (/= 0 count))
1406     (if (plusp count)
1407     (forward-page point count)
1408     (backward-page point (1+ count))))
1409     (t (backward-page point count)))
1410     (setf (offset mark) (offset point))
1411     (forward-page mark 1)))
1412    
1413 dmurray 1.170 (define-named-command com-count-lines-page ()
1414     (let* ((pane (current-window))
1415     (point (point pane))
1416     (start (clone-mark point))
1417     (end (clone-mark point)))
1418     (backward-page start)
1419     (forward-page end)
1420     (let ((total (number-of-lines-in-region start end))
1421     (before (number-of-lines-in-region start point))
1422     (after (number-of-lines-in-region point end)))
1423     (display-message "Page has ~A lines (~A + ~A)" total before after))))
1424 dmurray 1.168
1425 dmurray 1.172 (define-named-command com-count-lines-region ()
1426     (let* ((pane (current-window))
1427     (point (point pane))
1428     (mark (mark pane))
1429     (lines (number-of-lines-in-region point mark))
1430     (chars (abs (- (offset point) (offset mark)))))
1431     (display-message "Region has ~D line~:P, ~D character~:P." lines chars)))
1432    
1433     (define-named-command com-what-cursor-position ()
1434     (let* ((pane (current-window))
1435     (point (point pane))
1436     (buffer (buffer pane))
1437     (offset (offset point))
1438     (size (size buffer))
1439     (char (object-after point))
1440     (column (column-number point)))
1441     (display-message "Char: ~:C (#o~O ~:*~D ~:*#x~X) point=~D of ~D (~D%) column ~D"
1442     char (char-code char) offset size
1443     (round (* 100 (/ offset size))) column)))
1444    
1445 rstrandh 1.109 (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
1446     (let* ((*package* (find-package :climacs-gui))
1447 rstrandh 1.124 (string (handler-case (accept 'string :prompt "Eval")
1448     (error () (progn (beep)
1449     (display-message "Empty string")
1450     (return-from com-eval-expression nil)))))
1451     (result (format nil "~a"
1452     (handler-case (eval (read-from-string string))
1453     (error (condition) (progn (beep)
1454     (display-message "~a" condition)
1455     (return-from com-eval-expression nil)))))))
1456 rstrandh 1.109 (if insertp
1457     (insert-sequence (point (current-window)) result)
1458     (display-message result))))
1459    
1460 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1461     ;;;
1462 rstrandh 1.169 ;;; Commenting
1463    
1464     ;;; figure out how to make commands without key bindings accept numeric arguments.
1465     (define-named-command com-comment-region ()
1466     (let* ((pane (current-window))
1467     (point (point pane))
1468     (mark (mark pane))
1469     (syntax (syntax (buffer pane))))
1470     (comment-region syntax point mark)))
1471    
1472     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1473     ;;;
1474 rstrandh 1.141 ;;; For testing purposes
1475    
1476     (define-named-command com-reset-profile ()
1477 rstrandh 1.142 #+sbcl (sb-profile:reset)
1478     #-sbcl nil)
1479 rstrandh 1.141
1480     (define-named-command com-report-profile ()
1481 rstrandh 1.142 #+sbcl (sb-profile:report)
1482     #-sbcl nil)
1483 rstrandh 1.141
1484     (define-named-command com-recompile ()
1485     (asdf:operate 'asdf:load-op :climacs))
1486    
1487     (define-named-command com-backward-expression ((count 'integer :prompt "Number of expressions"))
1488     (let* ((pane (current-window))
1489     (point (point pane))
1490     (syntax (syntax (buffer pane))))
1491 dmurray 1.171 (if (plusp count)
1492     (loop repeat count do (backward-expression point syntax))
1493     (loop repeat (- count) do (forward-expression point syntax)))))
1494 rstrandh 1.141
1495     (define-named-command com-forward-expression ((count 'integer :prompt "Number of expresssions"))
1496     (let* ((pane (current-window))
1497     (point (point pane))
1498     (syntax (syntax (buffer pane))))
1499 dmurray 1.171 (if (plusp count)
1500     (loop repeat count do (forward-expression point syntax))
1501     (loop repeat (- count) do (backward-expression point syntax)))))
1502 rstrandh 1.141
1503 dmurray 1.168 (define-named-command com-mark-expression ((count 'integer :prompt "Number of expressions"))
1504     (let* ((pane (current-window))
1505 dmurray 1.175 (point (point pane))
1506     (mark (mark pane))
1507     (syntax (syntax (buffer pane))))
1508     (unless (eq (previous-command pane) 'com-mark-expression)
1509     (setf (offset mark) (offset point)))
1510     (if (plusp count)
1511     (loop repeat count do (forward-expression mark syntax))
1512     (loop repeat (- count) do (backward-expression mark syntax)))))
1513    
1514     (define-named-command com-kill-expression ((count 'integer :prompt "Number of expressions"))
1515     (let* ((pane (current-window))
1516     (point (point pane))
1517     (mark (clone-mark point))
1518     (syntax (syntax (buffer pane))))
1519     (if (plusp count)
1520     (loop repeat count do (forward-expression mark syntax))
1521     (loop repeat (- count) do (backward-expression mark syntax)))
1522     (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))
1523     (delete-region mark point)))
1524    
1525     (define-named-command com-backward-kill-expression
1526     ((count 'integer :prompt "Number of expressions"))
1527     (let* ((pane (current-window))
1528     (point (point pane))
1529     (mark (clone-mark point))
1530     (syntax (syntax (buffer pane))))
1531     (if (plusp count)
1532     (loop repeat count do (backward-expression mark syntax))
1533     (loop repeat (- count) do (forward-expression mark syntax)))
1534     (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))
1535     (delete-region mark point)))
1536    
1537     (define-named-command com-forward-list ((count 'integer :prompt "Number of lists"))
1538     (let* ((pane (current-window))
1539     (point (point pane))
1540     (syntax (syntax (buffer pane))))
1541     (if (plusp count)
1542     (loop repeat count do (forward-list point syntax))
1543     (loop repeat (- count) do (backward-list point syntax)))))
1544    
1545     (define-named-command com-backward-list ((count 'integer :prompt "Number of lists"))
1546     (let* ((pane (current-window))
1547     (point (point pane))
1548     (syntax (syntax (buffer pane))))
1549     (if (plusp count)
1550     (loop repeat count do (backward-list point syntax))
1551     (loop repeat (- count) do (forward-list point syntax)))))
1552    
1553     (define-named-command com-down-list ((count 'integer :prompt "Number of lists"))
1554     (let* ((pane (current-window))
1555     (point (point pane))
1556     (syntax (syntax (buffer pane))))
1557     (if (plusp count)
1558     (loop repeat count do (down-list point syntax))
1559     (loop repeat (- count) do (backward-down-list point syntax)))))
1560    
1561     (define-named-command com-backward-down-list ((count 'integer :prompt "Number of lists"))
1562     (let* ((pane (current-window))
1563     (point (point pane))
1564     (syntax (syntax (buffer pane))))
1565     (if (plusp count)
1566     (loop repeat count do (backward-down-list point syntax))
1567     (loop repeat (- count) do (down-list point syntax)))))
1568    
1569     (define-named-command com-backward-up-list ((count 'integer :prompt "Number of lists"))
1570     (let* ((pane (current-window))
1571     (point (point pane))
1572     (syntax (syntax (buffer pane))))
1573     (if (plusp count)
1574     (loop repeat count do (backward-up-list point syntax))
1575     (loop repeat (- count) do (up-list point syntax)))))
1576    
1577     (define-named-command com-up-list ((count 'integer :prompt "Number of lists"))
1578     (let* ((pane (current-window))
1579     (point (point pane))
1580     (syntax (syntax (buffer pane))))
1581     (if (plusp count)
1582     (loop repeat count do (up-list point syntax))
1583     (loop repeat (- count) do (backward-up-list point syntax)))))
1584 dmurray 1.168
1585 rstrandh 1.143 (define-named-command com-eval-defun ()
1586     (let* ((pane (current-window))
1587     (point (point pane))
1588     (syntax (syntax (buffer pane))))
1589     (eval-defun point syntax)))
1590    
1591 dmurray 1.171 (define-named-command com-beginning-of-definition ((count 'integer :prompt "Number of definitions"))
1592 dmurray 1.170 (let* ((pane (current-window))
1593     (point (point pane))
1594     (syntax (syntax (buffer pane))))
1595 dmurray 1.171 (if (plusp count)
1596     (loop repeat count do (beginning-of-definition point syntax))
1597     (loop repeat (- count) do (end-of-definition point syntax)))))
1598 dmurray 1.170
1599 dmurray 1.171 (define-named-command com-end-of-definition ((count 'integer :prompt "Number of definitions"))
1600 dmurray 1.170 (let* ((pane (current-window))
1601     (point (point pane))
1602     (syntax (syntax (buffer pane))))
1603 dmurray 1.171 (if (plusp count)
1604     (loop repeat count do (end-of-definition point syntax))
1605     (loop repeat (- count) do (beginning-of-definition point syntax)))))
1606 dmurray 1.170
1607     (define-named-command com-mark-definition ()
1608     (let* ((pane (current-window))
1609     (point (point pane))
1610     (mark (mark pane))
1611     (syntax (syntax (buffer pane))))
1612     (unless (eq (previous-command pane) 'com-mark-definition)
1613     (beginning-of-definition point syntax)
1614     (setf (offset mark) (offset point)))
1615     (end-of-definition mark syntax)))
1616    
1617 rstrandh 1.144 (define-named-command com-package ()
1618     (let* ((pane (current-window))
1619     (syntax (syntax (buffer pane)))
1620     (package (climacs-lisp-syntax::package-of syntax)))
1621     (display-message (format nil "~s" package))))
1622    
1623 rstrandh 1.166 (define-gesture-name :select-other :pointer-button-press (:left :meta) :unique nil)
1624    
1625     (define-presentation-translator lisp-string-to-string
1626     (climacs-lisp-syntax::lisp-string string global-climacs-table
1627     :gesture :select-other
1628     :tester-definitive t
1629     :menu nil
1630 dmurray 1.167 :priority 10)
1631 rstrandh 1.166 (object)
1632     object)
1633    
1634 rstrandh 1.144 (define-named-command com-accept-string ()
1635     (display-message (format nil "~s" (accept 'string))))
1636 dmurray 1.172
1637 rstrandh 1.144 (define-named-command com-accept-symbol ()
1638     (display-message (format nil "~s" (accept 'symbol))))
1639 rstrandh 1.166
1640     (define-named-command com-accept-lisp-string ()
1641 dmurray 1.167 (display-message (format nil "~s" (accept 'lisp-string))))
1642 rstrandh 1.144
1643 dmurray 1.177 (define-named-command com-toggle-visible-mark ()
1644     (setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window)))))
1645    
1646 rstrandh 1.141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1647     ;;;
1648 rstrandh 1.164 ;;; Dead-escape command tables
1649 ejohnson 1.27
1650 rstrandh 1.80 (make-command-table 'dead-escape-climacs-table :errorp nil)
1651    
1652     (add-menu-item-to-command-table 'global-climacs-table "dead-escape"
1653     :menu 'dead-escape-climacs-table
1654     :keystroke '(:escape))
1655    
1656     (defun dead-escape-set-key (gesture command)
1657     (add-command-to-command-table command 'dead-escape-climacs-table
1658     :keystroke gesture :errorp nil))
1659    
1660 ejohnson 1.27 (defun global-set-key (gesture command)
1661     (add-command-to-command-table command 'global-climacs-table
1662 rstrandh 1.80 :keystroke gesture :errorp nil)
1663     (when (and
1664     (listp gesture)
1665     (find :meta gesture))
1666     (dead-escape-set-key (remove :meta gesture) command)))
1667 ejohnson 1.27
1668 mvilleneuve 1.89 (loop for code from (char-code #\Space) to (char-code #\~)
1669 dmurray 1.171 do (global-set-key (code-char code) `(com-self-insert ,*numeric-argument-marker*)))
1670 ejohnson 1.27
1671 dmurray 1.171 (global-set-key #\Newline `(com-self-insert ,*numeric-argument-marker*))
1672 mvilleneuve 1.86 (global-set-key #\Tab 'com-indent-line)
1673 rstrandh 1.150 (global-set-key '(#\i :control) 'com-indent-line)
1674 rstrandh 1.109 (global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*))
1675 mvilleneuve 1.79 (global-set-key '(#\j :control) 'com-newline-and-indent)
1676 rstrandh 1.62 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
1677     (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
1678 ejohnson 1.27 (global-set-key '(#\a :control) 'com-beginning-of-line)
1679     (global-set-key '(#\e :control) 'com-end-of-line)
1680 dmurray 1.171 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*))
1681 rstrandh 1.111 (global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*))
1682 rstrandh 1.75 (global-set-key '(#\l :control) 'com-full-redisplay)
1683 rstrandh 1.111 (global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*))
1684 rstrandh 1.112 (global-set-key '(#\o :control) `(com-open-line ,*numeric-argument-marker*))
1685 rstrandh 1.110 (global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*))
1686 rstrandh 1.42 (global-set-key '(#\t :control) 'com-transpose-objects)
1687 ejohnson 1.27 (global-set-key '(#\Space :control) 'com-set-mark)
1688 ejohnson 1.50 (global-set-key '(#\y :control) 'com-yank)
1689 dmurray 1.170 (global-set-key '(#\w :control) 'com-kill-region)
1690 dmurray 1.176 (global-set-key '(#\w :control :meta) 'com-append-next-kill)
1691 dmurray 1.171 (global-set-key '(#\e :meta) `(com-forward-sentence ,*numeric-argument-marker*))
1692     (global-set-key '(#\a :meta) `(com-backward-sentence ,*numeric-argument-marker*))
1693 dmurray 1.173 (global-set-key '(#\k :meta) `(com-kill-sentence ,*numeric-argument-marker*))
1694 dmurray 1.168 (global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*))
1695 rstrandh 1.102 (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))
1696     (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))
1697 rstrandh 1.43 (global-set-key '(#\t :meta) 'com-transpose-words)
1698 rstrandh 1.60 (global-set-key '(#\u :meta) 'com-upcase-word)
1699     (global-set-key '(#\l :meta) 'com-downcase-word)
1700     (global-set-key '(#\c :meta) 'com-capitalize-word)
1701 ejohnson 1.50 (global-set-key '(#\y :meta) 'com-rotate-yank)
1702 dholman 1.159 (global-set-key '(#\z :meta) 'com-zap-to-character)
1703 dmurray 1.170 (global-set-key '(#\w :meta) 'com-copy-region)
1704 rstrandh 1.39 (global-set-key '(#\v :control) 'com-page-down)
1705 rstrandh 1.40 (global-set-key '(#\v :meta) 'com-page-up)
1706 dmurray 1.173 (global-set-key '(#\v :control :meta) 'com-scroll-other-window)
1707 dmurray 1.176 (global-set-key '(#\V :control :meta :shift) 'com-scroll-other-window-up)
1708 ejohnson 1.27 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
1709     (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
1710 rstrandh 1.32 (global-set-key '(#\m :meta) 'com-back-to-indentation)
1711 dmurray 1.173 (global-set-key '(#\\ :meta) `(com-delete-horizontal-space ,*numeric-argument-p*))
1712 dmurray 1.176 (global-set-key '(#\Space :meta) `(com-just-one-space ,*numeric-argument-marker*))
1713 mvilleneuve 1.74 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
1714 mvilleneuve 1.90 (global-set-key '(#\q :meta) 'com-fill-paragraph)
1715 dmurray 1.170 (global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*))
1716     (global-set-key '(#\Backspace :meta) `(com-backward-kill-word ,*numeric-argument-marker*))
1717 dmurray 1.168 (global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*))
1718 rstrandh 1.49 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
1719 dmurray 1.171 (global-set-key '(#\{ :meta :shift) `(com-backward-paragraph ,*numeric-argument-marker*))
1720     (global-set-key '(#\} :meta :shift) `(com-forward-paragraph ,*numeric-argument-marker*))
1721 dmurray 1.168 (global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*))
1722 mvilleneuve 1.97 (global-set-key '(#\s :control) 'com-isearch-mode-forward)
1723     (global-set-key '(#\r :control) 'com-isearch-mode-backward)
1724 dholman 1.159 (global-set-key '(#\_ :shift :meta) 'com-redo)
1725     (global-set-key '(#\_ :shift :control) 'com-undo)
1726 mvilleneuve 1.100 (global-set-key '(#\% :shift :meta) 'com-query-replace)
1727 dmurray 1.172 (global-set-key '(#\= :meta) 'com-count-lines-region)
1728 rstrandh 1.111 (global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*))
1729     (global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*))
1730 rstrandh 1.62 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
1731 ejohnson 1.66 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
1732 rstrandh 1.102 (global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*))
1733     (global-set-key '(:right :control) `(com-forward-word ,*numeric-argument-marker*))
1734 ejohnson 1.27 (global-set-key '(:home) 'com-beginning-of-line)
1735     (global-set-key '(:end) 'com-end-of-line)
1736 abridgewater 1.57 (global-set-key '(:prior) 'com-page-up)
1737     (global-set-key '(:next) 'com-page-down)
1738 ejohnson 1.27 (global-set-key '(:home :control) 'com-beginning-of-buffer)
1739     (global-set-key '(:end :control) 'com-end-of-buffer)
1740 dmurray 1.171 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*))
1741     (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*))
1742 abakic 1.58
1743     (global-set-key '(:insert) 'com-toggle-overwrite-mode)
1744 dmurray 1.170 (global-set-key '(#\~ :meta :shift) 'com-not-modified)
1745 rstrandh 1.141
1746     (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*))
1747     (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*))
1748 dmurray 1.175 (global-set-key '(#\Backspace :control :meta) `(com-backward-kill-expression ,*numeric-argument-marker*))
1749     (global-set-key '(#\k :control :meta) `(com-kill-expression ,*numeric-argument-marker*))
1750     (global-set-key '(#\n :control :meta) `(com-forward-list ,*numeric-argument-marker*))
1751     (global-set-key '(#\p :control :meta) `(com-backward-list ,*numeric-argument-marker*))
1752     (global-set-key '(#\d :control :meta) `(com-down-list ,*numeric-argument-marker*))
1753     (global-set-key '(#\u :control :meta) `(com-backward-up-list ,*numeric-argument-marker*))
1754 dmurray 1.170 (global-set-key '(#\x :control :meta) 'com-eval-defun)
1755 dmurray 1.171 (global-set-key '(#\a :control :meta) `(com-beginning-of-definition ,*numeric-argument-marker*))
1756     (global-set-key '(#\e :control :meta) `(com-end-of-definition ,*numeric-argument-marker*))
1757 dmurray 1.170 (global-set-key '(#\h :control :meta) 'com-mark-definition)
1758 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1759     ;;;
1760     ;;; C-x command table
1761    
1762     (make-command-table 'c-x-climacs-table :errorp nil)
1763    
1764     (add-menu-item-to-command-table 'global-climacs-table "C-x"
1765     :menu 'c-x-climacs-table
1766     :keystroke '(#\x :control))
1767    
1768     (defun c-x-set-key (gesture command)
1769     (add-command-to-command-table command 'c-x-climacs-table
1770     :keystroke gesture :errorp nil))
1771    
1772 rstrandh 1.83 (c-x-set-key '(#\0) 'com-delete-window)
1773 ejohnson 1.107 (c-x-set-key '(#\1) 'com-single-window)
1774 rstrandh 1.77 (c-x-set-key '(#\2) 'com-split-window-vertically)
1775 rstrandh 1.83 (c-x-set-key '(#\3) 'com-split-window-horizontally)
1776 rstrandh 1.75 (c-x-set-key '(#\b) 'com-switch-to-buffer)
1777 ejohnson 1.27 (c-x-set-key '(#\f :control) 'com-find-file)
1778 dmurray 1.170 (c-x-set-key '(#\f) `(com-set-fill-column ,*numeric-argument-marker*))
1779 dmurray 1.168 (c-x-set-key '(#\h) 'com-mark-whole-buffer)
1780 crhodes 1.139 (c-x-set-key '(#\i) 'com-insert-file)
1781 rstrandh 1.91 (c-x-set-key '(#\k) 'com-kill-buffer)
1782 rstrandh 1.83 (c-x-set-key '(#\o) 'com-other-window)
1783 rstrandh 1.98 (c-x-set-key '(#\r) 'com-redo)
1784     (c-x-set-key '(#\u) 'com-undo)
1785 dmurray 1.170 (c-x-set-key '(#\]) `(com-forward-page ,*numeric-argument-marker*))
1786     (c-x-set-key '(#\[) `(com-backward-page ,*numeric-argument-marker*))
1787 dmurray 1.173 (c-x-set-key '(#\p :control) `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*))
1788 dmurray 1.170 (c-x-set-key '(#\l) 'com-count-lines-page)
1789 ejohnson 1.27 (c-x-set-key '(#\s :control) 'com-save-buffer)
1790 rstrandh 1.45 (c-x-set-key '(#\t :control) 'com-transpose-lines)
1791 ejohnson 1.27 (c-x-set-key '(#\w :control) 'com-write-buffer)
1792 rstrandh 1.45 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
1793 dmurray 1.172 (c-x-set-key '(#\=) 'com-what-cursor-position)
1794 dmurray