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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5