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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.176 - (show annotations)
Sun Aug 14 18:09:42 2005 UTC (8 years, 8 months ago) by dmurray
Branch: MAIN
Changes since 1.175: +25 -0 lines
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.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2
3 ;;; (c) copyright 2004-2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004-2005 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7 ;;; (c) copyright 2005 by
8 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 ;;; (c) copyright 2005 by
10 ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11
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 (defclass extended-pane (climacs-pane esa-pane-mixin)
32 (;; for next-line and previous-line commands
33 (goal-column :initform nil)
34 ;; for dynamic abbrev expansion
35 (original-prefix :initform nil)
36 (prefix-start-offset :initform nil)
37 (dabbrev-expansion-mark :initform nil)
38 (overwrite-mode :initform nil)))
39
40 (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 (defparameter *with-scrollbars* t
53 "If T, classic look and feel. If NIL, stripped-down look (:")
54
55 (define-application-frame climacs (standard-application-frame
56 esa-frame-mixin)
57 ((buffers :initform '() :accessor buffers))
58 (:command-table (global-climacs-table :inherit-from (global-esa-table)))
59 (:menu-bar nil)
60 (:panes
61 (win (let* ((extended-pane
62 (make-pane 'extended-pane
63 :width 900 :height 400
64 :end-of-line-action :scroll
65 :incremental-redisplay t
66 :display-function 'display-win
67 :command-table 'global-climacs-table))
68 (info-pane
69 (make-pane 'climacs-info-pane
70 :master-pane extended-pane
71 :width 900)))
72 (setf (windows *application-frame*) (list extended-pane)
73 (buffers *application-frame*) (list (buffer extended-pane)))
74
75 (vertically ()
76 (if *with-scrollbars*
77 (scrolling ()
78 extended-pane)
79 extended-pane)
80 info-pane)))
81 (int (make-pane 'climacs-minibuffer-pane :width 900)))
82 (:layouts
83 (default
84 (vertically (:scroll-bars nil)
85 win
86 int)))
87 (:top-level (esa-top-level)))
88
89 (defun current-window ()
90 (car (windows *application-frame*)))
91
92 (defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
93 (declare (ignore args))
94 (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
95 (loop for buffer in buffers
96 do (update-syntax buffer (syntax buffer)))
97 (call-next-method)
98 (loop for buffer in buffers
99 do (clear-modify buffer))))
100
101 (defun climacs (&key (width 900) (height 400))
102 "Starts up a climacs session"
103 (let ((frame (make-application-frame
104 'climacs :width width :height height)))
105 (run-frame-top-level frame)))
106
107 (defun display-info (frame pane)
108 (declare (ignore frame))
109 (let* ((master-pane (master-pane pane))
110 (buf (buffer master-pane))
111 (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 (if (needs-saving buf) "**" "--")
116 (name buf)
117 *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 (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 *with-scrollbars*
140 (if (recordingp *application-frame*)
141 "Def"
142 ""))))
143 (princ name-info pane)))
144
145 (defun display-win (frame pane)
146 "The display function used by the climacs application frame."
147 (declare (ignore frame))
148 (redisplay-pane pane (eq pane (current-window))))
149
150 (defmethod handle-repaint :before ((pane extended-pane) region)
151 (declare (ignore region))
152 (redisplay-frame-pane *application-frame* pane))
153
154 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
155
156 (defmethod execute-frame-command :around ((frame climacs) command)
157 (handler-case
158 (with-undo ((buffer (current-window)))
159 (call-next-method))
160 (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 (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
178 (defmacro define-named-command (command-name args &body body)
179 `(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
184 (define-named-command com-toggle-overwrite-mode ()
185 (with-slots (overwrite-mode) (current-window)
186 (setf overwrite-mode (not overwrite-mode))))
187
188 (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 (defun possibly-fill-line ()
197 (let* ((pane (current-window))
198 (buffer (buffer pane)))
199 (when (auto-fill-mode pane)
200 (let* ((fill-column (auto-fill-column pane))
201 (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 (1- fill-column))
207 (fill-line point
208 (lambda (mark)
209 (syntax-line-indentation mark tab-width syntax))
210 fill-column
211 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 (define-command com-self-insert ((count 'integer))
227 (loop repeat count do (insert-character *current-gesture*)))
228
229 (define-named-command com-beginning-of-line ()
230 (beginning-of-line (point (current-window))))
231
232 (define-named-command com-end-of-line ()
233 (end-of-line (point (current-window))))
234
235 (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
255 (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 (define-named-command com-transpose-objects ()
282 (let* ((point (point (current-window))))
283 (unless (beginning-of-buffer-p point)
284 (when (end-of-line-p point)
285 (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 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
293 (backward-object (point (current-window)) count))
294
295 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
296 (forward-object (point (current-window)) count))
297
298 (define-named-command com-transpose-words ()
299 (let* ((point (point (current-window))))
300 (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
322 (define-named-command com-transpose-lines ()
323 (let ((point (point (current-window))))
324 (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 (end-of-line point)
339 (when (end-of-buffer-p point)
340 (insert-object point #\Newline))
341 (next-line point 0)
342 (insert-sequence point line)
343 (insert-object point #\Newline))))
344
345 (define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?"))
346 (let* ((win (current-window))
347 (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 (if (plusp numarg)
352 (previous-line point (slot-value win 'goal-column) numarg)
353 (next-line point (slot-value win 'goal-column) (- numarg)))))
354
355 (define-named-command com-next-line ((numarg 'integer :prompt "How many lines?"))
356 (let* ((win (current-window))
357 (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 (if (plusp numarg)
362 (next-line point (slot-value win 'goal-column) numarg)
363 (previous-line point (slot-value win 'goal-column) (- numarg)))))
364
365 (define-named-command com-open-line ((numarg 'integer :prompt "How many lines?"))
366 (open-line (point (current-window)) numarg))
367
368 (define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
369 (numargp 'boolean :prompt "Kill entire lines?"))
370 (let* ((pane (current-window))
371 (point (point pane))
372 (mark (offset point)))
373 (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 (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 (t
388 (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
399 (define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
400 (if (plusp count)
401 (forward-word (point (current-window)) count)
402 (backward-word (point (current-window)) (- count))))
403
404 (define-named-command com-backward-word ((count 'integer :prompt "Number of words"))
405 (backward-word (point (current-window)) count))
406
407 (define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
408 (delete-word (point (current-window)) count))
409
410 (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 (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 (if (plusp count)
447 (forward-word mark count)
448 (backward-word mark (- count)))))
449
450 (define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words"))
451 (backward-delete-word (point (current-window)) count))
452
453 (define-named-command com-upcase-region ()
454 (let ((cw (current-window)))
455 (upcase-region (mark cw) (point cw))))
456
457 (define-named-command com-downcase-region ()
458 (let ((cw (current-window)))
459 (downcase-region (mark cw) (point cw))))
460
461 (define-named-command com-capitalize-region ()
462 (let ((cw (current-window)))
463 (capitalize-region (mark cw) (point cw))))
464
465 (define-named-command com-upcase-word ()
466 (upcase-word (point (current-window))))
467
468 (define-named-command com-downcase-word ()
469 (downcase-word (point (current-window))))
470
471 (define-named-command com-capitalize-word ()
472 (capitalize-word (point (current-window))))
473
474 (define-named-command com-tabify-region ()
475 (let ((pane (current-window)))
476 (tabify-region
477 (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
478
479 (define-named-command com-untabify-region ()
480 (let ((pane (current-window)))
481 (untabify-region
482 (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
483
484 (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 (let* ((pane (current-window))
496 (point (point pane)))
497 (indent-current-line pane point)))
498
499 (define-named-command com-newline-and-indent ()
500 (let* ((pane (current-window))
501 (point (point pane)))
502 (insert-object point #\Newline)
503 (indent-current-line pane point)))
504
505 (define-named-command com-delete-indentation ()
506 (delete-indentation (point (current-window))))
507
508 (define-named-command com-auto-fill-mode ()
509 (let ((pane (current-window)))
510 (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
511
512 (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 (backward-paragraph begin-mark syntax))
521 (unless (eql (object-after end-mark) #\Newline)
522 (forward-paragraph end-mark syntax))
523 (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 (eval-when (:compile-toplevel :load-toplevel)
533 (define-presentation-type completable-pathname ()
534 :inherit-from 'pathname))
535
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 (namestring #+sbcl *default-pathname-defaults*
544 #+cmu (ext:default-directory)
545 #-(or sbcl cmu) *default-pathname-defaults*)))
546 (full-so-far (concatenate 'string directory-prefix so-far))
547 (pathnames
548 (loop with length = (length full-so-far)
549 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 (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 (defun filepath-filename (pathname)
614 (if (null (pathname-type pathname))
615 (pathname-name pathname)
616 (concatenate 'string (pathname-name pathname)
617 "." (pathname-type pathname))))
618
619 (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 (define-named-command com-find-file ()
630 (let ((filepath (accept 'completable-pathname
631 :prompt "Find File"))
632 (buffer (make-instance 'climacs-buffer))
633 (pane (current-window)))
634 (setf (offset (point (buffer pane))) (offset (point pane)))
635 (push buffer (buffers *application-frame*))
636 (setf (buffer (current-window)) buffer)
637 (setf (syntax buffer)
638 (make-instance
639 (syntax-class-name-for-filepath filepath)
640 :buffer (buffer (point pane))))
641 ;; Don't want to create the file if it doesn't exist.
642 (when (probe-file filepath)
643 (with-open-file (stream filepath :direction :input)
644 (input-from-stream stream buffer 0)))
645 (setf (filepath buffer) filepath
646 (name buffer) (filepath-filename filepath)
647 (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
653 (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 (defun save-buffer (buffer)
668 (let ((filepath (or (filepath buffer)
669 (accept 'completable-pathname
670 :prompt "Save Buffer to File"))))
671 (with-open-file (stream filepath :direction :output :if-exists :supersede)
672 (output-to-stream stream buffer 0 (size buffer)))
673 (setf (filepath buffer) filepath
674 (name buffer) (filepath-filename filepath))
675 (display-message "Wrote: ~a" (filepath buffer))
676 (setf (needs-saving buffer) nil)))
677
678 (define-named-command com-save-buffer ()
679 (let ((buffer (buffer (current-window))))
680 (if (or (null (filepath buffer))
681 (needs-saving buffer))
682 (save-buffer buffer)
683 (display-message "No changes need to be saved from ~a" (name buffer)))))
684
685 (defmethod frame-exit :around ((frame climacs))
686 (loop for buffer in (buffers frame)
687 when (and (needs-saving buffer)
688 (filepath buffer)
689 (handler-case (accept 'boolean
690 :prompt (format nil "Save buffer: ~a ?" (name buffer)))
691 (error () (progn (beep)
692 (display-message "Invalid answer")
693 (return-from frame-exit nil)))))
694 do (save-buffer buffer))
695 (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
696 (buffers frame))
697 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
698 (error () (progn (beep)
699 (display-message "Invalid answer")
700 (return-from frame-exit nil)))))
701 (call-next-method)))
702
703 (define-named-command com-write-buffer ()
704 (let ((filepath (accept 'completable-pathname
705 :prompt "Write Buffer to File"))
706 (buffer (buffer (current-window))))
707 (with-open-file (stream filepath :direction :output :if-exists :supersede)
708 (output-to-stream stream buffer 0 (size buffer)))
709 (setf (filepath buffer) filepath
710 (name buffer) (filepath-filename filepath)
711 (needs-saving buffer) nil)
712 (display-message "Wrote: ~a" (filepath buffer))))
713
714 (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 (declare (ignore success))
726 (or object
727 (car (push (make-instance 'climacs-buffer :name string)
728 (buffers *application-frame*))))))
729
730 (define-named-command com-switch-to-buffer ()
731 (let ((buffer (accept 'buffer
732 :prompt "Switch to buffer"))
733 (pane (current-window)))
734 (setf (offset (point (buffer pane))) (offset (point pane)))
735 (setf (buffer pane) buffer)
736 (full-redisplay pane)))
737
738 (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 (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 (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 (define-named-command com-full-redisplay ()
755 (full-redisplay (current-window)))
756
757 (define-named-command com-load-file ()
758 (let ((filepath (accept 'completable-pathname
759 :prompt "Load File")))
760 (load filepath)))
761
762 (define-named-command com-beginning-of-buffer ()
763 (beginning-of-buffer (point (current-window))))
764
765 (define-named-command com-page-down ()
766 (let ((pane (current-window)))
767 (page-down pane)))
768
769 (define-named-command com-page-up ()
770 (let ((pane (current-window)))
771 (page-up pane)))
772
773 (define-named-command com-end-of-buffer ()
774 (end-of-buffer (point (current-window))))
775
776 (define-named-command com-mark-whole-buffer ()
777 (beginning-of-buffer (point (current-window)))
778 (end-of-buffer (mark (current-window))))
779
780 (define-named-command com-back-to-indentation ()
781 (let ((point (point (current-window))))
782 (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 (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 (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
815 (define-named-command com-goto-position ()
816 (setf (offset (point (current-window)))
817 (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
822 (define-named-command com-goto-line ()
823 (loop with mark = (let ((m (clone-mark
824 (low-mark (buffer (current-window)))
825 :right)))
826 (beginning-of-buffer m)
827 m)
828 do (end-of-line mark)
829 until (end-of-buffer-p mark)
830 repeat (1- (handler-case (accept 'integer :prompt "Goto Line")
831 (error () (progn (beep)
832 (display-message "Not a valid line number")
833 (return-from com-goto-line nil)))))
834 do (incf (offset mark))
835 (end-of-line mark)
836 finally (beginning-of-line mark)
837 (setf (offset (point (current-window)))
838 (offset mark))))
839
840 (define-named-command com-browse-url ()
841 (let ((url (accept 'url :prompt "Browse URL")))
842 #+ (and sbcl darwin)
843 (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)))
844
845 (define-named-command com-set-mark ()
846 (let ((pane (current-window)))
847 (setf (mark pane) (clone-mark (point pane)))))
848
849 (define-named-command com-exchange-point-and-mark ()
850 (let ((pane (current-window)))
851 (psetf (offset (mark pane)) (offset (point pane))
852 (offset (point pane)) (offset (mark pane)))))
853
854 (define-named-command com-set-syntax ()
855 (let* ((pane (current-window))
856 (buffer (buffer pane)))
857 (setf (syntax buffer)
858 (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 :buffer (buffer (point pane))))))
863
864 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
865 ;;;
866 ;;; Commands for splitting windows
867
868 (defun replace-constellation (constellation additional-constellation vertical-p)
869 (let* ((parent (sheet-parent constellation))
870 (children (sheet-children parent))
871 (first (first children))
872 (second (second children))
873 (third (third children))
874 (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
875 (assert (member constellation children))
876 (sheet-disown-child parent constellation)
877 (let ((new (if vertical-p
878 (vertically ()
879 (1/2 constellation) adjust (1/2 additional-constellation))
880 (horizontally ()
881 (1/2 constellation) adjust (1/2 additional-constellation)))))
882 (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
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 as two values.
900 If *with-scrollbars nil, omit the scroller."
901
902 (let* ((extended-pane
903 (make-pane 'extended-pane
904 :width 900 :height 400
905 :name 'win
906 :end-of-line-action :scroll
907 :incremental-redisplay t
908 :display-function 'display-win
909 :command-table 'global-climacs-table))
910 (vbox
911 (vertically ()
912 (if *with-scrollbars*
913 (scrolling ()
914 extended-pane)
915 extended-pane)
916 (make-pane 'climacs-info-pane
917 :master-pane extended-pane
918 :width 900))))
919 (values vbox extended-pane)))
920
921 (define-named-command com-split-window-vertically ()
922 (with-look-and-feel-realization
923 ((frame-manager *application-frame*) *application-frame*)
924 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
925 (let* ((current-window (current-window))
926 (constellation-root (if *with-scrollbars*
927 (parent3 current-window)
928 (sheet-parent current-window))))
929 (setf (offset (point (buffer current-window))) (offset (point current-window))
930 (buffer new-pane) (buffer current-window)
931 (auto-fill-mode new-pane) (auto-fill-mode current-window)
932 (auto-fill-column new-pane) (auto-fill-column current-window))
933 (push new-pane (windows *application-frame*))
934 (setf *standard-output* new-pane)
935 (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 (constellation-root (if *with-scrollbars*
945 (parent3 current-window)
946 (sheet-parent current-window))))
947 (setf (offset (point (buffer current-window))) (offset (point current-window))
948 (buffer new-pane) (buffer current-window)
949 (auto-fill-mode new-pane) (auto-fill-mode current-window)
950 (auto-fill-column new-pane) (auto-fill-column current-window))
951 (push new-pane (windows *application-frame*))
952 (setf *standard-output* new-pane)
953 (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 (list (car (windows *application-frame*)))))
961 (setf *standard-output* (car (windows *application-frame*))))
962
963 (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 (com-delete-window))
968 (setf *standard-output* (car (windows *application-frame*))))
969
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
975 (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 (define-named-command com-delete-window ()
981 (unless (null (cdr (windows *application-frame*)))
982 (let* ((constellation (if *with-scrollbars*
983 (parent3 (current-window))
984 (sheet-parent (current-window))))
985 (box (sheet-parent constellation))
986 (box-children (sheet-children box))
987 (other (if (eq constellation (first box-children))
988 (third box-children)
989 (first box-children)))
990 (parent (sheet-parent box))
991 (children (sheet-children parent))
992 (first (first children))
993 (second (second children))
994 (third (third children)))
995 (pop (windows *application-frame*))
996 (setf *standard-output* (car (windows *application-frame*)))
997 (sheet-disown-child box other)
998 (sheet-disown-child parent box)
999 (sheet-adopt-child parent other)
1000 (reorder-sheets parent (if (eq box first)
1001 (if third
1002 (list other second third)
1003 (list other second))
1004 (if third
1005 (list first second other)
1006 (list first other)))))))
1007
1008 ;;;;;;;;;;;;;;;;;;;;
1009 ;; Kill ring commands
1010
1011 ;; Copies an element from a kill-ring to a buffer at the given offset
1012 (define-named-command com-yank ()
1013 (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
1014
1015 ;; Destructively cut a given buffer region into the kill-ring
1016 (define-named-command com-kill-region ()
1017 (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
1022 ;; Non destructively copies in buffer region to the kill ring
1023 (define-named-command com-copy-region ()
1024 (let ((pane (current-window)))
1025 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
1026
1027 (define-named-command com-rotate-yank ()
1028 (let* ((pane (current-window))
1029 (point (point pane))
1030 (last-yank (kill-ring-yank *kill-ring*)))
1031 (if (eq (previous-command pane)
1032 'com-rotate-yank)
1033 (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
1038 (define-named-command com-resize-kill-ring ()
1039 (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 (setf (kill-ring-max-size *kill-ring*) size)))
1044
1045 (define-named-command com-append-next-kill ()
1046 (setf (append-next-p *kill-ring*) t))
1047
1048 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1049 ;;;
1050 ;;; Incremental search
1051
1052 (defun isearch-command-loop (pane forwardp)
1053 (let ((point (point pane)))
1054 (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 :search-mark (clone-mark point)
1062 :search-forward-p forwardp
1063 :search-success-p t)))
1064 (simple-command-loop 'isearch-climacs-table
1065 (isearch-mode pane)
1066 ((setf (isearch-mode pane) nil)))))
1067
1068 (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 (when success
1080 (setf (offset point) (offset mark2)
1081 (offset mark) (if forwardp
1082 (- (offset mark2) (length string))
1083 (+ (offset mark2) (length string)))))
1084 (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A"
1085 success forwardp string)
1086 (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
1095 (define-named-command com-isearch-mode-forward ()
1096 (display-message "Isearch: ")
1097 (isearch-command-loop (current-window) t))
1098
1099 (define-named-command com-isearch-mode-backward ()
1100 (display-message "Isearch backward: ")
1101 (isearch-command-loop (current-window) nil))
1102
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 (forwardp (search-forward-p (first states))))
1111 (unless forwardp
1112 (incf (offset mark)))
1113 (isearch-from-mark pane mark string forwardp)))
1114
1115 (define-named-command com-isearch-delete-char ()
1116 (let* ((pane (current-window)))
1117 (cond ((null (second (isearch-states pane)))
1118 (display-message "Isearch: ")
1119 (beep))
1120 (t
1121 (pop (isearch-states pane))
1122 (loop until (endp (rest (isearch-states pane)))
1123 until (search-success-p (first (isearch-states pane)))
1124 do (pop (isearch-states pane)))
1125 (let ((state (first (isearch-states pane))))
1126 (setf (offset (point pane))
1127 (if (search-forward-p state)
1128 (+ (offset (search-mark state))
1129 (length (search-string state)))
1130 (- (offset (search-mark state))
1131 (length (search-string state)))))
1132 (display-message "Isearch~:[ backward~;~]: ~A"
1133 (search-forward-p state)
1134 (search-string state)))))))
1135
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 (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
1156 (define-named-command com-isearch-exit ()
1157 (setf (isearch-mode (current-window)) nil))
1158
1159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1160 ;;;
1161 ;;; Query replace
1162
1163 (defun query-replace-find-next-match (mark string)
1164 (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
1172 (define-named-command com-query-replace ()
1173 (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 (error () (progn (beep)
1185 (display-message "Empty string")
1186 (return-from com-query-replace nil)))))
1187 (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 (error () (progn (beep)
1197 (display-message "Empty string")
1198 (return-from com-query-replace nil)))))
1199 (point (point pane))
1200 (occurrences 0))
1201 (declare (special string1 string2 occurrences))
1202 (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 (display-message "Query Replace ~A with ~A:"
1208 string1 string2)
1209 (simple-command-loop 'query-replace-climacs-table
1210 (query-replace-mode pane)
1211 ((setf (query-replace-mode pane) nil))))
1212 (display-message "Replaced ~A occurrence~:P" occurrences)))
1213
1214 (define-named-command com-query-replace-replace ()
1215 (declare (special string1 string2 occurrences))
1216 (let* ((pane (current-window))
1217 (point (point pane))
1218 (buffer (buffer pane))
1219 (string1-length (length string1)))
1220 (backward-object point string1-length)
1221 (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 (insert-sequence point string2)
1226 (setf offset2 (+ offset1 (length string2)))
1227 (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 (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
1238 (define-named-command com-query-replace-skip ()
1239 (declare (special string1 string2))
1240 (let* ((pane (current-window))
1241 (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
1247 (define-named-command com-query-replace-exit ()
1248 (setf (query-replace-mode (current-window)) nil))
1249
1250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1251 ;;;
1252 ;;; Undo/redo
1253
1254 (define-named-command com-undo ()
1255 (handler-case (undo (undo-tree (buffer (current-window))))
1256 (no-more-undo () (beep) (display-message "No more undo")))
1257 (full-redisplay (current-window)))
1258
1259 (define-named-command com-redo ()
1260 (handler-case (redo (undo-tree (buffer (current-window))))
1261 (no-more-undo () (beep) (display-message "No more redo")))
1262 (full-redisplay (current-window)))
1263
1264 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1265 ;;;
1266 ;;; Dynamic abbrevs
1267
1268 (define-named-command com-dabbrev-expand ()
1269 (let* ((win (current-window))
1270 (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 (define-named-command com-backward-paragraph ((count 'integer :prompt "Number of paragraphs"))
1306 (let* ((pane (current-window))
1307 (point (point pane))
1308 (syntax (syntax (buffer pane))))
1309 (if (plusp count)
1310 (loop repeat count do (backward-paragraph point syntax))
1311 (loop repeat (- count) do (forward-paragraph point syntax)))))
1312
1313 (define-named-command com-forward-paragraph ((count 'integer :prompt "Number of paragraphs"))
1314 (let* ((pane (current-window))
1315 (point (point pane))
1316 (syntax (syntax (buffer pane))))
1317 (if (plusp count)
1318 (loop repeat count do (forward-paragraph point syntax))
1319 (loop repeat (- count) do (backward-paragraph point syntax)))))
1320
1321 (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 (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
1335 (define-named-command com-backward-sentence ((count 'integer :prompt "Number of sentences"))
1336 (let* ((pane (current-window))
1337 (point (point pane))
1338 (syntax (syntax (buffer pane))))
1339 (if (plusp count)
1340 (loop repeat count do (backward-sentence point syntax))
1341 (loop repeat (- count) do (forward-sentence point syntax)))))
1342
1343 (define-named-command com-forward-sentence ((count 'integer :prompt "Number of sentences"))
1344 (let* ((pane (current-window))
1345 (point (point pane))
1346 (syntax (syntax (buffer pane))))
1347 (if (plusp count)
1348 (loop repeat count do (forward-sentence point syntax))
1349 (loop repeat (- count) do (backward-sentence point syntax)))))
1350
1351 (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 (delete-region point mark)))
1361
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 (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 (if (plusp count)
1383 (forward-page point count)
1384 (backward-page point count))))
1385
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 (if (plusp count)
1397 (backward-page point count)
1398 (forward-page point count))))
1399
1400 (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 (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
1425 (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 (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
1446 (let* ((*package* (find-package :climacs-gui))
1447 (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 (if insertp
1457 (insert-sequence (point (current-window)) result)
1458 (display-message result))))
1459
1460 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1461 ;;;
1462 ;;; 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 ;;; For testing purposes
1475
1476 (define-named-command com-reset-profile ()
1477 #+sbcl (sb-profile:reset)
1478 #-sbcl nil)
1479
1480 (define-named-command com-report-profile ()
1481 #+sbcl (sb-profile:report)
1482 #-sbcl nil)
1483
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 (if (plusp count)
1492 (loop repeat count do (backward-expression point syntax))
1493 (loop repeat (- count) do (forward-expression point syntax)))))
1494
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 (if (plusp count)
1500 (loop repeat count do (forward-expression point syntax))
1501 (loop repeat (- count) do (backward-expression point syntax)))))
1502
1503 (define-named-command com-mark-expression ((count 'integer :prompt "Number of expressions"))
1504 (let* ((pane (current-window))
1505 (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
1585 (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 (define-named-command com-beginning-of-definition ((count 'integer :prompt "Number of definitions"))
1592 (let* ((pane (current-window))
1593 (point (point pane))
1594 (syntax (syntax (buffer pane))))
1595 (if (plusp count)
1596 (loop repeat count do (beginning-of-definition point syntax))
1597 (loop repeat (- count) do (end-of-definition point syntax)))))
1598
1599 (define-named-command com-end-of-definition ((count 'integer :prompt "Number of definitions"))
1600 (let* ((pane (current-window))
1601 (point (point pane))
1602 (syntax (syntax (buffer pane))))
1603 (if (plusp count)
1604 (loop repeat count do (end-of-definition point syntax))
1605 (loop repeat (- count) do (beginning-of-definition point syntax)))))
1606
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 (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 (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 :priority 10)
1631 (object)
1632 object)
1633
1634 (define-named-command com-accept-string ()
1635 (display-message (format nil "~s" (accept 'string))))
1636
1637 (define-named-command com-accept-symbol ()
1638 (display-message (format nil "~s" (accept 'symbol))))
1639
1640 (define-named-command com-accept-lisp-string ()
1641 (display-message (format nil "~s" (accept 'lisp-string))))
1642
1643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1644 ;;;
1645 ;;; Dead-escape command tables
1646
1647 (make-command-table 'dead-escape-climacs-table :errorp nil)
1648
1649 (add-menu-item-to-command-table 'global-climacs-table "dead-escape"
1650 :menu 'dead-escape-climacs-table
1651 :keystroke '(:escape))
1652
1653 (defun dead-escape-set-key (gesture command)
1654 (add-command-to-command-table command 'dead-escape-climacs-table
1655 :keystroke gesture :errorp nil))
1656
1657 (defun global-set-key (gesture command)
1658 (add-command-to-command-table command 'global-climacs-table
1659 :keystroke gesture :errorp nil)
1660 (when (and
1661 (listp gesture)
1662 (find :meta gesture))
1663 (dead-escape-set-key (remove :meta gesture) command)))
1664
1665 (loop for code from (char-code #\Space) to (char-code #\~)
1666 do (global-set-key (code-char code) `(com-self-insert ,*numeric-argument-marker*)))
1667
1668 (global-set-key #\Newline `(com-self-insert ,*numeric-argument-marker*))
1669 (global-set-key #\Tab 'com-indent-line)
1670 (global-set-key '(#\i :control) 'com-indent-line)
1671 (global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*))
1672 (global-set-key '(#\j :control) 'com-newline-and-indent)
1673 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
1674 (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
1675 (global-set-key '(#\a :control) 'com-beginning-of-line)
1676 (global-set-key '(#\e :control) 'com-end-of-line)
1677 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*))
1678 (global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*))
1679 (global-set-key '(#\l :control) 'com-full-redisplay)
1680 (global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*))
1681 (global-set-key '(#\o :control) `(com-open-line ,*numeric-argument-marker*))
1682 (global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*))
1683 (global-set-key '(#\t :control) 'com-transpose-objects)
1684 (global-set-key '(#\Space :control) 'com-set-mark)
1685 (global-set-key '(#\y :control) 'com-yank)
1686 (global-set-key '(#\w :control) 'com-kill-region)
1687 (global-set-key '(#\w :control :meta) 'com-append-next-kill)
1688 (global-set-key '(#\e :meta) `(com-forward-sentence ,*numeric-argument-marker*))
1689 (global-set-key '(#\a :meta) `(com-backward-sentence ,*numeric-argument-marker*))
1690 (global-set-key '(#\k :meta) `(com-kill-sentence ,*numeric-argument-marker*))
1691 (global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*))
1692 (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))
1693 (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))
1694 (global-set-key '(#\t :meta) 'com-transpose-words)
1695 (global-set-key '(#\u :meta) 'com-upcase-word)
1696 (global-set-key '(#\l :meta) 'com-downcase-word)
1697 (global-set-key '(#\c :meta) 'com-capitalize-word)
1698 (global-set-key '(#\y :meta) 'com-rotate-yank)
1699 (global-set-key '(#\z :meta) 'com-zap-to-character)
1700 (global-set-key '(#\w :meta) 'com-copy-region)
1701 (global-set-key '(#\v :control) 'com-page-down)
1702 (global-set-key '(#\v :meta) 'com-page-up)
1703 (global-set-key '(#\v :control :meta) 'com-scroll-other-window)
1704 (global-set-key '(#\V :control :meta :shift) 'com-scroll-other-window-up)
1705 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
1706 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
1707 (global-set-key '(#\m :meta) 'com-back-to-indentation)
1708 (global-set-key '(#\\ :meta) `(com-delete-horizontal-space ,*numeric-argument-p*))
1709 (global-set-key '(#\Space :meta) `(com-just-one-space ,*numeric-argument-marker*))
1710 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
1711 (global-set-key '(#\q :meta) 'com-fill-paragraph)
1712 (global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*))
1713 (global-set-key '(#\Backspace :meta) `(com-backward-kill-word ,*numeric-argument-marker*))
1714 (global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*))
1715 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
1716 (global-set-key '(#\{ :meta :shift) `(com-backward-paragraph ,*numeric-argument-marker*))
1717 (global-set-key '(#\} :meta :shift) `(com-forward-paragraph ,*numeric-argument-marker*))
1718 (global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*))
1719 (global-set-key '(#\s :control) 'com-isearch-mode-forward)
1720 (global-set-key '(#\r :control) 'com-isearch-mode-backward)
1721 (global-set-key '(#\_ :shift :meta) 'com-redo)
1722 (global-set-key '(#\_ :shift :control) 'com-undo)
1723 (global-set-key '(#\% :shift :meta) 'com-query-replace)
1724 (global-set-key '(#\= :meta) 'com-count-lines-region)
1725 (global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*))
1726 (global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*))
1727 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
1728 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
1729 (global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*))
1730 (global-set-key '(:right :control) `(com-forward-word ,*numeric-argument-marker*))
1731 (global-set-key '(:home) 'com-beginning-of-line)
1732 (global-set-key '(:end) 'com-end-of-line)
1733 (global-set-key '(:prior) 'com-page-up)
1734 (global-set-key '(:next) 'com-page-down)
1735 (global-set-key '(:home :control) 'com-beginning-of-buffer)
1736 (global-set-key '(:end :control) 'com-end-of-buffer)
1737 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*))
1738 (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker* ,*numeric-argument-p*))
1739
1740 (global-set-key '(:insert) 'com-toggle-overwrite-mode)
1741 (global-set-key '(#\~ :meta :shift) 'com-not-modified)
1742
1743 (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*))
1744 (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*))
1745 (global-set-key '(#\Backspace :control :meta) `(com-backward-kill-expression ,*numeric-argument-marker*))
1746 (global-set-key '(#\k :control :meta) `(com-kill-expression ,*numeric-argument-marker*))
1747 (global-set-key '(#\n :control :meta) `(com-forward-list ,*numeric-argument-marker*))
1748 (global-set-key '(#\p :control :meta) `(com-backward-list ,*numeric-argument-marker*))
1749 (global-set-key '(#\d :control :meta) `(com-down-list ,*numeric-argument-marker*))
1750 (global-set-key '(#\u :control :meta) `(com-backward-up-list ,*numeric-argument-marker*))
1751 (global-set-key '(#\x :control :meta) 'com-eval-defun)
1752 (global-set-key '(#\a :control :meta) `(com-beginning-of-definition ,*numeric-argument-marker*))
1753 (global-set-key '(#\e :control :meta) `(com-end-of-definition ,*numeric-argument-marker*))
1754 (global-set-key '(#\h :control :meta) 'com-mark-definition)
1755 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1756 ;;;
1757 ;;; C-x command table
1758
1759 (make-command-table 'c-x-climacs-table :errorp nil)
1760
1761 (add-menu-item-to-command-table 'global-climacs-table "C-x"
1762 :menu 'c-x-climacs-table
1763 :keystroke '(#\x :control))
1764
1765 (defun c-x-set-key (gesture command)
1766 (add-command-to-command-table command 'c-x-climacs-table
1767 :keystroke gesture :errorp nil))
1768
1769 (c-x-set-key '(#\0) 'com-delete-window)
1770 (c-x-set-key '(#\1) 'com-single-window)
1771 (c-x-set-key '(#\2) 'com-split-window-vertically)
1772 (c-x-set-key '(#\3) 'com-split-window-horizontally)
1773 (c-x-set-key '(#\b) 'com-switch-to-buffer)
1774 (c-x-set-key '(#\f :control) 'com-find-file)
1775 (c-x-set-key '(#\f) `(com-set-fill-column ,*numeric-argument-marker*))
1776 (c-x-set-key '(#\h) 'com-mark-whole-buffer)
1777 (c-x-set-key '(#\i) 'com-insert-file)
1778 (c-x-set-key '(#\k) 'com-kill-buffer)
1779 (c-x-set-key '(#\o) 'com-other-window)
1780 (c-x-set-key '(#\r) 'com-redo)
1781 (c-x-set-key '(#\u) 'com-undo)
1782 (c-x-set-key '(#\]) `(com-forward-page ,*numeric-argument-marker*))
1783 (c-x-set-key '(#\[) `(com-backward-page ,*numeric-argument-marker*))
1784 (c-x-set-key '(#\p :control) `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*))
1785 (c-x-set-key '(#\l) 'com-count-lines-page)
1786 (c-x-set-key '(#\s :control) 'com-save-buffer)
1787 (c-x-set-key '(#\t :control) 'com-transpose-lines)
1788 (c-x-set-key '(#\w :control) 'com-write-buffer)
1789 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
1790 (c-x-set-key '(#\=) 'com-what-cursor-position)
1791 (c-x-set-key '(#\Backspace) `(com-backward-kill-sentence ,*numeric-argument-marker*))
1792
1793 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1794 ;;;
1795 ;;; Some Unicode stuff
1796
1797 (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
1798 (insert-object (point (current-window)) (code-char code)))
1799
1800 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1801 ;;;
1802 ;;; Dead-acute command table
1803
1804 (make-command-table 'dead-acute-climacs-table :errorp nil)
1805
1806 (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
1807 :menu 'dead-acute-climacs-table
1808 :keystroke '(:dead--acute))
1809
1810 (defun dead-acute-set-key (gesture command)
1811 (add-command-to-command-table command 'dead-acute-climacs-table
1812 :keystroke gesture :errorp nil))
1813
1814 (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
1815 (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
1816 (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
1817 (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
1818 (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
1819 (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
1820 (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
1821 (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
1822 (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
1823 (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
1824 (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
1825 (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
1826 (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
1827 (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
1828 (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
1829 (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
1830 (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
1831 (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
1832 (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
1833 (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
1834
1835 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
1836
1837 (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
1838 :menu 'dead-acute-dead-accute-climacs-table
1839 :keystroke '(:dead--acute))
1840
1841 (defun dead-acute-dead-accute-set-key (gesture command)
1842 (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
1843 :keystroke gesture :errorp nil))
1844
1845 (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
1846 (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
1847 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1848 ;;;
1849 ;;; Dead-grave command table
1850
1851 (make-command-table 'dead-grave-climacs-table :errorp nil)
1852
1853 (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
1854 :menu 'dead-grave-climacs-table
1855 :keystroke '(:dead--grave))
1856
1857 (defun dead-grave-set-key (gesture command)
1858 (add-command-to-command-table command 'dead-grave-climacs-table
1859 :keystroke gesture :errorp nil))
1860
1861 (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
1862 (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
1863 (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
1864 (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
1865 (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
1866 (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
1867 (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
1868 (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
1869 (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
1870 (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
1871 (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
1872
1873 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1874 ;;;
1875 ;;; Dead-diaeresis command table
1876
1877 (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
1878
1879 (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
1880 :menu 'dead-diaeresis-climacs-table
1881 :keystroke '(:dead--diaeresis :shift))
1882
1883 (defun dead-diaeresis-set-key (gesture command)
1884 (add-command-to-command-table command 'dead-diaeresis-climacs-table
1885 :keystroke gesture :errorp nil))
1886
1887 (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
1888 (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
1889 (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
1890 (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
1891 (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
1892 (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
1893 (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
1894 (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
1895 (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
1896 (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
1897 (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
1898 (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
1899
1900 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1901 ;;;
1902 ;;; Dead-tilde command table
1903
1904 (make-command-table 'dead-tilde-climacs-table :errorp nil)
1905
1906 (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
1907 :menu 'dead-tilde-climacs-table
1908 :keystroke '(:dead--tilde :shift))
1909
1910 (defun dead-tilde-set-key (gesture command)
1911 (add-command-to-command-table command 'dead-tilde-climacs-table
1912 :keystroke gesture :errorp nil))
1913
1914 (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
1915 (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
1916 (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
1917 (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
1918 (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
1919 (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
1920 (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
1921 (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
1922 (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
1923 (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
1924 (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
1925
1926 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1927 ;;;
1928 ;;; Dead-circumflex command table
1929
1930 (make-command-table 'dead-circumflex-climacs-table :errorp nil)
1931
1932 (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
1933 :menu 'dead-circumflex-climacs-table
1934 :keystroke '(:dead--circumflex :shift))
1935
1936 (defun dead-circumflex-set-key (gesture command)
1937 (add-command-to-command-table command 'dead-circumflex-climacs-table
1938 :keystroke gesture :errorp nil))
1939
1940 (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
1941 (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
1942 (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
1943 (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
1944 (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
1945 (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
1946 (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
1947 (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
1948 (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
1949 (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
1950 (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))
1951
1952 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1953 ;;;
1954 ;;; Isearch command table
1955
1956 (make-command-table 'isearch-climacs-table :errorp nil)
1957
1958 (defun isearch-set-key (gesture command)
1959 (add-command-to-command-table command 'isearch-climacs-table
1960 :keystroke gesture :errorp nil))
1961
1962 (loop for code from (char-code #\Space) to (char-code #\~)
1963 do (isearch-set-key (code-char code) 'com-isearch-append-char))
1964
1965 (isearch-set-key '(#\Newline) 'com-isearch-exit)
1966 (isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
1967 (isearch-set-key '(#\s :control) 'com-isearch-forward)
1968 (isearch-set-key '(#\r :control) 'com-isearch-backward)
1969
1970 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1971 ;;;
1972 ;;; Query replace command table
1973
1974 (make-command-table 'query-replace-climacs-table :errorp nil)
1975
1976 (defun query-replace-set-key (gesture command)
1977 (add-command-to-command-table command 'query-replace-climacs-table
1978 :keystroke gesture :errorp nil))
1979
1980 (query-replace-set-key '(#\Newline) 'com-query-replace-exit)
1981 (query-replace-set-key '(#\Space) 'com-query-replace-replace)
1982 (query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
1983 (query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
1984 (query-replace-set-key '(#\q) 'com-query-replace-exit)
1985 (query-replace-set-key '(#\y) 'com-query-replace-replace)
1986 (query-replace-set-key '(#\n) 'com-query-replace-skip)
1987
1988 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1989 ;;;
1990 ;;; C-c command table
1991
1992 (make-command-table 'c-c-climacs-table :errorp nil)
1993
1994 (add-menu-item-to-command-table 'global-climacs-table "C-c"
1995 :menu 'c-c-climacs-table
1996 :keystroke '(#\c :control))
1997
1998 (defun c-c-set-key (gesture command)
1999 (add-command-to-command-table command 'c-c-climacs-table
2000 :keystroke gesture :errorp nil))
2001

  ViewVC Help
Powered by ViewVC 1.1.5