Commit | Line | Data |
---|---|---|
2d857fb1 KN |
1 | ;;; guile-scheme.el --- Guile Scheme editing mode |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ||
10 | ;; GNU Emacs 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ||
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
17 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
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) | |
93 | (set-keymap-parent map lisp-mode-shared-map) | |
94 | (define-key map [menu-bar] (make-sparse-keymap)) | |
95 | (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map)) | |
96 | (define-key map [uncomment-region] | |
97 | '("Uncomment Out Region" . (lambda (beg end) | |
98 | (interactive "r") | |
99 | (comment-region beg end '(4))))) | |
100 | (define-key map [comment-region] '("Comment Out Region" . comment-region)) | |
101 | (define-key map [indent-region] '("Indent Region" . indent-region)) | |
102 | (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) | |
103 | (define-key map "\e\C-i" 'guile-scheme-complete-symbol) | |
104 | (define-key map "\e\C-x" 'guile-scheme-eval-define) | |
105 | (define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp) | |
106 | (define-key map "\C-c\C-b" 'guile-scheme-eval-buffer) | |
107 | (define-key map "\C-c\C-r" 'guile-scheme-eval-region) | |
108 | (define-key map "\C-c:" 'guile-scheme-eval-expression) | |
109 | (define-key map "\C-c\C-a" 'guile-scheme-apropos) | |
110 | (define-key map "\C-c\C-d" 'guile-scheme-describe) | |
111 | ||
112 | (put 'comment-region 'menu-enable 'mark-active) | |
113 | (put 'uncomment-region 'menu-enable 'mark-active) | |
114 | (put 'indent-region 'menu-enable 'mark-active))) | |
115 | ||
116 | (defcustom guile-scheme-mode-hook nil | |
117 | "Normal hook run when entering `guile-scheme-mode'." | |
118 | :type 'hook | |
119 | :group 'guile-scheme) | |
120 | ||
121 | ;;;###autoload | |
122 | (defun guile-scheme-mode () | |
123 | "Major mode for editing Guile Scheme code. | |
124 | Editing commands are similar to those of `scheme-mode'. | |
125 | ||
126 | \\{scheme-mode-map} | |
127 | Entry to this mode calls the value of `scheme-mode-hook' | |
128 | if that value is non-nil." | |
129 | (interactive) | |
130 | (kill-all-local-variables) | |
131 | (setq mode-name "Guile Scheme") | |
132 | (setq major-mode 'guile-scheme-mode) | |
133 | (use-local-map guile-scheme-mode-map) | |
134 | (scheme-mode-variables) | |
135 | (setq mode-line-process | |
136 | '(:eval (if (processp guile-scheme-adapter) | |
137 | (format " [%s]" guile-scheme-command) | |
138 | ""))) | |
139 | (setq font-lock-defaults | |
140 | '((guile-scheme-font-lock-keywords) | |
141 | nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun | |
142 | (font-lock-mark-block-function . mark-defun))) | |
143 | (run-hooks 'guile-scheme-mode-hook)) | |
144 | ||
145 | \f | |
146 | ;;; | |
147 | ;;; Scheme interaction mode | |
148 | ;;; | |
149 | ||
150 | (defvar scheme-interaction-mode-map () | |
151 | "Keymap for Scheme Interaction mode. | |
152 | All commands in `guile-scheme-mode-map' are inherited by this map.") | |
153 | ||
154 | (unless scheme-interaction-mode-map | |
155 | (let ((map (make-sparse-keymap))) | |
156 | (setq scheme-interaction-mode-map map) | |
157 | (set-keymap-parent map guile-scheme-mode-map) | |
158 | (define-key map "\C-j" 'guile-scheme-eval-print-last-sexp) | |
159 | )) | |
160 | ||
161 | (defvar scheme-interaction-mode-hook nil | |
162 | "Normal hook run when entering `scheme-interaction-mode'.") | |
163 | ||
164 | (defun scheme-interaction-mode () | |
165 | "Major mode for evaluating Scheme expressions with Guile. | |
166 | ||
167 | \\{scheme-interaction-mode-map}" | |
168 | (interactive) | |
169 | (guile-scheme-mode) | |
170 | (use-local-map scheme-interaction-mode-map) | |
171 | (setq major-mode 'scheme-interaction-mode) | |
172 | (setq mode-name "Scheme Interaction") | |
173 | (run-hooks 'scheme-interaction-mode-hook)) | |
174 | ||
175 | \f | |
176 | ;;; | |
177 | ;;; Guile Scheme adapter | |
178 | ;;; | |
179 | ||
180 | (defvar guile-scheme-command "guile") | |
181 | (defvar guile-scheme-adapter nil) | |
182 | ||
183 | (defun guile-scheme-adapter () | |
184 | (if (and (processp guile-scheme-adapter) | |
185 | (eq (process-status guile-scheme-adapter) 'run)) | |
186 | guile-scheme-adapter | |
187 | (setq guile-scheme-adapter | |
188 | (guile:make-adapter guile-scheme-command 'emacs-scheme-channel)))) | |
189 | ||
190 | (defun guile-scheme-set-module () | |
191 | "Set the current module based on buffer contents. | |
192 | If there is a (define-module ...) form, evaluate it. | |
193 | Otherwise, choose module (guile-user)." | |
194 | (save-excursion | |
195 | (guile:eval | |
196 | (if (re-search-backward "^(define-module " nil t) | |
197 | (let ((start (match-beginning 0))) | |
198 | (goto-char start) | |
199 | (forward-sexp) | |
200 | (buffer-substring-no-properties start (point))) | |
201 | "(define-module (emacs-user))") | |
202 | (guile-scheme-adapter)))) | |
203 | ||
204 | (defun guile-scheme-eval-string (string) | |
205 | (guile-scheme-set-module) | |
206 | (guile:eval string (guile-scheme-adapter))) | |
207 | ||
208 | (defun guile-scheme-display-result (value flag) | |
209 | (if (string= value "#<unspecified>") | |
210 | (setq value "done")) | |
211 | (if flag | |
212 | (insert value) | |
213 | (message "%s" value))) | |
214 | ||
215 | \f | |
216 | ;;; | |
217 | ;;; Interactive commands | |
218 | ;;; | |
219 | ||
220 | (defun guile-scheme-eval-expression (string) | |
221 | "Evaluate the expression in STRING and show value in echo area." | |
222 | (interactive "SGuile Scheme Eval: ") | |
223 | (guile-scheme-display-result (guile-scheme-eval-string string) nil)) | |
224 | ||
225 | (defun guile-scheme-eval-region (start end) | |
226 | "Evaluate the region as Guile Scheme code." | |
227 | (interactive "r") | |
228 | (guile-scheme-eval-expression (buffer-substring-no-properties start end))) | |
229 | ||
230 | (defun guile-scheme-eval-buffer () | |
231 | "Evaluate the current buffer as Guile Scheme code." | |
232 | (interactive) | |
233 | (guile-scheme-eval-expression (buffer-string))) | |
234 | ||
235 | (defun guile-scheme-eval-last-sexp (arg) | |
236 | "Evaluate sexp before point; show value in echo area. | |
237 | With argument, print output into current buffer." | |
238 | (interactive "P") | |
239 | (guile-scheme-display-result | |
240 | (guile-scheme-eval-string | |
241 | (buffer-substring-no-properties | |
242 | (point) (save-excursion (backward-sexp) (point)))) arg)) | |
243 | ||
244 | (defun guile-scheme-eval-print-last-sexp () | |
245 | "Evaluate sexp before point; print value into current buffer." | |
246 | (interactive) | |
247 | (insert "\n") | |
248 | (guile-scheme-eval-last-sexp t) | |
249 | (insert "\n")) | |
250 | ||
251 | (defun guile-scheme-eval-define () | |
252 | (interactive) | |
253 | (guile-scheme-eval-region (save-excursion (end-of-defun) (point)) | |
254 | (save-excursion (beginning-of-defun) (point)))) | |
255 | ||
256 | (defun guile-scheme-load-file (file) | |
257 | "Load a Guile Scheme file." | |
258 | (interactive "fGuile Scheme load file: ") | |
259 | (guile-scheme-eval-string (format "(load %s)" (expand-file-name file))) | |
260 | (message "done")) | |
261 | ||
262 | (defun guile-scheme-complete-symbol () | |
263 | (interactive) | |
264 | (unless (boundp 'guile-emacs-complete-alist) | |
265 | (guile-import guile-emacs-complete-alist)) | |
266 | (let* ((end (point)) | |
267 | (start (save-excursion (skip-syntax-backward "w_") (point))) | |
268 | (pattern (buffer-substring-no-properties start end)) | |
269 | (alist (guile-emacs-complete-alist pattern))) | |
270 | (goto-char end) | |
271 | (let ((completion (try-completion pattern alist))) | |
272 | (cond ((eq completion t)) | |
273 | ((not completion) | |
274 | (message "Can't find completion for \"%s\"" pattern) | |
275 | (ding)) | |
276 | ((not (string= pattern completion)) | |
277 | (delete-region start end) | |
278 | (insert completion)) | |
279 | (t | |
280 | (message "Making completion list...") | |
281 | (with-output-to-temp-buffer "*Completions*" | |
282 | (display-completion-list alist)) | |
283 | (message "Making completion list...done")))))) | |
284 | ||
285 | ;; (define-command (guile-scheme-apropos regexp) | |
286 | ;; (interactive "sGuile-Scheme apropos (regexp): ") | |
287 | ;; (guile-scheme-set-module) | |
288 | ;; (let ((old #^guile-scheme-output-buffer)) | |
289 | ;; (dynamic-wind | |
290 | ;; (lambda () (set! #^guile-scheme-output-buffer #f)) | |
291 | ;; (lambda () | |
292 | ;; (with-output-to-temp-buffer "*Help*" | |
293 | ;; (lambda () | |
294 | ;; (apropos regexp)))) | |
295 | ;; (lambda () (set! #^guile-scheme-output-buffer old))))) | |
296 | ;; | |
297 | ;; (define (guile-scheme-input-symbol prompt) | |
298 | ;; (let* ((symbol (thing-at-point 'symbol)) | |
299 | ;; (table (map (lambda (sym) (list (symbol->string sym))) | |
300 | ;; (apropos-list ""))) | |
301 | ;; (default (if (assoc symbol table) | |
302 | ;; (string-append " (default " symbol ")") | |
303 | ;; ""))) | |
304 | ;; (string->symbol (completing-read (string-append prompt default ": ") | |
305 | ;; table #f #t #f #f symbol)))) | |
306 | ;; | |
307 | ;; (define-command (guile-scheme-describe symbol) | |
308 | ;; "Display the value and documentation of SYMBOL." | |
309 | ;; (interactive (list (guile-scheme-input-symbol "Describe Guile-Scheme variable"))) | |
310 | ;; (guile-scheme-set-module) | |
311 | ;; (let ((old #^guile-scheme-output-buffer)) | |
312 | ;; (dynamic-wind | |
313 | ;; (lambda () (set! #^guile-scheme-output-buffer #f)) | |
314 | ;; (lambda () | |
315 | ;; (begin-with-output-to-temp-buffer "*Help*" | |
316 | ;; (describe symbol))) | |
317 | ;; (lambda () (set! #^guile-scheme-output-buffer old))))) | |
318 | ;; | |
319 | ;; (define-command (guile-scheme-find-definition symbol) | |
320 | ;; (interactive (list (guile-scheme-input-symbol "Guile-Scheme find definition"))) | |
321 | ;; (guile-scheme-set-module) | |
322 | ;; ) | |
323 | ||
324 | \f | |
325 | ;;; | |
326 | ;;; Turn on guile-scheme-mode for .scm files by default. | |
327 | ;;; | |
328 | ||
329 | (setq auto-mode-alist | |
330 | (cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist)) | |
331 | ||
332 | (provide 'guile-scheme) | |
333 | ||
334 | ;;; guile-scheme.el ends here |