1 ;;; geiser-chicken.el -- chicken'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
17 (require 'geiser-connection
)
18 (require 'geiser-syntax
)
19 (require 'geiser-custom
)
20 (require 'geiser-base
)
21 (require 'geiser-eval
)
22 (require 'geiser-edit
)
29 (eval-when-compile (require 'cl-lib
))
31 (defconst geiser-chicken-builtin-keywords
41 "define-specialization"
50 "foreign-safe-lambda*"
61 "with-input-from-pipe"))
66 (defgroup geiser-chicken nil
67 "Customization for Geiser's Chicken flavour."
70 (geiser-custom--defcustom geiser-chicken-binary
71 (cond ((eq system-type
'windows-nt
) '("csi.exe" "-:c"))
72 ((eq system-type
'darwin
) "csi")
74 "Name to use to call the Chicken executable when starting a REPL."
75 :type
'(choice string
(repeat string
))
76 :group
'geiser-chicken
)
78 (geiser-custom--defcustom geiser-chicken-load-path nil
79 "A list of paths to be added to Chicken's load path when it's started."
81 :group
'geiser-chicken
)
83 (geiser-custom--defcustom geiser-chicken-init-file
"~/.chicken-geiser"
84 "Initialization file with user code for the Chicken REPL.
85 If all you want is to load ~/.csirc, set
86 `geiser-chicken-load-init-file-p' instead."
88 :group
'geiser-chicken
)
90 (geiser-custom--defcustom geiser-chicken-load-init-file-p nil
91 "Whether to load ~/.chicken when starting Chicken.
92 Note that, due to peculiarities in the way Chicken loads its init
93 file, using `geiser-chicken-init-file' is not equivalent to setting
96 :group
'geiser-chicken
)
98 (geiser-custom--defcustom geiser-chicken-extra-keywords nil
99 "Extra keywords highlighted in Chicken scheme buffers."
100 :type
'(repeat string
)
101 :group
'geiser-chicken
)
103 (geiser-custom--defcustom geiser-chicken-case-sensitive-p t
104 "Non-nil means keyword highlighting is case-sensitive."
106 :group
'geiser-chicken
)
108 (geiser-custom--defcustom geiser-chicken-match-limit
20
109 "The limit on the number of matching symbols that Chicken will provide to Geiser."
111 :group
'geiser-chicken
)
116 (defun geiser-chicken--binary ()
117 (if (listp geiser-chicken-binary
)
118 (car geiser-chicken-binary
)
119 geiser-chicken-binary
))
121 (defun geiser-chicken--parameters ()
122 "Return a list with all parameters needed to start Chicken.
123 This function uses `geiser-chicken-init-file' if it exists."
124 (let ((init-file (and (stringp geiser-chicken-init-file
)
125 (expand-file-name geiser-chicken-init-file
)))
126 (n-flags (and (not geiser-chicken-load-init-file-p
) '("-n"))))
127 `(,@(and (listp geiser-chicken-binary
) (cdr geiser-chicken-binary
))
128 ,@n-flags
"-include-path" ,(expand-file-name "chicken/" geiser-scheme-dir
)
129 ,@(apply 'append
(mapcar (lambda (p) (list "-include-path" p
))
130 geiser-chicken-load-path
))
131 ,@(and init-file
(file-readable-p init-file
) (list init-file
)))))
133 (defconst geiser-chicken--prompt-regexp
"#[^;]*;[^:0-9]*:?[0-9]+> ")
136 ;;; Evaluation support:
138 (defun geiser-chicken--geiser-procedure (proc &rest args
)
141 (let ((form (mapconcat 'identity
(cdr args
) " "))
142 (module (if (car args
) (concat "'" (car args
)) "#f")))
143 (format "(geiser#geiser-eval %s '%s)" module form
)))
144 ((load-file compile-file
)
145 (format "(geiser#geiser-load-file %s)" (car args
)))
147 "(geiser#geiser-no-values)")
149 (let ((form (mapconcat 'identity args
" ")))
150 (format "(geiser#geiser-%s %s)" proc form
)))))
152 (defconst geiser-chicken--module-re
153 "( *define-module +\\(([^)]+)\\)")
155 (defconst geiser-chicken--define-library-re
156 "( *define-library +\\(([^)]+)\\)")
158 (defun geiser-chicken--get-module (&optional module
)
161 (geiser-syntax--pop-to-top)
162 (if (or (re-search-backward geiser-chicken--module-re nil t
)
163 (re-search-backward geiser-chicken--define-library-re nil t
)
164 (looking-at geiser-chicken--module-re
)
165 (looking-at geiser-chicken--define-library-re
)
166 (re-search-forward geiser-chicken--module-re nil t
)
167 (re-search-forward geiser-chicken--define-library-re nil t
))
168 (geiser-chicken--get-module (match-string-no-properties 1))
170 ((listp module
) module
)
173 (car (geiser-syntax--read-from-string module
))
177 (defun geiser-chicken--module-cmd (module fmt
&optional def
)
179 (let* ((module (geiser-chicken--get-module module
))
180 (module (cond ((or (null module
) (eq module
:f
)) def
)
181 (t (format "%s" module
)))))
182 (and module
(format fmt module
)))))
184 (defun geiser-chicken--import-command (module)
185 (geiser-chicken--module-cmd module
"(use %s)"))
187 (defun geiser-chicken--enter-command (module)
188 (geiser-chicken--module-cmd module
",m %s" module
))
190 (defun geiser-chicken--exit-command () ",q")
192 (defun geiser-chicken--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-chicken--display-error (module key msg
)
204 (save-excursion (insert msg
))
205 (geiser-edit--buttonize-files))
206 (and (not key
) msg
(not (zerop (length msg
)))))
209 ;;; Trying to ascertain whether a buffer is Chicken Scheme:
211 (defconst geiser-chicken--guess-re
212 (regexp-opt '("csi" "chicken" "csc")))
214 (defun geiser-chicken--guess ()
216 (goto-char (point-min))
217 (re-search-forward geiser-chicken--guess-re nil t
)))
219 (defun geiser-chicken--external-help (id module
)
220 "Loads chicken doc into a buffer"
221 (let* ((version (geiser-chicken--version (geiser-chicken--binary)))
222 (major-version (car (split-string version
"\\\."))))
223 (browse-url (format "http://api.call-cc.org/%s/cdoc?q=%s&query-name=Look+up"
227 ;;; Keywords and syntax
229 (defun geiser-chicken--keywords ()
231 (geiser-syntax--simple-keywords geiser-chicken-extra-keywords
)
232 (geiser-syntax--simple-keywords geiser-chicken-builtin-keywords
)))
234 (geiser-syntax--scheme-indent
236 (compiler-typecase 1)
247 (foreign-primitive 2)
248 (foreign-safe-lambda 2)
249 (foreign-safe-lambda* 2)
251 (handle-exceptions 2)
262 (with-input-from-pipe 1)
263 (with-output-to-pipe 1))
268 (defconst geiser-chicken-minimum-version
"4.8.0.0")
270 (defun geiser-chicken--version (binary)
271 (cl-destructuring-bind (program . args
)
272 (append (if (listp binary
) binary
(list binary
))
274 (or (handle-exceptions exn \
276 (eval `(begin (import chicken.platform) \
277 (chicken-version)))) \
278 (chicken-version)))"))
280 (apply #'call-process program nil
'(t t
) t args
)
283 (defun connect-to-chicken ()
284 "Start a Chicken REPL connected to a remote process."
286 (geiser-connect 'chicken
))
288 (defun geiser-chicken4--compile-or-load (force-load)
290 (expand-file-name "chicken/geiser/chicken4.so" geiser-scheme-dir
))
292 (expand-file-name "chicken/geiser/chicken4.scm" geiser-scheme-dir
))
293 (force-load (or force-load
(eq system-type
'windows-nt
)))
295 "(define geiser-stdout (current-output-port))(current-output-port (make-output-port (lambda a #f) (lambda a #f)))")
297 "(current-output-port geiser-stdout)"))
301 (format "(load \"%s\")\n(import geiser)\n" source
))
302 ((file-exists-p target
)
303 (format "%s(load \"%s\")(import geiser)%s\n"
304 suppression-prefix target suppression-postfix
))
306 (format "%s(use utils)(compile-file \"%s\" options: '(\"-O3\" \"-s\") output-file: \"%s\" load: #t)(import geiser)%s\n"
307 suppression-prefix source target suppression-postfix
)))))
308 (geiser-eval--send/wait load-sequence
))))
310 (defun geiser-chicken5-load ()
311 (let ((source (expand-file-name "chicken/geiser/chicken5.scm"
313 (geiser-eval--send/wait
315 "(display '((result . t) (output . f))) (load \"%s\")"
318 (defun geiser-chicken--startup (remote)
319 (compilation-setup t
)
321 ((version< (geiser-chicken--version geiser-chicken-binary
) "5.0.0")
322 (geiser-chicken4--compile-or-load t
))
323 (t (geiser-chicken5-load))))
326 ;;; Implementation definition:
328 (define-geiser-implementation chicken
329 (unsupported-procedures '(callers callees generic-methods
))
330 (binary geiser-chicken--binary
)
331 (arglist geiser-chicken--parameters
)
332 (version-command geiser-chicken--version
)
333 (minimum-version geiser-chicken-minimum-version
)
334 (repl-startup geiser-chicken--startup
)
335 (prompt-regexp geiser-chicken--prompt-regexp
)
336 (debugger-prompt-regexp nil
)
338 (marshall-procedure geiser-chicken--geiser-procedure
)
339 (find-module geiser-chicken--get-module
)
340 (enter-command geiser-chicken--enter-command
)
341 (exit-command geiser-chicken--exit-command
)
342 (import-command geiser-chicken--import-command
)
343 (find-symbol-begin geiser-chicken--symbol-begin
)
344 (display-error geiser-chicken--display-error
)
345 (external-help geiser-chicken--external-help
)
346 (check-buffer geiser-chicken--guess
)
347 (keywords geiser-chicken--keywords
)
348 (case-sensitive geiser-chicken-case-sensitive-p
))
350 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'chicken t
)
351 (geiser-impl--add-to-alist 'regexp
"\\.release-info$" 'chicken t
)
352 (geiser-impl--add-to-alist 'regexp
"\\.meta$" 'chicken t
)
353 (geiser-impl--add-to-alist 'regexp
"\\.setup$" 'chicken t
)
355 (provide 'geiser-chicken
)