1 ;;; geiser-syntax.el -- utilities for parsing scheme syntax
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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
)
20 (eval-when-compile (require 'cl
))
25 (defmacro geiser-syntax--scheme-indent
(&rest pairs
)
26 `(progn ,@(mapcar (lambda (p)
27 `(put ',(car p
) 'scheme-indent-function
',(cadr p
)))
30 (geiser-syntax--scheme-indent
49 (with-error-to-port 1)
53 ;;; Extra syntax keywords
54 (defconst geiser-syntax--keywords
55 `(("\\[\\(else\\)\\>" .
1)
56 ("(\\(parameterize\\)\\>" .
1)
57 (,(rx "(" (group "define-syntax-rule") eow
(* space
)
58 (?
"(") (?
(group (1+ word
))))
59 (1 font-lock-keyword-face
)
60 (2 font-lock-function-name-face nil t
))))
62 (font-lock-add-keywords 'scheme-mode geiser-syntax--keywords
)
64 (geiser-impl--define-caller geiser-syntax--impl-kws keywords
()
65 "A variable (or thunk returning a value) giving additional,
66 implementation-specific entries for font-lock-keywords.")
68 (geiser-impl--define-caller geiser-syntax--case-sensitive case-sensitive
()
69 "A flag saying whether keywords are case sensitive.")
71 (defun geiser-syntax--add-kws ()
72 (when (not (and (boundp 'quack-mode
) quack-mode
))
73 (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation
))
74 (cs (geiser-syntax--case-sensitive geiser-impl--implementation
)))
75 (when kw
(font-lock-add-keywords nil kw
))
76 (setq font-lock-keywords-case-fold-search
(not cs
)))))
79 ;;; A simple scheme reader
81 (defvar geiser-syntax--read
/buffer-limit nil
)
83 (defsubst geiser-syntax--read
/eos
()
85 (and geiser-syntax--read
/buffer-limit
86 (<= geiser-syntax--read
/buffer-limit
(point)))))
88 (defsubst geiser-syntax--read
/next-char
()
89 (unless (geiser-syntax--read/eos
)
93 (defsubst geiser-syntax--read
/token
(token)
94 (geiser-syntax--read/next-char
)
95 (if (listp token
) token
(list token
)))
97 (defsubst geiser-syntax--read
/elisp
()
98 (ignore-errors (read (current-buffer))))
100 (defun geiser-syntax--read/symbol
()
101 (with-syntax-table scheme-mode-syntax-table
102 (when (re-search-forward "\\(\\sw\\|\\s_\\)+" nil t
)
103 (make-symbol (match-string-no-properties 0)))))
105 (defun geiser-syntax--read/matching
(open close
)
108 (while (and (> count
0)
109 (geiser-syntax--read/next-char
))
110 (cond ((looking-at-p open
) (setq count
(1+ count
)))
111 ((looking-at-p close
) (setq count
(1- count
)))))
112 (buffer-substring-no-properties p
(point))))
114 (defsubst geiser-syntax--read
/unprintable
()
115 (geiser-syntax--read/token
116 (cons 'unprintable
(geiser-syntax--read/matching
"<" ">"))))
118 (defun geiser-syntax--read/skip-comment
()
119 (while (and (geiser-syntax--read/next-char
)
120 (nth 8 (syntax-ppss))))
121 (geiser-syntax--read/next-token
))
123 (defun geiser-syntax--read/next-token
()
124 (skip-syntax-forward "->")
125 (if (geiser-syntax--read/eos
) '(eob)
127 (?\
; (geiser-syntax--read/skip-comment))
128 ((?\
( ?\
[) (geiser-syntax--read/token
'lparen
))
129 ((?\
) ?\
]) (geiser-syntax--read/token
'rparen
))
130 (?.
(if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
131 (geiser-syntax--read/token
'dot
)
132 (cons 'atom
(geiser-syntax--read/elisp
))))
133 (?\
# (case (geiser-syntax--read/next-char
)
135 (?|
(geiser-syntax--read/skip-comment
))
136 (?
: (if (geiser-syntax--read/next-char
)
137 (cons 'kwd
(geiser-syntax--read/symbol
))
139 (?
\\ (cons 'char
(geiser-syntax--read/elisp
)))
140 (?\
( (geiser-syntax--read/token
'vectorb
))
141 (?\
< (geiser-syntax--read/unprintable
))
142 ((?
' ?
` ?
,) (geiser-syntax--read/next-token
))
143 (t (let ((tok (geiser-syntax--read/symbol
)))
144 (cond ((equal (symbol-name tok
) "t") '(boolean .
:t
))
145 ((equal (symbol-name tok
) "f") '(boolean .
:f
))
146 (tok (cons 'atom tok
))
147 (t (geiser-syntax--read/next-token
)))))))
148 (?
\' (geiser-syntax--read/token
'(quote . quote
)))
149 (?\
` (geiser-syntax--read/token
150 `(backquote .
,backquote-backquote-symbol
)))
151 (?
, (if (eq (geiser-syntax--read/next-char
) ?
@)
152 (geiser-syntax--read/token
153 `(splice .
,backquote-splice-symbol
))
154 `(unquote .
,backquote-unquote-symbol
)))
155 (?
\" (cons 'string
(geiser-syntax--read/elisp
)))
156 (t (cons 'atom
(geiser-syntax--read/symbol
))))))
158 (defsubst geiser-syntax--read
/match
(&rest tks
)
159 (let ((token (geiser-syntax--read/next-token
)))
160 (if (memq (car token
) tks
) token
161 (error "Unexpected token: %s" token
))))
163 (defsubst geiser-syntax--read
/skip-until
(&rest tks
)
165 (while (and (not (memq (car token
) tks
))
166 (not (eq (car token
) 'eob
)))
167 (setq token
(geiser-syntax--read/next-token
)))
170 (defsubst geiser-syntax--read
/try
(&rest tks
)
172 (tk (ignore-errors (apply 'geiser-syntax--read
/match tks
))))
173 (unless tk
(goto-char p
))
176 (defun geiser-syntax--read/list
()
177 (cond ((geiser-syntax--read/try
'dot
)
178 (let ((tail (geiser-syntax--read)))
179 (geiser-syntax--read/skip-until
'eob
'rparen
)
181 ((geiser-syntax--read/try
'rparen
'eob
) nil
)
182 (t (cons (geiser-syntax--read)
183 (geiser-syntax--read/list
)))))
185 (defun geiser-syntax--read ()
186 (let ((token (geiser-syntax--read/next-token
))
187 (max-lisp-eval-depth (max max-lisp-eval-depth
3000)))
190 (lparen (geiser-syntax--read/list
))
191 (vectorb (apply 'vector
(geiser-syntax--read/list
)))
192 ((quote backquote unquote splice
) (list (cdr token
)
193 (geiser-syntax--read)))
194 (kwd (make-symbol (format ":%s" (cdr token
))))
195 (unprintable (format "#<%s>" (cdr token
)))
196 ((char string atom
) (cdr token
))
197 (boolean (cdr token
))
198 (t (error "Reading scheme syntax: unexpected token: %s" token
)))))
200 (defun geiser-syntax--read-from-string (string &optional start end
)
201 (when (stringp string
)
202 (let* ((start (or start
0))
203 (end (or end
(length string
)))
204 (max-lisp-eval-depth (min 20000
205 (max max-lisp-eval-depth
(- end start
)))))
207 (save-excursion (insert string
))
208 (cons (ignore-errors (geiser-syntax--read)) (point))))))
210 (defun geiser-syntax--form-from-string (s)
211 (car (geiser-syntax--read-from-string s
)))
213 (defsubst geiser-syntax--form-after-point
(&optional boundary
)
214 (let ((geiser-syntax--read/buffer-limit
(and (numberp boundary
) boundary
)))
215 (save-excursion (values (geiser-syntax--read) (point)))))
217 (defun geiser-syntax--mapconcat (fun lst sep
)
218 (cond ((null lst
) "")
219 ((not (listp lst
)) (format ".%s%s" sep
(funcall fun lst
)))
220 ((null (cdr lst
)) (format "%s" (funcall fun
(car lst
))))
222 (funcall fun
(car lst
))
224 (geiser-syntax--mapconcat fun
(cdr lst
) sep
)))))
226 (defun geiser-syntax--display (a)
227 (cond ((null a
) "()")
230 ((geiser-syntax--keywordp a
) (format "#%s" a
))
231 ((symbolp a
) (format "%s" a
))
232 ((equal a
"...") "...")
233 ((stringp a
) (format "%S" a
))
234 ((and (listp a
) (symbolp (car a
))
235 (equal (symbol-name (car a
)) "quote"))
236 (format "'%s" (geiser-syntax--display (cadr a
))))
239 (geiser-syntax--mapconcat 'geiser-syntax--display a
" ")))
240 (t (format "%s" a
))))
245 (defsubst geiser-syntax--symbol-at-point
()
246 (and (not (nth 8 (syntax-ppss)))
247 (car (geiser-syntax--read-from-string (thing-at-point 'symbol
)))))
249 (defsubst geiser-syntax--skip-comment
/string
()
250 (let ((pos (nth 8 (syntax-ppss))))
251 (goto-char (or pos
(point)))
254 (defsubst geiser-syntax--nesting-level
()
255 (or (nth 0 (syntax-ppss)) 0))
257 (defsubst geiser-syntax--in-string-p
()
258 (nth 3 (syntax-ppss)))
260 (defsubst geiser-syntax--pair-length
(p)
261 (if (cdr (last p
)) (1+ (safe-length p
)) (length p
)))
263 (defun geiser-syntax--shallow-form (boundary)
264 (when (looking-at-p "\\s(")
269 (while (< (point) boundary
)
270 (skip-syntax-forward "-<>")
271 (when (<= (point) boundary
)
273 (let ((s (thing-at-point 'symbol
)))
274 (unless (equal "." s
)
275 (push (car (geiser-syntax--read-from-string s
)) elems
))))))
278 (defsubst geiser-syntax--keywordp
(s)
279 (and s
(symbolp s
) (string-match "^:.+" (symbol-name s
))))
281 (defsubst geiser-syntax--symbol-eq
(s0 s1
)
282 (and (symbolp s0
) (symbolp s1
) (equal (symbol-name s0
) (symbol-name s1
))))
284 (defun geiser-syntax--scan-sexps (&optional begin
)
285 (let* ((fst (geiser-syntax--symbol-at-point))
286 (smth (or fst
(not (looking-at-p "[\s \s)\s>\s<\n]"))))
287 (path (and fst
`((,fst
0)))))
289 (while (not (zerop (geiser-syntax--nesting-level)))
290 (let ((boundary (point)))
291 (geiser-syntax--skip-comment/string
)
293 (let ((form (geiser-syntax--shallow-form boundary
)))
294 (when (and (listp form
) (car form
) (symbolp (car form
)))
295 (let* ((len (geiser-syntax--pair-length form
))
296 (pos (if smth
(1- len
) (progn (setq smth t
) len
)))
297 (prev (and (> pos
1) (nth (1- pos
) form
)))
298 (prev (and (geiser-syntax--keywordp prev
)
300 (push `(,(car form
) ,pos
,@prev
) path
)))))))
302 (cons (substring-no-properties (format "%s" (car e
))) (cdr e
)))
305 (defsubst geiser-syntax--binding-form-p
(bfs sbfs f
)
307 (let ((f (symbol-name f
)))
308 (or (member f
'("define" "define*" "define-syntax"
309 "syntax-rules" "lambda" "case-lambda"
310 "let" "let*" "let-values" "let*-values"
311 "letrec" "letrec*" "parameterize"))
315 (defsubst geiser-syntax--binding-form
*-p
(sbfs f
)
317 (let ((f (symbol-name f
)))
318 (or (member f
'("let*" "let*-values" "letrec" "letrec*"))
321 (defsubst geiser-syntax--if-symbol
(x) (and (symbolp x
) x
))
322 (defsubst geiser-syntax--if-list
(x) (and (listp x
) x
))
324 (defsubst geiser-syntax--normalize
(vars)
326 (let ((i (if (listp i
) (car i
) i
)))
327 (and (symbolp i
) (symbol-name i
))))
330 (defun geiser-syntax--linearize (form)
331 (cond ((not (listp form
)) (list form
))
333 (t (cons (car form
) (geiser-syntax--linearize (cdr form
))))))
335 (defun geiser-syntax--scan-locals (bfs sbfs form nesting locals
)
336 (if (or (null form
) (not (listp form
)))
337 (geiser-syntax--normalize locals
)
338 (if (not (geiser-syntax--binding-form-p bfs sbfs
(car form
)))
339 (geiser-syntax--scan-locals bfs sbfs
342 (let* ((head (car form
))
343 (name (geiser-syntax--if-symbol (cadr form
)))
344 (names (if name
(geiser-syntax--if-list (caddr form
))
345 (geiser-syntax--if-list (cadr form
))))
347 (geiser-syntax--binding-form-p bfs sbfs
(car names
))))
348 (rest (if (and name
(not bns
)) (cdddr form
) (cddr form
)))
349 (use-names (and (or rest
351 (geiser-syntax--binding-form*-p sbfs head
))
353 (when name
(push name locals
))
354 (when (geiser-syntax--symbol-eq head
'case-lambda
)
355 (dolist (n (and (> nesting
0) (caar (last form
))))
356 (when n
(push n locals
)))
357 (setq rest
(and (> nesting
0) (cdr form
)))
358 (setq use-names nil
))
359 (when (geiser-syntax--symbol-eq head
'syntax-rules
)
360 (dolist (n (and (> nesting
0) (cdaar (last form
))))
361 (when n
(push n locals
)))
362 (setq rest
(and (> nesting
0) (cdr form
))))
364 (dolist (n (geiser-syntax--linearize names
))
365 (let ((xs (if (and (listp n
) (listp (car n
))) (car n
) (list n
))))
366 (dolist (x xs
) (when x
(push x locals
))))))
367 (dolist (f (butlast rest
))
369 (geiser-syntax--symbol-eq (car f
) 'define
)
371 (push (cadr f
) locals
)))
372 (geiser-syntax--scan-locals bfs sbfs
373 (car (last (or rest names
)))
377 (defun geiser-syntax--locals-around-point (bfs sbfs
)
378 (when (eq major-mode
'scheme-mode
)
380 (let ((sym (unless (geiser-syntax--skip-comment/string
)
381 (thing-at-point 'symbol
))))
382 (skip-syntax-forward "->")
383 (let ((boundary (point))
384 (nesting (geiser-syntax--nesting-level)))
385 (while (not (zerop (geiser-syntax--nesting-level)))
387 (multiple-value-bind (form end
)
388 (geiser-syntax--form-after-point boundary
)
390 (geiser-syntax--scan-locals bfs
397 ;;; Fontify strings as Scheme code:
399 (defun geiser-syntax--font-lock-buffer ()
400 (let ((name " *geiser font lock*"))
401 (or (get-buffer name
)
402 (let ((buffer (get-buffer-create name
)))
404 (let ((geiser-default-implementation
405 (or geiser-default-implementation
406 (car geiser-active-implementations
))))
410 (defun geiser-syntax--scheme-str (str)
412 (set-buffer (geiser-syntax--font-lock-buffer))
415 (let ((font-lock-verbose nil
)) (font-lock-fontify-buffer))
419 (provide 'geiser-syntax
)