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

Contents of /src/hemlock/abbrev.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5