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

Contents of /src/hemlock/dabbrev.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Tue Feb 25 15:18:34 2003 UTC (11 years, 1 month ago) by emarsden
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, 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, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, 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, 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, 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, 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
From Luke Gorrie:

   - add support for copy-word during isearch (bound to C-w as per GNU Emacs)
   - add dabbrev support (bound to M-/)
1 ;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 (ext:file-comment
4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/dabbrev.lisp,v 1.1 2003/02/25 15:18:34 emarsden Rel $")
5
6 ;;; **********************************************************************
7 ;;; Dynamic abbreviation (dabbrev) command, knocked off from GNU Emacs.
8 ;;; Written by Luke Gorrie <luke@bluetail.com> in February 2002.
9 ;;; This code has been placed in the public domain.
10
11 (in-package "HEMLOCK")
12
13 ;;; ----------------------------------------------------------------------
14 ;;; Internal state for continuing expansions. This is only maintained
15 ;;; between consecutive calls to Dabbrev Expand, and all gets reset when a
16 ;;; new expansion is staretd.
17
18 (defvar *expanded-suffix-length* nil
19 "Length of the previously expanded suffix, or Nil if no expansion has
20 been made. This length is needed to undo an expansion.")
21
22 (defvar *seen-dabbrevs* nil
23 "List of abbreviations that have already been offered, and will be
24 skipped in future.")
25
26 (defvar *dabbrev-continuation* nil
27 "Closure which, when called with no arguments, continues from the
28 previous expansion.")
29
30 (defcommand "Dabbrev Expand" (p)
31 "Expand previous word \"dynamically\".
32
33 Expands to the most recent, preceding word for which this is a prefix.
34 If no suitable preceding word is found, words following point are
35 considered.
36
37 Repeated calls continue by finding new expansions."
38 "See command docstring. I mean, really."
39 (declare (ignore p))
40 (if (eq (last-command-type) :dabbrev-expand)
41 (continue-dabbrev-search)
42 (new-dabbrev-search)))
43
44 (defun continue-dabbrev-search ()
45 "Replace the previous expansion with the next new one."
46 (funcall *dabbrev-continuation*))
47
48 (defun new-dabbrev-search ()
49 "Start a new search for an expansion."
50 (reset-dabbrev-state)
51 (let ((mark (copy-mark (current-point) :temporary)))
52 (when (start-of-dabbrev-prefix mark)
53 (let ((prefix (region-to-string (region mark (current-point)))))
54 (if (string= prefix "")
55 (editor-error "No possible abbreviation preceding point")
56 (dabbrev-find-expansion mark :backward prefix))))))
57
58 (defun reset-dabbrev-state ()
59 (setq *expanded-suffix-length* nil
60 *seen-dabbrevs* nil
61 *dabbrev-continuation* nil))
62
63 (defun start-of-dabbrev-prefix (mark)
64 "Move Mark to the beginning of the word containing it. Returns NIL if
65 there is no matching word."
66 (or (reverse-find-attribute mark :lisp-syntax #'not-constituent-p)
67 (or (start-line-p mark)
68 (line-start mark))))
69
70 ;;; ----------------------------------------------------------------------
71 ;;; Main searching engine
72
73 (defun dabbrev-find-expansion (start-mark direction string)
74 "Try to find an expansion of STRING in DIRECTION, starting from
75 START-MARK. The expansion suffix is returned if found, otherwise NIL."
76 (let ((searchm (copy-mark start-mark :temporary)))
77 (if (find-pattern searchm
78 (new-search-pattern :string-sensitive
79 direction
80 string))
81 ;; Marks to be placed for the region of the new suffix.
82 (let ((start (copy-mark searchm :temporary))
83 (end (copy-mark searchm :temporary)))
84 (character-offset start (length string))
85 (move-mark end start)
86 (or (find-attribute end :lisp-syntax #'not-constituent-p)
87 (line-end end))
88 (let ((match-region (region start end)))
89 (cond ((and (> (count-characters match-region) 0)
90 (at-beginning-of-word-p searchm)
91 (not (member (region-to-string match-region)
92 *seen-dabbrevs*
93 :test #'string=)))
94 (dabbrev-apply-expansion searchm match-region direction string))
95 ((and (eq direction :forward)
96 (next-character end))
97 (dabbrev-find-expansion end direction string))
98 ((and (eq direction :backward)
99 (previous-character searchm))
100 (dabbrev-find-expansion searchm direction string))
101 (t
102 (continue-failed-expansion direction string)))))
103 (continue-failed-expansion direction string))))
104
105 (defun continue-failed-expansion (direction string)
106 "Continue (or not) the search, after one avenue has failed."
107 (cond ((eq direction :backward)
108 ;; Turn around -- now try forwards from Point
109 (dabbrev-find-expansion (current-point) :forward string))
110 (t
111 ;; We've tried both directions, so just give up.
112 ;; Alternatively we could try other sources of abbreviations next.
113 (undo-previous-expansion)
114 (editor-error (if *seen-dabbrevs*
115 "No more expansions of `~A'"
116 "No expansion for `~A'")
117 string))))
118
119 (defun dabbrev-apply-expansion (match region direction prefix)
120 "Apply the expansion found at Match to the buffer by inserting the
121 suffix in Region after the original prefix."
122 (undo-previous-expansion)
123 (setq *expanded-suffix-length* (count-characters region))
124 (let ((suffix (region-to-string region))
125 (search-continue-pos (if (eq direction :forward)
126 (region-end region)
127 match)))
128 (push suffix *seen-dabbrevs*)
129 (insert-string (current-point) suffix)
130 (dabbrev-install-continuation
131 (lambda ()
132 (dabbrev-find-expansion search-continue-pos direction prefix)))))
133
134 (defun undo-previous-expansion ()
135 (when *expanded-suffix-length*
136 (delete-characters (current-point) (- *expanded-suffix-length*))))
137
138 (defun dabbrev-install-continuation (k)
139 (setf (last-command-type) :dabbrev-expand)
140 (setq *dabbrev-continuation* k))
141
142 ;;; ----------------------------------------------------------------------
143 ;;; Little helpers
144
145 (defun at-beginning-of-word-p (mark)
146 (or (start-line-p mark)
147 (not (eq (character-attribute
148 :lisp-syntax
149 (previous-character mark))
150 :constituent))))
151
152 (defun not-constituent-p (property)
153 (not (eq property :constituent)))
154

  ViewVC Help
Powered by ViewVC 1.1.5