1 ;;; geiser-gambit.el -- gambit's implementation of the geiser protocols
3 ;; Copyright (C) 2014, 2015, 2019 Daniel Leslie
5 ;; Based on geiser-guile.el by Jose Antonio Ortega Ruiz
7 ;; This program is free software; you can redistribute it and/or
8 ;; modify it under the terms of the Modified BSD License. You should
9 ;; have received a copy of the license along with this program. If
10 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
12 ;; Start date: Sun Mar 08, 2009 23:03
16 ;; Gambit in geiser, thank you to Chris Blom for the start he did few years ago
17 ;; https://github.com/ChrisBlom
20 ;; [ ] the gambit guessing words lists
25 (require 'geiser-connection
)
26 (require 'geiser-syntax
)
27 (require 'geiser-custom
)
28 (require 'geiser-base
)
29 (require 'geiser-eval
)
30 (require 'geiser-edit
)
37 (eval-when-compile (require 'cl-lib
))
39 (defconst geiser-gambit--builtin-keywords
40 '("##debug-repl" "##import" "define-macro" "##symbol-table" "##decompile"))
44 (defgroup geiser-gambit nil
45 "Customization for Geiser's Gambit flavour."
48 ;; define the interpreter for geiser.
49 ;; the geiser-costum--defcustom is a macro that will
50 ;; call a declaration into the documentation of the
51 ;; structure of the method and then define the method
52 ;; with a defcustom: define a variable that represents an option users might want to set
53 (geiser-custom--defcustom geiser-gambit-binary
54 (cond ((eq system-type
'windows-nt
) '("gsi.exe"))
56 "Name to use to call the gambit executable when starting a REPL."
57 :type
'(choice string
(repeat string
))
58 :group
'geiser-gambit
)
60 (geiser-custom--defcustom geiser-gambit-load-path nil
61 "A list of paths to be added to gambit's load path when it's
64 :group
'geiser-gambit
)
66 (geiser-custom--defcustom geiser-gambit-compile-geiser-p t
67 "Non-nil means that the Geiser runtime will be compiled on load."
69 :group
'geiser-gambit
)
71 (geiser-custom--defcustom geiser-gambit-init-file
"~/.gambit-geiser"
72 "Initialization file with user code for the Gambit REPL.
73 If all you want is to load ~/.gambit, set
74 `geiser-gambit-load-init-file-p' instead."
76 :group
'geiser-gambit
)
78 (geiser-custom--defcustom geiser-gambit-load-init-file-p nil
79 "Whether to load ~/.gambit when starting Gambit.
80 Note that, due to peculiarities in the way Gambit loads its init
81 file, using `geiser-gambit-init-file' is not equivalent to setting
84 :group
'geiser-gambit
)
86 (geiser-custom--defcustom geiser-gambit-extra-keywords nil
87 "Extra keywords highlighted in gambit scheme buffers."
88 :type
'(repeat string
)
89 :group
'geiser-gambit
)
91 (geiser-custom--defcustom geiser-gambit-case-sensitive-p t
92 "Non-nil means keyword highlighting is case-sensitive."
94 :group
'geiser-gambit
)
96 ;; TODO path for debugger and debugging functions
100 (defun geiser-gambit--binary ()
101 (if (listp geiser-gambit-binary
)
102 (car geiser-gambit-binary
)
103 geiser-gambit-binary
))
105 (defconst geiser-gambit--prompt-regexp
"> ")
107 (defconst geiser-gambit--debugger-prompt-regexp
"[0-9]+> ")
108 ;; taken from gerbil scheme
109 (geiser-custom--defcustom geiser-gambit-debug-show-bt-p t
110 "Whether to automatically show a full backtrace when entering the debugger.
111 If `nil', only the last frame is shown."
113 :group
'geiser-gambit
)
115 (geiser-custom--defcustom geiser-gambit-show-debug-help-p t
116 "Whether to show brief help in the echo area when entering the debugger."
118 :group
'geiser-gambit
)
120 (geiser-custom--defcustom geiser-gambit-jump-on-debug-p nil
121 "Whether to automatically jump to error when entering the debugger.
122 If `t', Geiser will use `next-error' to jump to the error's location."
124 :group
'geiser-gambit
)
126 ;;; evaluation support when module loaded at opening
127 ;;; the gambit/geiser# is the namespace of geiser module for gambit
128 (defun geiser-gambit--geiser-procedure (proc &rest args
)
131 (let* ((form (mapconcat 'identity
(cdr args
) " "))
132 (module (cond ((string-equal "'()" (car args
))
134 ((and (car args
) (not (string-prefix-p "'" (car args
)))
135 (not (string-prefix-p "#" (car args
))))
136 (concat "'" (car args
)))
139 (cmd (format "(gambit/geiser#geiser:eval %s '%s)" module form
)))
141 ((load-file compile-file
)
142 (format "(gambit/geiser#geiser:load-file %s)" (car args
)))
144 "(gambit/geiser#geiser:no-values)")
146 (let ((form (mapconcat 'identity args
" ")))
147 (format "(gambit/geiser#geiser:%s %s)" proc form
)))))
149 ;;(defconst geiser-gambit--module-re
150 ;; "( *module +\\(([^)]+)\\|[^ ]+\\)\\|( *define-library +\\(([^)]+)\\|[^ ]+\\)")
152 ;;(defun geiser-gambit--module-cmd (module fmt &optional def)
154 ;; (let* ((module (geiser-gambit--get-module module))
155 ;; (module (cond ((or (null module) (eq module :f)) def)
156 ;; (t (format "%s" module)))))
157 ;; (and module (format fmt module)))))
159 ;; not supported by gambit
161 ;;(defun geiser-gambit--get-module (&optional module)
162 ;; (cond ((null module)
164 ;; (geiser-syntax--pop-to-top)
165 ;; (if (or (re-search-backward geiser-gambit--module-re nil t)
166 ;; (looking-at geiser-gambit--library-re)
167 ;; (re-search-forward geiser-gambit--module-re nil t))
168 ;; (geiser-gambit--get-module (match-string-no-properties 1))
170 ;; ((listp module) module)
172 ;; (condition-case nil
173 ;; (car (geiser-syntax--read-from-string module))
177 ;;(defun geiser-gambit--import-command (module)
178 ;; (geiser-gambit--module-cmd module ",use %s"))
180 ;; not implemented by gambit for the moment
181 ;;(defun geiser-gambit--enter-command (module)
182 ;; (geiser-gambit--module-cmd module ",m %s" module))
184 (defun geiser-gambit--exit-command () ",q")
186 (defun geiser-gambit--symbol-begin (module)
187 (save-excursion (skip-syntax-backward "^-()> ") (point)))
193 (defun geiser-gambit--display-error (module key msg
)
196 (save-excursion (insert msg
))
197 (geiser-edit--buttonize-files))
198 (and (not key
) msg
(not (zerop (length msg
)))))
201 (defun geiser-gambit--enter-debugger ()
202 (let ((bt-cmd (if geiser-gambit-debug-show-bt-p
"\n#||#,b\n" "")))
203 (compilation-forget-errors)
204 (goto-char (point-max))
205 (geiser-repl--prepare-send)
206 (comint-send-string nil bt-cmd
)
207 (when geiser-gambit-show-debug-help-p
208 (message "Debug REPL. Enter ,t to return to top level, ,? for help."))
209 (when geiser-gambit-jump-on-debug-p
210 (accept-process-output (get-buffer-process (current-buffer))
212 (ignore-errors (next-error)))))
214 ;;; Trying to ascertain whether a buffer is Gambit Scheme:
216 (defconst geiser-gambit--guess-re
217 (regexp-opt (append '("gsi" "gambit") geiser-gambit--builtin-keywords
)))
219 (defun geiser-gambit--guess ()
221 (goto-char (point-min))
222 (re-search-forward geiser-gambit--guess-re nil t
)))
224 ;; no help at the moment TODO
225 ;; (defun geiser-gambit--external-help (id module)
226 ;; "Loads gambit doc into a buffer"
227 ;; (browse-url (format "http://api.call-cc.org/cdoc?q=%s&query-name=Look+up" id)))
229 ;;; Keywords and syntax
231 (defun geiser-gambit--keywords ()
232 `(,geiser-gambit--builtin-keywords
))
234 (geiser-syntax--scheme-indent
239 (match-let scheme-let-indent
)
244 (let-values scheme-let-indent
)
245 (let*-values scheme-let-indent
)
248 (parameterize scheme-let-indent
)
252 (foreign-primitive 2)
253 (foreign-safe-lambda 2)
254 (foreign-safe-lambda* 2)
267 (compiler-typecase 1)
270 (require-extension 0)
272 (handle-exceptions 2)
276 (define-syntax-rule 1)
277 (define-record-type 1)
280 (define-specialization 1)
289 (defconst geiser-gambit-minimum-version
"v4.9.3")
291 (defun geiser-gambit--version (binary)
292 (shell-command-to-string (format "%s -e \"(display (##system-version-string))\""
295 (defun geiser-gambit--parameters ()
296 "Return a list with all parameters needed to start Gambit Scheme."
297 ;; if your version of gambit support modules we directly load geiser module
298 ;; else we go load the file in geiser
299 (let* ((v (geiser-gambit--version (geiser-gambit--binary)))
300 (gambit-version (substring v
1 (string-width v
))))
301 (if (version< gambit-version
"4.9.4")
302 `( "-:d-" ,(expand-file-name "gambit/geiser/gambit.scm" geiser-scheme-dir
) "-" )
303 `("-:d-" "gambit/geiser" "-"))))
306 (defun connect-to-gambit ()
307 "Start a Gambit REPL connected to a remote process."
309 (geiser-connect 'gambit
))
311 (defun geiser-gambit--startup (remote)
312 (compilation-setup t
))
313 ;;; Implementation definition:
315 (define-geiser-implementation gambit
316 (unsupported-procedures '(callers callees generic-methods
317 module-location symbol-documentation
))
318 (binary geiser-gambit--binary
)
319 (arglist geiser-gambit--parameters
)
320 (version-command geiser-gambit--version
)
321 (minimum-version geiser-gambit-minimum-version
)
322 (repl-startup geiser-gambit--startup
)
323 (prompt-regexp geiser-gambit--prompt-regexp
)
324 (debugger-prompt-regexp geiser-gambit--debugger-prompt-regexp
)
325 (enter-debugger geiser-gambit--enter-debugger
)
326 (marshall-procedure geiser-gambit--geiser-procedure
)
327 ;; (find-module geiser-gambit--get-module)
328 ;; (enter-command geiser-gambit--enter-command)
329 (exit-command geiser-gambit--exit-command
)
330 ;; (import-command geiser-gambit--import-command)
331 (find-symbol-begin geiser-gambit--symbol-begin
)
332 (display-error geiser-gambit--display-error
)
333 ;; (external-help geiser-gambit--external-help)
334 (check-buffer geiser-gambit--guess
)
335 (keywords geiser-gambit--keywords
)
336 (case-sensitive geiser-gambit-case-sensitive-p
))
338 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'gambit t
)
340 (provide 'geiser-gambit
)