Commit | Line | Data |
---|---|---|
2d857fb1 KN |
1 | ;;; guile-scheme.el --- Guile Scheme editing mode |
2 | ||
6e7d5622 | 3 | ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. |
2d857fb1 | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free | |
17 | ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA | |
18 | ;;;; 02111-1307 USA | |
2d857fb1 KN |
19 | |
20 | ;;; Commentary: | |
21 | ||
22 | ;; Put the following lines in your ~/.emacs: | |
23 | ;; | |
24 | ;; (require 'guile-scheme) | |
25 | ;; (setq initial-major-mode 'scheme-interaction-mode) | |
26 | ||
27 | ;;; Code: | |
28 | ||
29 | (require 'guile) | |
30 | (require 'scheme) | |
31 | ||
32 | (defgroup guile-scheme nil | |
33 | "Editing Guile-Scheme code" | |
34 | :group 'lisp) | |
35 | ||
36 | (defvar guile-scheme-syntax-keywords | |
37 | '((begin 0) (if 1) (cond 0) (case 1) (do 2) | |
38 | quote syntax lambda and or else delay receive use-modules | |
39 | (match 1) (match-lambda 0) (match-lambda* 0) | |
40 | (let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1) | |
41 | (let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2))) | |
42 | ||
43 | (defvar guile-scheme-special-procedures | |
44 | '((catch 1) (lazy-catch 1) (stack-catch 1) | |
45 | map for-each (dynamic-wind 3))) | |
46 | ||
47 | ;; set indent functions | |
48 | (dolist (x (append guile-scheme-syntax-keywords | |
49 | guile-scheme-special-procedures)) | |
50 | (when (consp x) | |
51 | (put (car x) 'scheme-indent-function (cadr x)))) | |
52 | ||
53 | (defconst guile-scheme-font-lock-keywords | |
54 | (eval-when-compile | |
55 | (list | |
56 | (list (concat "(\\(define\\*?\\(" | |
57 | ;; Function names. | |
58 | "\\(\\|-public\\|-method\\|-generic\\)\\|" | |
59 | ;; Macro names, as variable names. | |
60 | "\\(-syntax\\|-macro\\)\\|" | |
61 | ;; Others | |
62 | "-\\sw+\\)\\)\\>" | |
63 | ;; Any whitespace and declared object. | |
64 | "\\s *(?\\(\\sw+\\)?") | |
65 | '(1 font-lock-keyword-face) | |
66 | '(5 (cond ((match-beginning 3) font-lock-function-name-face) | |
67 | ((match-beginning 4) font-lock-variable-name-face) | |
68 | (t font-lock-type-face)) nil t)) | |
69 | (list (concat | |
70 | "(" (regexp-opt | |
71 | (mapcar (lambda (e) | |
72 | (prin1-to-string (if (consp e) (car e) e))) | |
73 | (append guile-scheme-syntax-keywords | |
74 | guile-scheme-special-procedures)) 'words)) | |
75 | '(1 font-lock-keyword-face)) | |
76 | '("<\\sw+>" . font-lock-type-face) | |
77 | '("\\<:\\sw+\\>" . font-lock-builtin-face) | |
78 | )) | |
79 | "Expressions to highlight in Guile Scheme mode.") | |
80 | ||
81 | \f | |
82 | ;;; | |
83 | ;;; Guile Scheme mode | |
84 | ;;; | |
85 | ||
86 | (defvar guile-scheme-mode-map nil | |
87 | "Keymap for Guile Scheme mode. | |
88 | All commands in `lisp-mode-shared-map' are inherited by this map.") | |
89 | ||
90 | (unless guile-scheme-mode-map | |
91 | (let ((map (make-sparse-keymap "Guile-Scheme"))) | |
92 | (setq guile-scheme-mode-map map) | |
19a96c8a KN |
93 | (cond ((boundp 'lisp-mode-shared-map) |
94 | (set-keymap-parent map lisp-mode-shared-map)) | |
95 | ((boundp 'shared-lisp-mode-map) | |
96 | (set-keymap-parent map shared-lisp-mode-map))) | |
2d857fb1 KN |
97 | (define-key map [menu-bar] (make-sparse-keymap)) |
98 | (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map)) | |
99 | (define-key map [uncomment-region] | |
100 | '("Uncomment Out Region" . (lambda (beg end) | |
101 | (interactive "r") | |
102 | (comment-region beg end '(4))))) | |
103 | (define-key map [comment-region] '("Comment Out Region" . comment-region)) | |
104 | (define-key map [indent-region] '("Indent Region" . indent-region)) | |
105 | (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) | |
106 | (define-key map "\e\C-i" 'guile-scheme-complete-symbol) | |
107 | (define-key map "\e\C-x" 'guile-scheme-eval-define) | |
108 | (define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp) | |
109 | (define-key map "\C-c\C-b" 'guile-scheme-eval-buffer) | |
110 | (define-key map "\C-c\C-r" 'guile-scheme-eval-region) | |
111 | (define-key map "\C-c:" 'guile-scheme-eval-expression) | |
112 | (define-key map "\C-c\C-a" 'guile-scheme-apropos) | |
113 | (define-key map "\C-c\C-d" 'guile-scheme-describe) | |
19a96c8a | 114 | (define-key map "\C-c\C-k" 'guile-scheme-kill-process) |
2d857fb1 KN |
115 | |
116 | (put 'comment-region 'menu-enable 'mark-active) | |
117 | (put 'uncomment-region 'menu-enable 'mark-active) | |
118 | (put 'indent-region 'menu-enable 'mark-active))) | |
119 | ||
120 | (defcustom guile-scheme-mode-hook nil | |
121 | "Normal hook run when entering `guile-scheme-mode'." | |
122 | :type 'hook | |
123 | :group 'guile-scheme) | |
124 | ||
125 | ;;;###autoload | |
126 | (defun guile-scheme-mode () | |
127 | "Major mode for editing Guile Scheme code. | |
128 | Editing commands are similar to those of `scheme-mode'. | |
129 | ||
130 | \\{scheme-mode-map} | |
131 | Entry to this mode calls the value of `scheme-mode-hook' | |
132 | if that value is non-nil." | |
133 | (interactive) | |
134 | (kill-all-local-variables) | |
135 | (setq mode-name "Guile Scheme") | |
136 | (setq major-mode 'guile-scheme-mode) | |
137 | (use-local-map guile-scheme-mode-map) | |
138 | (scheme-mode-variables) | |
139 | (setq mode-line-process | |
140 | '(:eval (if (processp guile-scheme-adapter) | |
141 | (format " [%s]" guile-scheme-command) | |
142 | ""))) | |
143 | (setq font-lock-defaults | |
144 | '((guile-scheme-font-lock-keywords) | |
145 | nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun | |
146 | (font-lock-mark-block-function . mark-defun))) | |
147 | (run-hooks 'guile-scheme-mode-hook)) | |
148 | ||
149 | \f | |
150 | ;;; | |
151 | ;;; Scheme interaction mode | |
152 | ;;; | |
153 | ||
154 | (defvar scheme-interaction-mode-map () | |
155 | "Keymap for Scheme Interaction mode. | |
156 | All commands in `guile-scheme-mode-map' are inherited by this map.") | |
157 | ||
158 | (unless scheme-interaction-mode-map | |
159 | (let ((map (make-sparse-keymap))) | |
160 | (setq scheme-interaction-mode-map map) | |
161 | (set-keymap-parent map guile-scheme-mode-map) | |
162 | (define-key map "\C-j" 'guile-scheme-eval-print-last-sexp) | |
163 | )) | |
164 | ||
165 | (defvar scheme-interaction-mode-hook nil | |
166 | "Normal hook run when entering `scheme-interaction-mode'.") | |
167 | ||
168 | (defun scheme-interaction-mode () | |
169 | "Major mode for evaluating Scheme expressions with Guile. | |
170 | ||
171 | \\{scheme-interaction-mode-map}" | |
172 | (interactive) | |
173 | (guile-scheme-mode) | |
174 | (use-local-map scheme-interaction-mode-map) | |
175 | (setq major-mode 'scheme-interaction-mode) | |
176 | (setq mode-name "Scheme Interaction") | |
177 | (run-hooks 'scheme-interaction-mode-hook)) | |
178 | ||
179 | \f | |
180 | ;;; | |
181 | ;;; Guile Scheme adapter | |
182 | ;;; | |
183 | ||
184 | (defvar guile-scheme-command "guile") | |
185 | (defvar guile-scheme-adapter nil) | |
19a96c8a | 186 | (defvar guile-scheme-module nil) |
2d857fb1 KN |
187 | |
188 | (defun guile-scheme-adapter () | |
189 | (if (and (processp guile-scheme-adapter) | |
190 | (eq (process-status guile-scheme-adapter) 'run)) | |
191 | guile-scheme-adapter | |
19a96c8a | 192 | (setq guile-scheme-module nil) |
2d857fb1 KN |
193 | (setq guile-scheme-adapter |
194 | (guile:make-adapter guile-scheme-command 'emacs-scheme-channel)))) | |
195 | ||
196 | (defun guile-scheme-set-module () | |
197 | "Set the current module based on buffer contents. | |
198 | If there is a (define-module ...) form, evaluate it. | |
199 | Otherwise, choose module (guile-user)." | |
200 | (save-excursion | |
19a96c8a KN |
201 | (let ((module (if (re-search-backward "^(define-module " nil t) |
202 | (let ((start (match-beginning 0))) | |
203 | (goto-char start) | |
204 | (forward-sexp) | |
205 | (buffer-substring-no-properties start (point))) | |
206 | "(define-module (emacs-user))"))) | |
207 | (unless (string= guile-scheme-module module) | |
208 | (prog1 (guile:eval module (guile-scheme-adapter)) | |
209 | (setq guile-scheme-module module)))))) | |
2d857fb1 KN |
210 | |
211 | (defun guile-scheme-eval-string (string) | |
212 | (guile-scheme-set-module) | |
213 | (guile:eval string (guile-scheme-adapter))) | |
214 | ||
215 | (defun guile-scheme-display-result (value flag) | |
216 | (if (string= value "#<unspecified>") | |
217 | (setq value "done")) | |
218 | (if flag | |
219 | (insert value) | |
220 | (message "%s" value))) | |
221 | ||
222 | \f | |
223 | ;;; | |
224 | ;;; Interactive commands | |
225 | ;;; | |
226 | ||
227 | (defun guile-scheme-eval-expression (string) | |
228 | "Evaluate the expression in STRING and show value in echo area." | |
229 | (interactive "SGuile Scheme Eval: ") | |
230 | (guile-scheme-display-result (guile-scheme-eval-string string) nil)) | |
231 | ||
232 | (defun guile-scheme-eval-region (start end) | |
233 | "Evaluate the region as Guile Scheme code." | |
234 | (interactive "r") | |
235 | (guile-scheme-eval-expression (buffer-substring-no-properties start end))) | |
236 | ||
237 | (defun guile-scheme-eval-buffer () | |
238 | "Evaluate the current buffer as Guile Scheme code." | |
239 | (interactive) | |
240 | (guile-scheme-eval-expression (buffer-string))) | |
241 | ||
242 | (defun guile-scheme-eval-last-sexp (arg) | |
243 | "Evaluate sexp before point; show value in echo area. | |
244 | With argument, print output into current buffer." | |
245 | (interactive "P") | |
246 | (guile-scheme-display-result | |
247 | (guile-scheme-eval-string | |
248 | (buffer-substring-no-properties | |
249 | (point) (save-excursion (backward-sexp) (point)))) arg)) | |
250 | ||
251 | (defun guile-scheme-eval-print-last-sexp () | |
252 | "Evaluate sexp before point; print value into current buffer." | |
253 | (interactive) | |
19a96c8a KN |
254 | (let ((start (point))) |
255 | (guile-scheme-eval-last-sexp t) | |
256 | (insert "\n") | |
257 | (save-excursion (goto-char start) (insert "\n")))) | |
2d857fb1 KN |
258 | |
259 | (defun guile-scheme-eval-define () | |
260 | (interactive) | |
261 | (guile-scheme-eval-region (save-excursion (end-of-defun) (point)) | |
262 | (save-excursion (beginning-of-defun) (point)))) | |
263 | ||
264 | (defun guile-scheme-load-file (file) | |
265 | "Load a Guile Scheme file." | |
266 | (interactive "fGuile Scheme load file: ") | |
267 | (guile-scheme-eval-string (format "(load %s)" (expand-file-name file))) | |
268 | (message "done")) | |
269 | ||
19a96c8a KN |
270 | (guile-import guile-emacs-complete-alist) |
271 | ||
2d857fb1 KN |
272 | (defun guile-scheme-complete-symbol () |
273 | (interactive) | |
2d857fb1 KN |
274 | (let* ((end (point)) |
275 | (start (save-excursion (skip-syntax-backward "w_") (point))) | |
276 | (pattern (buffer-substring-no-properties start end)) | |
277 | (alist (guile-emacs-complete-alist pattern))) | |
278 | (goto-char end) | |
279 | (let ((completion (try-completion pattern alist))) | |
280 | (cond ((eq completion t)) | |
281 | ((not completion) | |
282 | (message "Can't find completion for \"%s\"" pattern) | |
283 | (ding)) | |
284 | ((not (string= pattern completion)) | |
285 | (delete-region start end) | |
286 | (insert completion)) | |
287 | (t | |
288 | (message "Making completion list...") | |
289 | (with-output-to-temp-buffer "*Completions*" | |
290 | (display-completion-list alist)) | |
291 | (message "Making completion list...done")))))) | |
292 | ||
19a96c8a KN |
293 | (guile-import guile-emacs-apropos) |
294 | ||
295 | (defun guile-scheme-apropos (regexp) | |
296 | (interactive "sGuile Scheme apropos (regexp): ") | |
297 | (guile-scheme-set-module) | |
298 | (with-output-to-temp-buffer "*Help*" | |
299 | (princ (guile-emacs-apropos regexp)))) | |
300 | ||
301 | (guile-import guile-emacs-describe) | |
302 | ||
303 | (defun guile-scheme-describe (symbol) | |
304 | (interactive (list (guile-scheme-input-symbol "Describe Guile variable"))) | |
305 | (guile-scheme-set-module) | |
306 | (with-output-to-temp-buffer "*Help*" | |
307 | (princ (guile-emacs-describe symbol)))) | |
308 | ||
309 | (defun guile-scheme-kill-process () | |
310 | (interactive) | |
311 | (if guile-scheme-adapter | |
312 | (guile-process-kill guile-scheme-adapter)) | |
313 | (setq guile-scheme-adapter nil)) | |
314 | ||
315 | \f | |
316 | ;;; | |
317 | ;;; Internal functions | |
318 | ;;; | |
319 | ||
320 | (guile-import apropos-internal guile-apropos-internal) | |
321 | ||
322 | (defvar guile-scheme-complete-table (make-vector 151 nil)) | |
323 | ||
324 | (defun guile-scheme-input-symbol (prompt) | |
325 | (mapc (lambda (sym) | |
326 | (if (symbolp sym) | |
327 | (intern (symbol-name sym) guile-scheme-complete-table))) | |
328 | (guile-apropos-internal "")) | |
329 | (let* ((str (thing-at-point 'symbol)) | |
330 | (default (if (intern-soft str guile-scheme-complete-table) | |
331 | (concat " (default " str ")") | |
332 | ""))) | |
333 | (intern (completing-read (concat prompt default ": ") | |
334 | guile-scheme-complete-table nil t nil nil str)))) | |
2d857fb1 KN |
335 | |
336 | \f | |
337 | ;;; | |
338 | ;;; Turn on guile-scheme-mode for .scm files by default. | |
339 | ;;; | |
340 | ||
341 | (setq auto-mode-alist | |
342 | (cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist)) | |
343 | ||
344 | (provide 'guile-scheme) | |
345 | ||
346 | ;;; guile-scheme.el ends here |