/[cmucl]/src/hemlock/abbrev.lisp
ViewVC logotype

Contents of /src/hemlock/abbrev.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Feb 11 21:54:44 1994 UTC (20 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.1: +12 -9 lines
Copy new_compiler branch to trunk.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/abbrev.lisp,v 1.2 1994/02/11 21:54:44 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Hemlock Word Abbreviation Mode
15 ;;; by Jamie W. Zawinski
16 ;;; 24 September 1985
17 ;;;
18 (in-package "HEMLOCK")
19
20 ;;;; These Things are Here:
21
22 ;;; C-X C-A Add Mode Word Abbrev
23 ;;; Define a mode abbrev for the word before point.
24 ;;; C-X + Add Global Word Abbrev
25 ;;; Define a global abbrev for the word before point.
26 ;;; C-X C-H Inverse Add Mode Word Abbrev
27 ;;; Define expansion for mode abbrev before point.
28 ;;; C-X - Inverse Add Global Word Abbrev
29 ;;; Define expansion for global abbrev before point.
30 ;;; Alt Space Abbrev Expand Only
31 ;;; Expand abbrev without inserting anything.
32 ;;; M-' Word Abbrev Prefix Mark
33 ;;; Mark a prefix to be glued to an abbrev following.
34 ;;; C-X U Unexpand Last Word
35 ;;; Unexpands last abbrev or undoes C-X U.
36
37 ;;; List Word Abbrevs Shows definitions of all word abbrevs.
38 ;;; Edit Word Abbrevs Lets you edit the definition list directly.
39 ;;; Read Word Abbrev File <filename> Define word abbrevs from a definition file.
40 ;;; Write Word Abbrev File Make a definition file from current abbrevs.
41
42 ;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
43 ;;; Delete All Word Abbrevs Wipes them all.
44 ;;; Delete Mode Word Abbrev Kills all Mode abbrev.
45 ;;; Delete Global Word Abbrev Kills all Global abbrev.
46
47 ;;; Insert Word Abbrevs Inserts a list of current definitions in the
48 ;;; format that Define Word Abbrevs uses.
49 ;;; Define Word Abbrevs Defines set of abbrevs from a definition list in
50 ;;; the buffer.
51 ;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
52 ;;; definition, or mode.
53
54 ;;; Append Incremental Word Abbrev File Appends to a file changed abbrev
55 ;;; definitions since last dumping.
56
57 (defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0)
58
59
60 (defvar *Global-Abbrev-Table* (make-hash-table :test #'equal)
61 "Hash table holding global abbrev definitions.")
62
63 (defhvar "Abbrev Pathname Defaults"
64 "Holds the name of the last Abbrev-file written."
65 :value (pathname "abbrev.defns"))
66
67 (defvar *new-abbrevs* ()
68 "holds a list of abbrevs (and their definitions and modes) changed since saving.")
69
70
71 ;;; C-X C-H Inverse Add Mode Word Abbrev
72 ;;; Define a mode expansion for the word before point.
73
74 (defcommand "Inverse Add Mode Word Abbrev" (p)
75 "Defines a mode word abbrev expansion for the word before the point."
76 "Defines a mode word abbrev expansion for the word before the point."
77 (declare (ignore p))
78 (let ((word (prev-word 1 (current-point)))
79 (mode (buffer-major-mode (current-buffer))))
80 (make-word-abbrev-command nil word nil mode)))
81
82
83 ;;; C-X C-A Add Mode Word Abbrev
84 ;;; Define mode abbrev for word before point.
85
86 (defcommand "Add Mode Word Abbrev" (p)
87 "Defines a mode word abbrev for the word before the point.
88 With a positive argument, uses that many preceding words as the expansion.
89 With a zero argument, uses the region as the expansion. With a negative
90 argument, prompts for a word abbrev to delete in the current mode."
91 "Defines or deletes a mode word abbrev."
92 (if (and p (minusp p))
93 (delete-mode-word-abbrev-command nil)
94 (let* ((val (if (eql p 0)
95 (region-to-string (current-region nil))
96 (prev-word (or p 1) (current-point))))
97 (mode (buffer-major-mode (current-buffer))))
98 (make-word-abbrev-command nil nil val mode))))
99
100
101
102 ;;; C-X - Inverse Add Global Word Abbrev
103 ;;; Define global expansion for word before point.
104
105 (defcommand "Inverse Add Global Word Abbrev" (p)
106 "Defines a Global expansion for the word before point."
107 "Defines a Global expansion for the word before point."
108 (declare (ignore p))
109 (let ((word (prev-word 1 (current-point))))
110 (make-word-abbrev-command nil word nil "Global")))
111
112
113
114 ;;; C-X + Add Global Word Abbrev
115 ;;; Define global Abbrev for word before point.
116
117 (defcommand "Add Global Word Abbrev" (p)
118 "Defines a global word abbrev for the word before the point.
119 With a positive argument, uses that many preceding words as the expansion.
120 With a zero argument, uses the region as the expansion. With a negative
121 argument, prompts for a global word abbrev to delete."
122 "Defines or deletes a global word abbrev."
123 (if (and p (minusp p))
124 (delete-global-word-abbrev-command nil)
125 (let ((val (if (eql p 0)
126 (region-to-string (current-region nil))
127 (prev-word (or p 1) (current-point)))))
128 (make-word-abbrev-command nil nil val "Global"))))
129
130
131 ;;;; Defining Abbrevs
132
133 ;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
134
135 (defvar *global-abbrev-string-table*
136 (make-string-table :initial-contents '(("Global" . nil))))
137
138 (defcommand "Make Word Abbrev" (p &optional abbrev expansion mode)
139 "Defines an arbitrary word abbreviation.
140 Prompts for abbrev, expansion, and mode."
141 "Makes Abbrev be a word abbreviation for Expansion when in Mode. If
142 mode is \"Global\" then make a global abbrev."
143 (declare (ignore p))
144 (unless mode
145 (setq mode
146 (prompt-for-keyword
147 (list *mode-names* *global-abbrev-string-table*)
148 :prompt "Mode of abbrev to add: "
149 :default "Global"
150 :help
151 "Type the mode of the Abbrev you want to add, or confirm for Global.")))
152 (let ((globalp (string-equal mode "Global")))
153 (unless (or globalp (mode-major-p mode))
154 (editor-error "~A is not a major mode." mode))
155 (unless abbrev
156 (setq abbrev
157 (prompt-for-string
158 :trim t
159 :prompt
160 (list "~A abbreviation~@[ of ~S~]: " mode expansion)
161 :help
162 (list "Define a ~A word abbrev." mode))))
163 (when (zerop (length abbrev))
164 (editor-error "Abbreviation must be at least one character long."))
165 (unless (every #'(lambda (ch)
166 (zerop (character-attribute :word-delimiter ch)))
167 (the simple-string abbrev))
168 (editor-error "Word Abbrevs must be a single word."))
169 (unless expansion
170 (setq expansion
171 (prompt-for-string
172 :prompt (list "~A expansion for ~S: " mode abbrev)
173 :help (list "Define the ~A expansion of ~S." mode abbrev))))
174 (setq abbrev (string-downcase abbrev))
175 (let* ((table (cond (globalp *global-abbrev-table*)
176 ((hemlock-bound-p 'Mode-Abbrev-Table :mode mode)
177 (variable-value 'Mode-Abbrev-Table :mode mode))
178 (t
179 (let ((new (make-hash-table :test #'equal)))
180 (defhvar "Mode Abbrev Table"
181 "Hash Table of Mode Abbrevs"
182 :value new :mode mode)
183 new))))
184 (old (gethash abbrev table)))
185 (when (or (not old)
186 (prompt-for-y-or-n
187 :prompt
188 (list "Current ~A definition of ~S is ~S.~%Redefine?"
189 mode abbrev old)
190 :default t
191 :help (list "Redefine the expansion of ~S." abbrev)))
192 (setf (gethash abbrev table) expansion)
193 (push (list abbrev expansion (if globalp nil mode))
194 *new-abbrevs*)))))
195
196
197 ;;; Alt Space Abbrev Expand Only
198 ;;; Expand abbrev without inserting anything.
199
200 (defcommand "Abbrev Expand Only" (p)
201 "This command expands the word before point into its abbrev definition
202 (if indeed it has one)."
203 "This command expands the word before point into its abbrev definition
204 (if indeed it has one)."
205 (declare (ignore p))
206 (let* ((word (prev-word 1 (current-point)))
207 (glob (gethash (string-downcase word) *global-abbrev-table*))
208 (mode (if (hemlock-bound-p 'Mode-Abbrev-Table)
209 (gethash (string-downcase word)
210 (value Mode-Abbrev-Table))))
211 (end-word (reverse-find-attribute (copy-mark (current-point)
212 :right-inserting)
213 :word-delimiter #'zerop))
214 (result (if mode mode glob)))
215 (when (or mode glob)
216 (delete-characters end-word (- (length word)))
217 (cond ((equal word (string-capitalize word))
218 (setq result (string-capitalize result)))
219 ((equal word (string-upcase word))
220 (setq result (string-upcase result))))
221 (insert-string end-word result)
222 (unless (hemlock-bound-p 'last-expanded)
223 (defhvar "last expanded"
224 "Holds a mark, the last expanded abbrev, and its expansion in a list."
225 :buffer (current-buffer)))
226 (setf (value last-expanded)
227 (list (copy-mark (current-point) :right-inserting)
228 word result)))
229 (delete-mark end-word))
230 (when (and (hemlock-bound-p 'prefix-mark)
231 (value prefix-mark))
232 (delete-characters (value prefix-mark) 1)
233 (delete-mark (value prefix-mark))
234 (setf (value prefix-mark) nil)))
235
236
237
238 ;;; This function returns the n words immediately before the mark supplied.
239
240 (defun prev-word (n mark)
241 (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary)
242 :word-delimiter #'zerop))
243 (mark-2 (copy-mark mark-1)))
244 (dotimes (x n (region-to-string (region mark-2 mark-1)))
245 (reverse-find-attribute (mark-before mark-2) :word-delimiter))))
246
247
248
249 ;;; M-' Word Abbrev Prefix Mark
250 ;;; Mark a prefix to be glued to an abbrev following.
251
252 ;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander)
253 ;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately
254 ;;; after prefix-mark.
255
256 (defcommand "Word Abbrev Prefix Mark" (p)
257 "Marks a prefix to be glued to an abbrev following."
258 "Marks a prefix to be glued to an abbrev following."
259 (declare (ignore p))
260 (unless (hemlock-bound-p 'prefix-mark)
261 (defhvar "prefix mark"
262 "Holds a mark (or not) pointing to the current Prefix Mark."
263 :buffer (current-buffer)))
264 (when (value prefix-mark)
265 (delete-mark (value prefix-mark)))
266 (setf (value prefix-mark) (copy-mark (current-point) :right-inserting))
267 (insert-character (value prefix-mark) #\-))
268
269
270 ;;; C-X U Unexpand Last Word
271 ;;; Unexpands last abbrev or undoes last C-X U.
272
273 (defcommand "Unexpand Last Word" (p)
274 "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\".
275 Only one abbrev may be undone."
276 "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"."
277 (declare (ignore p))
278 (unless (or (not (hemlock-bound-p 'last-expanded))
279 (value last-expanded))
280 (editor-error "Nothing to Undo."))
281 (let ((mark (car (value last-expanded)))
282 (word1 (second (value last-expanded)))
283 (word2 (third (value last-expanded))))
284 (unless (string= word2
285 (region-to-string
286 (region (character-offset (copy-mark mark :temporary)
287 (- (length word2)))
288 mark)))
289 (editor-error "The last expanded Abbrev has been altered in the text."))
290 (delete-characters mark (- (length word2)))
291 (insert-string mark word1)
292 (character-offset mark (length word1))
293 (setf (value last-expanded) (list mark word2 word1))))
294
295
296
297 ;;; Delete Mode Word Abbrev Kills some Mode abbrevs.
298
299 (defcommand "Delete Mode Word Abbrev"
300 (p &optional abbrev
301 (mode (buffer-major-mode (current-buffer))))
302 "Prompts for a word abbrev and deletes the mode expansion in the current mode.
303 If called with a prefix argument, deletes all word abbrevs define in the
304 current mode."
305 "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true."
306 (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode)))
307 (if p
308 (when boundp
309 (delete-variable 'Mode-Abbrev-Table :mode mode))
310 (let ((down
311 (string-downcase
312 (or abbrev
313 (prompt-for-string
314 :prompt (list "~A abbrev to delete: " mode)
315 :help
316 (list "Give the name of a ~A mode word abbrev to delete." mode)
317 :trim t))))
318 (table (and boundp (variable-value 'mode-abbrev-table :mode mode))))
319 (unless (and table (gethash down table))
320 (editor-error "~S is not the name of an abbrev in ~A mode."
321 down mode))
322 (remhash down table)))))
323
324
325 ;;; Delete Global Word Abbrevs Kills some Global abbrevs.
326
327 (defcommand "Delete Global Word Abbrev" (p &optional abbrev)
328 "Prompts for a word abbrev and delete the global expansion.
329 If called with a prefix argument, deletes all global abbrevs."
330 "Deletes the global word abbreviation named Abbrev. If P is true,
331 deletes all global abbrevs."
332 (if p
333 (setq *global-abbrev-table* (make-hash-table :test #'equal))
334 (let ((down
335 (string-downcase
336 (or abbrev
337 (prompt-for-string
338 :prompt "Global abbrev to delete: "
339 :help "Give the name of a global word abbrev to delete."
340 :trim t)))))
341 (unless (gethash down *global-abbrev-table*)
342 (editor-error "~S is not the name of a global word abbrev." down))
343 (remhash down *global-abbrev-table*))))
344
345 ;;; Delete All Word Abbrevs Wipes them all.
346
347 (defcommand "Delete All Word Abbrevs" (p)
348 "Deletes all currently defined Word Abbrevs"
349 "Deletes all currently defined Word Abbrevs"
350 (declare (ignore p))
351 (Delete-Global-Word-Abbrev-Command 1)
352 (Delete-Mode-Word-Abbrev-Command 1))
353
354
355 ;;;; Abbrev I/O
356
357 ;;; List Word Abbrevs Shows definitions of all word abbrevs.
358
359 (defcommand "List Word Abbrevs" (p)
360 "Lists all of the currently defined Word Abbrevs."
361 "Lists all of the currently defined Word Abbrevs."
362 (word-abbrev-apropos-command p ""))
363
364
365 ;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
366 ;;; definition, or mode.
367
368 (defcommand "Word Abbrev Apropos" (p &optional search-string)
369 "Lists all of the currently defined Word Abbrevs which contain a given string
370 in their abbrev. definition, or mode."
371 "Lists all of the currently defined Word Abbrevs which contain a given string
372 in their abbrev. definition, or mode."
373 (declare (ignore p))
374 (unless search-string
375 (setq search-string
376 (string-downcase
377 (prompt-for-string
378 :prompt "Apropos string: "
379 :help "The string to search word abbrevs and definitions for."))))
380 (multiple-value-bind (count mode-tables) (count-abbrevs)
381 (with-pop-up-display (s :height (min (1+ count) 30))
382 (unless (zerop (hash-table-count *global-abbrev-table*))
383 (maphash #'(lambda (key val)
384 (when (or (search search-string (string-downcase key))
385 (search search-string (string-downcase val)))
386 (write-abbrev key val nil s t)))
387 *global-abbrev-table*))
388 (dolist (modename mode-tables)
389 (let ((table (variable-value 'Mode-Abbrev-Table :mode modename)))
390 (if (search search-string (string-downcase modename))
391 (maphash #'(lambda (key val)
392 (write-abbrev key val modename s t))
393 table)
394 (maphash #'(lambda (key val)
395 (when (or (search search-string (string-downcase key))
396 (search search-string (string-downcase val)))
397 (write-abbrev key val modename s t)))
398 table))))
399 (terpri s))))
400
401
402
403 (defun count-abbrevs ()
404 (let* ((count (hash-table-count *global-abbrev-table*))
405 (mode-tables nil))
406 (do-strings (which x *mode-names*)
407 (declare (ignore x))
408 (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which)
409 (let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table
410 :mode which))))
411 (unless (zerop table-count)
412 (incf count table-count)
413 (push which mode-tables)))))
414 (values count mode-tables)))
415
416
417 ;;; Edit Word Abbrevs Lets you edit the definition list directly.
418
419 (defcommand "Edit Word Abbrevs" (p)
420 "Allows direct editing of currently defined Word Abbrevs."
421 "Allows direct editing of currently defined Word Abbrevs."
422 (declare (ignore p))
423 (when (getstring "Edit Word Abbrevs" *buffer-names*)
424 (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*)))
425 (let ((old-buf (current-buffer))
426 (new-buf (make-buffer "Edit Word Abbrevs")))
427 (change-to-buffer new-buf)
428 (unwind-protect
429 (progn
430 (insert-word-abbrevs-command nil)
431 (do-recursive-edit)
432 (unless (equal #\newline (previous-character (buffer-end (current-point))))
433 (insert-character (current-point) #\newline))
434 (delete-all-word-abbrevs-command nil)
435 (define-word-abbrevs-command nil))
436 (progn
437 (change-to-buffer old-buf)
438 (delete-buffer new-buf)))))
439
440
441
442 ;;; Insert Word Abbrevs Inserts a list of current definitions in the
443 ;;; format that Define Word Abbrevs uses.
444
445 (defcommand "Insert Word Abbrevs" (p)
446 "Inserts into the current buffer a list of all currently defined abbrevs in the
447 format used by \"Define Word Abbrevs\"."
448 "Inserts into the current buffer a list of all currently defined abbrevs in the
449 format used by \"Define Word Abbrevs\"."
450
451 (declare (ignore p))
452 (multiple-value-bind (x mode-tables)
453 (count-abbrevs)
454 (declare (ignore x))
455 (with-output-to-mark (stream (current-point) :full)
456 (maphash #'(lambda (key val)
457 (write-abbrev key val nil stream))
458 *global-abbrev-table*)
459
460 (dolist (mode mode-tables)
461 (let ((modename (if (listp mode) (car mode) mode)))
462 (maphash #'(lambda (key val)
463 (write-abbrev key val modename stream))
464 (variable-value 'Mode-Abbrev-Table :mode modename)))))))
465
466
467
468 ;;; Define Word Abbrevs Defines set of abbrevs from a definition list in
469 ;;; the buffer.
470
471 (defcommand "Define Word Abbrevs" (p)
472 "Defines Word Abbrevs from the definition list in the current buffer. The
473 definition list must be in the format produced by \"Insert Word Abbrevs\"."
474 "Defines Word Abbrevs from the definition list in the current buffer. The
475 definition list must be in the format produced by \"Insert Word Abbrevs\"."
476
477 (declare (ignore p))
478 (with-input-from-region (file (buffer-region (current-buffer)))
479 (read-abbrevs file)))
480
481
482 ;;; Read Word Abbrev file <filename> Define word abbrevs from a definition file.
483
484 ;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is
485 ;;; the minimum number of characters possible to define an abbrev. It thinks the
486 ;;; current abbrev "wraps" if there is no #\" at the end of the line or there are
487 ;;; two #\"s at the end of the line (unless that is the entire definition string,
488 ;;; i.e, a null-abbrev).
489
490 ;;; The format of the Abbrev files is
491 ;;;
492 ;;; ABBREV<tab><tab>"ABBREV DEFINITION"
493 ;;;
494 ;;; for Global Abbrevs, and
495 ;;;
496 ;;; ABBREV<tab>(MODE)<tab>"ABBREV DEFINITION"
497 ;;;
498 ;;; for Modal Abbrevs.
499 ;;; Double-quotes contained within the abbrev definition are doubled. If the first
500 ;;; line of an abbrev definition is not closed by a single double-quote, then
501 ;;; the subsequent lines are read in until a single double-quote is found.
502
503 (defcommand "Read Word Abbrev File" (p &optional filename)
504 "Reads in a file of previously defined abbrev definitions."
505 "Reads in a file of previously defined abbrev definitions."
506 (declare (ignore p))
507 (setf (value abbrev-pathname-defaults)
508 (if filename
509 filename
510 (prompt-for-file
511 :prompt "Name of abbrev file: "
512 :help "The name of the abbrev file to load."
513 :default (value abbrev-pathname-defaults)
514 :must-exist nil)))
515 (with-open-file (file (value abbrev-pathname-defaults) :direction :input
516 :element-type 'base-char :if-does-not-exist :error)
517 (read-abbrevs file)))
518
519
520 ;;; Does the actual defining of abbrevs from a given stream, expecting tabs and
521 ;;; doubled double-quotes.
522
523 (defun read-abbrevs (file)
524 (do ((line (read-line file nil nil)
525 (read-line file nil nil)))
526 ((null line))
527 (unless (< (length line) 4)
528 (let* ((tab (position #\tab line))
529 (tab2 (position #\tab line :start (1+ tab)))
530 (abbrev (subseq line 0 tab))
531 (modename (subseq line (1+ tab) tab2))
532 (expansion (do* ((last (1+ (position #\" line))
533 (if found (min len (1+ found)) 0))
534 (len (length line))
535 (found (if (position #\" line :start last)
536 (1+ (position #\" line :start last)))
537 (if (position #\" line :start last)
538 (1+ (position #\" line :start last))))
539 (expansion (subseq line last (if found found len))
540 (concatenate 'simple-string expansion
541 (subseq line last
542 (if found found
543 len)))))
544 ((and (or (null found) (= found len))
545 (equal #\" (char line (1- len)))
546 (or (not (equal #\" (char line (- len 2))))
547 (= (- len 3) tab2)))
548 (subseq expansion 0 (1- (length expansion))))
549
550 (when (null found)
551 (setq line (read-line file nil nil)
552 last 0
553 len (length line)
554 found (if (position #\" line)
555 (1+ (position #\" line)))
556 expansion (format nil "~A~%~A" expansion
557 (subseq line 0 (if found
558 found
559 0))))))))
560
561 (cond ((equal modename "")
562 (setf (gethash abbrev *global-abbrev-table*)
563 expansion))
564 (t (setq modename (subseq modename 1 (1- (length modename))))
565 (unless (hemlock-bound-p 'Mode-Abbrev-Table
566 :mode modename)
567 (defhvar "Mode Abbrev Table"
568 "Hash Table of Mode Abbrevs"
569 :value (make-hash-table :test #'equal)
570 :mode modename))
571 (setf (gethash abbrev (variable-value
572 'Mode-Abbrev-Table :mode modename))
573 expansion)))))))
574
575
576 ;;; Write Word Abbrev File Make a definition file from current abbrevs.
577
578 (defcommand "Write Word Abbrev File" (p &optional filename)
579 "Saves the currently defined Abbrevs to a file."
580 "Saves the currently defined Abbrevs to a file."
581 (declare (ignore p))
582 (unless filename
583 (setq filename
584 (prompt-for-file
585 :prompt "Write abbrevs to file: "
586 :default (value abbrev-pathname-defaults)
587 :help "Name of the file to write current abbrevs to."
588 :must-exist nil)))
589 (with-open-file (file filename :direction :output
590 :element-type 'base-char :if-exists :supersede
591 :if-does-not-exist :create)
592 (multiple-value-bind (x mode-tables) (count-abbrevs)
593 (declare (ignore x))
594 (maphash #'(lambda (key val)
595 (write-abbrev key val nil file))
596 *global-abbrev-table*)
597
598 (dolist (modename mode-tables)
599 (let ((mode (if (listp modename) (car modename) modename)))
600 (maphash #'(lambda (key val)
601 (write-abbrev key val mode file))
602 (variable-value 'Mode-Abbrev-Table :mode mode))))))
603 (let ((tn (truename filename)))
604 (setf (value abbrev-pathname-defaults) tn)
605 (message "~A written." (namestring tn))))
606
607
608
609 ;;; Append to Word Abbrev File Appends to a file changed abbrev
610 ;;; definitions since last dumping.
611
612 (defcommand "Append to Word Abbrev File" (p &optional filename)
613 "Appends Abbrevs defined or redefined since the last save to a file."
614 "Appends Abbrevs defined or redefined since the last save to a file."
615 (declare (ignore p))
616 (cond
617 (*new-abbrevs*
618 (unless filename
619 (setq filename
620 (prompt-for-file
621 :prompt
622 "Append incremental abbrevs to file: "
623 :default (value abbrev-pathname-defaults)
624 :must-exist nil
625 :help "Filename to append recently defined Abbrevs to.")))
626 (write-incremental :append filename))
627 (t
628 (message "No Abbrev definitions have been changed since the last write."))))
629
630
631 (defun write-incremental (mode filename)
632 (with-open-file (file filename :direction :output
633 :element-type 'base-char
634 :if-exists mode :if-does-not-exist :create)
635 (dolist (def *new-abbrevs*)
636 (let ((abb (car def))
637 (val (second def))
638 (mode (third def)))
639 (write-abbrev abb val mode file))))
640 (let ((tn (truename filename)))
641 (setq *new-abbrevs* nil)
642 (setf (value abbrev-pathname-defaults) tn)
643 (message "~A written." (namestring tn))))
644
645
646 ;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function
647 ;;; writes to the stream with doubled double-quotes and stuff.
648 ;;; If the flag is true, then the output is in a pretty format (like "List Word
649 ;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word
650 ;;; Abbrev File" uses).
651
652 (defun write-abbrev (abbrev expansion modename file &optional flag)
653 (if flag
654 (if modename
655 (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format
656 (format file "~5t~A~35t\"" abbrev)) ; pretty format
657 (cond (modename
658 (write-string abbrev file)
659 (write-char #\tab file)
660 (format file "(~A)" modename) ; "~A<tab>(~A)<tab>\""
661 (write-char #\tab file)
662 (write-char #\" file))
663 (t
664 (write-string abbrev file)
665 (write-char #\tab file) ; "~A<tab><tab>\""
666 (write-char #\tab file)
667 (write-char #\" file))))
668 (do* ((prev 0 found)
669 (found (position #\" expansion)
670 (position #\" expansion :start found)))
671 ((not found)
672 (write-string expansion file :start prev)
673 (write-char #\" file)
674 (terpri file))
675 (incf found)
676 (write-string expansion file :start prev :end found)
677 (write-char #\" file)))
678
679
680 (defcommand "Abbrev Mode" (p)
681 "Put current buffer in Abbrev mode."
682 "Put current buffer in Abbrev mode."
683 (declare (ignore p))
684 (setf (buffer-minor-mode (current-buffer) "Abbrev")
685 (not (buffer-minor-mode (current-buffer) "Abbrev"))))

  ViewVC Help
Powered by ViewVC 1.1.5