/usr/share/emacs/site-lisp/slime/contrib/slime-enclosing-context.el is in slime 2:2.18-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | (require 'slime)
(require 'slime-parse)
(define-slime-contrib slime-enclosing-context
"Utilities on top of slime-parse."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL"))
(defun slime-parse-sexp-at-point (&optional n)
"Returns the sexps at point as a list of strings, otherwise nil.
\(If there are not as many sexps as N, a list with < N sexps is
returned.\)
If SKIP-BLANKS-P is true, leading whitespaces &c are skipped.
"
(interactive "p") (or n (setq n 1))
(save-excursion
(let ((result nil))
(dotimes (i n)
;; Is there an additional sexp in front of us?
(save-excursion
(unless (slime-point-moves-p (ignore-errors (forward-sexp)))
(return)))
(push (slime-sexp-at-point) result)
;; Skip current sexp
(ignore-errors (forward-sexp) (skip-chars-forward "[:space:]")))
(nreverse result))))
(defun slime-has-symbol-syntax-p (string)
(if (and string (not (zerop (length string))))
(member (char-syntax (aref string 0))
'(?w ?_ ?\' ?\\))))
(defun slime-parse-extended-operator-name (user-point forms indices points)
"Assume that point is directly at the operator that should be parsed.
USER-POINT is the value of `point' where the user was looking at.
OPS, INDICES and POINTS are updated to reflect the new values after
parsing, and are then returned back as multiple values."
;; OPS, INDICES and POINTS are like the finally returned values of
;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order,
;; i.e. the leftmost operator comes first.
(save-excursion
(ignore-errors
(let* ((current-op (first (first forms)))
(op-name (upcase (slime-cl-symbol-name current-op)))
(assoc (assoc op-name slime-extended-operator-name-parser-alist))
(entry (cdr assoc))
(parser (if (and entry (listp entry))
(apply (first entry) (rest entry))
entry)))
(ignore-errors
(forward-char (1+ (length current-op)))
(skip-chars-forward "[:space:]"))
(when parser
(multiple-value-setq (forms indices points)
;; We pass the fully qualified name (`current-op'), so it's the
;; fully qualified name that will be sent to SWANK.
(funcall parser current-op user-point forms indices points))))))
(values forms indices points))
(defun slime-parse-extended-operator-name (user-point forms indices points)
"Assume that point is directly at the operator that should be parsed.
USER-POINT is the value of `point' where the user was looking at.
OPS, INDICES and POINTS are updated to reflect the new values after
parsing, and are then returned back as multiple values."
;; OPS, INDICES and POINTS are like the finally returned values of
;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order,
;; i.e. the leftmost operator comes first.
(save-excursion
(ignore-errors
(let* ((current-op (first (first forms)))
(op-name (upcase (slime-cl-symbol-name current-op)))
(assoc (assoc op-name slime-extended-operator-name-parser-alist))
(entry (cdr assoc))
(parser (if (and entry (listp entry))
(apply (first entry) (rest entry))
entry)))
(ignore-errors
(forward-char (1+ (length current-op)))
(skip-chars-forward "[:space:]"))
(when parser
(multiple-value-setq (forms indices points)
;; We pass the fully qualified name (`current-op'), so it's the
;; fully qualified name that will be sent to SWANK.
(funcall parser current-op user-point forms indices points))))))
(values forms indices points))
(defun slime-beginning-of-string ()
(let* ((parser-state (slime-current-parser-state))
(inside-string-p (nth 3 parser-state))
(string-start-pos (nth 8 parser-state)))
(if inside-string-p
(goto-char string-start-pos)
(error "We're not within a string"))))
(defun slime-enclosing-form-specs (&optional max-levels)
"Return the list of ``raw form specs'' of all the forms
containing point from right to left.
As a secondary value, return a list of indices: Each index tells
for each corresponding form spec in what argument position the
user's point is.
As tertiary value, return the positions of the operators that are
contained in the returned form specs.
When MAX-LEVELS is non-nil, go up at most this many levels of
parens.
\(See SWANK::PARSE-FORM-SPEC for more information about what
exactly constitutes a ``raw form specs'')
Examples:
A return value like the following
(values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3))
can be interpreted as follows:
The user point is located in the 3rd argument position of a
form with the operator name \"quux\" (which starts at P1.)
This form is located in the 2nd argument position of a form
with the operator name \"bar\" (which starts at P2.)
This form again is in the 1st argument position of a form
with the operator name \"foo\" (which itself begins at P3.)
For instance, the corresponding buffer content could have looked
like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point.
"
(let ((level 1)
(parse-sexp-lookup-properties nil)
(initial-point (point))
(result '()) (arg-indices '()) (points '()))
;; The expensive lookup of syntax-class text properties is only
;; used for interactive balancing of #<...> in presentations; we
;; do not need them in navigating through the nested lists.
;; This speeds up this function significantly.
(ignore-errors
(save-excursion
;; Make sure we get the whole thing at point.
(if (not (slime-inside-string-p))
(slime-end-of-symbol)
(slime-beginning-of-string)
(forward-sexp))
(save-restriction
;; Don't parse more than 20000 characters before point, so we don't spend
;; too much time.
(narrow-to-region (max (point-min) (- (point) 20000)) (point-max))
(narrow-to-region (save-excursion (beginning-of-defun) (point))
(min (1+ (point)) (point-max)))
(while (or (not max-levels)
(<= level max-levels))
(let ((arg-index 0))
;; Move to the beginning of the current sexp if not already there.
(if (or (and (char-after)
(member (char-syntax (char-after)) '(?\( ?')))
(member (char-syntax (char-before)) '(?\ ?>)))
(incf arg-index))
(ignore-errors (backward-sexp 1))
(while (and (< arg-index 64)
(ignore-errors (backward-sexp 1)
(> (point) (point-min))))
(incf arg-index))
(backward-up-list 1)
(when (member (char-syntax (char-after)) '(?\( ?'))
(incf level)
(forward-char 1)
(let ((name (slime-symbol-at-point)))
(cond
(name
(save-restriction
(widen) ; to allow looking-ahead/back in extended parsing.
(multiple-value-bind (new-result new-indices new-points)
(slime-parse-extended-operator-name
initial-point
(cons `(,name) result) ; minimal form spec
(cons arg-index arg-indices)
(cons (point) points))
(setq result new-result)
(setq arg-indices new-indices)
(setq points new-points))))
(t
(push nil result)
(push arg-index arg-indices)
(push (point) points))))
(backward-up-list 1)))))))
(cl-values
(nreverse result)
(nreverse arg-indices)
(nreverse points))))
(defvar slime-variable-binding-ops-alist
'((let &bindings &body)
(let* &bindings &body)))
(defvar slime-function-binding-ops-alist
'((flet &bindings &body)
(labels &bindings &body)
(macrolet &bindings &body)))
(defun slime-lookup-binding-op (op &optional binding-type)
(cl-labels ((lookup-in (list) (cl-assoc op list :test 'equalp :key 'symbol-name)))
(cond ((eq binding-type :variable) (lookup-in slime-variable-binding-ops-alist))
((eq binding-type :function) (lookup-in slime-function-binding-ops-alist))
(t (or (lookup-in slime-variable-binding-ops-alist)
(lookup-in slime-function-binding-ops-alist))))))
(defun slime-binding-op-p (op &optional binding-type)
(and (slime-lookup-binding-op op binding-type) t))
(defun slime-binding-op-body-pos (op)
(let ((special-lambda-list (slime-lookup-binding-op op)))
(if special-lambda-list (cl-position '&body special-lambda-list))))
(defun slime-binding-op-bindings-pos (op)
(let ((special-lambda-list (slime-lookup-binding-op op)))
(if special-lambda-list (cl-position '&bindings special-lambda-list))))
(defun slime-enclosing-bound-names ()
"Returns all bound function names as first value, and the
points where their bindings are established as second value."
(cl-multiple-value-call #'slime-find-bound-names
(slime-enclosing-form-specs)))
(defun slime-find-bound-names (ops indices points)
(let ((binding-names) (binding-start-points))
(save-excursion
(cl-loop for (op . nil) in ops
for index in indices
for point in points
do (when (and (slime-binding-op-p op)
;; Are the bindings of OP in scope?
(>= index (slime-binding-op-body-pos op)))
(goto-char point)
(forward-sexp (slime-binding-op-bindings-pos op))
(down-list)
(ignore-errors
(cl-loop
(down-list)
(push (slime-symbol-at-point) binding-names)
(push (save-excursion (backward-up-list) (point))
binding-start-points)
(up-list)))))
(cl-values (nreverse binding-names) (nreverse binding-start-points)))))
(defun slime-enclosing-bound-functions ()
(cl-multiple-value-call #'slime-find-bound-functions
(slime-enclosing-form-specs)))
(defun slime-find-bound-functions (ops indices points)
(let ((names) (arglists) (start-points))
(save-excursion
(cl-loop for (op . nil) in ops
for index in indices
for point in points
do (when (and (slime-binding-op-p op :function)
;; Are the bindings of OP in scope?
(>= index (slime-binding-op-body-pos op)))
(goto-char point)
(forward-sexp (slime-binding-op-bindings-pos op))
(down-list)
;; If we're at the end of the bindings, an error will
;; be signalled by the `down-list' below.
(ignore-errors
(cl-loop
(down-list)
(cl-destructuring-bind (name arglist)
(slime-parse-sexp-at-point 2)
(cl-assert (slime-has-symbol-syntax-p name))
(cl-assert arglist)
(push name names)
(push arglist arglists)
(push (save-excursion (backward-up-list) (point))
start-points))
(up-list)))))
(cl-values (nreverse names)
(nreverse arglists)
(nreverse start-points)))))
(defun slime-enclosing-bound-macros ()
(cl-multiple-value-call #'slime-find-bound-macros
(slime-enclosing-form-specs)))
(defun slime-find-bound-macros (ops indices points)
;; Kludgy!
(let ((slime-function-binding-ops-alist '((macrolet &bindings &body))))
(slime-find-bound-functions ops indices points)))
(provide 'slime-enclosing-context)
|