/[slime]/slime/contrib/slime-parse.el
ViewVC logotype

Contents of /slime/contrib/slime-parse.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (show annotations)
Sat Sep 18 20:47:29 2010 UTC (3 years, 6 months ago) by trittweiler
Branch: MAIN
CVS Tags: SLIME-2-3, FAIRLY-STABLE, byte-stream, SLIME-2-2
Changes since 1.38: +7 -4 lines
	* slime-parse.el (slime-parse-form-upto-point): Fix lp#627308.

	* slime-autodoc.el (slime-canonicalize-whitespace): New
	helper. Extracted out of `slime-format-autodoc'.
	(slime-autodoc-to-string): New helper.
	(slime-check-autodoc-at-point): Use it.
	(autodoc.1): Add test case for above fix.
1
2 (define-slime-contrib slime-parse
3 "Utility contrib containg functions to parse forms in a buffer."
4 (:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
5 "Tobias C. Rittweiler <tcr@freebits.de>")
6 (:license "GPL"))
7
8 (defun slime-parse-form-until (limit form-suffix)
9 "Parses form from point to `limit'."
10 ;; For performance reasons, this function does not use recursion.
11 (let ((todo (list (point))) ; stack of positions
12 (sexps) ; stack of expressions
13 (cursexp)
14 (curpos)
15 (depth 1)) ; This function must be called from the
16 ; start of the sexp to be parsed.
17 (while (and (setq curpos (pop todo))
18 (progn
19 (goto-char curpos)
20 ;; (Here we also move over suppressed
21 ;; reader-conditionalized code! Important so CL-side
22 ;; of autodoc won't see that garbage.)
23 (ignore-errors (slime-forward-cruft))
24 (< (point) limit)))
25 (setq cursexp (pop sexps))
26 (cond
27 ;; End of an sexp?
28 ((or (looking-at "\\s)") (eolp))
29 (decf depth)
30 (push (nreverse cursexp) (car sexps)))
31 ;; Start of a new sexp?
32 ((looking-at "\\s'*\\s(")
33 (let ((subpt (match-end 0)))
34 (ignore-errors
35 (forward-sexp)
36 ;; (In case of error, we're at an incomplete sexp, and
37 ;; nothing's left todo after it.)
38 (push (point) todo))
39 (push cursexp sexps)
40 (push subpt todo) ; to descend into new sexp
41 (push nil sexps)
42 (incf depth)))
43 ;; In mid of an sexp..
44 (t
45 (let ((pt1 (point))
46 (pt2 (condition-case e
47 (progn (forward-sexp) (point))
48 (scan-error
49 (fourth e))))) ; end of sexp
50 (push (buffer-substring-no-properties pt1 pt2) cursexp)
51 (push pt2 todo)
52 (push cursexp sexps)))))
53 (when sexps
54 (setf (car sexps) (nreconc form-suffix (car sexps)))
55 (while (> depth 1)
56 (push (nreverse (pop sexps)) (car sexps))
57 (decf depth))
58 (nreverse (car sexps)))))
59
60 (defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped)
61 "Returns t if the character that `get-char-fn' yields has
62 characer syntax of `syntax'. If `unescaped' is true, it's ensured
63 that the character is not escaped."
64 (let ((char (funcall get-char-fn (point)))
65 (char-before (funcall get-char-fn (1- (point)))))
66 (if (and char (eq (char-syntax char) (aref syntax 0)))
67 (if unescaped
68 (or (null char-before)
69 (not (eq (char-syntax char-before) ?\\)))
70 t)
71 nil)))
72
73 (defconst slime-cursor-marker 'swank::%cursor-marker%)
74
75 (defun slime-parse-form-upto-point (&optional max-levels)
76 (save-restriction
77 ;; Don't parse more than 500 lines before point, so we don't spend
78 ;; too much time. NB. Make sure to go to beginning of line, and
79 ;; not possibly anywhere inside comments or strings.
80 (narrow-to-region (line-beginning-position -500) (point-max))
81 (save-excursion
82 (let ((suffix (list slime-cursor-marker)))
83 (cond ((slime-compare-char-syntax #'char-after "(" t)
84 ;; We're at the start of some expression, so make sure
85 ;; that SWANK::%CURSOR-MARKER% will come after that
86 ;; expression. If the expression is not balanced, make
87 ;; still sure that the marker does *not* come directly
88 ;; after the preceding expression.
89 (or (ignore-errors (forward-sexp) t)
90 (push "" suffix)))
91 ((or (bolp) (slime-compare-char-syntax #'char-before " " t))
92 ;; We're after some expression, so we have to make sure
93 ;; that %CURSOR-MARKER% does *not* come directly after
94 ;; that expression.
95 (push "" suffix))
96 ((slime-compare-char-syntax #'char-before "(" t)
97 ;; We're directly after an opening parenthesis, so we
98 ;; have to make sure that something comes before
99 ;; %CURSOR-MARKER%.
100 (push "" suffix))
101 (t
102 ;; We're at a symbol, so make sure we get the whole symbol.
103 (slime-end-of-symbol)))
104 (let ((pt (point)))
105 (ignore-errors (up-list (if max-levels (- max-levels) -5)))
106 (ignore-errors (down-list))
107 (slime-parse-form-until pt suffix))))))
108
109 (let ((byte-compile-warnings '()))
110 (mapc #'byte-compile
111 '(slime-parse-form-upto-point
112 slime-parse-form-until
113 slime-compare-char-syntax
114 )))
115
116 ;;;; Test cases
117
118 (defun slime-check-buffer-form (result-form)
119 (slime-test-expect
120 (format "Buffer form correct in `%s' (at %d)" (buffer-string) (point))
121 result-form
122 (slime-parse-form-upto-point 10)))
123
124 (def-slime-test form-up-to-point.1
125 (buffer-sexpr result-form &optional skip-trailing-test-p)
126 ""
127 '(("(char= #\\(*HERE*" ("char=" "#\\(" swank::%cursor-marker%))
128 ("(char= #\\( *HERE*" ("char=" "#\\(" "" swank::%cursor-marker%))
129 ("(char= #\\) *HERE*" ("char=" "#\\)" "" swank::%cursor-marker%))
130 ("(char= #\\*HERE*" ("char=" "#\\" swank::%cursor-marker%) t)
131 ("(defun*HERE*" ("defun" swank::%cursor-marker%))
132 ("(defun foo*HERE*" ("defun" "foo" swank::%cursor-marker%))
133 ("(defun foo (x y)*HERE*" ("defun" "foo" ("x" "y") swank::%cursor-marker%))
134 ("(defun foo (x y*HERE*" ("defun" "foo" ("x" "y" swank::%cursor-marker%)))
135 ("(apply 'foo*HERE*" ("apply" "'foo" swank::%cursor-marker%))
136 ("(apply #'foo*HERE*" ("apply" "#'foo" swank::%cursor-marker%))
137 ("(declare ((vector bit *HERE*" ("declare" (("vector" "bit" "" swank::%cursor-marker%))))
138 ("(with-open-file (*HERE*" ("with-open-file" ("" swank::%cursor-marker%)))
139 ("(((*HERE*" ((("" swank::%cursor-marker%))))
140 ("(defun #| foo #| *HERE*" ("defun" "" swank::%cursor-marker%))
141 ("(defun #-(and) (bar) f*HERE*" ("defun" "f" swank::%cursor-marker%))
142 ("(remove-if #'(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
143 ("`(remove-if ,(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
144 ("`(remove-if ,@(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") swank::%cursor-marker%))))
145 (slime-check-top-level)
146 (with-temp-buffer
147 (lisp-mode)
148 (insert buffer-sexpr)
149 (search-backward "*HERE*")
150 (delete-region (match-beginning 0) (match-end 0))
151 (slime-check-buffer-form result-form)
152 (unless skip-trailing-test-p
153 (insert ")") (backward-char)
154 (slime-check-buffer-form result-form))
155 ))
156
157 (defun slime-trace-query (spec)
158 "Ask the user which function to trace; SPEC is the default.
159 The result is a string."
160 (cond ((null spec)
161 (slime-read-from-minibuffer "(Un)trace: "))
162 ((stringp spec)
163 (slime-read-from-minibuffer "(Un)trace: " spec))
164 ((symbolp spec) ; `slime-extract-context' can return symbols.
165 (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
166 (t
167 (destructure-case spec
168 ((setf n)
169 (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
170 ((:defun n)
171 (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
172 ((:defgeneric n)
173 (let* ((name (prin1-to-string n))
174 (answer (slime-read-from-minibuffer "(Un)trace: " name)))
175 (cond ((and (string= name answer)
176 (y-or-n-p (concat "(Un)trace also all "
177 "methods implementing "
178 name "? ")))
179 (prin1-to-string `(:defgeneric ,n)))
180 (t
181 answer))))
182 ((:defmethod &rest _)
183 (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
184 ((:call caller callee)
185 (let* ((callerstr (prin1-to-string caller))
186 (calleestr (prin1-to-string callee))
187 (answer (slime-read-from-minibuffer "(Un)trace: "
188 calleestr)))
189 (cond ((and (string= calleestr answer)
190 (y-or-n-p (concat "(Un)trace only when " calleestr
191 " is called by " callerstr "? ")))
192 (prin1-to-string `(:call ,caller ,callee)))
193 (t
194 answer))))
195 (((:labels :flet) &rest _)
196 (slime-read-from-minibuffer "(Un)trace local function: "
197 (prin1-to-string spec)))
198 (t (error "Don't know how to trace the spec %S" spec))))))
199
200 (defun slime-extract-context ()
201 "Parse the context for the symbol at point.
202 Nil is returned if there's no symbol at point. Otherwise we detect
203 the following cases (the . shows the point position):
204
205 (defun n.ame (...) ...) -> (:defun name)
206 (defun (setf n.ame) (...) ...) -> (:defun (setf name))
207 (defmethod n.ame (...) ...) -> (:defmethod name (...))
208 (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name)
209 (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name)
210 (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name)
211 (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name))
212
213 (defmacro n.ame (...) ...) -> (:defmacro name)
214 (defsetf n.ame (...) ...) -> (:defsetf name)
215 (define-setf-expander n.ame (...) ...) -> (:define-setf-expander name)
216 (define-modify-macro n.ame (...) ...) -> (:define-modify-macro name)
217 (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
218 (defvar n.ame (...) ...) -> (:defvar name)
219 (defparameter n.ame ...) -> (:defparameter name)
220 (defconstant n.ame ...) -> (:defconstant name)
221 (defclass n.ame ...) -> (:defclass name)
222 (defstruct n.ame ...) -> (:defstruct name)
223 (defpackage n.ame ...) -> (:defpackage name)
224 For other contexts we return the symbol at point."
225 (let ((name (slime-symbol-at-point)))
226 (if name
227 (let ((symbol (read name)))
228 (or (progn ;;ignore-errors
229 (slime-parse-context symbol))
230 symbol)))))
231
232 (defun slime-parse-context (name)
233 (save-excursion
234 (cond ((slime-in-expression-p '(defun *)) `(:defun ,name))
235 ((slime-in-expression-p '(defmacro *)) `(:defmacro ,name))
236 ((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name))
237 ((slime-in-expression-p '(setf *))
238 ;;a setf-definition, but which?
239 (backward-up-list 1)
240 (slime-parse-context `(setf ,name)))
241 ((slime-in-expression-p '(defmethod *))
242 (unless (looking-at "\\s ")
243 (forward-sexp 1)) ; skip over the methodname
244 (let (qualifiers arglist)
245 (loop for e = (read (current-buffer))
246 until (listp e) do (push e qualifiers)
247 finally (setq arglist e))
248 `(:defmethod ,name ,@qualifiers
249 ,(slime-arglist-specializers arglist))))
250 ((and (symbolp name)
251 (slime-in-expression-p `(,name)))
252 ;; looks like a regular call
253 (let ((toplevel (ignore-errors (slime-parse-toplevel-form))))
254 (cond ((slime-in-expression-p `(setf (*))) ;a setf-call
255 (if toplevel
256 `(:call ,toplevel (setf ,name))
257 `(setf ,name)))
258 ((not toplevel)
259 name)
260 ((slime-in-expression-p `(labels ((*))))
261 `(:labels ,toplevel ,name))
262 ((slime-in-expression-p `(flet ((*))))
263 `(:flet ,toplevel ,name))
264 (t
265 `(:call ,toplevel ,name)))))
266 ((slime-in-expression-p '(define-compiler-macro *))
267 `(:define-compiler-macro ,name))
268 ((slime-in-expression-p '(define-modify-macro *))
269 `(:define-modify-macro ,name))
270 ((slime-in-expression-p '(define-setf-expander *))
271 `(:define-setf-expander ,name))
272 ((slime-in-expression-p '(defsetf *))
273 `(:defsetf ,name))
274 ((slime-in-expression-p '(defvar *)) `(:defvar ,name))
275 ((slime-in-expression-p '(defparameter *)) `(:defparameter ,name))
276 ((slime-in-expression-p '(defconstant *)) `(:defconstant ,name))
277 ((slime-in-expression-p '(defclass *)) `(:defclass ,name))
278 ((slime-in-expression-p '(defpackage *)) `(:defpackage ,name))
279 ((slime-in-expression-p '(defstruct *))
280 `(:defstruct ,(if (consp name)
281 (car name)
282 name)))
283 (t
284 name))))
285
286
287 (defun slime-in-expression-p (pattern)
288 "A helper function to determine the current context.
289 The pattern can have the form:
290 pattern ::= () ;matches always
291 | (*) ;matches inside a list
292 | (<symbol> <pattern>) ;matches if the first element in
293 ; the current list is <symbol> and
294 ; if <pattern> matches.
295 | ((<pattern>)) ;matches if we are in a nested list."
296 (save-excursion
297 (let ((path (reverse (slime-pattern-path pattern))))
298 (loop for p in path
299 always (ignore-errors
300 (etypecase p
301 (symbol (slime-beginning-of-list)
302 (eq (read (current-buffer)) p))
303 (number (backward-up-list p)
304 t)))))))
305
306 (defun slime-pattern-path (pattern)
307 ;; Compute the path to the * in the pattern to make matching
308 ;; easier. The path is a list of symbols and numbers. A number
309 ;; means "(down-list <n>)" and a symbol "(look-at <sym>)")
310 (if (null pattern)
311 '()
312 (etypecase (car pattern)
313 ((member *) '())
314 (symbol (cons (car pattern) (slime-pattern-path (cdr pattern))))
315 (cons (cons 1 (slime-pattern-path (car pattern)))))))
316
317 (defun slime-beginning-of-list (&optional up)
318 "Move backward to the beginning of the current expression.
319 Point is placed before the first expression in the list."
320 (backward-up-list (or up 1))
321 (down-list 1)
322 (skip-syntax-forward " "))
323
324 (defun slime-end-of-list (&optional up)
325 (backward-up-list (or up 1))
326 (forward-list 1)
327 (down-list -1))
328
329 (defun slime-parse-toplevel-form ()
330 (ignore-errors ; (foo)
331 (save-excursion
332 (goto-char (car (slime-region-for-defun-at-point)))
333 (down-list 1)
334 (forward-sexp 1)
335 (slime-parse-context (read (current-buffer))))))
336
337 (defun slime-arglist-specializers (arglist)
338 (cond ((or (null arglist)
339 (member (first arglist) '(&optional &key &rest &aux)))
340 (list))
341 ((consp (first arglist))
342 (cons (second (first arglist))
343 (slime-arglist-specializers (rest arglist))))
344 (t
345 (cons 't
346 (slime-arglist-specializers (rest arglist))))))
347
348 (defun slime-definition-at-point (&optional only-functional)
349 "Return object corresponding to the definition at point."
350 (let ((toplevel (slime-parse-toplevel-form)))
351 (if (or (symbolp toplevel)
352 (and only-functional
353 (not (member (car toplevel)
354 '(:defun :defgeneric :defmethod
355 :defmacro :define-compiler-macro)))))
356 (error "Not in a definition")
357 (destructure-case toplevel
358 (((:defun :defgeneric) symbol)
359 (format "#'%s" symbol))
360 (((:defmacro :define-modify-macro) symbol)
361 (format "(macro-function '%s)" symbol))
362 ((:define-compiler-macro symbol)
363 (format "(compiler-macro-function '%s)" symbol))
364 ((:defmethod symbol &rest args)
365 (declare (ignore args))
366 (format "#'%s" symbol))
367 (((:defparameter :defvar :defconstant) symbol)
368 (format "'%s" symbol))
369 (((:defclass :defstruct) symbol)
370 (format "(find-class '%s)" symbol))
371 ((:defpackage symbol)
372 (format "(or (find-package '%s) (error \"Package %s not found\"))"
373 symbol symbol))
374 (t
375 (error "Not in a definition"))))))
376
377 ;; FIXME: not used here; move it away
378 (if (and (featurep 'emacs) (>= emacs-major-version 22))
379 ;; N.B. The 2nd, and 6th return value cannot be relied upon.
380 (defsubst slime-current-parser-state ()
381 ;; `syntax-ppss' does not save match data as it invokes
382 ;; `beginning-of-defun' implicitly which does not save match
383 ;; data. This issue has been reported to the Emacs maintainer on
384 ;; Feb27.
385 (syntax-ppss))
386 (defsubst slime-current-parser-state ()
387 (let ((original-pos (point)))
388 (save-excursion
389 (beginning-of-defun)
390 (parse-partial-sexp (point) original-pos)))))
391
392 (defun slime-inside-string-p ()
393 (nth 3 (slime-current-parser-state)))
394
395 (defun slime-inside-comment-p ()
396 (nth 4 (slime-current-parser-state)))
397
398 (defun slime-inside-string-or-comment-p ()
399 (let ((state (slime-current-parser-state)))
400 (or (nth 3 state) (nth 4 state))))
401
402 ;;; The following two functions can be handy when inspecting
403 ;;; source-location while debugging `M-.'.
404 ;;;
405 (defun slime-current-tlf-number ()
406 "Return the current toplevel number."
407 (interactive)
408 (let ((original-pos (car (slime-region-for-defun-at-point)))
409 (n 0))
410 (save-excursion
411 ;; We use this and no repeated `beginning-of-defun's to get
412 ;; reader conditionals right.
413 (goto-char (point-min))
414 (while (progn (slime-forward-sexp)
415 (< (point) original-pos))
416 (incf n)))
417 n))
418
419 ;;; This is similiar to `slime-enclosing-form-paths' in the
420 ;;; `slime-parse' contrib except that this does not do any duck-tape
421 ;;; parsing, and gets reader conditionals right.
422 (defun slime-current-form-path ()
423 "Returns the path from the beginning of the current toplevel
424 form to the atom at point, or nil if we're in front of a tlf."
425 (interactive)
426 (let ((source-path nil))
427 (save-excursion
428 ;; Moving forward to get reader conditionals right.
429 (loop for inner-pos = (point)
430 for outer-pos = (nth-value 1 (slime-current-parser-state))
431 while outer-pos do
432 (goto-char outer-pos)
433 (unless (eq (char-before) ?#) ; when at #(...) continue.
434 (forward-char)
435 (let ((n 0))
436 (while (progn (slime-forward-sexp)
437 (< (point) inner-pos))
438 (incf n))
439 (push n source-path)
440 (goto-char outer-pos)))))
441 source-path))
442
443 (provide 'slime-parse)

  ViewVC Help
Powered by ViewVC 1.1.5