1 ;; geiser-guile.el -- guile's implementation of the geiser protocols
3 ;; Copyright (C) 2009, 2010, 2011 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: Sun Mar 08, 2009 23:03
14 (require 'geiser-connection
)
15 (require 'geiser-syntax
)
16 (require 'geiser-custom
)
17 (require 'geiser-base
)
18 (require 'geiser-eval
)
19 (require 'geiser-edit
)
29 (defgroup geiser-guile nil
30 "Customization for Geiser's Guile flavour."
33 (geiser-custom--defcustom geiser-guile-binary
34 (cond ((eq system-type
'windows-nt
) "guile.exe")
35 ((eq system-type
'darwin
) "guile")
37 "Name to use to call the Guile executable when starting a REPL."
38 :type
'(choice string
(repeat string
))
41 (geiser-custom--defcustom geiser-guile-load-path nil
42 "A list of paths to be added to Guile's load path when it's
47 (geiser-custom--defcustom geiser-guile-init-file
"~/.guile-geiser"
48 "Initialization file with user code for the Guile REPL.
49 If all you want is to load ~/.guile, set
50 `geiser-guile-load-init-file-p' instead."
54 (geiser-custom--defcustom geiser-guile-load-init-file-p nil
55 "Whether to load ~/.guile when starting Guile.
56 Note that, due to peculiarities in the way Guile loads its init
57 file, using `geiser-guile-init-file' is not equivalent to setting
62 (geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
63 "Whether to autmatically show a full backtrace when entering the debugger.
64 If `nil', only the last frame is shown."
68 (geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
69 "Whether to autmatically jump to error when entering the debugger.
70 If `t', Geiser will use `next-error' to jump to the error's location."
74 (geiser-custom--defcustom geiser-guile-show-debug-help-p t
75 "Whether to show brief help in the echo area when entering the debugger."
79 (geiser-custom--defcustom geiser-guile-warning-level
'medium
80 "Verbosity of the warnings reported by Guile.
82 You can either choose one of the predefined warning sets, or
83 provide a list of symbols identifying the ones you want. Possible
84 choices are arity-mismatch, unbound-variable, unused-variable and
85 unused-toplevel. Unrecognised symbols are ignored.
87 The predefined levels are:
89 - Medium: arity-mismatch, unbound-variable, format
90 - High: arity-mismatch, unbound-variable, unused-variable, format
93 Changes to the value of this variable will automatically take
94 effect on new REPLs. For existing ones, use the command
95 \\[geiser-guile-update-warning-level]."
96 :type
'(choice (const :tag
"Medium (arity and unbound vars)" medium
)
97 (const :tag
"High (also unused vars)" high
)
98 (const :tag
"No warnings" none
)
99 (repeat :tag
"Custom" symbol
))
100 :group
'geiser-guile
)
102 (geiser-custom--defcustom geiser-guile-extra-keywords nil
103 "Extra keywords highlighted in Guile scheme buffers."
104 :type
'(repeat string
)
105 :group
'geiser-guile
)
107 (geiser-custom--defcustom geiser-guile-manual-lookup-other-window-p nil
108 "Non-nil means pop up the Info buffer in another window."
110 :group
'geiser-guile
)
115 (defun geiser-guile--binary ()
116 (if (listp geiser-guile-binary
)
117 (car geiser-guile-binary
)
118 geiser-guile-binary
))
120 (defun geiser-guile--parameters ()
121 "Return a list with all parameters needed to start Guile.
122 This function uses `geiser-guile-init-file' if it exists."
123 (let ((init-file (and (stringp geiser-guile-init-file
)
124 (expand-file-name geiser-guile-init-file
)))
125 (q-flags (and (not geiser-guile-load-init-file-p
) '("-q"))))
126 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
127 ,@q-flags
"-L" ,(expand-file-name "guile/" geiser-scheme-dir
)
128 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
))
129 geiser-guile-load-path
))
130 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
132 ;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
133 (defconst geiser-guile--prompt-regexp
"[^@()]+@([^)]*?)> ")
134 (defconst geiser-guile--debugger-prompt-regexp
135 "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
138 ;;; Evaluation support:
139 (defsubst geiser-guile--linearize-args
(args)
140 (mapconcat 'identity args
" "))
142 (defun geiser-guile--geiser-procedure (proc &rest args
)
144 ((eval compile
) (format ",geiser-eval %s %s%s"
146 (geiser-guile--linearize-args (cdr args
))
147 (if (cddr args
) "" " ()")))
148 ((load-file compile-file
) (format ",geiser-load-file %s" (car args
)))
149 ((no-values) ",geiser-no-values")
150 (t (format "ge:%s (%s)" proc
(geiser-guile--linearize-args args
)))))
152 (defconst geiser-guile--module-re
153 "(define-module +\\(([^)]+)\\)")
155 (defconst geiser-guile--library-re
156 "(library +\\(([^)]+)\\)")
158 (defun geiser-guile--get-module (&optional module
)
162 (while (not (zerop (geiser-syntax--nesting-level)))
164 (if (or (re-search-backward geiser-guile--module-re nil t
)
165 (looking-at geiser-guile--library-re
)
166 (re-search-forward geiser-guile--module-re nil t
))
167 (geiser-guile--get-module (match-string-no-properties 1))
169 ((listp module
) module
)
172 (car (geiser-syntax--read-from-string module
))
176 (defun geiser-guile--module-cmd (module fmt
&optional def
)
178 (let* ((module (geiser-guile--get-module module
))
179 (module (cond ((or (null module
) (eq module
:f
)) def
)
180 (t (format "%s" module
)))))
181 (and module
(format fmt module
)))))
183 (defun geiser-guile--import-command (module)
184 (geiser-guile--module-cmd module
",use %s"))
186 (defun geiser-guile--enter-command (module)
187 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
190 (defun geiser-guile--exit-command () ",q")
192 (defun geiser-guile--symbol-begin (module)
194 (max (save-excursion (beginning-of-line) (point))
195 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
196 (save-excursion (skip-syntax-backward "^-()>") (point))))
201 (defun geiser-guile--enter-debugger ()
202 (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
203 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
204 (compilation-forget-errors)
205 (goto-char (point-max))
206 (geiser-repl--prepare-send)
207 (comint-send-string nil bt-cmd
)
208 (when geiser-guile-show-debug-help-p
209 (message "Debug REPL. Enter ,q to quit, ,h for help."))
210 (when geiser-guile-jump-on-debug-p
211 (accept-process-output (get-buffer-process (current-buffer))
213 (ignore-errors (next-error)))))
215 (defun geiser-guile--display-error (module key msg
)
218 (save-excursion (insert msg
))
219 (geiser-edit--buttonize-files))
220 (and (not key
) msg
(not (zerop (length msg
)))))
223 ;;; Trying to ascertain whether a buffer is Guile Scheme:
225 (defconst geiser-guile--guess-re
226 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
227 geiser-guile--module-re
))
229 (defun geiser-guile--guess ()
231 (goto-char (point-min))
232 (re-search-forward geiser-guile--guess-re nil t
)))
236 (defun geiser-guile--keywords ()
237 (when geiser-guile-extra-keywords
238 `((,(format "[[(]%s\\>" (regexp-opt geiser-guile-extra-keywords
1))
242 ;;; Compilation shell regexps
244 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
246 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
248 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
250 (defun geiser-guile--resolve-file (file)
251 (when (and (stringp file
)
252 (not (member file
'("socket" "stdin" "unknown file"))))
253 (if (file-name-absolute-p file
) file
254 (or (gethash file geiser-guile--file-cache
)
256 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
257 geiser-guile--file-cache
)))))
259 (defun geiser-guile--resolve-file-x ()
260 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
261 (and (stringp f
) (list f
))))
266 (defun geiser-guile-update-warning-level ()
267 "Update the warning level used by the REPL.
268 The new level is set using the value of `geiser-guile-warning-level'."
270 (let ((code `(:eval
(:ge set-warnings
',geiser-guile-warning-level
)
271 (geiser evaluation
))))
272 (geiser-eval--send/result code
)))
274 (defun connect-to-guile ()
275 "Start a Guile REPL connected to a remote process.
277 Start the external Guile process with the flag --listen to make
278 it spawn a server thread."
280 (geiser-connect 'guile
))
282 (defun geiser-guile--set-load-path ()
283 (let* ((path (expand-file-name "guile/" geiser-scheme-dir
))
284 (witness "geiser/emacs.scm")
285 (code `(begin (if (not (%search-load-path
,witness
))
286 (set! %load-path
(cons ,path %load-path
)))
288 (geiser-eval--send/wait code
)))
290 (defun geiser-guile--startup (remote)
291 (set (make-local-variable 'compilation-error-regexp-alist
)
292 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
293 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
294 (compilation-setup t
)
295 (font-lock-add-keywords nil
296 `((,geiser-guile--path-rx
1
297 compilation-error-face
)))
298 (let ((geiser-log-verbose-p t
))
299 (when remote
(geiser-guile--set-load-path))
300 (geiser-eval--send/wait
",use (geiser emacs)\n'done")
301 (geiser-guile-update-warning-level)))
305 (info-lookup-add-help :topic
'symbol
:mode
'geiser-guile-mode
307 :regexp
"[^()`',\" \n]+"
309 '(("(r5rs)Index" nil
"^[ ]+-+ [^:]+:[ ]*" "\\b")
310 ("(Guile)R5RS Index" nil
"^ - [^:]+: " "\\b")
311 ("(Guile)Procedure Index" nil
"^ - [^:]+: " "\\b")
312 ("(Guile)Variable Index" nil
"^ - [^:]+: " "\\b")))
314 (defun guile--manual-look-up (id mod
)
315 (let ((info-lookup-other-window-flag
316 geiser-guile-manual-lookup-other-window-p
))
317 (info-lookup-symbol id
'geiser-guile-mode
))
318 (when geiser-guile-manual-lookup-other-window-p
319 (switch-to-buffer-other-window "*info*"))
320 (search-forward (format "%s" id
) nil t
))
324 ;;; Implementation definition:
326 (define-geiser-implementation guile
327 (binary geiser-guile--binary
)
328 (arglist geiser-guile--parameters
)
329 (repl-startup geiser-guile--startup
)
330 (prompt-regexp geiser-guile--prompt-regexp
)
331 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
332 (enter-debugger geiser-guile--enter-debugger
)
333 (marshall-procedure geiser-guile--geiser-procedure
)
334 (find-module geiser-guile--get-module
)
335 (enter-command geiser-guile--enter-command
)
336 (exit-command geiser-guile--exit-command
)
337 (import-command geiser-guile--import-command
)
338 (find-symbol-begin geiser-guile--symbol-begin
)
339 (display-error geiser-guile--display-error
)
340 (external-help guile--manual-look-up
)
341 (check-buffer geiser-guile--guess
)
342 (keywords geiser-guile--keywords
))
344 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile t
)
347 (provide 'geiser-guile
)