1 ;;; geiser-debug.el -- displaying debug information and evaluation results
3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the Modified BSD License. You should
7 ;; have received a copy of the license along with this program. If
8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
10 ;; Start date: Mon Feb 23, 2009 22:34
14 (require 'geiser-edit
)
15 (require 'geiser-autodoc
)
16 (require 'geiser-impl
)
17 (require 'geiser-eval
)
18 (require 'geiser-menu
)
19 (require 'geiser-popup
)
20 (require 'geiser-base
)
23 ;;; Debug buffer mode:
25 (defvar geiser-debug-mode-map
26 (let ((map (make-sparse-keymap)))
28 (set-keymap-parent map button-buffer-map
)
31 (defun geiser-debug-mode ()
32 "A major mode for displaying Scheme compilation and evaluation results.
33 \\{geiser-debug-mode-map}"
35 (kill-all-local-variables)
37 (use-local-map geiser-debug-mode-map
)
38 (set-syntax-table scheme-mode-syntax-table
)
39 (setq mode-name
"Geiser DBG")
40 (setq major-mode
'geiser-debug-mode
)
41 (setq next-error-function
'geiser-edit--open-next
)
42 (setq buffer-read-only t
))
44 (defun geiser-debug--button-p (nextp)
45 (let ((m (funcall (if nextp
'next-button
'previous-button
) (point))))
46 (and m
(funcall (if nextp
'< '>) (point) (marker-position m
)))))
48 (geiser-menu--defmenu debug geiser-debug-mode-map
49 ("Next error" "n" forward-button
:enable
(geiser-debug--button-p t
))
50 ("Previous error" "p" backward-button
:enable
(geiser-debug--button-p t
))
52 ("Quit" nil View-quit
))
55 ;;; Buffer for displaying evaluation results:
57 (geiser-popup--define debug
"*Geiser dbg*" geiser-debug-mode
)
60 ;;; Displaying retorts
62 (geiser-impl--define-caller geiser-debug--display-error
63 display-error
(module key message
)
64 "This method takes 3 parameters (a module name, the error key,
65 and the accompanying error message) and should display
66 (in the current buffer) a formatted version of the error. If the
67 error was successfully displayed, the call should evaluate to a
70 (geiser-impl--define-caller geiser-debug--enter-debugger
72 "This method is called upon entering the debugger, in the REPL
75 (defun geiser-debug--display-retort (what ret
&optional res
)
76 (let* ((err (geiser-eval--retort-error ret
))
77 (key (geiser-eval--error-key err
))
78 (output (geiser-eval--retort-output ret
))
79 (impl geiser-impl--implementation
)
80 (module (geiser-eval--get-module))
82 (dir default-directory
)
83 (buffer (current-buffer))
84 (debug (eq key
'geiser-debugger
)))
86 (switch-to-geiser nil nil buffer
)
87 (geiser-debug--enter-debugger impl
))
88 (geiser-debug--with-buffer
90 (when dir
(setq default-directory dir
))
93 (when (and res
(not err
))
96 (setq jump
(geiser-debug--display-error impl module key output
))
97 (goto-char (point-min)))
98 (when jump
(geiser-debug--pop-to-buffer))))
100 (defsubst geiser-debug--wrap-region
(str)
101 (format "(begin %s)" str
))
103 (defun geiser-debug--unwrap (str)
104 (if (string-match "(begin[ \t\n\v\r]+\\(.+\\)*)" str
)
108 (defun geiser-debug--send-region (compile start end and-go wrap
)
109 (let* ((str (buffer-substring-no-properties start end
))
110 (wrapped (if wrap
(geiser-debug--wrap-region str
) str
))
111 (code `(,(if compile
:comp
:eval
) (:scm
,wrapped
)))
112 (ret (geiser-eval--send/wait code
))
113 (res (geiser-eval--retort-result-str ret
))
114 (err (geiser-eval--retort-error ret
)))
115 (geiser-autodoc--clean-cache)
116 (when and-go
(funcall and-go
))
117 (when (not err
) (message "%s" res
))
118 (geiser-debug--display-retort (geiser-syntax--scheme-str str
) ret res
)))
120 (defun geiser-debug--expand-region (start end all wrap
)
121 (let* ((str (buffer-substring-no-properties start end
))
122 (wrapped (if wrap
(geiser-debug--wrap-region str
) str
))
123 (code `(:eval
(:ge macroexpand
(quote (:scm
,wrapped
))
125 (ret (geiser-eval--send/wait code
))
126 (err (geiser-eval--retort-error ret
))
127 (result (geiser-eval--retort-result ret
)))
129 (geiser-debug--display-retort str ret
)
130 (geiser-debug--with-buffer
132 (insert (format "%s" (if wrap
(geiser-debug--unwrap result
) result
)))
133 (goto-char (point-min)))
134 (geiser-debug--pop-to-buffer))))
137 (provide 'geiser-debug
)
138 ;;; geiser-debug.el ends here