1 | ;;; complete.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2004 Peter Graves |
---|
4 | ;;; $Id: complete.lisp,v 1.2 2004-09-05 00:12:25 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | (in-package "J") |
---|
21 | |
---|
22 | (export 'complete) |
---|
23 | |
---|
24 | (defvar *prefix* nil) |
---|
25 | (defvar *completions* ()) |
---|
26 | (defvar *completion-index* 0) |
---|
27 | |
---|
28 | (defun compound-prefix-match (prefix target) |
---|
29 | (let ((tlen (length target)) |
---|
30 | (tpos 0)) |
---|
31 | (dotimes (i (length prefix)) |
---|
32 | (when (>= tpos tlen) |
---|
33 | (return-from compound-prefix-match nil)) |
---|
34 | (let ((ch (schar prefix i))) |
---|
35 | (if (char= ch #\-) |
---|
36 | (unless (setf tpos (position #\- target :start tpos)) |
---|
37 | (return-from compound-prefix-match nil)) |
---|
38 | (unless (char-equal ch (schar target tpos)) |
---|
39 | (return-from compound-prefix-match nil))) |
---|
40 | (incf tpos))) |
---|
41 | t)) |
---|
42 | |
---|
43 | (defun completion-set (prefix) |
---|
44 | (let ((result ())) |
---|
45 | (do-external-symbols (symbol "CL") |
---|
46 | (let ((name (symbol-name symbol))) |
---|
47 | (when (compound-prefix-match prefix name) |
---|
48 | (push symbol result)))) |
---|
49 | result)) |
---|
50 | |
---|
51 | (defun completion-prefix () |
---|
52 | (let* ((string (line-chars (current-line))) |
---|
53 | (end (mark-charpos (current-point)))) |
---|
54 | (do ((start (1- end) (1- start))) |
---|
55 | ((< start 0) (subseq string 0 end)) |
---|
56 | (let ((ch (schar string start))) |
---|
57 | (when (or (eql ch #\space) (eql ch #\()) |
---|
58 | (incf start) |
---|
59 | (return-from completion-prefix (subseq string start end))))))) |
---|
60 | |
---|
61 | (defun complete () |
---|
62 | (cond ((eq *last-command* 'complete) |
---|
63 | (unless (> (length *completions*) 1) |
---|
64 | (return-from complete)) |
---|
65 | (undo) |
---|
66 | (incf *completion-index*) |
---|
67 | (when (> *completion-index* (1- (length *completions*))) |
---|
68 | (setf *completion-index* 0))) |
---|
69 | (t |
---|
70 | (setf *prefix* (completion-prefix) |
---|
71 | *completions* nil |
---|
72 | *completion-index* 0) |
---|
73 | (when *prefix* |
---|
74 | (setf *completions* (completion-set *prefix*))))) |
---|
75 | (when *completions* |
---|
76 | (let ((completion (string-downcase (nth *completion-index* *completions*))) |
---|
77 | (point (current-point))) |
---|
78 | (with-single-undo |
---|
79 | (goto-char (make-mark (mark-line point) |
---|
80 | (- (mark-charpos point) (length *prefix*)))) |
---|
81 | (set-mark point) |
---|
82 | (delete-region) |
---|
83 | (insert completion))) |
---|
84 | (setf *current-command* 'complete)) |
---|
85 | (values)) |
---|
86 | |
---|
87 | (map-key-for-mode "Ctrl Space" "(complete)" "Lisp") |
---|
88 | (map-key-for-mode "Ctrl Space" "(complete)" "Lisp Shell") |
---|