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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.169 - (show annotations)
Thu Aug 4 01:10:45 2005 UTC (8 years, 8 months ago) by rstrandh
Branch: MAIN
Changes since 1.168: +12 -0 lines
Implemented comment-region and uncomment region as syntax-dependent
generic functions.

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

  ViewVC Help
Powered by ViewVC 1.1.5