1 ;;; geiser-syntax.el -- utilities for parsing scheme syntax
3 ;; Copyright (C) 2009, 2010 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
64 (parameterize-break 1)
88 ;;; A simple scheme reader
90 (defvar geiser-syntax--read
/buffer-limit nil
)
92 (defsubst geiser-syntax--read
/eos
()
94 (and geiser-syntax--read
/buffer-limit
95 (<= geiser-syntax--read
/buffer-limit
(point)))))
97 (defsubst geiser-syntax--read
/next-char
()
98 (unless (geiser-syntax--read/eos
)
102 (defsubst geiser-syntax--read
/token
(token)
103 (geiser-syntax--read/next-char
)
104 (if (listp token
) token
(list token
)))
106 (defsubst geiser-syntax--read
/elisp
()
107 (ignore-errors (read (current-buffer))))
109 (defun geiser-syntax--read/matching
(open close
)
112 (while (and (> count
0)
113 (geiser-syntax--read/next-char
))
114 (cond ((looking-at-p open
) (setq count
(1+ count
)))
115 ((looking-at-p close
) (setq count
(1- count
)))))
116 (buffer-substring-no-properties p
(point))))
118 (defsubst geiser-syntax--read
/unprintable
()
119 (geiser-syntax--read/token
120 (cons 'unprintable
(geiser-syntax--read/matching
"<" ">"))))
122 (defun geiser-syntax--read/skip-comment
()
123 (while (and (geiser-syntax--read/next-char
)
124 (nth 8 (syntax-ppss))))
125 (geiser-syntax--read/next-token
))
127 (defun geiser-syntax--read/next-token
()
128 (skip-syntax-forward "->")
129 (if (geiser-syntax--read/eos
) '(eob)
131 (?\
; (geiser-syntax--read/skip-comment))
132 ((?\
( ?\
[) (geiser-syntax--read/token
'lparen
))
133 ((?\
) ?\
]) (geiser-syntax--read/token
'rparen
))
134 (?.
(if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
135 (geiser-syntax--read/token
'dot
)
136 (cons 'atom
(geiser-syntax--read/elisp
))))
137 (?\
# (case (geiser-syntax--read/next-char
)
139 (?|
(geiser-syntax--read/skip-comment
))
140 (?
: (if (geiser-syntax--read/next-char
)
141 (cons 'kwd
(geiser-syntax--read/elisp
))
143 (?
\\ (cons 'char
(geiser-syntax--read/elisp
)))
144 (?\
( (geiser-syntax--read/token
'vectorb
))
145 (?\
< (geiser-syntax--read/unprintable
))
146 ((?
' ?
` ?
,) (geiser-syntax--read/next-token
))
147 (t (let ((tok (geiser-syntax--read/elisp
)))
148 (if tok
(cons 'atom
(intern (format "#%s" tok
)))
149 (geiser-syntax--read/next-token
))))))
150 (?
\' (geiser-syntax--read/token
'(quote . quote
)))
151 (?\
` (geiser-syntax--read/token
152 `(backquote .
,backquote-backquote-symbol
)))
153 (?
, (if (eq (geiser-syntax--read/next-char
) ?
@)
154 (geiser-syntax--read/token
155 `(splice .
,backquote-splice-symbol
))
156 `(unquote .
,backquote-unquote-symbol
)))
157 (?
\" (cons 'string
(geiser-syntax--read/elisp
)))
158 (t (cons 'atom
(geiser-syntax--read/elisp
))))))
160 (defsubst geiser-syntax--read
/match
(&rest tks
)
161 (let ((token (geiser-syntax--read/next-token
)))
162 (if (memq (car token
) tks
) token
163 (error "Unexpected token: %s" token
))))
165 (defsubst geiser-syntax--read
/skip-until
(&rest tks
)
167 (while (and (not (memq (car token
) tks
))
168 (not (eq (car token
) 'eob
)))
169 (setq token
(geiser-syntax--read/next-token
)))
172 (defsubst geiser-syntax--read
/try
(&rest tks
)
174 (tk (ignore-errors (apply 'geiser-syntax--read
/match tks
))))
175 (unless tk
(goto-char p
))
178 (defun geiser-syntax--read/list
()
179 (cond ((geiser-syntax--read/try
'dot
)
180 (let ((tail (geiser-syntax--read)))
181 (geiser-syntax--read/skip-until
'eob
'rparen
)
183 ((geiser-syntax--read/try
'rparen
'eob
) nil
)
184 (t (cons (geiser-syntax--read)
185 (geiser-syntax--read/list
)))))
187 (defun geiser-syntax--read ()
188 (let ((token (geiser-syntax--read/next-token
))
189 (max-lisp-eval-depth (max max-lisp-eval-depth
3000)))
192 (lparen (geiser-syntax--read/list
))
193 (vectorb (apply 'vector
(geiser-syntax--read/list
)))
194 ((quote backquote unquote splice
) (list (cdr token
)
195 (geiser-syntax--read)))
196 (kwd (intern (format ":%s" (cdr token
))))
197 (unprintable (format "#<%s>" (cdr token
)))
198 ((char string atom
) (cdr token
))
199 (t (error "Reading scheme syntax: unexpected token: %s" token
)))))
201 (defun geiser-syntax--read-from-string (string &optional start end
)
202 (when (stringp string
)
203 (let* ((start (or start
0))
204 (end (or end
(length string
)))
205 (max-lisp-eval-depth (max max-lisp-eval-depth
(- end start
))))
207 (save-excursion (insert string
))
208 (cons (ignore-errors (geiser-syntax--read)) (point))))))
210 (defsubst geiser-syntax--form-after-point
(&optional boundary
)
211 (let ((geiser-syntax--read/buffer-limit
(and (numberp boundary
) boundary
)))
212 (save-excursion (values (geiser-syntax--read) (point)))))
217 (defsubst geiser-syntax--symbol-at-point
()
218 (and (not (nth 8 (syntax-ppss))) (symbol-at-point)))
220 (defsubst geiser-syntax--skip-comment
/string
()
221 (let ((pos (nth 8 (syntax-ppss))))
222 (goto-char (or pos
(point)))
225 (defsubst geiser-syntax--nesting-level
()
226 (or (nth 0 (syntax-ppss)) 0))
228 (defsubst geiser-syntax--pair-length
(p)
229 (if (cdr (last p
)) (1+ (safe-length p
)) (length p
)))
231 (defun geiser-syntax--shallow-form (boundary)
232 (when (looking-at-p "\\s(")
237 (while (< (point) boundary
)
238 (skip-syntax-forward "-<>")
239 (when (<= (point) boundary
)
241 (let ((s (symbol-at-point)))
242 (when (not (eq s
'.
)) (push (symbol-at-point) elems
))))))
245 (defun geiser-syntax--scan-sexps (&optional begin
)
246 (let* ((fst (geiser-syntax--symbol-at-point))
247 (smth (or fst
(not (looking-at-p "[\s \s)\s>\s<\n]"))))
248 (path (and fst
`((,fst
0)))))
250 (while (not (zerop (geiser-syntax--nesting-level)))
251 (let ((boundary (point)))
252 (geiser-syntax--skip-comment/string
)
254 (let ((form (geiser-syntax--shallow-form boundary
)))
255 (when (and (listp form
) (car form
) (symbolp (car form
)))
256 (let* ((len (geiser-syntax--pair-length form
))
257 (pos (if smth
(1- len
) (progn (setq smth t
) len
)))
258 (prev (and (> pos
1) (nth (1- pos
) form
)))
259 (prev (and (keywordp prev
) (list prev
))))
260 (push `(,(car form
) ,pos
,@prev
) path
)))))))
263 (defsubst geiser-syntax--binding-form-p
(bfs sbfs f
)
264 (or (memq f
'(define define
* define-syntax define-syntax-rule
265 lambda let let
* letrec parameterize
))
269 (defsubst geiser-syntax--binding-form
*-p
(sbfs f
)
270 (or (eq 'let
* f
) (memq f sbfs
)))
272 (defsubst geiser-syntax--if-symbol
(x) (and (symbolp x
) x
))
273 (defsubst geiser-syntax--if-list
(x) (and (listp x
) x
))
274 (defsubst geiser-syntax--normalize
(vars)
275 (mapcar (lambda (i) (if (listp i
) (car i
) i
)) vars
))
277 (defun geiser-syntax--linearize (form)
278 (cond ((not (listp form
)) (list form
))
280 (t (cons (car form
) (geiser-syntax--linearize (cdr form
))))))
282 (defun geiser-syntax--scan-locals (bfs sbfs form partial locals
)
283 (if (or (null form
) (not (listp form
)))
284 (geiser-syntax--normalize locals
)
285 (if (not (geiser-syntax--binding-form-p bfs sbfs
(car form
)))
286 (geiser-syntax--scan-locals bfs sbfs
287 (car (last form
)) partial locals
)
288 (let* ((head (car form
))
289 (name (geiser-syntax--if-symbol (cadr form
)))
290 (names (if name
(geiser-syntax--if-list (caddr form
))
291 (geiser-syntax--if-list (cadr form
))))
292 (rest (if name
(cdddr form
) (cddr form
)))
295 (geiser-syntax--binding-form*-p sbfs
297 (when name
(push name locals
))
299 (dolist (n (geiser-syntax--linearize names
))
301 (dolist (f (butlast rest
))
302 (when (and (listp f
) (eq (car f
) 'define
))
303 (push (cadr f
) locals
)))
304 (geiser-syntax--scan-locals bfs sbfs
305 (car (last (or rest names
)))
309 (defun geiser-syntax--locals-around-point (bfs sbfs
)
310 (when (eq major-mode
'scheme-mode
)
312 (let* ((sym (unless (geiser-syntax--skip-comment/string
)
315 (while (not (zerop (geiser-syntax--nesting-level)))
317 (multiple-value-bind (form end
)
318 (geiser-syntax--form-after-point boundary
)
320 (geiser-syntax--scan-locals bfs sbfs form
321 (> end boundary
) '())))))))
324 ;;; Fontify strings as Scheme code:
326 (defun geiser-syntax--font-lock-buffer ()
327 (let ((name " *geiser font lock*"))
328 (or (get-buffer name
)
329 (let ((buffer (get-buffer-create name
)))
331 (let ((geiser-default-implementation
332 (or geiser-default-implementation
333 (car geiser-active-implementations
))))
337 (defun geiser-syntax--scheme-str (str)
339 (set-buffer (geiser-syntax--font-lock-buffer))
342 (let ((font-lock-verbose nil
)) (font-lock-fontify-buffer))
346 (provide 'geiser-syntax
)
347 ;;; geiser-syntax.el ends here