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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.68 - (hide annotations)
Fri Jan 14 20:44:47 2005 UTC (9 years, 3 months ago) by abakic
Branch: MAIN
Changes since 1.67: +11 -7 lines
Turned *overwrite-mode* variable into a slot of climacs-pane. (Perhaps
there should be pane-mixin and buffer-mixin for non-essential slots.)
1 ejohnson 1.27 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2    
3 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
4 ejohnson 1.27 ;;; Robert Strandh (strandh@labri.fr)
5 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
6 ejohnson 1.27 ;;; Elliott Johnson (ejohnson@fasl.info)
7 mvilleneuve 1.65 ;;; (c) copyright 2005 by
8     ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 abakic 1.68 ;;; (c) copyright 2005 by
10     ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11 ejohnson 1.27
12     ;;; This library is free software; you can redistribute it and/or
13     ;;; modify it under the terms of the GNU Library General Public
14     ;;; License as published by the Free Software Foundation; either
15     ;;; version 2 of the License, or (at your option) any later version.
16     ;;;
17     ;;; This library is distributed in the hope that it will be useful,
18     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20     ;;; Library General Public License for more details.
21     ;;;
22     ;;; You should have received a copy of the GNU Library General Public
23     ;;; License along with this library; if not, write to the
24     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25     ;;; Boston, MA 02111-1307 USA.
26    
27     ;;; GUI for the Climacs editor.
28    
29     (in-package :climacs-gui)
30    
31     (defclass filename-mixin ()
32     ((filename :initform nil :accessor filename)))
33    
34 rstrandh 1.38 (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin)
35     ((needs-saving :initform nil :accessor needs-saving))
36     (:default-initargs :name "*scratch*"))
37    
38 ejohnson 1.27
39     (defclass climacs-pane (application-pane)
40     ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
41     (point :initform nil :initarg :point :reader point)
42     (syntax :initarg :syntax :accessor syntax)
43 rstrandh 1.49 (mark :initform nil :initarg :mark :reader mark)
44     ;; allows a certain number of commands to have some minimal memory
45     (previous-command :initform nil :accessor previous-command)
46     ;; for next-line and previous-line commands
47     (goal-column :initform nil)
48     ;; for dynamic abbrev expansion
49     (original-prefix :initform nil)
50     (prefix-start-offset :initform nil)
51 abakic 1.68 (dabbrev-expansion-mark :initform nil)
52     (overwrite-mode :initform nil)))
53 ejohnson 1.27
54     (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
55     (declare (ignore args))
56     (with-slots (buffer point syntax mark) pane
57     (when (null point)
58     (setf point (make-instance 'standard-right-sticky-mark
59     :buffer buffer)))
60     (when (null mark)
61     (setf mark (make-instance 'standard-right-sticky-mark
62     :buffer buffer)))
63     (setf syntax (make-instance 'texinfo-syntax :pane pane))))
64    
65 rstrandh 1.28 (defclass minibuffer-pane (application-pane) ())
66    
67     (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
68     (declare (ignore type args))
69     (window-clear pane))
70    
71 ejohnson 1.27 (define-application-frame climacs ()
72     ((win :reader win))
73     (:panes
74     (win (make-pane 'climacs-pane
75     :width 900 :height 400
76     :name 'win
77     :incremental-redisplay t
78     :display-function 'display-win))
79 rstrandh 1.62
80     (info :application
81     :width 900 :height 20 :max-height 20
82     :name 'info :background +light-gray+
83     :scroll-bars nil
84     :borders nil
85     :incremental-redisplay t
86     :display-function 'display-info)
87     (int (make-pane 'minibuffer-pane
88     :width 900 :height 20 :max-height 20 :min-height 20
89     :scroll-bars nil)))
90 ejohnson 1.27 (:layouts
91     (default
92     (vertically (:scroll-bars nil)
93     (scrolling (:width 900 :height 400) win)
94     info
95 rstrandh 1.45 int))
96     (without-interactor
97     (vertically (:scroll-bars nil)
98     (scrolling (:width 900 :height 400) win)
99     info)))
100 ejohnson 1.27 (:top-level (climacs-top-level)))
101    
102 rstrandh 1.28 (defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
103     (declare (ignore args))
104     (clear-modify (buffer (win frame))))
105    
106 ejohnson 1.27 (defun climacs ()
107     "Starts up a climacs session"
108     (let ((frame (make-application-frame 'climacs)))
109     (run-frame-top-level frame)))
110    
111 rstrandh 1.30 (defun display-message (format-string &rest format-args)
112     (apply #'format *standard-input* format-string format-args))
113    
114 ejohnson 1.27 (defun display-info (frame pane)
115     (let* ((win (win frame))
116     (buf (buffer win))
117 abakic 1.58 (name-info (format nil " ~a ~a Syntax: ~a ~a"
118 rstrandh 1.28 (if (needs-saving buf) "**" "--")
119 rstrandh 1.38 (name buf)
120 abakic 1.58 (name (syntax win))
121 abakic 1.68 (if (slot-value win 'overwrite-mode)
122 abakic 1.58 "Ovwrt"
123 rstrandh 1.61 ""))))
124 ejohnson 1.27 (princ name-info pane)))
125    
126     (defun display-win (frame pane)
127     "The display function used by the climacs application frame."
128     (declare (ignore frame))
129     (redisplay-pane pane))
130    
131     (defun find-gestures (gestures start-table)
132     (loop with table = (find-command-table start-table)
133     for (gesture . rest) on gestures
134     for item = (find-keystroke-item gesture table :errorp nil)
135     while item
136     do (if (eq (command-menu-item-type item) :command)
137     (return (if (null rest) item nil))
138     (setf table (command-menu-item-value item)))
139     finally (return item)))
140    
141 ejohnson 1.50 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
142 ejohnson 1.27 (defparameter *current-gesture* nil)
143    
144 rstrandh 1.36 (defun meta-digit (gesture)
145     (position gesture
146     '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
147     (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
148     :test #'event-matches-gesture-name-p))
149    
150 rstrandh 1.47 (defun climacs-read-gesture ()
151     (loop for gesture = (read-gesture :stream *standard-input*)
152     when (event-matches-gesture-name-p gesture '(#\g :control))
153     do (throw 'outer-loop nil)
154     until (or (characterp gesture)
155     (and (typep gesture 'keyboard-event)
156     (or (keyboard-event-character gesture)
157     (not (member (keyboard-event-key-name
158     gesture)
159     '(:control-left :control-right
160     :shift-left :shift-right
161     :meta-left :meta-right
162     :super-left :super-right
163     :hyper-left :hyper-right
164     :shift-lock :caps-lock
165     :alt-left :alt-right))))))
166     finally (return gesture)))
167    
168 rstrandh 1.36 (defun read-numeric-argument (&key (stream *standard-input*))
169 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
170 rstrandh 1.62 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
171 rstrandh 1.36 (let ((numarg 4))
172 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
173 rstrandh 1.62 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
174 rstrandh 1.36 do (setf numarg (* 4 numarg))
175     finally (unread-gesture gesture :stream stream))
176 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
177 rstrandh 1.36 (cond ((and (characterp gesture)
178     (digit-char-p gesture 10))
179     (setf numarg (- (char-code gesture) (char-code #\0)))
180 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
181 rstrandh 1.36 while (and (characterp gesture)
182     (digit-char-p gesture 10))
183 rstrandh 1.62 do (setf numarg (+ (* 10 numarg)
184     (- (char-code gesture) (char-code #\0))))
185 rstrandh 1.36 finally (unread-gesture gesture :stream stream)
186     (return (values numarg t))))
187     (t
188 rstrandh 1.62 (unread-gesture gesture :stream stream)
189 rstrandh 1.36 (values numarg t))))))
190     ((meta-digit gesture)
191     (let ((numarg (meta-digit gesture)))
192 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
193 rstrandh 1.36 while (meta-digit gesture)
194     do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
195     finally (unread-gesture gesture :stream stream)
196     (return (values numarg t)))))
197     (t (unread-gesture gesture :stream stream)
198     (values 1 nil)))))
199    
200 ejohnson 1.27 (defun climacs-top-level (frame &key
201     command-parser command-unparser
202     partial-command-parser prompt)
203     (declare (ignore command-parser command-unparser partial-command-parser prompt))
204     (setf (slot-value frame 'win) (find-pane-named frame 'win))
205     (let ((*standard-output* (find-pane-named frame 'win))
206     (*standard-input* (find-pane-named frame 'int))
207     (*print-pretty* nil)
208     (*abort-gestures* nil))
209     (redisplay-frame-panes frame :force-p t)
210 rstrandh 1.47 (loop (catch 'outer-loop
211 rstrandh 1.62 (loop for gestures = '()
212     for numarg = (read-numeric-argument :stream *standard-input*)
213     do (loop (setf *current-gesture* (climacs-read-gesture))
214     (setf gestures (nconc gestures (list *current-gesture*)))
215     (let ((item (find-gestures gestures 'global-climacs-table)))
216     (cond ((not item)
217     (beep) (return))
218     ((eq (command-menu-item-type item) :command)
219     (let ((command (command-menu-item-value item)))
220     (unless (consp command)
221     (setf command (list command)))
222     (setf command (substitute-numeric-argument-marker command numarg))
223     (handler-case
224     (execute-frame-command frame command)
225     (error (condition)
226     (beep)
227     (format *error-output* "~a~%" condition)))
228     (setf (previous-command *standard-output*)
229     (if (consp command)
230     (car command)
231     command))
232     (return)))
233     (t nil))))
234 rstrandh 1.47 (let ((buffer (buffer (win frame))))
235     (when (modified-p buffer)
236     (setf (needs-saving buffer) t)))
237     (redisplay-frame-panes frame)))
238     (beep)
239     (let ((buffer (buffer (win frame))))
240     (when (modified-p buffer)
241     (setf (needs-saving buffer) t)))
242     (redisplay-frame-panes frame))))
243 ejohnson 1.27
244 mvilleneuve 1.64 (defun region-limits (pane)
245     (with-slots (point mark) pane
246     (if (< (offset mark) (offset point))
247     (values mark point)
248     (values point mark))))
249    
250 abridgewater 1.34 (defmacro define-named-command (command-name args &body body)
251 rstrandh 1.62 `(define-climacs-command ,(if (listp command-name)
252     `(,@command-name :name t)
253     `(,command-name :name t)) ,args ,@body))
254 abridgewater 1.34
255     (define-named-command (com-quit) ()
256 ejohnson 1.27 (frame-exit *application-frame*))
257    
258 abakic 1.58 (define-named-command com-toggle-overwrite-mode ()
259 abakic 1.68 (let ((win (win *application-frame*)))
260     (setf (slot-value win 'overwrite-mode)
261     (not (slot-value win 'overwrite-mode)))))
262 abakic 1.58
263 ejohnson 1.27 (define-command com-self-insert ()
264 abakic 1.68 (let* ((win (win *application-frame*))
265     (point (point win)))
266 abakic 1.58 (unless (constituentp *current-gesture*)
267     (possibly-expand-abbrev point))
268 abakic 1.68 (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
269 abakic 1.58 (progn
270     (delete-range point)
271     (insert-object point *current-gesture*))
272     (insert-object point *current-gesture*))))
273 ejohnson 1.27
274 abridgewater 1.34 (define-named-command com-beginning-of-line ()
275 ejohnson 1.27 (beginning-of-line (point (win *application-frame*))))
276    
277 abridgewater 1.34 (define-named-command com-end-of-line ()
278 ejohnson 1.27 (end-of-line (point (win *application-frame*))))
279    
280 rstrandh 1.62 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
281     (delete-range (point (win *application-frame*)) count))
282 ejohnson 1.27
283 rstrandh 1.62 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
284     (delete-range (point (win *application-frame*)) (- count)))
285 ejohnson 1.27
286 rstrandh 1.42 (define-named-command com-transpose-objects ()
287     (let* ((point (point (win *application-frame*))))
288     (unless (beginning-of-buffer-p point)
289     (when (end-of-line-p point)
290 rstrandh 1.43 (backward-object point))
291     (let ((object (object-after point)))
292     (delete-range point)
293     (backward-object point)
294     (insert-object point object)
295     (forward-object point)))))
296    
297 rstrandh 1.62 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
298     (backward-object (point (win *application-frame*)) count))
299 rstrandh 1.43
300 rstrandh 1.62 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
301     (forward-object (point (win *application-frame*)) count))
302 rstrandh 1.43
303     (define-named-command com-transpose-words ()
304     (let* ((point (point (win *application-frame*))))
305     (let (bw1 bw2 ew1 ew2)
306     (backward-word point)
307     (setf bw1 (offset point))
308     (forward-word point)
309     (setf ew1 (offset point))
310     (forward-word point)
311     (when (= (offset point) ew1)
312     ;; this is emacs' message in the minibuffer
313     (error "Don't have two things to transpose"))
314     (setf ew2 (offset point))
315     (backward-word point)
316     (setf bw2 (offset point))
317     (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
318     (w1 (buffer-sequence (buffer point) bw1 ew1)))
319     (delete-word point)
320     (insert-sequence point w1)
321     (backward-word point)
322     (backward-word point)
323     (delete-word point)
324     (insert-sequence point w2)
325     (forward-word point)))))
326 rstrandh 1.42
327 rstrandh 1.45 (define-named-command com-transpose-lines ()
328     (let ((point (point (win *application-frame*))))
329     (beginning-of-line point)
330     (unless (beginning-of-buffer-p point)
331     (previous-line point))
332     (let* ((bol (offset point))
333     (eol (progn (end-of-line point)
334     (offset point)))
335     (line (buffer-sequence (buffer point) bol eol)))
336     (delete-region bol point)
337     ;; Remove newline at end of line as well.
338     (unless (end-of-buffer-p point)
339     (delete-range point))
340     ;; If the current line is at the end of the buffer, we want to
341     ;; be able to insert past it, so we need to get an extra line
342     ;; at the end.
343     (when (progn (end-of-line point)
344     (end-of-buffer-p point))
345     (insert-object point #\Newline))
346     (next-line point)
347     (insert-sequence point line)
348     (insert-object point #\Newline))))
349    
350 abridgewater 1.34 (define-named-command com-previous-line ()
351 rstrandh 1.49 (let* ((win (win *application-frame*))
352     (point (point win)))
353     (unless (or (eq (previous-command win) 'com-previous-line)
354     (eq (previous-command win) 'com-next-line))
355     (setf (slot-value win 'goal-column) (column-number point)))
356     (previous-line point (slot-value win 'goal-column))))
357 ejohnson 1.27
358 abridgewater 1.34 (define-named-command com-next-line ()
359 rstrandh 1.49 (let* ((win (win *application-frame*))
360     (point (point win)))
361     (unless (or (eq (previous-command win) 'com-previous-line)
362     (eq (previous-command win) 'com-next-line))
363     (setf (slot-value win 'goal-column) (column-number point)))
364     (next-line point (slot-value win 'goal-column))))
365 ejohnson 1.27
366 abridgewater 1.34 (define-named-command com-open-line ()
367 rstrandh 1.28 (open-line (point (win *application-frame*))))
368 ejohnson 1.27
369 abridgewater 1.34 (define-named-command com-kill-line ()
370 ejohnson 1.54 (let* ((pane (win *application-frame*))
371     (point (point pane))
372     (mark (offset point)))
373 ejohnson 1.56 (cond ((end-of-buffer-p point) nil)
374     ((end-of-line-p point)(forward-object point))
375     (t
376     (end-of-line point)
377     (cond ((beginning-of-buffer-p point) nil)
378     ((beginning-of-line-p point)(forward-object point)))))
379 ejohnson 1.54 (if (eq (previous-command pane) 'com-kill-line)
380 ejohnson 1.51 (kill-ring-concatenating-push *kill-ring*
381 ejohnson 1.54 (region-to-sequence mark point))
382 ejohnson 1.51 (kill-ring-standard-push *kill-ring*
383 ejohnson 1.54 (region-to-sequence mark point)))
384     (delete-region mark point)))
385 ejohnson 1.27
386 abridgewater 1.34 (define-named-command com-forward-word ()
387 ejohnson 1.27 (forward-word (point (win *application-frame*))))
388    
389 abridgewater 1.34 (define-named-command com-backward-word ()
390 ejohnson 1.27 (backward-word (point (win *application-frame*))))
391    
392 abridgewater 1.34 (define-named-command com-delete-word ()
393 rstrandh 1.32 (delete-word (point (win *application-frame*))))
394    
395 abridgewater 1.34 (define-named-command com-backward-delete-word ()
396 rstrandh 1.32 (backward-delete-word (point (win *application-frame*))))
397    
398 mvilleneuve 1.64 (define-named-command com-upcase-region ()
399     (multiple-value-bind (start end) (region-limits (win *application-frame*))
400     (upcase-region start end)))
401    
402     (define-named-command com-downcase-region ()
403     (multiple-value-bind (start end) (region-limits (win *application-frame*))
404     (downcase-region start end)))
405    
406     (define-named-command com-capitalize-region ()
407     (multiple-value-bind (start end) (region-limits (win *application-frame*))
408     (capitalize-region start end)))
409    
410 rstrandh 1.60 (define-named-command com-upcase-word ()
411     (upcase-word (point (win *application-frame*))))
412    
413     (define-named-command com-downcase-word ()
414     (downcase-word (point (win *application-frame*))))
415    
416     (define-named-command com-capitalize-word ()
417     (capitalize-word (point (win *application-frame*))))
418    
419 abridgewater 1.34 (define-named-command com-toggle-layout ()
420 ejohnson 1.27 (setf (frame-current-layout *application-frame*)
421     (if (eq (frame-current-layout *application-frame*) 'default)
422 rstrandh 1.45 'without-interactor
423 ejohnson 1.27 'default)))
424    
425     (define-command com-extended-command ()
426     (let ((item (accept 'command :prompt "Extended Command")))
427     (execute-frame-command *application-frame* item)))
428    
429 rstrandh 1.41 (eval-when (:compile-toplevel :load-toplevel)
430 ejohnson 1.35 (define-presentation-type completable-pathname ()
431     :inherit-from 'pathname))
432 ejohnson 1.27
433     (defun filename-completer (so-far mode)
434     (flet ((remove-trail (s)
435     (subseq s 0 (let ((pos (position #\/ s :from-end t)))
436     (if pos (1+ pos) 0)))))
437     (let* ((directory-prefix
438     (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
439     ""
440     (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
441     (full-so-far (concatenate 'string directory-prefix so-far))
442     (pathnames
443     (loop with length = (length full-so-far)
444     for path in (directory (concatenate 'string
445     (remove-trail so-far)
446     "*.*"))
447     when (let ((mismatch (mismatch (namestring path) full-so-far)))
448     (or (null mismatch) (= mismatch length)))
449     collect path))
450     (strings (mapcar #'namestring pathnames))
451     (first-string (car strings))
452     (length-common-prefix nil)
453     (completed-string nil)
454     (full-completed-string nil))
455     (unless (null pathnames)
456     (setf length-common-prefix
457     (loop with length = (length first-string)
458     for string in (cdr strings)
459     do (setf length (min length (or (mismatch string first-string) length)))
460     finally (return length))))
461     (unless (null pathnames)
462     (setf completed-string
463     (subseq first-string (length directory-prefix)
464     (if (null (cdr pathnames)) nil length-common-prefix)))
465     (setf full-completed-string
466     (concatenate 'string directory-prefix completed-string)))
467     (case mode
468     ((:complete-limited :complete-maximal)
469     (cond ((null pathnames)
470     (values so-far nil nil 0 nil))
471     ((null (cdr pathnames))
472     (values completed-string t (car pathnames) 1 nil))
473     (t
474     (values completed-string nil nil (length pathnames) nil))))
475     (:complete
476     (cond ((null pathnames)
477     (values so-far t so-far 1 nil))
478     ((null (cdr pathnames))
479     (values completed-string t (car pathnames) 1 nil))
480     ((find full-completed-string strings :test #'string-equal)
481     (let ((pos (position full-completed-string strings :test #'string-equal)))
482     (values completed-string
483     t (elt pathnames pos) (length pathnames) nil)))
484     (t
485     (values completed-string nil nil (length pathnames) nil))))
486     (:possibilities
487     (values nil nil nil (length pathnames)
488     (loop with length = (length directory-prefix)
489     for name in pathnames
490     collect (list (subseq (namestring name) length nil)
491     name))))))))
492    
493     (define-presentation-method accept
494     ((type completable-pathname) stream (view textual-view) &key)
495     (multiple-value-bind (pathname success string)
496     (complete-input stream
497     #'filename-completer
498     :partial-completers '(#\Space)
499     :allow-any-input t)
500     (declare (ignore success))
501     (or pathname string)))
502    
503     (defun pathname-filename (pathname)
504     (if (null (pathname-type pathname))
505     (pathname-name pathname)
506     (concatenate 'string (pathname-name pathname)
507     "." (pathname-type pathname))))
508    
509 abridgewater 1.34 (define-named-command com-find-file ()
510 ejohnson 1.27 (let ((filename (accept 'completable-pathname
511     :prompt "Find File")))
512     (with-slots (buffer point syntax) (win *application-frame*)
513     (setf buffer (make-instance 'climacs-buffer)
514     point (make-instance 'standard-right-sticky-mark :buffer buffer)
515     syntax (make-instance 'texinfo-syntax :pane (win *application-frame*)))
516     (with-open-file (stream filename :direction :input :if-does-not-exist :create)
517     (input-from-stream stream buffer 0))
518     (setf (filename buffer) filename
519 rstrandh 1.28 (name buffer) (pathname-filename filename)
520     (needs-saving buffer) nil)
521 rstrandh 1.37 (beginning-of-buffer point)
522 rstrandh 1.28 ;; this one is needed so that the buffer modification protocol
523     ;; resets the low and high marks after redisplay
524 rstrandh 1.37 (redisplay-frame-panes *application-frame*))))
525 ejohnson 1.27
526 abridgewater 1.34 (define-named-command com-save-buffer ()
527 rstrandh 1.30 (let* ((buffer (buffer (win *application-frame*)))
528     (filename (or (filename buffer)
529     (accept 'completable-pathname
530     :prompt "Save Buffer to File"))))
531     (if (or (null (filename buffer))
532     (needs-saving buffer))
533     (progn (with-open-file (stream filename :direction :output :if-exists :supersede)
534     (output-to-stream stream buffer 0 (size buffer)))
535     (setf (filename buffer) filename
536     (name buffer) (pathname-filename filename))
537     (display-message "Wrote: ~a" (filename buffer)))
538     (display-message "No changes need to be saved from ~a" (name buffer)))
539     (setf (needs-saving buffer) nil)))
540 ejohnson 1.27
541 abridgewater 1.34 (define-named-command com-write-buffer ()
542 ejohnson 1.27 (let ((filename (accept 'completable-pathname
543     :prompt "Write Buffer to File"))
544     (buffer (buffer (win *application-frame*))))
545     (with-open-file (stream filename :direction :output :if-exists :supersede)
546     (output-to-stream stream buffer 0 (size buffer)))
547     (setf (filename buffer) filename
548 rstrandh 1.28 (name buffer) (pathname-filename filename)
549 rstrandh 1.30 (needs-saving buffer) nil)
550     (display-message "Wrote: ~a" (filename buffer))))
551 ejohnson 1.27
552 rstrandh 1.63 (define-named-command com-load-file ()
553     (let ((filename (accept 'completable-pathname
554     :prompt "Load File")))
555     (load filename)))
556    
557 abridgewater 1.34 (define-named-command com-beginning-of-buffer ()
558 ejohnson 1.27 (beginning-of-buffer (point (win *application-frame*))))
559    
560 rstrandh 1.39 (define-named-command com-page-down ()
561     (let ((pane (win *application-frame*)))
562     (page-down pane (syntax pane))))
563    
564 rstrandh 1.40 (define-named-command com-page-up ()
565     (let ((pane (win *application-frame*)))
566     (page-up pane (syntax pane))))
567    
568 abridgewater 1.34 (define-named-command com-end-of-buffer ()
569 ejohnson 1.27 (end-of-buffer (point (win *application-frame*))))
570    
571 abridgewater 1.34 (define-named-command com-back-to-indentation ()
572 rstrandh 1.32 (let ((point (point (win *application-frame*))))
573     (beginning-of-line point)
574     (loop until (end-of-line-p point)
575     while (whitespacep (object-after point))
576     do (incf (offset point)))))
577    
578 abridgewater 1.34 (define-named-command com-goto-position ()
579 rstrandh 1.32 (setf (offset (point (win *application-frame*)))
580     (accept 'integer :prompt "Goto Position")))
581    
582 abridgewater 1.34 (define-named-command com-goto-line ()
583 rstrandh 1.32 (loop with mark = (make-instance 'standard-right-sticky-mark
584     :buffer (buffer (win *application-frame*)))
585     do (end-of-line mark)
586     until (end-of-buffer-p mark)
587     repeat (accept 'integer :prompt "Goto Line")
588     do (incf (offset mark))
589     (end-of-line mark)
590     finally (beginning-of-line mark)
591     (setf (offset (point (win *application-frame*)))
592     (offset mark))))
593    
594 abridgewater 1.34 (define-named-command com-browse-url ()
595 ejohnson 1.27 (accept 'url :prompt "Browse URL"))
596    
597 abridgewater 1.34 (define-named-command com-set-mark ()
598 ejohnson 1.27 (with-slots (point mark) (win *application-frame*)
599 rstrandh 1.45 (setf mark (clone-mark point))))
600    
601     (define-named-command com-exchange-point-and-mark ()
602     (with-slots (point mark) (win *application-frame*)
603     (psetf (offset mark) (offset point)
604     (offset point) (offset mark))))
605 rstrandh 1.38
606     (define-named-command com-set-syntax ()
607 rstrandh 1.67 (let* ((pane (win *application-frame*))
608     (buffer (buffer pane)))
609     (setf (syntax (win *application-frame*))
610     (make-instance (accept 'syntax :prompt "Set Syntax")
611     :pane pane))
612     (setf (offset (low-mark buffer)) 0
613     (offset (high-mark buffer)) (size buffer))))
614 ejohnson 1.27
615     ;;;;;;;;;;;;;;;;;;;;
616     ;; Kill ring commands
617    
618 ejohnson 1.31 ;; Copies an element from a kill-ring to a buffer at the given offset
619 ejohnson 1.50 (define-named-command com-yank ()
620     (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*)))
621 ejohnson 1.27
622 ejohnson 1.31 ;; Destructively cut a given buffer region into the kill-ring
623 abridgewater 1.34 (define-named-command com-cut-out ()
624 mvilleneuve 1.64 (multiple-value-bind (start end) (region-limits (win *application-frame*))
625     (kill-ring-standard-push *kill-ring* (region-to-sequence start end))
626     (delete-region (offset start) end)))
627 ejohnson 1.27
628 ejohnson 1.31 ;; Non destructively copies in buffer region to the kill ring
629 abridgewater 1.34 (define-named-command com-copy-out ()
630 ejohnson 1.54 (with-slots (point mark)(win *application-frame*)
631 ejohnson 1.55 (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))))
632 ejohnson 1.50
633 ejohnson 1.27
634 ejohnson 1.50 (define-named-command com-rotate-yank ()
635 ejohnson 1.54 (let* ((pane (win *application-frame*))
636     (point (point pane))
637 ejohnson 1.50 (last-yank (kill-ring-yank *kill-ring*)))
638 ejohnson 1.54 (if (eq (previous-command pane)
639 ejohnson 1.50 'com-rotate-yank)
640 ejohnson 1.54 (progn
641     (delete-range point (* -1 (length last-yank)))
642     (rotate-yank-position *kill-ring*)))
643     (insert-sequence point (kill-ring-yank *kill-ring*))))
644 ejohnson 1.27
645 ejohnson 1.50 (define-named-command com-resize-kill-ring ()
646 ejohnson 1.46 (let ((size (accept 'integer :prompt "New kill ring size")))
647 ejohnson 1.50 (setf (kill-ring-max-size *kill-ring*) size)))
648 rstrandh 1.47
649     (define-named-command com-search-forward ()
650     (search-forward (point (win *application-frame*))
651     (accept 'string :prompt "Search Forward")
652     :test (lambda (a b)
653     (and (characterp b) (char-equal a b)))))
654    
655     (define-named-command com-search-backward ()
656     (search-backward (point (win *application-frame*))
657     (accept 'string :prompt "Search Backward")
658     :test (lambda (a b)
659     (and (characterp b) (char-equal a b)))))
660 ejohnson 1.27
661 rstrandh 1.49 (define-named-command com-dabbrev-expand ()
662     (let* ((win (win *application-frame*))
663     (point (point win)))
664     (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
665     (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
666     (setf (offset dabbrev-expansion-mark)
667     (offset point))
668     (forward-word dabbrev-expansion-mark))
669     ((mark< dabbrev-expansion-mark point)
670     (backward-object dabbrev-expansion-mark))
671     (t (forward-object dabbrev-expansion-mark)))))
672     (unless (or (beginning-of-buffer-p point)
673     (not (constituentp (object-before point))))
674     (unless (and (eq (previous-command win) 'com-dabbrev-expand)
675     (not (null prefix-start-offset)))
676     (setf dabbrev-expansion-mark (clone-mark point))
677     (backward-word dabbrev-expansion-mark)
678     (setf prefix-start-offset (offset dabbrev-expansion-mark))
679     (setf original-prefix (region-to-sequence prefix-start-offset point))
680     (move))
681     (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
682     (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
683     (not (constituentp (object-before dabbrev-expansion-mark))))
684     (looking-at dabbrev-expansion-mark original-prefix)))
685     do (move))
686     (if (end-of-buffer-p dabbrev-expansion-mark)
687     (progn (delete-region prefix-start-offset point)
688     (insert-sequence point original-prefix)
689     (setf prefix-start-offset nil))
690     (progn (delete-region prefix-start-offset point)
691     (insert-sequence point
692     (let ((offset (offset dabbrev-expansion-mark)))
693     (prog2 (forward-word dabbrev-expansion-mark)
694     (region-to-sequence offset dabbrev-expansion-mark)
695     (setf (offset dabbrev-expansion-mark) offset))))
696     (move))))))))
697    
698 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
699     ;;;
700     ;;; Global command table
701    
702     (make-command-table 'global-climacs-table :errorp nil)
703    
704     (defun global-set-key (gesture command)
705     (add-command-to-command-table command 'global-climacs-table
706     :keystroke gesture :errorp nil))
707    
708     (loop for code from (char-code #\space) to (char-code #\~)
709     do (global-set-key (code-char code) 'com-self-insert))
710    
711     (global-set-key #\newline 'com-self-insert)
712     (global-set-key #\tab 'com-self-insert)
713 rstrandh 1.62 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
714     (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
715 ejohnson 1.27 (global-set-key '(#\a :control) 'com-beginning-of-line)
716     (global-set-key '(#\e :control) 'com-end-of-line)
717 rstrandh 1.62 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
718 ejohnson 1.27 (global-set-key '(#\p :control) 'com-previous-line)
719     (global-set-key '(#\n :control) 'com-next-line)
720     (global-set-key '(#\o :control) 'com-open-line)
721     (global-set-key '(#\k :control) 'com-kill-line)
722 rstrandh 1.42 (global-set-key '(#\t :control) 'com-transpose-objects)
723 ejohnson 1.27 (global-set-key '(#\Space :control) 'com-set-mark)
724 ejohnson 1.50 (global-set-key '(#\y :control) 'com-yank)
725 ejohnson 1.27 (global-set-key '(#\w :control) 'com-cut-out)
726     (global-set-key '(#\f :meta) 'com-forward-word)
727     (global-set-key '(#\b :meta) 'com-backward-word)
728 rstrandh 1.43 (global-set-key '(#\t :meta) 'com-transpose-words)
729 rstrandh 1.60 (global-set-key '(#\u :meta) 'com-upcase-word)
730     (global-set-key '(#\l :meta) 'com-downcase-word)
731     (global-set-key '(#\c :meta) 'com-capitalize-word)
732 ejohnson 1.27 (global-set-key '(#\x :meta) 'com-extended-command)
733 ejohnson 1.50 (global-set-key '(#\y :meta) 'com-rotate-yank)
734 ejohnson 1.27 (global-set-key '(#\w :meta) 'com-copy-out)
735 rstrandh 1.39 (global-set-key '(#\v :control) 'com-page-down)
736 rstrandh 1.40 (global-set-key '(#\v :meta) 'com-page-up)
737 ejohnson 1.27 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
738     (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
739 rstrandh 1.32 (global-set-key '(#\m :meta) 'com-back-to-indentation)
740     (global-set-key '(#\d :meta) 'com-delete-word)
741     (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
742 rstrandh 1.49 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
743 ejohnson 1.27
744     (global-set-key '(:up) 'com-previous-line)
745     (global-set-key '(:down) 'com-next-line)
746 rstrandh 1.62 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
747 ejohnson 1.66 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
748 ejohnson 1.27 (global-set-key '(:left :control) 'com-backward-word)
749     (global-set-key '(:right :control) 'com-forward-word)
750     (global-set-key '(:home) 'com-beginning-of-line)
751     (global-set-key '(:end) 'com-end-of-line)
752 abridgewater 1.57 (global-set-key '(:prior) 'com-page-up)
753     (global-set-key '(:next) 'com-page-down)
754 ejohnson 1.27 (global-set-key '(:home :control) 'com-beginning-of-buffer)
755     (global-set-key '(:end :control) 'com-end-of-buffer)
756 rstrandh 1.62 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
757     (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
758 abakic 1.58
759     (global-set-key '(:insert) 'com-toggle-overwrite-mode)
760 ejohnson 1.27
761     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
762     ;;;
763     ;;; C-x command table
764    
765     (make-command-table 'c-x-climacs-table :errorp nil)
766    
767     (add-menu-item-to-command-table 'global-climacs-table "C-x"
768     :menu 'c-x-climacs-table
769     :keystroke '(#\x :control))
770    
771     (defun c-x-set-key (gesture command)
772     (add-command-to-command-table command 'c-x-climacs-table
773     :keystroke gesture :errorp nil))
774    
775     (c-x-set-key '(#\c :control) 'com-quit)
776     (c-x-set-key '(#\f :control) 'com-find-file)
777 rstrandh 1.63 (c-x-set-key '(#\l :control) 'com-load-file)
778 ejohnson 1.27 (c-x-set-key '(#\s :control) 'com-save-buffer)
779 rstrandh 1.45 (c-x-set-key '(#\t :control) 'com-transpose-lines)
780 ejohnson 1.27 (c-x-set-key '(#\w :control) 'com-write-buffer)
781 rstrandh 1.45 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
782 rstrandh 1.44
783     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
784     ;;;
785     ;;; Some Unicode stuff
786    
787     (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
788     (insert-object (point (win *application-frame*)) (code-char code)))
789    
790     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
791     ;;;
792     ;;; Dead-acute command table
793    
794     (make-command-table 'dead-acute-climacs-table :errorp nil)
795    
796     (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
797     :menu 'dead-acute-climacs-table
798     :keystroke '(:dead--acute))
799    
800     (defun dead-acute-set-key (gesture command)
801     (add-command-to-command-table command 'dead-acute-climacs-table
802     :keystroke gesture :errorp nil))
803    
804     (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
805     (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
806     (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
807     (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
808     (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
809     (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
810     (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
811     (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
812     (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
813     (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
814     (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
815     (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
816     (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
817     (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
818     (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
819     (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
820     (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
821     (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
822     (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
823     (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
824    
825 rstrandh 1.45 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
826    
827     (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
828     :menu 'dead-acute-dead-accute-climacs-table
829     :keystroke '(:dead--acute))
830    
831     (defun dead-acute-dead-accute-set-key (gesture command)
832     (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
833     :keystroke gesture :errorp nil))
834    
835     (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
836     (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
837 rstrandh 1.44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
838     ;;;
839     ;;; Dead-grave command table
840    
841     (make-command-table 'dead-grave-climacs-table :errorp nil)
842    
843     (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
844     :menu 'dead-grave-climacs-table
845     :keystroke '(:dead--grave))
846    
847     (defun dead-grave-set-key (gesture command)
848     (add-command-to-command-table command 'dead-grave-climacs-table
849     :keystroke gesture :errorp nil))
850    
851     (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
852     (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
853     (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
854     (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
855     (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
856     (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
857     (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
858     (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
859     (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
860     (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
861     (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
862    
863     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
864     ;;;
865     ;;; Dead-diaeresis command table
866    
867     (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
868    
869     (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
870     :menu 'dead-diaeresis-climacs-table
871     :keystroke '(:dead--diaeresis :shift))
872    
873     (defun dead-diaeresis-set-key (gesture command)
874     (add-command-to-command-table command 'dead-diaeresis-climacs-table
875     :keystroke gesture :errorp nil))
876    
877     (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
878     (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
879     (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
880     (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
881     (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
882     (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
883     (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
884     (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
885     (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
886     (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
887     (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
888     (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
889    
890     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
891     ;;;
892     ;;; Dead-tilde command table
893    
894     (make-command-table 'dead-tilde-climacs-table :errorp nil)
895    
896     (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
897     :menu 'dead-tilde-climacs-table
898     :keystroke '(:dead--tilde :shift))
899    
900     (defun dead-tilde-set-key (gesture command)
901     (add-command-to-command-table command 'dead-tilde-climacs-table
902     :keystroke gesture :errorp nil))
903    
904     (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
905     (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
906     (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
907     (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
908     (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
909     (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
910     (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
911     (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
912     (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
913     (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
914     (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
915    
916     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
917     ;;;
918     ;;; Dead-circumflex command table
919    
920     (make-command-table 'dead-circumflex-climacs-table :errorp nil)
921    
922     (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
923     :menu 'dead-circumflex-climacs-table
924     :keystroke '(:dead--circumflex :shift))
925    
926     (defun dead-circumflex-set-key (gesture command)
927     (add-command-to-command-table command 'dead-circumflex-climacs-table
928     :keystroke gesture :errorp nil))
929    
930     (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
931     (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
932     (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
933     (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
934     (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
935     (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
936     (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
937     (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
938     (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
939     (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
940     (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

  ViewVC Help
Powered by ViewVC 1.1.5