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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.162 - (show annotations)
Fri Jul 22 05:35:06 2005 UTC (8 years, 8 months ago) by rstrandh
Branch: MAIN
Changes since 1.161: +0 -11 lines
Removed functions find-climacs-pane and find-real-pane because they
are no longer needed.

Removed stupid names from panes, because they are not needed.

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

  ViewVC Help
Powered by ViewVC 1.1.5