1 ;;; -*- Mode:Emacs-Lisp -*-
2 ;;; gambit.el --- Run Gambit in an [X]Emacs buffer
4 ;; Copyright (c) 1997-2011 Marc Feeley & Michael Sperber
6 ;; Authors: Marc Feeley <feeley@iro.umontreal.ca>
7 ;; Mike Sperber <sperber@informatik.uni-tuebingen.de>
8 ;; Keywords: processes, lisp
10 ;; To use this package, make sure this file is accessible from your
11 ;; load-path and that the following lines are in your ".emacs" file:
13 ;; (autoload 'gambit-inferior-mode "gambit" "Hook Gambit mode into cmuscheme.")
14 ;; (autoload 'gambit-mode "gambit" "Hook Gambit mode into scheme.")
15 ;; (add-hook 'inferior-scheme-mode-hook (function gambit-inferior-mode))
16 ;; (add-hook 'scheme-mode-hook (function gambit-mode))
17 ;; (setq scheme-program-name "gsi -:d-")
19 ;; Alternatively, if you don't mind always loading this package,
20 ;; you can simply add this line to your ".emacs" file:
24 ;; You can then start Gambit with "M-x run-scheme".
26 ;; When Gambit signals an error, Emacs will intercept the location
27 ;; information in the error message and automatically open a buffer
28 ;; highlighting the error.
30 ;; The continuation of the error can be inspected with the "C-c ["
31 ;; (crawl towards older frames) and "C-c ]" (crawl towards newer
32 ;; frames). For each new frame visited, Emacs will highlight the
33 ;; expression associated with the frame.
35 ;; "C-c c", "C-c s" and "C-c l" can be used to send the commands
36 ;; ",c", ",s" and ",l" respectively to Gambit. This is convenient for
37 ;; single-stepping a program.
39 ;; "C-c _" can be used to delete the last popup window that was
40 ;; created to highlight a Scheme expression.
42 ;;;----------------------------------------------------------------------------
44 ;; User overridable parameters.
46 (defvar scheme-program-name
"gsi -:d-")
48 (defvar gambit-repl-command-prefix
"\C-c"
49 "Emacs keybinding prefix for Gambit REPL's commands.")
51 (defvar gambit-highlight-color
"gold"
52 "Color of the overlay for highlighting Scheme expressions.")
54 (defvar gambit-highlight-face
55 (let ((face 'gambit-highlight-face
))
59 (if (x-display-color-p)
60 (set-face-background face gambit-highlight-color
)
62 ;(make-face-bold face)
63 (set-face-underline-p face t
))))
64 (error (setq face nil
)))
66 "Face of overlay for highlighting Scheme expressions.")
68 (defvar gambit-new-window-height
6
69 "Height of a window opened to highlight a Scheme expression.")
71 (defvar gambit-move-to-highlighted
(not gambit-highlight-face
)
72 "Flag to move to window opened to highlight a Scheme expression.")
74 ;;;----------------------------------------------------------------------------
76 ;; These must be loaded first because we redefine some of the
77 ;; functions they contain.
82 ;;;----------------------------------------------------------------------------
84 (defun gambit-indent-function (indent-point state
)
85 (let ((normal-indent (current-column)))
86 (goto-char (1+ (elt state
1)))
87 (parse-partial-sexp (point) calculate-lisp-indent-last-sexp
0 t
)
88 (if (and (elt state
2)
89 (not (looking-at "\\sw\\|\\s_")))
90 ;; car of form doesn't seem to be a a symbol
92 (if (not (> (save-excursion (forward-line 1) (point))
93 calculate-lisp-indent-last-sexp
))
94 (progn (goto-char calculate-lisp-indent-last-sexp
)
96 (parse-partial-sexp (point)
97 calculate-lisp-indent-last-sexp
0 t
)))
98 ;; Indent under the list or under the first sexp on the same
99 ;; line as calculate-lisp-indent-last-sexp. Note that first
100 ;; thing on that line has to be complete sexp since we are
101 ;; inside the innermost containing sexp.
102 (backward-prefix-chars)
104 (let ((function (buffer-substring (point)
105 (progn (forward-sexp 1) (point))))
107 (setq method
(or (gambit-indent-method function
)
108 (get (intern-soft function
) 'scheme-indent-function
)
109 (get (intern-soft function
) 'scheme-indent-hook
)))
110 (cond ((or (eq method
'defun
)
112 (> (length function
) 3)
113 (string-match "\\`def" function
)))
114 (lisp-indent-defform state indent-point
))
116 (lisp-indent-specform method state
117 indent-point normal-indent
))
119 (funcall method state indent-point normal-indent
)))))))
121 (defun gambit-indent-method (function)
123 (alist gambit-indent-regexp-alist
))
124 (while (and (not method
) (not (null alist
)))
125 (let* ((regexp (car alist
))
126 (x (string-match (car regexp
) function
)))
128 (setq method
(cdr regexp
)))
129 (setq alist
(cdr alist
))))
132 (set lisp-indent-function
'gambit-indent-function
)
134 (defvar gambit-indent-regexp-alist
136 ("^declare$" . defun
)
137 ("^##declare$" . defun
)
138 ("^##define" . defun
)
139 ("^macro-check" . defun
)
140 ("^macro-force-vars$" . defun
)
141 ("^macro-number-dispatch$" . defun
)
144 ;;;----------------------------------------------------------------------------
146 ;; Portable functions for FSF Emacs and Xemacs.
148 (defun window-top-edge (window)
149 (if (fboundp 'window-edges
)
150 (car (cdr (window-edges window
)))
151 (car (cdr (window-pixel-edges window
)))))
153 ;; Xemacs calls its overlays "extents", so we have to use them to emulate
154 ;; overlays on Xemacs. Some versions of Xemacs have the portability package
155 ;; "overlays.el" for this, so we could simply do:
157 ;; (condition-case nil ; load "overlay.el" if we have it
158 ;; (require 'overlay)
161 ;; Unfortunately some versions of Xemacs don't have this package so
162 ;; we explicitly define an interface to extents.
164 (if (not (fboundp 'make-overlay
))
165 (defun make-overlay (start end
)
166 (make-extent start end
)))
168 (if (not (fboundp 'overlay-put
))
169 (defun overlay-put (overlay prop val
)
170 (set-extent-property overlay prop val
)))
172 (if (not (fboundp 'move-overlay
))
173 (defun move-overlay (overlay start end buffer
)
174 (set-extent-endpoints overlay start end buffer
)))
176 ;;;----------------------------------------------------------------------------
178 ;; Redefine the function scheme-send-region from `cmuscheme' so
179 ;; that we can keep track of all text sent to Gambit's stdin.
181 (defun scheme-send-region (start end
)
182 "Send the current region to the inferior Scheme process."
184 (scheme-send-string (buffer-substring start end
)))
186 (defun scheme-send-string (str)
187 "Send a string to the inferior Scheme process."
188 (let* ((clean-str (gambit-string-terminate-with-newline str
))
190 (pmark (process-mark proc
))
191 (buffer (get-buffer scheme-buffer
))
192 (old-buffer (current-buffer)))
195 (set-marker comint-last-input-start
(point))
197 (set-marker pmark
(point))
198 (gambit-input-sender proc clean-str
)
199 (set-buffer old-buffer
)))
201 (defun gambit-input-sender (proc str
)
202 (let ((clean-str (gambit-string-terminate-with-newline str
)))
203 (gambit-register-input clean-str
)
204 (gambit-make-read-only (current-buffer) (point-max))
206 (comint-send-string proc clean-str
)))
208 (defun gambit-register-input (str)
209 (let ((marker (make-marker)))
210 (set-marker marker comint-last-input-start
)
211 (setq gambit-input-line-marker-alist
212 (cons (cons gambit-input-line-count
214 gambit-input-line-marker-alist
))
215 (setq gambit-input-line-count
216 (+ gambit-input-line-count
217 (gambit-string-count-lines str
)))))
219 (defun gambit-make-read-only (buffer end
)
220 ' ; disable read-only interaction, cause it doesn't work!
222 (put-text-property 1 end
'front-sticky
'(read-only) buffer
)
223 (put-text-property 1 end
'rear-nonsticky
'(read-only) buffer
)
224 (put-text-property 1 end
'read-only t buffer
)))
226 ;;;----------------------------------------------------------------------------
228 (defun gambit-load-file (file-name)
229 "Load a Scheme file FILE-NAME into the inferior Scheme process."
230 (interactive (comint-get-source "Load Scheme file: " scheme-prev-l
/c-dir
/file
231 scheme-source-modes t
)) ; T because LOAD
232 ; needs an exact name
233 (comint-check-source file-name
) ; Check to see if buffer needs saved.
234 (setq scheme-prev-l
/c-dir
/file
(cons (file-name-directory file-name
)
235 (file-name-nondirectory file-name
)))
236 (scheme-send-string (concat "(load \"" file-name
"\"\)\n")))
238 (defun gambit-compile-file (file-name)
239 "Compile a Scheme file FILE-NAME in the inferior Scheme process."
240 (interactive (comint-get-source "Compile Scheme file: "
241 scheme-prev-l
/c-dir
/file
243 nil
)) ; NIL because COMPILE doesn't
244 ; need an exact name.
245 (comint-check-source file-name
) ; Check to see if buffer needs saved.
246 (setq scheme-prev-l
/c-dir
/file
(cons (file-name-directory file-name
)
247 (file-name-nondirectory file-name
)))
248 (scheme-send-string (concat "(compile-file \"" file-name
"\"\)\n")))
250 ;;;----------------------------------------------------------------------------
252 ;; Buffer local variables of the Gambit inferior process(es).
254 (defvar gambit-input-line-count nil
255 "Line number as seen by the Gambit process.")
257 (defvar gambit-input-line-marker-alist nil
258 "Alist of line numbers of input blocks and markers.")
260 (defvar gambit-last-output-marker nil
261 "Points to the last character output by the Gambit process.")
263 ;;;----------------------------------------------------------------------------
267 (defun gambit-string-count-lines (str)
268 "Returns number of complete lines in string."
271 (while (string-match "\n" str start
)
273 (setq start
(match-end 0)))
276 (defun gambit-string-terminate-with-newline (str)
277 "Adds a newline at end of string if it doesn't already have one."
278 (let ((len (length str
)))
280 (not (equal (aref str
(- len
1)) ?
\n)))
284 ;;;----------------------------------------------------------------------------
286 ;; Define keys for single stepping and continuation crawling.
288 (defun gambit-step-continuation ()
290 (scheme-send-string "#||#,s;"))
292 (defun gambit-leap-continuation ()
294 (scheme-send-string "#||#,l;"))
296 (defun gambit-continue ()
298 (scheme-send-string "#||#,c;"))
300 (defun gambit-environment ()
302 (scheme-send-string "#||#,e;"))
304 (defun gambit-backtrace ()
306 (scheme-send-string "#||#,b;"))
308 (defun gambit-crawl-backtrace-newer ()
310 (scheme-send-string "#||#,-;"))
312 (defun gambit-crawl-backtrace-older ()
314 (scheme-send-string "#||#,+;"))
316 (defun gambit-kill-last-popup ()
318 (let ((windows gambit-popups
))
319 (while (not (null windows
))
320 (let ((window (car windows
)))
321 (setq windows
(cdr windows
))
323 (window-live-p window
))
325 (setq gambit-popups windows
)
327 (delete-window window
)))))))
329 (defun gambit-add-popup (popup)
331 (cons popup
(gambit-gc-popups gambit-popups
))))
333 (defun gambit-gc-popups (popups)
336 ((window-live-p (car popups
))
337 (cons (car popups
) (gambit-gc-popups (cdr popups
))))
339 (gambit-gc-popups (cdr popups
)))))
341 (defvar gambit-popups nil
)
343 ;;;----------------------------------------------------------------------------
345 ;; Procedures to intercept and process the location information output
348 (defun gambit-output-filter (str)
352 (process-mark (get-buffer-process buffer
)))
354 (if (string-match "\n" str
) ; match only after end of line is seen
357 (goto-char output-marker
)
362 (goto-char (+ gambit-last-output-marker
1))
365 (gambit-extract-location
366 (buffer-substring start end
)))
368 (gambit-make-read-only buffer output-marker
)
369 (set-marker gambit-last-output-marker
(- output-marker
1))
371 (gambit-windows-displaying-buffer buffer
))
372 (initially-selected-window
374 (if (not (null windows
))
377 (select-window (car windows
))
378 (goto-char output-marker
)
379 (if (not (pos-visible-in-window-p))
381 (select-window initially-selected-window
))))
383 (gambit-highlight-location locat
))))
385 (defun gambit-extract-location (str)
387 (alist gambit-location-regexp-alist
))
388 (while (and (not location
) (not (null alist
)))
389 (let* ((regexp (car alist
))
390 (x (string-match (car regexp
) str
)))
392 (let* ((pos1 (nth 1 regexp
))
393 (pos2 (nth 2 regexp
))
394 (pos3 (nth 3 regexp
))
396 (match-beginning pos1
)
399 (match-beginning pos2
)
401 (column (substring str
402 (match-beginning pos3
)
404 (setq location
(list (read name
) (read line
) (read column
)))))
405 (setq alist
(cdr alist
))))
408 (defvar gambit-location-regexp-alist
409 '(("\\(\\\"\\(\\\\\\\\\\|\\\\\"\\|[^\\\"\n]\\)+\\\"\\)@\\([0-9]+\\)\\.\\([0-9]+\\)[^0-9]" 1 3 4)
410 ("\\((console)\\)@\\([0-9]+\\)\\.\\([0-9]+\\)[^0-9]" 1 2 3)
411 ("\\((stdin)\\)@\\([0-9]+\\)\\.\\([0-9]+\\)[^0-9]" 1 2 3)))
413 (defun gambit-closest-non-following (line alist
)
415 (while (not (null alist
))
416 (let ((x (car alist
)))
417 (if (and (<= (car x
) line
)
419 (> (car x
) (car closest
))))
421 (setq alist
(cdr alist
))))
424 (defun gambit-highlight-location (locat)
426 ; invariant: the current buffer is the Scheme buffer
428 (let ((name (car locat
))
429 (line (car (cdr locat
)))
430 (column (car (cdr (cdr locat
)))))
431 (cond ((or (equal name
'(console))
432 (equal name
'(stdin)))
434 (gambit-closest-non-following
436 gambit-input-line-marker-alist
)))
438 (let ((n (- line
(car closest
))))
439 (gambit-highlight-expression
442 (goto-char (cdr closest
))
443 (if (> n
0) (forward-line n
))
444 (forward-char (- column
1))
447 (let ((buffer (find-file-noselect name
)))
449 (gambit-highlight-expression
454 (forward-char (- column
1))
457 (defun gambit-highlight-expression (location-buffer pos
)
459 "Highlight the expression at a specific location in a buffer.
461 The location buffer is the one that contains the location to
462 highlight and "pos
" points to the first character of the
463 expression in the buffer. If the location buffer is not visible
464 then we must display it in a window. We also have to make sure
465 the highlighted expression is visible, which may require the
466 window to be scrolled.
468 Our approach is simple: if the location buffer is not visible or
469 it is the Scheme buffer and it is only displayed in the selected
470 window, then we split one of the windows in 2 and use the bottom
471 window to display the location buffer. The window chosen is
472 preferentially the topmost window displaying the Scheme buffer,
473 otherwise it is the selected window. Before we do the split, we
474 enlarge the window if it is too small."
476 (let* ((location-windows
477 (gambit-windows-displaying-buffer location-buffer
))
478 (initially-selected-window
481 ; "location-windows" is the list of windows containing
482 ; the location buffer.
484 (if (or (null location-windows
)
485 (and (eq location-buffer
(get-buffer scheme-buffer
))
486 (eq initially-selected-window
(car location-windows
))
487 (null (cdr location-windows
))))
489 (let* ((scheme-windows
490 (gambit-windows-displaying-buffer (get-buffer scheme-buffer
)))
492 (if (null scheme-windows
)
493 initially-selected-window
494 (car scheme-windows
)))
496 (window-height window-to-split
)))
497 (select-window window-to-split
)
498 (if (< height
(* 2 gambit-new-window-height
))
500 (- (* 2 gambit-new-window-height
)
505 (- (window-height window-to-split
)
506 gambit-new-window-height
))))
507 (gambit-add-popup bottom-window
)
508 (select-window bottom-window
)
509 (switch-to-buffer location-buffer
)))
511 (select-window (car (reverse location-windows
))))
513 ; Highlight the expression in the location buffer.
516 (set-buffer (window-buffer (selected-window)))
518 (if (not (pos-visible-in-window-p))
519 (recenter (- (/ (window-height) 2) 1)))
520 (gambit-highlight-region
525 (forward-sexp) ; we assume this uses the same syntax as Gambit
526 (error ; if forward-sexp fails with this condition name
531 (if (not (eq initially-selected-window
(selected-window)))
534 (if (not gambit-move-to-highlighted
)
535 (select-window initially-selected-window
))))))
537 (defun gambit-windows-displaying-buffer (buffer)
539 (walk-windows (function
541 (if (eq buffer
(window-buffer w
))
542 (setq windows
(cons w windows
)))))
548 (< (window-top-edge w1
)
549 (window-top-edge w2
)))))))
551 (defvar gambit-highlight-overlay
552 (let ((ovl (make-overlay (point-min) (point-min))))
553 (overlay-put ovl
'face gambit-highlight-face
)
555 "Overlay for highlighting Scheme expressions.")
557 (defun gambit-highlight-region (buffer start end
)
558 (if gambit-highlight-overlay
559 (move-overlay gambit-highlight-overlay start end buffer
)))
561 (defun gambit-unhighlight ()
562 (gambit-highlight-region (get-buffer scheme-buffer
) 1 1))
564 ;;;----------------------------------------------------------------------------
566 (defun gambit-install-comment-syntax ()
567 "Configure #| ... |# comments."
568 ;; XEmacs 19 and beyond use 8-bit modify-syntax-entry flags.
569 ;; Emacs 19 uses a 1-bit flag. We will have to set up our
570 ;; syntax tables differently to handle this.
571 ;; Stolen from CC Mode.
572 (let ((table (copy-syntax-table))
574 (modify-syntax-entry ?a
". 12345678" table
)
576 ;; XEmacs 19, and beyond Emacs 19.34
578 (setq entry
(aref table ?a
))
579 ;; In Emacs, table entries are cons cells
580 (if (consp entry
) (setq entry
(car entry
))))
582 ((fboundp 'get-char-table
) (setq entry
(get-char-table ?a table
)))
583 ;; before and including Emacs 19.34
584 ((and (fboundp 'char-table-p
)
585 (char-table-p table
))
586 (setq entry
(car (char-table-range table
[?a
]))))
588 (t (error "Gambit mode is incompatible with this version of Emacs")))
589 (if (= (logand (lsh entry -
16) 255) 255)
592 (modify-syntax-entry ?
# "(#58" scheme-mode-syntax-table
)
593 (modify-syntax-entry ?|
". 67" scheme-mode-syntax-table
))
595 (modify-syntax-entry ?
# "_ 14" scheme-mode-syntax-table
)
596 (modify-syntax-entry ?|
"\" 23" scheme-mode-syntax-table
))))
598 (defun gambit-extend-mode-map (map)
599 (define-key map
[(f8)] 'gambit-continue
)
600 (define-key map
[(f9)] 'gambit-crawl-backtrace-newer
)
601 (define-key map
[(f10)] 'gambit-crawl-backtrace-older
)
602 (define-key map
[(f11)] 'gambit-step-continuation
)
603 (define-key map
[(f12)] 'gambit-leap-continuation
)
605 (define-key map
"\C-c\C-l" 'gambit-load-file
)
606 (define-key map
"\C-c\C-k" 'gambit-compile-file
)
608 (let ((prefix gambit-repl-command-prefix
))
609 (define-key map
(concat prefix
"c") 'gambit-continue
)
610 (define-key map
(concat prefix
"]") 'gambit-crawl-backtrace-newer
)
611 (define-key map
(concat prefix
"[") 'gambit-crawl-backtrace-older
)
612 (define-key map
(concat prefix
"s") 'gambit-step-continuation
)
613 (define-key map
(concat prefix
"l") 'gambit-leap-continuation
)
614 (define-key map
(concat prefix
"_") 'gambit-kill-last-popup
)))
616 (defun gambit-inferior-mode ()
618 (gambit-install-comment-syntax)
619 (gambit-extend-mode-map inferior-scheme-mode-map
)
621 (make-local-variable 'gambit-input-line-count
)
622 (setq gambit-input-line-count
1)
624 (make-local-variable 'gambit-input-line-marker-alist
)
625 (setq gambit-input-line-marker-alist
'())
627 (make-local-variable 'gambit-last-output-marker
)
628 (setq gambit-last-output-marker
(make-marker))
629 (set-marker gambit-last-output-marker
0)
631 (setq comint-input-sender
(function gambit-input-sender
))
633 (add-hook 'comint-output-filter-functions
634 (function gambit-output-filter
)
636 t
)) ; hook is buffer-local
638 (defun gambit-mode ()
639 (gambit-install-comment-syntax)
640 (gambit-extend-mode-map scheme-mode-map
))
642 ;;(autoload 'gambit-inferior-mode "gambit" "Hook Gambit mode into cmuscheme.")
643 ;;(autoload 'gambit-mode "gambit" "Hook Gambit mode into scheme.")
644 (add-hook 'inferior-scheme-mode-hook
(function gambit-inferior-mode
))
645 (add-hook 'scheme-mode-hook
(function gambit-mode
))
649 ;;;----------------------------------------------------------------------------