Whitespace
[geiser.git] / elisp / geiser-syntax.el
blob162d90921e1de765c5c57a66be3afefee1380484
1 ;;; geiser-syntax.el -- utilities for parsing scheme syntax
3 ;; Copyright (C) 2009, 2010, 2011, 2012 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 (begin0 1)
32 (c-declare 0)
33 (c-lambda 2)
34 (case-lambda 0)
35 (case-lambda: 0)
36 (catch defun)
37 (class defun)
38 (class* defun)
39 (compound-unit/sig 0)
40 (define: defun)
41 (dynamic-wind 0)
42 (instantiate 2)
43 (interface 1)
44 (lambda: 1)
45 (lambda/kw 1)
46 (let*-values 1)
47 (let*-values: 1)
48 (let+ 1)
49 (let: 1)
50 (letrec: 1)
51 (letrec* 1)
52 (letrec-values 1)
53 (letrec-values: 1)
54 (let-values 1)
55 (let-values: 1)
56 (let/cc: 1)
57 (let/ec 1)
58 (match defun)
59 (mixin 2)
60 (module defun)
61 (opt-lambda 1)
62 (parameterize 1)
63 (parameterize-break 1)
64 (parameterize* 1)
65 (pmatch defun)
66 (quasisyntax/loc 1)
67 (receive 2)
68 (send* 1)
69 (sigaction 1)
70 (syntax-case 2)
71 (syntax-id-rules defun)
72 (syntax/loc 1)
73 (type-case defun)
74 (unit defun)
75 (unit/sig 2)
76 (unless 1)
77 (when 1)
78 (while 1)
79 (with-fluid* 1)
80 (with-fluids 1)
81 (with-fluids* 1)
82 (with-handlers 1)
83 (with-handlers: 1)
84 (with-method 1)
85 (with-error-to-port 1)
86 (with-syntax 1))
89 ;;; Extra syntax keywords
90 (defconst geiser-syntax--keywords
91 '(("\\[\\(else\\)\\>" . 1)
92 ("(\\(parameterize\\)\\>" . 1)))
94 (font-lock-add-keywords 'scheme-mode geiser-syntax--keywords)
96 (geiser-impl--define-caller geiser-syntax--impl-kws keywords ()
97 "A variable (or thunk returning a value) giving additional,
98 implementation-specific entries for font-lock-keywords.")
100 (defun geiser-syntax--add-kws ()
101 (when (not (and (boundp 'quack-mode) quack-mode))
102 (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation)))
103 (when kw (font-lock-add-keywords nil kw)))))
106 ;;; A simple scheme reader
108 (defvar geiser-syntax--read/buffer-limit nil)
110 (defsubst geiser-syntax--read/eos ()
111 (or (eobp)
112 (and geiser-syntax--read/buffer-limit
113 (<= geiser-syntax--read/buffer-limit (point)))))
115 (defsubst geiser-syntax--read/next-char ()
116 (unless (geiser-syntax--read/eos)
117 (forward-char)
118 (char-after)))
120 (defsubst geiser-syntax--read/token (token)
121 (geiser-syntax--read/next-char)
122 (if (listp token) token (list token)))
124 (defsubst geiser-syntax--read/elisp ()
125 (ignore-errors (read (current-buffer))))
127 (defun geiser-syntax--read/symbol ()
128 (with-syntax-table scheme-mode-syntax-table
129 (when (re-search-forward "\\(\\sw\\|\\s_\\)+" nil t)
130 (make-symbol (match-string-no-properties 0)))))
132 (defun geiser-syntax--read/matching (open close)
133 (let ((count 1)
134 (p (1+ (point))))
135 (while (and (> count 0)
136 (geiser-syntax--read/next-char))
137 (cond ((looking-at-p open) (setq count (1+ count)))
138 ((looking-at-p close) (setq count (1- count)))))
139 (buffer-substring-no-properties p (point))))
141 (defsubst geiser-syntax--read/unprintable ()
142 (geiser-syntax--read/token
143 (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))
145 (defun geiser-syntax--read/skip-comment ()
146 (while (and (geiser-syntax--read/next-char)
147 (nth 8 (syntax-ppss))))
148 (geiser-syntax--read/next-token))
150 (defun geiser-syntax--read/next-token ()
151 (skip-syntax-forward "->")
152 (if (geiser-syntax--read/eos) '(eob)
153 (case (char-after)
154 (?\; (geiser-syntax--read/skip-comment))
155 ((?\( ?\[) (geiser-syntax--read/token 'lparen))
156 ((?\) ?\]) (geiser-syntax--read/token 'rparen))
157 (?. (if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
158 (geiser-syntax--read/token 'dot)
159 (cons 'atom (geiser-syntax--read/elisp))))
160 (?\# (case (geiser-syntax--read/next-char)
161 ('nil '(eob))
162 (?| (geiser-syntax--read/skip-comment))
163 (?: (if (geiser-syntax--read/next-char)
164 (cons 'kwd (geiser-syntax--read/symbol))
165 '(eob)))
166 (?\\ (cons 'char (geiser-syntax--read/elisp)))
167 (?\( (geiser-syntax--read/token 'vectorb))
168 (?\< (geiser-syntax--read/unprintable))
169 ((?' ?` ?,) (geiser-syntax--read/next-token))
170 (t (let ((tok (geiser-syntax--read/symbol)))
171 (cond ((equal (symbol-name tok) "t") '(boolean . :t))
172 ((equal (symbol-name tok) "f") '(boolean . :f))
173 (tok (cons 'atom tok))
174 (t (geiser-syntax--read/next-token)))))))
175 (?\' (geiser-syntax--read/token '(quote . quote)))
176 (?\` (geiser-syntax--read/token
177 `(backquote . ,backquote-backquote-symbol)))
178 (?, (if (eq (geiser-syntax--read/next-char) ?@)
179 (geiser-syntax--read/token
180 `(splice . ,backquote-splice-symbol))
181 `(unquote . ,backquote-unquote-symbol)))
182 (?\" (cons 'string (geiser-syntax--read/elisp)))
183 (t (cons 'atom (geiser-syntax--read/symbol))))))
185 (defsubst geiser-syntax--read/match (&rest tks)
186 (let ((token (geiser-syntax--read/next-token)))
187 (if (memq (car token) tks) token
188 (error "Unexpected token: %s" token))))
190 (defsubst geiser-syntax--read/skip-until (&rest tks)
191 (let (token)
192 (while (and (not (memq (car token) tks))
193 (not (eq (car token) 'eob)))
194 (setq token (geiser-syntax--read/next-token)))
195 token))
197 (defsubst geiser-syntax--read/try (&rest tks)
198 (let ((p (point))
199 (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
200 (unless tk (goto-char p))
201 tk))
203 (defun geiser-syntax--read/list ()
204 (cond ((geiser-syntax--read/try 'dot)
205 (let ((tail (geiser-syntax--read)))
206 (geiser-syntax--read/skip-until 'eob 'rparen)
207 tail))
208 ((geiser-syntax--read/try 'rparen 'eob) nil)
209 (t (cons (geiser-syntax--read)
210 (geiser-syntax--read/list)))))
212 (defun geiser-syntax--read ()
213 (let ((token (geiser-syntax--read/next-token))
214 (max-lisp-eval-depth (max max-lisp-eval-depth 3000)))
215 (case (car token)
216 (eob nil)
217 (lparen (geiser-syntax--read/list))
218 (vectorb (apply 'vector (geiser-syntax--read/list)))
219 ((quote backquote unquote splice) (list (cdr token)
220 (geiser-syntax--read)))
221 (kwd (make-symbol (format ":%s" (cdr token))))
222 (unprintable (format "#<%s>" (cdr token)))
223 ((char string atom) (cdr token))
224 (boolean (cdr token))
225 (t (error "Reading scheme syntax: unexpected token: %s" token)))))
227 (defun geiser-syntax--read-from-string (string &optional start end)
228 (when (stringp string)
229 (let* ((start (or start 0))
230 (end (or end (length string)))
231 (max-lisp-eval-depth (max max-lisp-eval-depth (- end start))))
232 (with-temp-buffer
233 (save-excursion (insert string))
234 (cons (ignore-errors (geiser-syntax--read)) (point))))))
236 (defsubst geiser-syntax--form-after-point (&optional boundary)
237 (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary)))
238 (save-excursion (values (geiser-syntax--read) (point)))))
240 (defun geiser-syntax--mapconcat (fun lst sep)
241 (cond ((null lst) "")
242 ((not (listp lst)) (format ".%s%s" sep (funcall fun lst)))
243 ((null (cdr lst)) (format "%s" (funcall fun (car lst))))
244 (t (format "%s%s%s"
245 (funcall fun (car lst))
247 (geiser-syntax--mapconcat fun (cdr lst) sep)))))
249 (defun geiser-syntax--display (a)
250 (cond ((null a) "()")
251 ((eq a :t) "#t")
252 ((eq a :f) "#f")
253 ((geiser-syntax--keywordp a) (format "#%s" a))
254 ((symbolp a) (format "%s" a))
255 ((equal a "...") "...")
256 ((stringp a) (format "%S" a))
257 ((and (listp a) (symbolp (car a))
258 (equal (symbol-name (car a)) "quote"))
259 (format "'%s" (geiser-syntax--display (cadr a))))
260 ((listp a)
261 (format "(%s)"
262 (geiser-syntax--mapconcat 'geiser-syntax--display a " ")))
263 (t (format "%s" a))))
266 ;;; Code parsing:
268 (defsubst geiser-syntax--symbol-at-point ()
269 (and (not (nth 8 (syntax-ppss)))
270 (car (geiser-syntax--read-from-string (thing-at-point 'symbol)))))
272 (defsubst geiser-syntax--skip-comment/string ()
273 (let ((pos (nth 8 (syntax-ppss))))
274 (goto-char (or pos (point)))
275 pos))
277 (defsubst geiser-syntax--nesting-level ()
278 (or (nth 0 (syntax-ppss)) 0))
280 (defsubst geiser-syntax--pair-length (p)
281 (if (cdr (last p)) (1+ (safe-length p)) (length p)))
283 (defun geiser-syntax--shallow-form (boundary)
284 (when (looking-at-p "\\s(")
285 (save-excursion
286 (forward-char)
287 (let ((elems))
288 (ignore-errors
289 (while (< (point) boundary)
290 (skip-syntax-forward "-<>")
291 (when (<= (point) boundary)
292 (forward-sexp)
293 (let ((s (thing-at-point 'symbol)))
294 (unless (equal "." s)
295 (push (car (geiser-syntax--read-from-string s)) elems))))))
296 (nreverse elems)))))
298 (defsubst geiser-syntax--keywordp (s)
299 (and s (symbolp s) (string-match "^:.+" (symbol-name s))))
301 (defsubst geiser-syntax--symbol-eq (s0 s1)
302 (and (symbolp s0) (symbolp s1) (equal (symbol-name s0) (symbol-name s1))))
304 (defun geiser-syntax--scan-sexps (&optional begin)
305 (let* ((fst (geiser-syntax--symbol-at-point))
306 (smth (or fst (not (looking-at-p "[\s \s)\s>\s<\n]"))))
307 (path (and fst `((,fst 0)))))
308 (save-excursion
309 (while (not (zerop (geiser-syntax--nesting-level)))
310 (let ((boundary (point)))
311 (geiser-syntax--skip-comment/string)
312 (backward-up-list)
313 (let ((form (geiser-syntax--shallow-form boundary)))
314 (when (and (listp form) (car form) (symbolp (car form)))
315 (let* ((len (geiser-syntax--pair-length form))
316 (pos (if smth (1- len) (progn (setq smth t) len)))
317 (prev (and (> pos 1) (nth (1- pos) form)))
318 (prev (and (geiser-syntax--keywordp prev)
319 (list prev))))
320 (push `(,(car form) ,pos ,@prev) path)))))))
321 (mapcar (lambda (e)
322 (cons (substring-no-properties (format "%s" (car e))) (cdr e)))
323 (nreverse path))))
325 (defsubst geiser-syntax--binding-form-p (bfs sbfs f)
326 (and (symbolp f)
327 (let ((f (symbol-name f)))
328 (or (member f '("define" "define*" "define-syntax"
329 "syntax-rules" "lambda" "case-lambda"
330 "let" "let*" "let-values" "let*-values"
331 "letrec" "letrec*" "parameterize"))
332 (member f bfs)
333 (member f sbfs)))))
335 (defsubst geiser-syntax--binding-form*-p (sbfs f)
336 (and (symbolp f)
337 (let ((f (symbol-name f)))
338 (or (member f '("let*" "let*-values" "letrec" "letrec*"))
339 (member f sbfs)))))
341 (defsubst geiser-syntax--if-symbol (x) (and (symbolp x) x))
342 (defsubst geiser-syntax--if-list (x) (and (listp x) x))
344 (defsubst geiser-syntax--normalize (vars)
345 (mapcar (lambda (i)
346 (let ((i (if (listp i) (car i) i)))
347 (and (symbolp i) (symbol-name i))))
348 vars))
350 (defun geiser-syntax--linearize (form)
351 (cond ((not (listp form)) (list form))
352 ((null form) nil)
353 (t (cons (car form) (geiser-syntax--linearize (cdr form))))))
355 (defun geiser-syntax--scan-locals (bfs sbfs form nesting locals)
356 (if (or (null form) (not (listp form)))
357 (geiser-syntax--normalize locals)
358 (if (not (geiser-syntax--binding-form-p bfs sbfs (car form)))
359 (geiser-syntax--scan-locals bfs sbfs
360 (car (last form))
361 (1- nesting) locals)
362 (let* ((head (car form))
363 (name (geiser-syntax--if-symbol (cadr form)))
364 (names (if name (geiser-syntax--if-list (caddr form))
365 (geiser-syntax--if-list (cadr form))))
366 (bns (and name
367 (geiser-syntax--binding-form-p bfs sbfs (car names))))
368 (rest (if (and name (not bns)) (cdddr form) (cddr form)))
369 (use-names (and (or rest
370 (< nesting 1)
371 (geiser-syntax--binding-form*-p sbfs head))
372 (not bns))))
373 (when name (push name locals))
374 (when (geiser-syntax--symbol-eq head 'case-lambda)
375 (dolist (n (and (> nesting 0) (caar (last form))))
376 (when n (push n locals)))
377 (setq rest (and (> nesting 0) (cdr form)))
378 (setq use-names nil))
379 (when (geiser-syntax--symbol-eq head 'syntax-rules)
380 (dolist (n (and (> nesting 0) (cdaar (last form))))
381 (when n (push n locals)))
382 (setq rest (and (> nesting 0) (cdr form))))
383 (when use-names
384 (dolist (n (geiser-syntax--linearize names))
385 (let ((xs (if (and (listp n) (listp (car n))) (car n) (list n))))
386 (dolist (x xs) (when x (push x locals))))))
387 (dolist (f (butlast rest))
388 (when (and (listp f)
389 (geiser-syntax--symbol-eq (car f) 'define)
390 (cadr f))
391 (push (cadr f) locals)))
392 (geiser-syntax--scan-locals bfs sbfs
393 (car (last (or rest names)))
394 (1- nesting)
395 locals)))))
397 (defun geiser-syntax--locals-around-point (bfs sbfs)
398 (when (eq major-mode 'scheme-mode)
399 (save-excursion
400 (let ((sym (unless (geiser-syntax--skip-comment/string)
401 (thing-at-point 'symbol))))
402 (skip-syntax-forward "->")
403 (let ((boundary (point))
404 (nesting (geiser-syntax--nesting-level)))
405 (while (not (zerop (geiser-syntax--nesting-level)))
406 (backward-up-list))
407 (multiple-value-bind (form end)
408 (geiser-syntax--form-after-point boundary)
409 (delete sym
410 (geiser-syntax--scan-locals bfs
411 sbfs
412 form
413 (1- nesting)
414 '()))))))))
417 ;;; Fontify strings as Scheme code:
419 (defun geiser-syntax--font-lock-buffer ()
420 (let ((name " *geiser font lock*"))
421 (or (get-buffer name)
422 (let ((buffer (get-buffer-create name)))
423 (set-buffer buffer)
424 (let ((geiser-default-implementation
425 (or geiser-default-implementation
426 (car geiser-active-implementations))))
427 (scheme-mode))
428 buffer))))
430 (defun geiser-syntax--scheme-str (str)
431 (save-current-buffer
432 (set-buffer (geiser-syntax--font-lock-buffer))
433 (erase-buffer)
434 (insert str)
435 (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
436 (buffer-string)))
439 (provide 'geiser-syntax)