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

Contents of /src/hemlock/abbrev.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.2 - (hide annotations) (vendor branch)
Wed Oct 10 17:35:23 1990 UTC (23 years, 6 months ago) by wlott
Changes since 1.1.1.1: +4 -3 lines
Merged MIPS branch onto new-compiler branch.
1 ram 1.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     (if p
330     (setq *global-abbrev-table* (make-hash-table :test #'equal))
331     (let ((down
332     (string-downcase
333     (or abbrev
334     (prompt-for-string
335     :prompt "Global abbrev to delete: "
336     :help "Give the name of a global word abbrev to delete."
337     :trim t)))))
338     (unless (gethash down *global-abbrev-table*)
339     (editor-error "~S is not the name of a global word abbrev." down))
340     (remhash down *global-abbrev-table*))))
341    
342     ;;; Delete All Word Abbrevs Wipes them all.
343    
344     (defcommand "Delete All Word Abbrevs" (p)
345     "Deletes all currently defined Word Abbrevs"
346     "Deletes all currently defined Word Abbrevs"
347     (declare (ignore p))
348     (Delete-Global-Word-Abbrev-Command 1)
349     (Delete-Mode-Word-Abbrev-Command 1))
350    
351    
352     ;;;; Abbrev I/O
353    
354     ;;; List Word Abbrevs Shows definitions of all word abbrevs.
355    
356     (defcommand "List Word Abbrevs" (p)
357     "Lists all of the currently defined Word Abbrevs."
358     "Lists all of the currently defined Word Abbrevs."
359     (word-abbrev-apropos-command p ""))
360    
361    
362     ;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
363     ;;; definition, or mode.
364    
365     (defcommand "Word Abbrev Apropos" (p &optional search-string)
366     "Lists all of the currently defined Word Abbrevs which contain a given string
367     in their abbrev. definition, or mode."
368     "Lists all of the currently defined Word Abbrevs which contain a given string
369     in their abbrev. definition, or mode."
370     (declare (ignore p))
371     (unless search-string
372     (setq search-string
373     (string-downcase
374     (prompt-for-string
375     :prompt "Apropos string: "
376     :help "The string to search word abbrevs and definitions for."))))
377     (multiple-value-bind (count mode-tables) (count-abbrevs)
378     (with-pop-up-display (s :height (min (1+ count) 30))
379     (unless (zerop (hash-table-count *global-abbrev-table*))
380     (maphash #'(lambda (key val)
381     (when (or (search search-string (string-downcase key))
382     (search search-string (string-downcase val)))
383     (write-abbrev key val nil s t)))
384     *global-abbrev-table*))
385     (dolist (modename mode-tables)
386     (let ((table (variable-value 'Mode-Abbrev-Table :mode modename)))
387     (if (search search-string (string-downcase modename))
388     (maphash #'(lambda (key val)
389     (write-abbrev key val modename s t))
390     table)
391     (maphash #'(lambda (key val)
392     (when (or (search search-string (string-downcase key))
393     (search search-string (string-downcase val)))
394     (write-abbrev key val modename s t)))
395     table))))
396     (terpri s))))
397    
398    
399    
400     (defun count-abbrevs ()
401     (let* ((count (hash-table-count *global-abbrev-table*))
402     (mode-tables nil))
403     (do-strings (which x *mode-names*)
404     (declare (ignore x))
405     (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which)
406     (let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table
407     :mode which))))
408     (unless (zerop table-count)
409     (incf count table-count)
410     (push which mode-tables)))))
411     (values count mode-tables)))
412    
413    
414     ;;; Edit Word Abbrevs Lets you edit the definition list directly.
415    
416     (defcommand "Edit Word Abbrevs" (p)
417     "Allows direct editing of currently defined Word Abbrevs."
418     "Allows direct editing of currently defined Word Abbrevs."
419     (declare (ignore p))
420     (when (getstring "Edit Word Abbrevs" *buffer-names*)
421     (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*)))
422     (let ((old-buf (current-buffer))
423     (new-buf (make-buffer "Edit Word Abbrevs")))
424     (change-to-buffer new-buf)
425     (unwind-protect
426     (progn
427     (insert-word-abbrevs-command nil)
428     (do-recursive-edit)
429     (unless (equal #\newline (previous-character (buffer-end (current-point))))
430     (insert-character (current-point) #\newline))
431     (delete-all-word-abbrevs-command nil)
432     (define-word-abbrevs-command nil))
433     (progn
434     (change-to-buffer old-buf)
435     (delete-buffer new-buf)))))
436    
437    
438    
439     ;;; Insert Word Abbrevs Inserts a list of current definitions in the
440     ;;; format that Define Word Abbrevs uses.
441    
442     (defcommand "Insert Word Abbrevs" (p)
443     "Inserts into the current buffer a list of all currently defined abbrevs in the
444     format used by \"Define Word Abbrevs\"."
445     "Inserts into the current buffer a list of all currently defined abbrevs in the
446     format used by \"Define Word Abbrevs\"."
447    
448     (declare (ignore p))
449     (multiple-value-bind (x mode-tables)
450     (count-abbrevs)
451     (declare (ignore x))
452     (with-output-to-mark (stream (current-point) :full)
453     (maphash #'(lambda (key val)
454     (write-abbrev key val nil stream))
455     *global-abbrev-table*)
456    
457     (dolist (mode mode-tables)
458     (let ((modename (if (listp mode) (car mode) mode)))
459     (maphash #'(lambda (key val)
460     (write-abbrev key val modename stream))
461     (variable-value 'Mode-Abbrev-Table :mode modename)))))))
462    
463    
464    
465     ;;; Define Word Abbrevs Defines set of abbrevs from a definition list in
466     ;;; the buffer.
467    
468     (defcommand "Define Word Abbrevs" (p)
469     "Defines Word Abbrevs from the definition list in the current buffer. The
470     definition list must be in the format produced by \"Insert Word Abbrevs\"."
471     "Defines Word Abbrevs from the definition list in the current buffer. The
472     definition list must be in the format produced by \"Insert Word Abbrevs\"."
473    
474     (declare (ignore p))
475     (with-input-from-region (file (buffer-region (current-buffer)))
476     (read-abbrevs file)))
477    
478    
479     ;;; Read Word Abbrev file <filename> Define word abbrevs from a definition file.
480    
481     ;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is
482     ;;; the minimum number of characters possible to define an abbrev. It thinks the
483     ;;; current abbrev "wraps" if there is no #\" at the end of the line or there are
484     ;;; two #\"s at the end of the line (unless that is the entire definition string,
485     ;;; i.e, a null-abbrev).
486    
487     ;;; The format of the Abbrev files is
488     ;;;
489     ;;; ABBREV<tab><tab>"ABBREV DEFINITION"
490     ;;;
491     ;;; for Global Abbrevs, and
492     ;;;
493     ;;; ABBREV<tab>(MODE)<tab>"ABBREV DEFINITION"
494     ;;;
495     ;;; for Modal Abbrevs.
496     ;;; Double-quotes contained within the abbrev definition are doubled. If the first
497     ;;; line of an abbrev definition is not closed by a single double-quote, then
498     ;;; the subsequent lines are read in until a single double-quote is found.
499    
500     (defcommand "Read Word Abbrev File" (p &optional filename)
501     "Reads in a file of previously defined abbrev definitions."
502     "Reads in a file of previously defined abbrev definitions."
503     (declare (ignore p))
504     (setf (value abbrev-pathname-defaults)
505     (if filename
506     filename
507     (prompt-for-file
508     :prompt "Name of abbrev file: "
509     :help "The name of the abbrev file to load."
510     :default (value abbrev-pathname-defaults)
511     :must-exist nil)))
512     (with-open-file (file (value abbrev-pathname-defaults) :direction :input
513 wlott 1.1.1.2 :element-type 'base-character :if-does-not-exist :error)
514 ram 1.1 (read-abbrevs file)))
515    
516    
517     ;;; Does the actual defining of abbrevs from a given stream, expecting tabs and
518     ;;; doubled double-quotes.
519    
520     (defun read-abbrevs (file)
521     (do ((line (read-line file nil nil)
522     (read-line file nil nil)))
523     ((null line))
524     (unless (< (length line) 4)
525     (let* ((tab (position #\tab line))
526     (tab2 (position #\tab line :start (1+ tab)))
527     (abbrev (subseq line 0 tab))
528     (modename (subseq line (1+ tab) tab2))
529     (expansion (do* ((last (1+ (position #\" line))
530     (if found (min len (1+ found)) 0))
531     (len (length line))
532     (found (if (position #\" line :start last)
533     (1+ (position #\" line :start last)))
534     (if (position #\" line :start last)
535     (1+ (position #\" line :start last))))
536     (expansion (subseq line last (if found found len))
537     (concatenate 'simple-string expansion
538     (subseq line last
539     (if found found
540     len)))))
541     ((and (or (null found) (= found len))
542     (equal #\" (char line (1- len)))
543     (or (not (equal #\" (char line (- len 2))))
544     (= (- len 3) tab2)))
545     (subseq expansion 0 (1- (length expansion))))
546    
547     (when (null found)
548     (setq line (read-line file nil nil)
549     last 0
550     len (length line)
551     found (if (position #\" line)
552     (1+ (position #\" line)))
553     expansion (format nil "~A~%~A" expansion
554     (subseq line 0 (if found
555     found
556     0))))))))
557    
558     (cond ((equal modename "")
559     (setf (gethash abbrev *global-abbrev-table*)
560     expansion))
561     (t (setq modename (subseq modename 1 (1- (length modename))))
562     (unless (hemlock-bound-p 'Mode-Abbrev-Table
563     :mode modename)
564     (defhvar "Mode Abbrev Table"
565     "Hash Table of Mode Abbrevs"
566     :value (make-hash-table :test #'equal)
567     :mode modename))
568     (setf (gethash abbrev (variable-value
569     'Mode-Abbrev-Table :mode modename))
570     expansion)))))))
571    
572    
573     ;;; Write Word Abbrev File Make a definition file from current abbrevs.
574    
575     (defcommand "Write Word Abbrev File" (p &optional filename)
576     "Saves the currently defined Abbrevs to a file."
577     "Saves the currently defined Abbrevs to a file."
578     (declare (ignore p))
579     (unless filename
580     (setq filename
581     (prompt-for-file
582     :prompt "Write abbrevs to file: "
583     :default (value abbrev-pathname-defaults)
584     :help "Name of the file to write current abbrevs to."
585     :must-exist nil)))
586     (with-open-file (file filename :direction :output
587 wlott 1.1.1.2 :element-type 'base-character :if-exists :supersede
588 ram 1.1 :if-does-not-exist :create)
589     (multiple-value-bind (x mode-tables) (count-abbrevs)
590     (declare (ignore x))
591     (maphash #'(lambda (key val)
592     (write-abbrev key val nil file))
593     *global-abbrev-table*)
594    
595     (dolist (modename mode-tables)
596     (let ((mode (if (listp modename) (car modename) modename)))
597     (maphash #'(lambda (key val)
598     (write-abbrev key val mode file))
599     (variable-value 'Mode-Abbrev-Table :mode mode))))))
600     (let ((tn (truename filename)))
601     (setf (value abbrev-pathname-defaults) tn)
602     (message "~A written." (namestring tn))))
603    
604    
605    
606     ;;; Append to Word Abbrev File Appends to a file changed abbrev
607     ;;; definitions since last dumping.
608    
609     (defcommand "Append to Word Abbrev File" (p &optional filename)
610     "Appends Abbrevs defined or redefined since the last save to a file."
611     "Appends Abbrevs defined or redefined since the last save to a file."
612     (declare (ignore p))
613     (cond
614     (*new-abbrevs*
615     (unless filename
616     (setq filename
617     (prompt-for-file
618     :prompt
619     "Append incremental abbrevs to file: "
620     :default (value abbrev-pathname-defaults)
621     :must-exist nil
622     :help "Filename to append recently defined Abbrevs to.")))
623     (write-incremental :append filename))
624     (t
625     (message "No Abbrev definitions have been changed since the last write."))))
626    
627    
628     (defun write-incremental (mode filename)
629 wlott 1.1.1.2 (with-open-file (file filename :direction :output
630     :element-type 'base-character
631 ram 1.1 :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