127 |
(define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go) |
(define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go) |
128 |
(define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition) |
(define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition) |
129 |
(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go) |
(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go) |
130 |
|
(define-key scheme-mode-map "\C-c\C-t" 'scheme-trace-procedure) |
131 |
|
(define-key scheme-mode-map "\C-c\C-x" 'scheme-expand-current-form) |
132 |
(define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme) |
(define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme) |
133 |
(define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file) |
(define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file) |
134 |
(define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile" |
(define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile" |
145 |
'("Compile Definition & Go" . scheme-compile-definition-and-go)) |
'("Compile Definition & Go" . scheme-compile-definition-and-go)) |
146 |
(define-key map [com-def] |
(define-key map [com-def] |
147 |
'("Compile Definition" . scheme-compile-definition)) |
'("Compile Definition" . scheme-compile-definition)) |
148 |
|
(define-key map [exp-form] |
149 |
|
'("Expand current form" . scheme-expand-current-form)) |
150 |
|
(define-key map [trace-proc] |
151 |
|
'("Trace procedure" . scheme-trace-procedure)) |
152 |
(define-key map [send-def-go] |
(define-key map [send-def-go] |
153 |
'("Evaluate Last Definition & Go" . scheme-send-definition-and-go)) |
'("Evaluate Last Definition & Go" . scheme-send-definition-and-go)) |
154 |
(define-key map [send-def] |
(define-key map [send-def] |
159 |
'("Evaluate Region" . scheme-send-region)) |
'("Evaluate Region" . scheme-send-region)) |
160 |
(define-key map [send-sexp] |
(define-key map [send-sexp] |
161 |
'("Evaluate Last S-expression" . scheme-send-last-sexp)) |
'("Evaluate Last S-expression" . scheme-send-last-sexp)) |
162 |
) |
) |
163 |
|
|
164 |
(defvar scheme-buffer) |
(defvar scheme-buffer) |
165 |
|
|
239 |
|
|
240 |
;;;###autoload |
;;;###autoload |
241 |
(defun run-scheme (cmd) |
(defun run-scheme (cmd) |
242 |
"Run an inferior Scheme process, input and output via buffer *scheme*. |
"Run an inferior Scheme process, input and output via buffer `*scheme*'. |
243 |
If there is a process already running in `*scheme*', switch to that buffer. |
If there is a process already running in `*scheme*', switch to that buffer. |
244 |
With argument, allows you to edit the command line (default is value |
With argument, allows you to edit the command line (default is value |
245 |
of `scheme-program-name'). Runs the hooks `inferior-scheme-mode-hook' |
of `scheme-program-name'). |
246 |
\(after the `comint-mode-hook' is run). |
If a file `~/.emacs_SCHEMENAME' exists, it is given as initial input. |
247 |
|
Note that this may lose due to a timing error if the Scheme processor |
248 |
|
discards input when it starts up. |
249 |
|
Runs the hook `inferior-scheme-mode-hook' \(after the `comint-mode-hook' |
250 |
|
is run). |
251 |
\(Type \\[describe-mode] in the process buffer for a list of commands.)" |
\(Type \\[describe-mode] in the process buffer for a list of commands.)" |
252 |
|
|
253 |
(interactive (list (if current-prefix-arg |
(interactive (list (if current-prefix-arg |
256 |
(if (not (comint-check-proc "*scheme*")) |
(if (not (comint-check-proc "*scheme*")) |
257 |
(let ((cmdlist (scheme-args-to-list cmd))) |
(let ((cmdlist (scheme-args-to-list cmd))) |
258 |
(set-buffer (apply 'make-comint "scheme" (car cmdlist) |
(set-buffer (apply 'make-comint "scheme" (car cmdlist) |
259 |
nil (cdr cmdlist))) |
(scheme-start-file (car cmdlist)) (cdr cmdlist))) |
260 |
(inferior-scheme-mode))) |
(inferior-scheme-mode))) |
261 |
(setq scheme-program-name cmd) |
(setq scheme-program-name cmd) |
262 |
(setq scheme-buffer "*scheme*") |
(setq scheme-buffer "*scheme*") |
263 |
(pop-to-buffer "*scheme*")) |
(pop-to-buffer "*scheme*")) |
264 |
;;;###autoload (add-hook 'same-window-buffer-names "*scheme*") |
;;;###autoload (add-hook 'same-window-buffer-names "*scheme*") |
265 |
|
|
266 |
|
(defun scheme-start-file (prog) |
267 |
|
"Return the name of the start file corresponding to PROG. |
268 |
|
Search in the directories \"~\" and \"~/.emacs.d\", in this |
269 |
|
order. Return nil if no start file found." |
270 |
|
(let* ((name (concat ".emacs_" (file-name-nondirectory prog))) |
271 |
|
(start-file (concat "~/" name))) |
272 |
|
(if (file-exists-p start-file) |
273 |
|
start-file |
274 |
|
(let ((start-file (concat user-emacs-directory name))) |
275 |
|
(and (file-exists-p start-file) start-file))))) |
276 |
|
|
277 |
(defun scheme-send-region (start end) |
(defun scheme-send-region (start end) |
278 |
"Send the current region to the inferior Scheme process." |
"Send the current region to the inferior Scheme process." |
279 |
(interactive "r") |
(interactive "r") |
317 |
(beginning-of-defun) |
(beginning-of-defun) |
318 |
(scheme-compile-region (point) end)))) |
(scheme-compile-region (point) end)))) |
319 |
|
|
320 |
|
(defcustom scheme-trace-command "(trace %s)" |
321 |
|
"*Template for issuing commands to trace a Scheme procedure. |
322 |
|
Some Scheme implementations might require more elaborate commands here. |
323 |
|
For PLT-Scheme, e.g., one should use |
324 |
|
|
325 |
|
(setq scheme-trace-command \"(begin (require (lib \\\"trace.ss\\\")) (trace %s))\") |
326 |
|
|
327 |
|
For Scheme 48 and Scsh use \",trace %s\"." |
328 |
|
:type 'string |
329 |
|
:group 'cmuscheme) |
330 |
|
|
331 |
|
(defcustom scheme-untrace-command "(untrace %s)" |
332 |
|
"*Template for switching off tracing of a Scheme procedure. |
333 |
|
Scheme 48 and Scsh users should set this variable to \",untrace %s\"." |
334 |
|
|
335 |
|
:type 'string |
336 |
|
:group 'cmuscheme) |
337 |
|
|
338 |
|
(defun scheme-trace-procedure (proc &optional untrace) |
339 |
|
"Trace procedure PROC in the inferior Scheme process. |
340 |
|
With a prefix argument switch off tracing of procedure PROC." |
341 |
|
(interactive |
342 |
|
(list (let ((current (symbol-at-point)) |
343 |
|
(action (if current-prefix-arg "Untrace" "Trace"))) |
344 |
|
(if current |
345 |
|
(read-string (format "%s procedure [%s]: " action current) nil nil (symbol-name current)) |
346 |
|
(read-string (format "%s procedure: " action)))) |
347 |
|
current-prefix-arg)) |
348 |
|
(when (= (length proc) 0) |
349 |
|
(error "Invalid procedure name")) |
350 |
|
(comint-send-string (scheme-proc) |
351 |
|
(format |
352 |
|
(if untrace scheme-untrace-command scheme-trace-command) |
353 |
|
proc)) |
354 |
|
(comint-send-string (scheme-proc) "\n")) |
355 |
|
|
356 |
|
(defcustom scheme-macro-expand-command "(expand %s)" |
357 |
|
"*Template for macro-expanding a Scheme form. |
358 |
|
For Scheme 48 and Scsh use \",expand %s\"." |
359 |
|
:type 'string |
360 |
|
:group 'cmuscheme) |
361 |
|
|
362 |
|
(defun scheme-expand-current-form () |
363 |
|
"Macro-expand the form at point in the inferior Scheme process." |
364 |
|
(interactive) |
365 |
|
(let ((current-form (scheme-form-at-point))) |
366 |
|
(if current-form |
367 |
|
(progn |
368 |
|
(comint-send-string (scheme-proc) |
369 |
|
(format |
370 |
|
scheme-macro-expand-command |
371 |
|
current-form)) |
372 |
|
(comint-send-string (scheme-proc) "\n")) |
373 |
|
(error "Not at a form")))) |
374 |
|
|
375 |
|
(defun scheme-form-at-point () |
376 |
|
(let ((next-sexp (thing-at-point 'sexp))) |
377 |
|
(if (and next-sexp (string-equal (substring next-sexp 0 1) "(")) |
378 |
|
next-sexp |
379 |
|
(save-excursion |
380 |
|
(backward-up-list) |
381 |
|
(scheme-form-at-point))))) |
382 |
|
|
383 |
(defun switch-to-scheme (eob-p) |
(defun switch-to-scheme (eob-p) |
384 |
"Switch to the scheme process buffer. |
"Switch to the scheme process buffer. |
385 |
With argument, position cursor at end of buffer." |
With argument, position cursor at end of buffer." |
386 |
(interactive "P") |
(interactive "P") |
387 |
(if (get-buffer scheme-buffer) |
(if (or (and scheme-buffer (get-buffer scheme-buffer)) |
388 |
|
(scheme-interactively-start-process)) |
389 |
(pop-to-buffer scheme-buffer) |
(pop-to-buffer scheme-buffer) |
390 |
(error "No current process buffer. See variable `scheme-buffer'")) |
(error "No current process buffer. See variable `scheme-buffer'")) |
391 |
(cond (eob-p |
(when eob-p |
392 |
(push-mark) |
(push-mark) |
393 |
(goto-char (point-max))))) |
(goto-char (point-max)))) |
394 |
|
|
395 |
(defun scheme-send-region-and-go (start end) |
(defun scheme-send-region-and-go (start end) |
396 |
"Send the current region to the inferior Scheme process. |
"Send the current region to the inferior Scheme process. |
502 |
for a minimal, simple implementation. Feel free to extend it.") |
for a minimal, simple implementation. Feel free to extend it.") |
503 |
|
|
504 |
(defun scheme-proc () |
(defun scheme-proc () |
505 |
"Return the current scheme process. See variable `scheme-buffer'." |
"Return the current Scheme process, starting one if necessary. |
506 |
(let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode) |
See variable `scheme-buffer'." |
507 |
(current-buffer) |
(unless (and scheme-buffer |
508 |
scheme-buffer)))) |
(get-buffer scheme-buffer) |
509 |
(or proc |
(comint-check-proc scheme-buffer)) |
510 |
(error "No current process. See variable `scheme-buffer'")))) |
(scheme-interactively-start-process)) |
511 |
|
(or (scheme-get-process) |
512 |
|
(error "No current process. See variable `scheme-buffer'"))) |
513 |
|
|
514 |
|
(defun scheme-get-process () |
515 |
|
"Return the current Scheme process or nil if none is running." |
516 |
|
(get-buffer-process (if (eq major-mode 'inferior-scheme-mode) |
517 |
|
(current-buffer) |
518 |
|
scheme-buffer))) |
519 |
|
|
520 |
|
(defun scheme-interactively-start-process (&optional cmd) |
521 |
|
"Start an inferior Scheme process. Return the process started. |
522 |
|
Since this command is run implicitly, always ask the user for the |
523 |
|
command to run." |
524 |
|
(save-window-excursion |
525 |
|
(run-scheme (read-string "Run Scheme: " scheme-program-name)))) |
526 |
|
|
527 |
;;; Do the user's customisation... |
;;; Do the user's customisation... |
528 |
|
|