1 ;; geiser-chicken.el -- chicken's implementation of the geiser protocols
3 ;; Copyright (C) 2014, 2015 Daniel Leslie
5 ;; Based on geiser-guile.el by Jose Antonio Ortego Ruize
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
15 (require 'geiser-connection
)
16 (require 'geiser-syntax
)
17 (require 'geiser-custom
)
18 (require 'geiser-base
)
19 (require 'geiser-eval
)
20 (require 'geiser-edit
)
27 (eval-when-compile (require 'cl
))
30 (defconst geiser-chicken-builtin-keywords
31 '("and-let*" "assume" "compiler-typecase" "cond-expand" "condition-case"
32 "cut" "cute" "declare" "define-constant" "define-inline" "define-interface"
33 "define-record" "define-record-type" "define-specialization"
34 "define-syntax-rule" "define-type" "define-values" "dotimes" "ecase"
35 "fluid-let" "foreign-lambda" "foreign-lambda*" "foreign-primitive"
36 "foreign-safe-lambda" "foreign-safe-lambda*" "functor" "handle-exceptions"
37 "import" "let*-values" "let-location" "let-optionals" "let-optionals*"
38 "let-values" "letrec*" "letrec-values" "match-letrec" "module"
39 "parameterize" "regex-case" "require-extension" "select" "set!"
40 "unless" "use" "when" "with-input-from-pipe" "match" "match-lambda"
41 "match-lambda*" "match-let" "match-let*" "receive"))
45 (defgroup geiser-chicken nil
46 "Customization for Geiser's Chicken flavour."
49 (geiser-custom--defcustom geiser-chicken-binary
50 (cond ((eq system-type
'windows-nt
) "csi.exe")
51 ((eq system-type
'darwin
) "csi")
53 "Name to use to call the Chicken executable when starting a REPL."
54 :type
'(choice string
(repeat string
))
55 :group
'geiser-chicken
)
57 (geiser-custom--defcustom geiser-chicken-load-path nil
58 "A list of paths to be added to Chicken's load path when it's
61 :group
'geiser-chicken
)
63 (geiser-custom--defcustom geiser-chicken-init-file
"~/.chicken-geiser"
64 "Initialization file with user code for the Chicken REPL.
65 If all you want is to load ~/.csirc, set
66 `geiser-chicken-load-init-file-p' instead."
68 :group
'geiser-chicken
)
70 (geiser-custom--defcustom geiser-chicken-load-init-file-p nil
71 "Whether to load ~/.chicken when starting Chicken.
72 Note that, due to peculiarities in the way Chicken loads its init
73 file, using `geiser-chicken-init-file' is not equivalent to setting
76 :group
'geiser-chicken
)
78 (geiser-custom--defcustom geiser-chicken-extra-keywords nil
79 "Extra keywords highlighted in Chicken scheme buffers."
80 :type
'(repeat string
)
81 :group
'geiser-chicken
)
83 (geiser-custom--defcustom geiser-chicken-case-sensitive-p t
84 "Non-nil means keyword highlighting is case-sensitive."
86 :group
'geiser-chicken
)
91 (defun geiser-chicken--binary ()
92 (if (listp geiser-chicken-binary
)
93 (car geiser-chicken-binary
)
94 geiser-chicken-binary
))
96 (defun geiser-chicken--parameters ()
97 "Return a list with all parameters needed to start Chicken.
98 This function uses `geiser-chicken-init-file' if it exists."
99 (let ((init-file (and (stringp geiser-chicken-init-file
)
100 (expand-file-name geiser-chicken-init-file
)))
101 (n-flags (and (not geiser-chicken-load-init-file-p
) '("-n"))))
102 `(,@(and (listp geiser-chicken-binary
) (cdr geiser-chicken-binary
))
103 ,@n-flags
"-include-path" ,(expand-file-name "chicken/" geiser-scheme-dir
)
104 ,@(apply 'append
(mapcar (lambda (p) (list "-include-path" p
))
105 geiser-chicken-load-path
))
106 ,@(and init-file
(file-readable-p init-file
) (list init-file
)))))
108 (defconst geiser-chicken--prompt-regexp
"#[^;]*;[^:0-9]*:?[0-9]+> ")
110 ;;; Evaluation support:
112 (defun geiser-chicken--geiser-procedure (proc &rest args
)
116 (let ((form (mapconcat 'identity
(cdr args
) " ")))
117 (format ",geiser-eval %s %s" (or (car args
) "#f") form
)))
118 ((load-file compile-file
)
119 (format ",geiser-load-file %s" (car args
)))
123 (let ((form (mapconcat 'identity args
" ")))
124 (format "(geiser-%s %s)" proc form
))))))
128 (defconst geiser-chicken--module-re
129 "( *module +\\(([^)]+)\\|[^ ]+\\)\\|( *define-library +\\(([^)]+)\\|[^ ]+\\)")
131 (defun geiser-chicken--get-module (&optional module
)
134 (geiser-syntax--pop-to-top)
135 (if (or (re-search-backward geiser-chicken--module-re nil t
)
136 (looking-at geiser-chicken--module-re
)
137 (re-search-forward geiser-chicken--module-re nil t
))
138 (geiser-chicken--get-module (match-string-no-properties 1))
140 ((listp module
) module
)
143 (car (geiser-syntax--read-from-string module
))
147 (defun geiser-chicken--module-cmd (module fmt
&optional def
)
149 (let* ((module (geiser-chicken--get-module module
))
150 (module (cond ((or (null module
) (eq module
:f
)) def
)
151 (t (format "%s" module
)))))
152 (and module
(format fmt module
)))))
154 (defun geiser-chicken--import-command (module)
155 (geiser-chicken--module-cmd module
"(use %s)"))
157 (defun geiser-chicken--enter-command (module)
158 (geiser-chicken--module-cmd module
",m %s" module
))
160 (defun geiser-chicken--exit-command () ",q")
162 (defun geiser-chicken--symbol-begin (module)
163 (save-excursion (skip-syntax-backward "^-()>") (point)))
167 (defun geiser-chicken--display-error (module key msg
)
170 (save-excursion (insert msg
))
171 (geiser-edit--buttonize-files))
172 (and (not key
) msg
(not (zerop (length msg
)))))
174 ;;; Trying to ascertain whether a buffer is Chicken Scheme:
176 (defconst geiser-chicken--guess-re
177 (regexp-opt (append '("csi" "chicken") geiser-chicken-builtin-keywords
)))
179 (defun geiser-chicken--guess ()
181 (goto-char (point-min))
182 (re-search-forward geiser-chicken--guess-re nil t
)))
184 (defun geiser-chicken--external-help (id module
)
185 "Loads chicken doc into a buffer"
186 (browse-url (format "http://api.call-cc.org/cdoc?q=%s&query-name=Look+up" id
)))
188 ;;; Keywords and syntax
190 (defun geiser-chicken--keywords ()
191 `((,(format "[[(]%s\\>" (regexp-opt geiser-chicken-builtin-keywords
1)) .
1)))
193 (geiser-syntax--scheme-indent
198 (match-let scheme-let-indent
)
203 (let-values scheme-let-indent
)
204 (let*-values scheme-let-indent
)
207 (parameterize scheme-let-indent
)
211 (foreign-primitive 2)
212 (foreign-safe-lambda 2)
213 (foreign-safe-lambda* 2)
226 (compiler-typecase 1)
229 (require-extension 0)
231 (handle-exceptions 2)
235 (define-syntax-rule 1)
236 (define-record-type 1)
239 (define-specialization 1)
241 (with-input-from-pipe 1)
249 (defconst geiser-chicken-minimum-version
"4.8.0.0")
251 (defun geiser-chicken--version (binary)
252 (shell-command-to-string (format "%s -e \"(display (chicken-version))\""
255 (defun connect-to-chicken ()
256 "Start a Chicken REPL connected to a remote process."
258 (geiser-connect 'chicken
))
260 (defun geiser-chicken--startup (remote)
261 (compilation-setup t
)
262 (let ((geiser-log-verbose-p t
))
263 (geiser-eval--send/wait
(format "(load \"%s\")\n"
264 (expand-file-name "chicken/geiser/emacs.scm" geiser-scheme-dir
)))))
266 ;;; Implementation definition:
268 (define-geiser-implementation chicken
269 (unsupported-procedures '(callers callees generic-methods
))
270 (binary geiser-chicken--binary
)
271 (arglist geiser-chicken--parameters
)
272 (version-command geiser-chicken--version
)
273 (minimum-version geiser-chicken-minimum-version
)
274 (repl-startup geiser-chicken--startup
)
275 (prompt-regexp geiser-chicken--prompt-regexp
)
276 (debugger-prompt-regexp nil
)
278 (marshall-procedure geiser-chicken--geiser-procedure
)
279 (find-module geiser-chicken--get-module
)
280 (enter-command geiser-chicken--enter-command
)
281 (exit-command geiser-chicken--exit-command
)
282 (import-command geiser-chicken--import-command
)
283 (find-symbol-begin geiser-chicken--symbol-begin
)
284 (display-error geiser-chicken--display-error
)
285 (external-help geiser-chicken--external-help
)
286 (check-buffer geiser-chicken--guess
)
287 (keywords geiser-chicken--keywords
)
288 (case-sensitive geiser-chicken-case-sensitive-p
))
290 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'chicken t
)
291 (geiser-impl--add-to-alist 'regexp
"\\.release-info$" 'chicken t
)
292 (geiser-impl--add-to-alist 'regexp
"\\.meta$" 'chicken t
)
293 (geiser-impl--add-to-alist 'regexp
"\\.setup$" 'chicken t
)
295 (provide 'geiser-chicken
)