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

Contents of /src/hemlock/abbrev.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +1 -3 lines
Fix headed boilerplate.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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     ;;;
7     (ext:file-comment
8 ram 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/abbrev.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Hemlock Word Abbreviation Mode
13     ;;; by Jamie W. Zawinski
14     ;;; 24 September 1985
15     ;;;
16     (in-package "HEMLOCK")
17    
18     ;;;; These Things are Here:
19    
20     ;;; C-X C-A Add Mode Word Abbrev
21     ;;; Define a mode abbrev for the word before point.
22     ;;; C-X + Add Global Word Abbrev
23     ;;; Define a global abbrev for the word before point.
24     ;;; C-X C-H Inverse Add Mode Word Abbrev
25     ;;; Define expansion for mode abbrev before point.
26     ;;; C-X - Inverse Add Global Word Abbrev
27     ;;; Define expansion for global abbrev before point.
28     ;;; Alt Space Abbrev Expand Only
29     ;;; Expand abbrev without inserting anything.
30     ;;; M-' Word Abbrev Prefix Mark
31     ;;; Mark a prefix to be glued to an abbrev following.
32     ;;; C-X U Unexpand Last Word
33     ;;; Unexpands last abbrev or undoes C-X U.
34    
35     ;;; List Word Abbrevs Shows definitions of all word abbrevs.
36     ;;; Edit Word Abbrevs Lets you edit the definition list directly.
37     ;;; Read Word Abbrev File <filename> Define word abbrevs from a definition file.
38     ;;; Write Word Abbrev File Make a definition file from current abbrevs.
39    
40     ;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
41     ;;; Delete All Word Abbrevs Wipes them all.
42     ;;; Delete Mode Word Abbrev Kills all Mode abbrev.
43     ;;; Delete Global Word Abbrev Kills all Global abbrev.
44    
45     ;;; Insert Word Abbrevs Inserts a list of current definitions in the
46     ;;; format that Define Word Abbrevs uses.
47     ;;; Define Word Abbrevs Defines set of abbrevs from a definition list in
48     ;;; the buffer.
49     ;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
50     ;;; definition, or mode.
51    
52     ;;; Append Incremental Word Abbrev File Appends to a file changed abbrev
53     ;;; definitions since last dumping.
54    
55     (defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0)
56    
57    
58     (defvar *Global-Abbrev-Table* (make-hash-table :test #'equal)
59     "Hash table holding global abbrev definitions.")
60    
61     (defhvar "Abbrev Pathname Defaults"
62     "Holds the name of the last Abbrev-file written."
63     :value (pathname "abbrev.defns"))
64    
65     (defvar *new-abbrevs* ()
66     "holds a list of abbrevs (and their definitions and modes) changed since saving.")
67    
68    
69     ;;; C-X C-H Inverse Add Mode Word Abbrev
70     ;;; Define a mode expansion for the word before point.
71    
72     (defcommand "Inverse Add Mode Word Abbrev" (p)
73     "Defines a mode word abbrev expansion for the word before the point."
74     "Defines a mode word abbrev expansion for the word before the point."
75     (declare (ignore p))
76     (let ((word (prev-word 1 (current-point)))
77     (mode (buffer-major-mode (current-buffer))))
78     (make-word-abbrev-command nil word nil mode)))
79    
80    
81     ;;; C-X C-A Add Mode Word Abbrev
82     ;;; Define mode abbrev for word before point.
83    
84     (defcommand "Add Mode Word Abbrev" (p)
85     "Defines a mode word abbrev for the word before the point.
86     With a positive argument, uses that many preceding words as the expansion.
87     With a zero argument, uses the region as the expansion. With a negative
88     argument, prompts for a word abbrev to delete in the current mode."
89     "Defines or deletes a mode word abbrev."
90     (if (and p (minusp p))
91     (delete-mode-word-abbrev-command nil)
92     (let* ((val (if (eql p 0)
93     (region-to-string (current-region nil))
94     (prev-word (or p 1) (current-point))))
95     (mode (buffer-major-mode (current-buffer))))
96     (make-word-abbrev-command nil nil val mode))))
97    
98    
99    
100     ;;; C-X - Inverse Add Global Word Abbrev
101     ;;; Define global expansion for word before point.
102    
103     (defcommand "Inverse Add Global Word Abbrev" (p)
104     "Defines a Global expansion for the word before point."
105     "Defines a Global expansion for the word before point."
106     (declare (ignore p))
107     (let ((word (prev-word 1 (current-point))))
108     (make-word-abbrev-command nil word nil "Global")))
109    
110    
111    
112     ;;; C-X + Add Global Word Abbrev
113     ;;; Define global Abbrev for word before point.
114    
115     (defcommand "Add Global Word Abbrev" (p)
116     "Defines a global word abbrev for the word before the point.
117     With a positive argument, uses that many preceding words as the expansion.
118     With a zero argument, uses the region as the expansion. With a negative
119     argument, prompts for a global word abbrev to delete."
120     "Defines or deletes a global word abbrev."
121     (if (and p (minusp p))
122     (delete-global-word-abbrev-command nil)
123     (let ((val (if (eql p 0)
124     (region-to-string (current-region nil))
125     (prev-word (or p 1) (current-point)))))
126     (make-word-abbrev-command nil nil val "Global"))))
127    
128    
129     ;;;; Defining Abbrevs
130    
131     ;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
132    
133     (defvar *global-abbrev-string-table*
134     (make-string-table :initial-contents '(("Global" . nil))))
135    
136     (defcommand "Make Word Abbrev" (p &optional abbrev expansion mode)
137     "Defines an arbitrary word abbreviation.
138     Prompts for abbrev, expansion, and mode."
139     "Makes Abbrev be a word abbreviation for Expansion when in Mode. If
140     mode is \"Global\" then make a global abbrev."
141     (declare (ignore p))
142     (unless mode
143     (setq mode
144     (prompt-for-keyword
145     (list *mode-names* *global-abbrev-string-table*)
146     :prompt "Mode of abbrev to add: "
147     :default "Global"
148     :help
149     "Type the mode of the Abbrev you want to add, or confirm for Global.")))
150     (let ((globalp (string-equal mode "Global")))
151     (unless (or globalp (mode-major-p mode))
152     (editor-error "~A is not a major mode." mode))
153     (unless abbrev
154     (setq abbrev
155     (prompt-for-string
156     :trim t
157     :prompt
158     (list "~A abbreviation~@[ of ~S~]: " mode expansion)
159     :help
160     (list "Define a ~A word abbrev." mode))))
161     (when (zerop (length abbrev))
162     (editor-error "Abbreviation must be at least one character long."))
163     (unless (every #'(lambda (ch)
164     (zerop (character-attribute :word-delimiter ch)))
165     (the simple-string abbrev))
166     (editor-error "Word Abbrevs must be a single word."))
167     (unless expansion
168     (setq expansion
169     (prompt-for-string
170     :prompt (list "~A expansion for ~S: " mode abbrev)
171     :help (list "Define the ~A expansion of ~S." mode abbrev))))
172     (setq abbrev (string-downcase abbrev))
173     (let* ((table (cond (globalp *global-abbrev-table*)
174     ((hemlock-bound-p 'Mode-Abbrev-Table :mode mode)
175     (variable-value 'Mode-Abbrev-Table :mode mode))
176     (t
177     (let ((new (make-hash-table :test #'equal)))
178     (defhvar "Mode Abbrev Table"
179     "Hash Table of Mode Abbrevs"
180     :value new :mode mode)
181     new))))
182     (old (gethash abbrev table)))
183     (when (or (not old)
184     (prompt-for-y-or-n
185     :prompt
186     (list "Current ~A definition of ~S is ~S.~%Redefine?"
187     mode abbrev old)
188     :default t
189     :help (list "Redefine the expansion of ~S." abbrev)))
190     (setf (gethash abbrev table) expansion)
191     (push (list abbrev expansion (if globalp nil mode))
192     *new-abbrevs*)))))
193    
194    
195     ;;; Alt Space Abbrev Expand Only
196     ;;; Expand abbrev without inserting anything.
197    
198     (defcommand "Abbrev Expand Only" (p)
199     "This command expands the word before point into its abbrev definition
200     (if indeed it has one)."
201     "This command expands the word before point into its abbrev definition
202     (if indeed it has one)."
203     (declare (ignore p))
204     (let* ((word (prev-word 1 (current-point)))
205     (glob (gethash (string-downcase word) *global-abbrev-table*))
206     (mode (if (hemlock-bound-p 'Mode-Abbrev-Table)
207     (gethash (string-downcase word)
208     (value Mode-Abbrev-Table))))
209     (end-word (reverse-find-attribute (copy-mark (current-point)
210     :right-inserting)
211     :word-delimiter #'zerop))
212     (result (if mode mode glob)))
213     (when (or mode glob)
214     (delete-characters end-word (- (length word)))
215     (cond ((equal word (string-capitalize word))
216     (setq result (string-capitalize result)))
217     ((equal word (string-upcase word))
218     (setq result (string-upcase result))))
219     (insert-string end-word result)
220     (unless (hemlock-bound-p 'last-expanded)
221     (defhvar "last expanded"
222     "Holds a mark, the last expanded abbrev, and its expansion in a list."
223     :buffer (current-buffer)))
224     (setf (value last-expanded)
225     (list (copy-mark (current-point) :right-inserting)
226     word result)))
227     (delete-mark end-word))
228     (when (and (hemlock-bound-p 'prefix-mark)
229     (value prefix-mark))
230     (delete-characters (value prefix-mark) 1)
231     (delete-mark (value prefix-mark))
232     (setf (value prefix-mark) nil)))
233    
234    
235    
236     ;;; This function returns the n words immediately before the mark supplied.
237    
238     (defun prev-word (n mark)
239     (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary)
240     :word-delimiter #'zerop))
241     (mark-2 (copy-mark mark-1)))
242     (dotimes (x n (region-to-string (region mark-2 mark-1)))
243     (reverse-find-attribute (mark-before mark-2) :word-delimiter))))
244    
245    
246    
247     ;;; M-' Word Abbrev Prefix Mark
248     ;;; Mark a prefix to be glued to an abbrev following.
249    
250     ;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander)
251     ;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately
252     ;;; after prefix-mark.
253    
254     (defcommand "Word Abbrev Prefix Mark" (p)
255     "Marks a prefix to be glued to an abbrev following."
256     "Marks a prefix to be glued to an abbrev following."
257     (declare (ignore p))
258     (unless (hemlock-bound-p 'prefix-mark)
259     (defhvar "prefix mark"
260     "Holds a mark (or not) pointing to the current Prefix Mark."
261     :buffer (current-buffer)))
262     (when (value prefix-mark)
263     (delete-mark (value prefix-mark)))
264     (setf (value prefix-mark) (copy-mark (current-point) :right-inserting))
265     (insert-character (value prefix-mark) #\-))
266    
267    
268     ;;; C-X U Unexpand Last Word
269     ;;; Unexpands last abbrev or undoes last C-X U.
270    
271     (defcommand "Unexpand Last Word" (p)
272     "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\".
273     Only one abbrev may be undone."
274     "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"."
275     (declare (ignore p))
276     (unless (or (not (hemlock-bound-p 'last-expanded))
277     (value last-expanded))
278     (editor-error "Nothing to Undo."))
279     (let ((mark (car (value last-expanded)))
280     (word1 (second (value last-expanded)))
281     (word2 (third (value last-expanded))))
282     (unless (string= word2
283     (region-to-string
284     (region (character-offset (copy-mark mark :temporary)
285     (- (length word2)))
286     mark)))
287     (editor-error "The last expanded Abbrev has been altered in the text."))
288     (delete-characters mark (- (length word2)))
289     (insert-string mark word1)
290     (character-offset mark (length word1))
291     (setf (value last-expanded) (list mark word2 word1))))
292    
293    
294    
295     ;;; Delete Mode Word Abbrev Kills some Mode abbrevs.
296    
297     (defcommand "Delete Mode Word Abbrev"
298     (p &optional abbrev
299     (mode (buffer-major-mode (current-buffer))))
300     "Prompts for a word abbrev and deletes the mode expansion in the current mode.
301     If called with a prefix argument, deletes all word abbrevs define in the
302     current mode."
303     "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true."
304     (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode)))
305     (if p
306     (when boundp
307     (delete-variable 'Mode-Abbrev-Table :mode mode))
308     (let ((down
309     (string-downcase
310     (or abbrev
311     (prompt-for-string
312     :prompt (list "~A abbrev to delete: " mode)
313     :help
314     (list "Give the name of a ~A mode word abbrev to delete." mode)
315     :trim t))))
316     (table (and boundp (variable-value 'mode-abbrev-table :mode mode))))
317     (unless (and table (gethash down table))
318     (editor-error "~S is not the name of an abbrev in ~A mode."
319     down mode))
320     (remhash down table)))))
321    
322    
323     ;;; Delete Global Word Abbrevs Kills some Global abbrevs.
324    
325     (defcommand "Delete Global Word Abbrev" (p &optional abbrev)
326     "Prompts for a word abbrev and delete the global expansion.
327     If called with a prefix argument, deletes all global abbrevs."
328     "Deletes the global word abbreviation named Abbrev. If P is true,
329     deletes all global abbrevs."
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 ram 1.2 :element-type 'base-char :if-does-not-exist :error)
515 ram 1.1 (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 ram 1.2 :element-type 'base-char :if-exists :supersede
589 ram 1.1 :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 ram 1.2 (with-open-file (file filename :direction :output
631     :element-type 'base-char
632 ram 1.1 :if-exists mode :if-does-not-exist :create)
633     (dolist (def *new-abbrevs*)
634     (let ((abb (car def))
635     (val (second def))
636     (mode (third def)))
637     (write-abbrev abb val mode file))))
638     (let ((tn (truename filename)))
639     (setq *new-abbrevs* nil)
640     (setf (value abbrev-pathname-defaults) tn)
641     (message "~A written." (namestring tn))))
642    
643    
644     ;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function
645     ;;; writes to the stream with doubled double-quotes and stuff.
646     ;;; If the flag is true, then the output is in a pretty format (like "List Word
647     ;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word
648     ;;; Abbrev File" uses).
649    
650     (defun write-abbrev (abbrev expansion modename file &optional flag)
651     (if flag
652     (if modename
653     (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format
654     (format file "~5t~A~35t\"" abbrev)) ; pretty format
655     (cond (modename
656     (write-string abbrev file)
657     (write-char #\tab file)
658     (format file "(~A)" modename) ; "~A<tab>(~A)<tab>\""
659     (write-char #\tab file)
660     (write-char #\" file))
661     (t
662     (write-string abbrev file)
663     (write-char #\tab file) ; "~A<tab><tab>\""
664     (write-char #\tab file)
665     (write-char #\" file))))
666     (do* ((prev 0 found)
667     (found (position #\" expansion)
668     (position #\" expansion :start found)))
669     ((not found)
670     (write-string expansion file :start prev)
671     (write-char #\" file)
672     (terpri file))
673     (incf found)
674     (write-string expansion file :start prev :end found)
675     (write-char #\" file)))
676    
677    
678     (defcommand "Abbrev Mode" (p)
679     "Put current buffer in Abbrev mode."
680     "Put current buffer in Abbrev mode."
681     (declare (ignore p))
682     (setf (buffer-minor-mode (current-buffer) "Abbrev")
683     (not (buffer-minor-mode (current-buffer) "Abbrev"))))

  ViewVC Help
Powered by ViewVC 1.1.5