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

Contents of /src/hemlock/dabbrev.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.16.1 - (hide annotations)
Sat May 22 12:22:45 2004 UTC (9 years, 11 months ago) by rtoy
Branch: UNICODE-BRANCH
Changes since 1.1: +1 -1 lines
Perform trivial merge from head to unicode-branch.
1 emarsden 1.1 ;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     (ext:file-comment
4 rtoy 1.1.16.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/dabbrev.lisp,v 1.1.16.1 2004/05/22 12:22:45 rtoy Exp $")
5 emarsden 1.1
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