Using implementation-specific keywords also in REPL
[geiser.git] / elisp / geiser-syntax.el
blob42e265e2845b1052d16218130a90e6aa80544aca
1 ;;; geiser-syntax.el -- utilities for parsing scheme syntax
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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 Feb 08, 2009 15:03
14 (require 'geiser-impl)
15 (require 'geiser-popup)
16 (require 'geiser-base)
18 (require 'scheme)
20 (eval-when-compile (require 'cl))
23 ;;; Indentation:
25 (defmacro geiser-syntax--scheme-indent (&rest pairs)
26 `(progn ,@(mapcar (lambda (p)
27 `(put ',(car p) 'scheme-indent-function ',(cadr p)))
28 pairs)))
30 (geiser-syntax--scheme-indent
31 (case-lambda 0)
32 (catch defun)
33 (class defun)
34 (dynamic-wind 0)
35 (let*-values 1)
36 (letrec* 1)
37 (letrec-values 1)
38 (let-values 1)
39 (let/ec 1)
40 (match defun)
41 (opt-lambda 1)
42 (parameterize 1)
43 (parameterize* 1)
44 (receive 2)
45 (syntax-case 2)
46 (unless 1)
47 (when 1)
48 (while 1)
49 (with-error-to-port 1)
50 (with-syntax 1))
53 ;;; Extra syntax keywords
54 (defconst geiser-syntax--keywords
55 '(("\\[\\(else\\)\\>" . 1)
56 ("(\\(parameterize\\)\\>" . 1)))
58 (font-lock-add-keywords 'scheme-mode geiser-syntax--keywords)
60 (geiser-impl--define-caller geiser-syntax--impl-kws keywords ()
61 "A variable (or thunk returning a value) giving additional,
62 implementation-specific entries for font-lock-keywords.")
64 (geiser-impl--define-caller geiser-syntax--case-sensitive case-sensitive ()
65 "A flag saying whether keywords are case sensitive.")
67 (defun geiser-syntax--add-kws ()
68 (when (not (and (boundp 'quack-mode) quack-mode))
69 (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation))
70 (cs (geiser-syntax--case-sensitive geiser-impl--implementation)))
71 (when kw (font-lock-add-keywords nil kw))
72 (setq font-lock-keywords-case-fold-search (not cs)))))
75 ;;; A simple scheme reader
77 (defvar geiser-syntax--read/buffer-limit nil)
79 (defsubst geiser-syntax--read/eos ()
80 (or (eobp)
81 (and geiser-syntax--read/buffer-limit
82 (<= geiser-syntax--read/buffer-limit (point)))))
84 (defsubst geiser-syntax--read/next-char ()
85 (unless (geiser-syntax--read/eos)
86 (forward-char)
87 (char-after)))
89 (defsubst geiser-syntax--read/token (token)
90 (geiser-syntax--read/next-char)
91 (if (listp token) token (list token)))
93 (defsubst geiser-syntax--read/elisp ()
94 (ignore-errors (read (current-buffer))))
96 (defun geiser-syntax--read/symbol ()
97 (with-syntax-table scheme-mode-syntax-table
98 (when (re-search-forward "\\(\\sw\\|\\s_\\)+" nil t)
99 (make-symbol (match-string-no-properties 0)))))
101 (defun geiser-syntax--read/matching (open close)
102 (let ((count 1)
103 (p (1+ (point))))
104 (while (and (> count 0)
105 (geiser-syntax--read/next-char))
106 (cond ((looking-at-p open) (setq count (1+ count)))
107 ((looking-at-p close) (setq count (1- count)))))
108 (buffer-substring-no-properties p (point))))
110 (defsubst geiser-syntax--read/unprintable ()
111 (geiser-syntax--read/token
112 (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))
114 (defun geiser-syntax--read/skip-comment ()
115 (while (and (geiser-syntax--read/next-char)
116 (nth 8 (syntax-ppss))))
117 (geiser-syntax--read/next-token))
119 (defun geiser-syntax--read/next-token ()
120 (skip-syntax-forward "->")
121 (if (geiser-syntax--read/eos) '(eob)
122 (case (char-after)
123 (?\; (geiser-syntax--read/skip-comment))
124 ((?\( ?\[) (geiser-syntax--read/token 'lparen))
125 ((?\) ?\]) (geiser-syntax--read/token 'rparen))
126 (?. (if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
127 (geiser-syntax--read/token 'dot)
128 (cons 'atom (geiser-syntax--read/elisp))))
129 (?\# (case (geiser-syntax--read/next-char)
130 ('nil '(eob))
131 (?| (geiser-syntax--read/skip-comment))
132 (?: (if (geiser-syntax--read/next-char)
133 (cons 'kwd (geiser-syntax--read/symbol))
134 '(eob)))
135 (?\\ (cons 'char (geiser-syntax--read/elisp)))
136 (?\( (geiser-syntax--read/token 'vectorb))
137 (?\< (geiser-syntax--read/unprintable))
138 ((?' ?` ?,) (geiser-syntax--read/next-token))
139 (t (let ((tok (geiser-syntax--read/symbol)))
140 (cond ((equal (symbol-name tok) "t") '(boolean . :t))
141 ((equal (symbol-name tok) "f") '(boolean . :f))
142 (tok (cons 'atom tok))
143 (t (geiser-syntax--read/next-token)))))))
144 (?\' (geiser-syntax--read/token '(quote . quote)))
145 (?\` (geiser-syntax--read/token
146 `(backquote . ,backquote-backquote-symbol)))
147 (?, (if (eq (geiser-syntax--read/next-char) ?@)
148 (geiser-syntax--read/token
149 `(splice . ,backquote-splice-symbol))
150 `(unquote . ,backquote-unquote-symbol)))
151 (?\" (cons 'string (geiser-syntax--read/elisp)))
152 (t (cons 'atom (geiser-syntax--read/symbol))))))
154 (defsubst geiser-syntax--read/match (&rest tks)
155 (let ((token (geiser-syntax--read/next-token)))
156 (if (memq (car token) tks) token
157 (error "Unexpected token: %s" token))))
159 (defsubst geiser-syntax--read/skip-until (&rest tks)
160 (let (token)
161 (while (and (not (memq (car token) tks))
162 (not (eq (car token) 'eob)))
163 (setq token (geiser-syntax--read/next-token)))
164 token))
166 (defsubst geiser-syntax--read/try (&rest tks)
167 (let ((p (point))
168 (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
169 (unless tk (goto-char p))
170 tk))
172 (defun geiser-syntax--read/list ()
173 (cond ((geiser-syntax--read/try 'dot)
174 (let ((tail (geiser-syntax--read)))
175 (geiser-syntax--read/skip-until 'eob 'rparen)
176 tail))
177 ((geiser-syntax--read/try 'rparen 'eob) nil)
178 (t (cons (geiser-syntax--read)
179 (geiser-syntax--read/list)))))
181 (defun geiser-syntax--read ()
182 (let ((token (geiser-syntax--read/next-token))
183 (max-lisp-eval-depth (max max-lisp-eval-depth 3000)))
184 (case (car token)
185 (eob nil)
186 (lparen (geiser-syntax--read/list))
187 (vectorb (apply 'vector (geiser-syntax--read/list)))
188 ((quote backquote unquote splice) (list (cdr token)
189 (geiser-syntax--read)))
190 (kwd (make-symbol (format ":%s" (cdr token))))
191 (unprintable (format "#<%s>" (cdr token)))
192 ((char string atom) (cdr token))
193 (boolean (cdr token))
194 (t (error "Reading scheme syntax: unexpected token: %s" token)))))
196 (defun geiser-syntax--read-from-string (string &optional start end)
197 (when (stringp string)
198 (let* ((start (or start 0))
199 (end (or end (length string)))
200 (max-lisp-eval-depth (max max-lisp-eval-depth (- end start))))
201 (with-temp-buffer
202 (save-excursion (insert string))
203 (cons (ignore-errors (geiser-syntax--read)) (point))))))
205 (defsubst geiser-syntax--form-after-point (&optional boundary)
206 (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary)))
207 (save-excursion (values (geiser-syntax--read) (point)))))
209 (defun geiser-syntax--mapconcat (fun lst sep)
210 (cond ((null lst) "")
211 ((not (listp lst)) (format ".%s%s" sep (funcall fun lst)))
212 ((null (cdr lst)) (format "%s" (funcall fun (car lst))))
213 (t (format "%s%s%s"
214 (funcall fun (car lst))
216 (geiser-syntax--mapconcat fun (cdr lst) sep)))))
218 (defun geiser-syntax--display (a)
219 (cond ((null a) "()")
220 ((eq a :t) "#t")
221 ((eq a :f) "#f")
222 ((geiser-syntax--keywordp a) (format "#%s" a))
223 ((symbolp a) (format "%s" a))
224 ((equal a "...") "...")
225 ((stringp a) (format "%S" a))
226 ((and (listp a) (symbolp (car a))
227 (equal (symbol-name (car a)) "quote"))
228 (format "'%s" (geiser-syntax--display (cadr a))))
229 ((listp a)
230 (format "(%s)"
231 (geiser-syntax--mapconcat 'geiser-syntax--display a " ")))
232 (t (format "%s" a))))
235 ;;; Code parsing:
237 (defsubst geiser-syntax--symbol-at-point ()
238 (and (not (nth 8 (syntax-ppss)))
239 (car (geiser-syntax--read-from-string (thing-at-point 'symbol)))))
241 (defsubst geiser-syntax--skip-comment/string ()
242 (let ((pos (nth 8 (syntax-ppss))))
243 (goto-char (or pos (point)))
244 pos))
246 (defsubst geiser-syntax--nesting-level ()
247 (or (nth 0 (syntax-ppss)) 0))
249 (defsubst geiser-syntax--in-string-p ()
250 (nth 3 (syntax-ppss)))
252 (defsubst geiser-syntax--pair-length (p)
253 (if (cdr (last p)) (1+ (safe-length p)) (length p)))
255 (defun geiser-syntax--shallow-form (boundary)
256 (when (looking-at-p "\\s(")
257 (save-excursion
258 (forward-char)
259 (let ((elems))
260 (ignore-errors
261 (while (< (point) boundary)
262 (skip-syntax-forward "-<>")
263 (when (<= (point) boundary)
264 (forward-sexp)
265 (let ((s (thing-at-point 'symbol)))
266 (unless (equal "." s)
267 (push (car (geiser-syntax--read-from-string s)) elems))))))
268 (nreverse elems)))))
270 (defsubst geiser-syntax--keywordp (s)
271 (and s (symbolp s) (string-match "^:.+" (symbol-name s))))
273 (defsubst geiser-syntax--symbol-eq (s0 s1)
274 (and (symbolp s0) (symbolp s1) (equal (symbol-name s0) (symbol-name s1))))
276 (defun geiser-syntax--scan-sexps (&optional begin)
277 (let* ((fst (geiser-syntax--symbol-at-point))
278 (smth (or fst (not (looking-at-p "[\s \s)\s>\s<\n]"))))
279 (path (and fst `((,fst 0)))))
280 (save-excursion
281 (while (not (zerop (geiser-syntax--nesting-level)))
282 (let ((boundary (point)))
283 (geiser-syntax--skip-comment/string)
284 (backward-up-list)
285 (let ((form (geiser-syntax--shallow-form boundary)))
286 (when (and (listp form) (car form) (symbolp (car form)))
287 (let* ((len (geiser-syntax--pair-length form))
288 (pos (if smth (1- len) (progn (setq smth t) len)))
289 (prev (and (> pos 1) (nth (1- pos) form)))
290 (prev (and (geiser-syntax--keywordp prev)
291 (list prev))))
292 (push `(,(car form) ,pos ,@prev) path)))))))
293 (mapcar (lambda (e)
294 (cons (substring-no-properties (format "%s" (car e))) (cdr e)))
295 (nreverse path))))
297 (defsubst geiser-syntax--binding-form-p (bfs sbfs f)
298 (and (symbolp f)
299 (let ((f (symbol-name f)))
300 (or (member f '("define" "define*" "define-syntax"
301 "syntax-rules" "lambda" "case-lambda"
302 "let" "let*" "let-values" "let*-values"
303 "letrec" "letrec*" "parameterize"))
304 (member f bfs)
305 (member f sbfs)))))
307 (defsubst geiser-syntax--binding-form*-p (sbfs f)
308 (and (symbolp f)
309 (let ((f (symbol-name f)))
310 (or (member f '("let*" "let*-values" "letrec" "letrec*"))
311 (member f sbfs)))))
313 (defsubst geiser-syntax--if-symbol (x) (and (symbolp x) x))
314 (defsubst geiser-syntax--if-list (x) (and (listp x) x))
316 (defsubst geiser-syntax--normalize (vars)
317 (mapcar (lambda (i)
318 (let ((i (if (listp i) (car i) i)))
319 (and (symbolp i) (symbol-name i))))
320 vars))
322 (defun geiser-syntax--linearize (form)
323 (cond ((not (listp form)) (list form))
324 ((null form) nil)
325 (t (cons (car form) (geiser-syntax--linearize (cdr form))))))
327 (defun geiser-syntax--scan-locals (bfs sbfs form nesting locals)
328 (if (or (null form) (not (listp form)))
329 (geiser-syntax--normalize locals)
330 (if (not (geiser-syntax--binding-form-p bfs sbfs (car form)))
331 (geiser-syntax--scan-locals bfs sbfs
332 (car (last form))
333 (1- nesting) locals)
334 (let* ((head (car form))
335 (name (geiser-syntax--if-symbol (cadr form)))
336 (names (if name (geiser-syntax--if-list (caddr form))
337 (geiser-syntax--if-list (cadr form))))
338 (bns (and name
339 (geiser-syntax--binding-form-p bfs sbfs (car names))))
340 (rest (if (and name (not bns)) (cdddr form) (cddr form)))
341 (use-names (and (or rest
342 (< nesting 1)
343 (geiser-syntax--binding-form*-p sbfs head))
344 (not bns))))
345 (when name (push name locals))
346 (when (geiser-syntax--symbol-eq head 'case-lambda)
347 (dolist (n (and (> nesting 0) (caar (last form))))
348 (when n (push n locals)))
349 (setq rest (and (> nesting 0) (cdr form)))
350 (setq use-names nil))
351 (when (geiser-syntax--symbol-eq head 'syntax-rules)
352 (dolist (n (and (> nesting 0) (cdaar (last form))))
353 (when n (push n locals)))
354 (setq rest (and (> nesting 0) (cdr form))))
355 (when use-names
356 (dolist (n (geiser-syntax--linearize names))
357 (let ((xs (if (and (listp n) (listp (car n))) (car n) (list n))))
358 (dolist (x xs) (when x (push x locals))))))
359 (dolist (f (butlast rest))
360 (when (and (listp f)
361 (geiser-syntax--symbol-eq (car f) 'define)
362 (cadr f))
363 (push (cadr f) locals)))
364 (geiser-syntax--scan-locals bfs sbfs
365 (car (last (or rest names)))
366 (1- nesting)
367 locals)))))
369 (defun geiser-syntax--locals-around-point (bfs sbfs)
370 (when (eq major-mode 'scheme-mode)
371 (save-excursion
372 (let ((sym (unless (geiser-syntax--skip-comment/string)
373 (thing-at-point 'symbol))))
374 (skip-syntax-forward "->")
375 (let ((boundary (point))
376 (nesting (geiser-syntax--nesting-level)))
377 (while (not (zerop (geiser-syntax--nesting-level)))
378 (backward-up-list))
379 (multiple-value-bind (form end)
380 (geiser-syntax--form-after-point boundary)
381 (delete sym
382 (geiser-syntax--scan-locals bfs
383 sbfs
384 form
385 (1- nesting)
386 '()))))))))
389 ;;; Fontify strings as Scheme code:
391 (defun geiser-syntax--font-lock-buffer ()
392 (let ((name " *geiser font lock*"))
393 (or (get-buffer name)
394 (let ((buffer (get-buffer-create name)))
395 (set-buffer buffer)
396 (let ((geiser-default-implementation
397 (or geiser-default-implementation
398 (car geiser-active-implementations))))
399 (scheme-mode))
400 buffer))))
402 (defun geiser-syntax--scheme-str (str)
403 (save-current-buffer
404 (set-buffer (geiser-syntax--font-lock-buffer))
405 (erase-buffer)
406 (insert str)
407 (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
408 (buffer-string)))
411 (provide 'geiser-syntax)