1 ;; geiser-guile.el -- guile's implementation of the geiser protocols
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: 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
)
27 (defgroup geiser-guile nil
28 "Customization for Geiser's Guile flavour."
31 (geiser-custom--defcustom geiser-guile-binary
32 (cond ((eq system-type
'windows-nt
) "guile.exe")
33 ((eq system-type
'darwin
) "guile")
35 "Name to use to call the Guile executable when starting a REPL."
36 :type
'(choice string
(repeat string
))
39 (geiser-custom--defcustom geiser-guile-load-path nil
40 "A list of paths to be added to Guile's load path when it's
45 (geiser-custom--defcustom geiser-guile-init-file
"~/.guile-geiser"
46 "Initialization file with user code for the Guile REPL."
50 (geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
51 "Whether to autmatically show a full backtrace when entering the debugger.
52 If `nil', only the last frame is shown."
56 (geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
57 "Whether to autmatically jump to error when entering the debugger.
58 If `t', Geiser will use `next-error' to jump to the error's location."
62 (geiser-custom--defcustom geiser-guile-show-debug-help-p t
63 "Whether to show brief help in the echo area when entering the debugger."
67 (geiser-custom--defcustom geiser-guile-warning-level
'medium
68 "Verbosity of the warnings reported by Guile.
70 You can choose either one of the predefined warning sets, or
71 provide a list of symbols identifying the ones you want. Possible
72 choices are arity-mismatch, unbound-variable, unused-variable and
73 unused-toplevel. Unrecognised symbols are ignored.
75 The predefined levels are:
77 - Medium: arity-mismatch, unbound-variable
78 - High: arity-mismatch, unbound-variable, unused-variable
81 Changes to the value of this variable will automatically take
82 effect on new REPLs. For existing ones, use the command
83 \\[geiser-guile-update-warning-level]."
84 :type
'(choice (const :tag
"Medium (arity and unbound vars)" medium
)
85 (const :tag
"High (also unused vars)" high
)
86 (const :tag
"No warnings" none
)
87 (repeat :tag
"Custom" symbol
))
93 (defun geiser-guile--binary ()
94 (if (listp geiser-guile-binary
)
95 (car geiser-guile-binary
)
98 (defun geiser-guile--parameters ()
99 "Return a list with all parameters needed to start Guile.
100 This function uses `geiser-guile-init-file' if it exists."
101 (let ((init-file (and (stringp geiser-guile-init-file
)
102 (expand-file-name geiser-guile-init-file
))))
103 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
104 "-q" "-L" ,(expand-file-name "guile/" geiser-scheme-dir
)
105 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
)) geiser-guile-load-path
))
106 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
108 ;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
109 (defconst geiser-guile--prompt-regexp
"[^@()]+@([^)]*?)> ")
110 (defconst geiser-guile--debugger-prompt-regexp
111 "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
114 ;;; Evaluation support:
115 (defsubst geiser-guile--linearize-args
(args)
116 (mapconcat 'identity args
" "))
118 (defun geiser-guile--geiser-procedure (proc &rest args
)
120 ((eval compile
) (format ",geiser-eval %s %s%s"
122 (geiser-guile--linearize-args (cdr args
))
123 (if (cddr args
) "" " ()")))
124 ((load-file compile-file
) (format ",geiser-load-file %s" (car args
)))
125 ((no-values) ",geiser-no-values")
126 (t (format "ge:%s (%s)" proc
(geiser-guile--linearize-args args
)))))
128 (defconst geiser-guile--module-re
129 "(define-module +\\(([^)]+)\\)")
131 (defconst geiser-guile--library-re
132 "(library +\\(([^)]+)\\)")
134 (defun geiser-guile--get-module (&optional module
)
138 (while (not (zerop (geiser-syntax--nesting-level)))
140 (if (or (re-search-backward geiser-guile--module-re nil t
)
141 (looking-at geiser-guile--library-re
))
142 (geiser-guile--get-module (match-string-no-properties 1))
144 ((listp module
) module
)
147 (car (geiser-syntax--read-from-string module
))
151 (defun geiser-guile--module-cmd (module fmt
&optional def
)
153 (let* ((module (geiser-guile--get-module module
))
154 (module (cond ((or (null module
) (eq module
:f
)) def
)
155 (t (format "%s" module
)))))
156 (and module
(format fmt module
)))))
158 (defun geiser-guile--import-command (module)
159 (geiser-guile--module-cmd module
",use %s"))
161 (defun geiser-guile--enter-command (module)
162 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
165 (defun geiser-guile--exit-command () ",q")
167 (defun geiser-guile--symbol-begin (module)
169 (max (save-excursion (beginning-of-line) (point))
170 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
171 (save-excursion (skip-syntax-backward "^-()>") (point))))
176 (defun geiser-guile--enter-debugger ()
177 (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
178 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
179 (compilation-forget-errors)
180 (goto-char (point-max))
181 (geiser-repl--prepare-send)
182 (comint-send-string nil bt-cmd
)
183 (when geiser-guile-show-debug-help-p
184 (message "Debug REPL. Enter ,q to quit, ,h for help."))
185 (when geiser-guile-jump-on-debug-p
186 (accept-process-output (get-buffer-process (current-buffer))
188 (ignore-errors (next-error)))))
190 (defun geiser-guile--display-error (module key msg
)
193 (save-excursion (insert msg
))
194 (geiser-edit--buttonize-files))
195 (and (not key
) msg
(not (zerop (length msg
)))))
198 ;;; Trying to ascertain whether a buffer is Guile Scheme:
200 (defconst geiser-guile--guess-re
201 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
202 geiser-guile--module-re
))
204 (defun geiser-guile--guess ()
206 (goto-char (point-min))
207 (re-search-forward geiser-guile--guess-re nil t
)))
210 ;;; Compilation shell regexps
212 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
214 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
216 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
218 (defun geiser-guile--resolve-file (file)
219 (when (and (stringp file
) (not (string-equal file
"unknown file")))
220 (if (file-name-absolute-p file
) file
221 (or (gethash file geiser-guile--file-cache
)
223 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
224 geiser-guile--file-cache
)))))
226 (defun geiser-guile--resolve-file-x ()
227 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
228 (and (stringp f
) (list f
))))
233 (defun geiser-guile-update-warning-level ()
234 "Update the warning level used by the REPL.
235 The new level is set using the value of `geiser-guile-warning-level'."
237 (let ((code `(:eval
(ge:set-warnings
',geiser-guile-warning-level
)
238 (geiser evaluation
))))
239 (geiser-eval--send/result code
)))
241 (defun connect-to-guile ()
242 "Start a Guile REPL connected to a remote process.
244 Start the external Guile process with the flag --listen to make
245 it spawn a server thread."
247 (geiser-connect 'guile
))
249 (defun geiser-guile--load-path-string ()
250 (let* ((path (expand-file-name "guile/" geiser-scheme-dir
))
251 (witness "geiser/emacs.scm")
252 (code `(if (not (%search-load-path
,witness
))
253 (set! %load-path
(cons ,path %load-path
)))))
254 (geiser-eval--scheme-str code
)))
256 (defun geiser-guile--startup (remote)
257 (set (make-local-variable 'compilation-error-regexp-alist
)
258 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
259 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
260 (compilation-setup t
)
261 (font-lock-add-keywords nil
262 `((,geiser-guile--path-rx
1
263 compilation-error-face
)))
265 (geiser-repl--send-silent (geiser-guile--load-path-string)))
266 (geiser-repl--send-silent ",use (geiser emacs)")
267 (geiser-guile-update-warning-level))
270 ;;; Implementation definition:
272 (define-geiser-implementation guile
273 (binary geiser-guile--binary
)
274 (arglist geiser-guile--parameters
)
275 (repl-startup geiser-guile--startup
)
276 (prompt-regexp geiser-guile--prompt-regexp
)
277 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
278 (enter-debugger geiser-guile--enter-debugger
)
279 (marshall-procedure geiser-guile--geiser-procedure
)
280 (find-module geiser-guile--get-module
)
281 (enter-command geiser-guile--enter-command
)
282 (exit-command geiser-guile--exit-command
)
283 (import-command geiser-guile--import-command
)
284 (find-symbol-begin geiser-guile--symbol-begin
)
285 (display-error geiser-guile--display-error
)
287 (check-buffer geiser-guile--guess
))
289 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile nil
)
292 (provide 'geiser-guile
)
293 ;;; geiser-guile.el ends here