Klimi's new dotfiles with stow.
Você não pode selecionar mais de 25 tópicos Os tópicos devem começar com uma letra ou um número, podem incluir traços ('-') e podem ter até 35 caracteres.
 
 
 
 
 
 

358 linhas
14 KiB

(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-parse
"Utility contrib containg functions to parse forms in a buffer."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL"))
(defun slime-parse-form-until (limit form-suffix)
"Parses form from point to `limit'."
;; For performance reasons, this function does not use recursion.
(let ((todo (list (point))) ; stack of positions
(sexps) ; stack of expressions
(cursexp)
(curpos)
(depth 1)) ; This function must be called from the
; start of the sexp to be parsed.
(while (and (setq curpos (pop todo))
(progn
(goto-char curpos)
;; (Here we also move over suppressed
;; reader-conditionalized code! Important so CL-side
;; of autodoc won't see that garbage.)
(ignore-errors (slime-forward-cruft))
(< (point) limit)))
(setq cursexp (pop sexps))
(cond
;; End of an sexp?
((or (looking-at "\\s)") (eolp))
(cl-decf depth)
(push (nreverse cursexp) (car sexps)))
;; Start of a new sexp?
((looking-at "\\s'*@*\\s(")
(let ((subpt (match-end 0)))
(ignore-errors
(forward-sexp)
;; (In case of error, we're at an incomplete sexp, and
;; nothing's left todo after it.)
(push (point) todo))
(push cursexp sexps)
(push subpt todo) ; to descend into new sexp
(push nil sexps)
(cl-incf depth)))
;; In mid of an sexp..
(t
(let ((pt1 (point))
(pt2 (condition-case e
(progn (forward-sexp) (point))
(scan-error
(cl-fourth e))))) ; end of sexp
(push (buffer-substring-no-properties pt1 pt2) cursexp)
(push pt2 todo)
(push cursexp sexps)))))
(when sexps
(setf (car sexps) (cl-nreconc form-suffix (car sexps)))
(while (> depth 1)
(push (nreverse (pop sexps)) (car sexps))
(cl-decf depth))
(nreverse (car sexps)))))
(defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped)
"Returns t if the character that `get-char-fn' yields has
characer syntax of `syntax'. If `unescaped' is true, it's ensured
that the character is not escaped."
(let ((char (funcall get-char-fn (point)))
(char-before (funcall get-char-fn (1- (point)))))
(if (and char (eq (char-syntax char) (aref syntax 0)))
(if unescaped
(or (null char-before)
(not (eq (char-syntax char-before) ?\\)))
t)
nil)))
(defconst slime-cursor-marker 'swank::%cursor-marker%)
(defun slime-parse-form-upto-point (&optional max-levels)
(save-restriction
;; Don't parse more than 500 lines before point, so we don't spend
;; too much time. NB. Make sure to go to beginning of line, and
;; not possibly anywhere inside comments or strings.
(narrow-to-region (line-beginning-position -500) (point-max))
(save-excursion
(let ((suffix (list slime-cursor-marker)))
(cond ((slime-compare-char-syntax #'char-after "(" t)
;; We're at the start of some expression, so make sure
;; that SWANK::%CURSOR-MARKER% will come after that
;; expression. If the expression is not balanced, make
;; still sure that the marker does *not* come directly
;; after the preceding expression.
(or (ignore-errors (forward-sexp) t)
(push "" suffix)))
((or (bolp) (slime-compare-char-syntax #'char-before " " t))
;; We're after some expression, so we have to make sure
;; that %CURSOR-MARKER% does *not* come directly after
;; that expression.
(push "" suffix))
((slime-compare-char-syntax #'char-before "(" t)
;; We're directly after an opening parenthesis, so we
;; have to make sure that something comes before
;; %CURSOR-MARKER%.
(push "" suffix))
(t
;; We're at a symbol, so make sure we get the whole symbol.
(slime-end-of-symbol)))
(let ((pt (point)))
(ignore-errors (up-list (if max-levels (- max-levels) -5)))
(ignore-errors (down-list))
(slime-parse-form-until pt suffix))))))
(require 'bytecomp)
(mapc (lambda (sym)
(cond ((fboundp sym)
(unless (byte-code-function-p (symbol-function sym))
(byte-compile sym)))
(t (error "%S is not fbound" sym))))
'(slime-parse-form-upto-point
slime-parse-form-until
slime-compare-char-syntax))
;;;; Test cases
(defun slime-extract-context ()
"Parse the context for the symbol at point.
Nil is returned if there's no symbol at point. Otherwise we detect
the following cases (the . shows the point position):
(defun n.ame (...) ...) -> (:defun name)
(defun (setf n.ame) (...) ...) -> (:defun (setf name))
(defmethod n.ame (...) ...) -> (:defmethod name (...))
(defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name)
(defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name)
(defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name)
(defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name))
(defmacro n.ame (...) ...) -> (:defmacro name)
(defsetf n.ame (...) ...) -> (:defsetf name)
(define-setf-expander n.ame (...) ...) -> (:define-setf-expander name)
(define-modify-macro n.ame (...) ...) -> (:define-modify-macro name)
(define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
(defvar n.ame (...) ...) -> (:defvar name)
(defparameter n.ame ...) -> (:defparameter name)
(defconstant n.ame ...) -> (:defconstant name)
(defclass n.ame ...) -> (:defclass name)
(defstruct n.ame ...) -> (:defstruct name)
(defpackage n.ame ...) -> (:defpackage name)
For other contexts we return the symbol at point."
(let ((name (slime-symbol-at-point)))
(if name
(let ((symbol (read name)))
(or (progn ;;ignore-errors
(slime-parse-context symbol))
symbol)))))
(defun slime-parse-context (name)
(save-excursion
(cond ((slime-in-expression-p '(defun *)) `(:defun ,name))
((slime-in-expression-p '(defmacro *)) `(:defmacro ,name))
((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name))
((slime-in-expression-p '(setf *))
;;a setf-definition, but which?
(backward-up-list 1)
(slime-parse-context `(setf ,name)))
((slime-in-expression-p '(defmethod *))
(unless (looking-at "\\s ")
(forward-sexp 1)) ; skip over the methodname
(let (qualifiers arglist)
(cl-loop for e = (read (current-buffer))
until (listp e) do (push e qualifiers)
finally (setq arglist e))
`(:defmethod ,name ,@qualifiers
,(slime-arglist-specializers arglist))))
((and (symbolp name)
(slime-in-expression-p `(,name)))
;; looks like a regular call
(let ((toplevel (ignore-errors (slime-parse-toplevel-form))))
(cond ((slime-in-expression-p `(setf (*))) ;a setf-call
(if toplevel
`(:call ,toplevel (setf ,name))
`(setf ,name)))
((not toplevel)
name)
((slime-in-expression-p `(labels ((*))))
`(:labels ,toplevel ,name))
((slime-in-expression-p `(flet ((*))))
`(:flet ,toplevel ,name))
(t
`(:call ,toplevel ,name)))))
((slime-in-expression-p '(define-compiler-macro *))
`(:define-compiler-macro ,name))
((slime-in-expression-p '(define-modify-macro *))
`(:define-modify-macro ,name))
((slime-in-expression-p '(define-setf-expander *))
`(:define-setf-expander ,name))
((slime-in-expression-p '(defsetf *))
`(:defsetf ,name))
((slime-in-expression-p '(defvar *)) `(:defvar ,name))
((slime-in-expression-p '(defparameter *)) `(:defparameter ,name))
((slime-in-expression-p '(defconstant *)) `(:defconstant ,name))
((slime-in-expression-p '(defclass *)) `(:defclass ,name))
((slime-in-expression-p '(defpackage *)) `(:defpackage ,name))
((slime-in-expression-p '(defstruct *))
`(:defstruct ,(if (consp name)
(car name)
name)))
(t
name))))
(defun slime-in-expression-p (pattern)
"A helper function to determine the current context.
The pattern can have the form:
pattern ::= () ;matches always
| (*) ;matches inside a list
| (<symbol> <pattern>) ;matches if the first element in
; the current list is <symbol> and
; if <pattern> matches.
| ((<pattern>)) ;matches if we are in a nested list."
(save-excursion
(let ((path (reverse (slime-pattern-path pattern))))
(cl-loop for p in path
always (ignore-errors
(cl-etypecase p
(symbol (slime-beginning-of-list)
(eq (read (current-buffer)) p))
(number (backward-up-list p)
t)))))))
(defun slime-pattern-path (pattern)
;; Compute the path to the * in the pattern to make matching
;; easier. The path is a list of symbols and numbers. A number
;; means "(down-list <n>)" and a symbol "(look-at <sym>)")
(if (null pattern)
'()
(cl-etypecase (car pattern)
((member *) '())
(symbol (cons (car pattern) (slime-pattern-path (cdr pattern))))
(cons (cons 1 (slime-pattern-path (car pattern)))))))
(defun slime-beginning-of-list (&optional up)
"Move backward to the beginning of the current expression.
Point is placed before the first expression in the list."
(backward-up-list (or up 1))
(down-list 1)
(skip-syntax-forward " "))
(defun slime-end-of-list (&optional up)
(backward-up-list (or up 1))
(forward-list 1)
(down-list -1))
(defun slime-parse-toplevel-form ()
(ignore-errors ; (foo)
(save-excursion
(goto-char (car (slime-region-for-defun-at-point)))
(down-list 1)
(forward-sexp 1)
(slime-parse-context (read (current-buffer))))))
(defun slime-arglist-specializers (arglist)
(cond ((or (null arglist)
(member (cl-first arglist) '(&optional &key &rest &aux)))
(list))
((consp (cl-first arglist))
(cons (cl-second (cl-first arglist))
(slime-arglist-specializers (cl-rest arglist))))
(t
(cons 't
(slime-arglist-specializers (cl-rest arglist))))))
(defun slime-definition-at-point (&optional only-functional)
"Return object corresponding to the definition at point."
(let ((toplevel (slime-parse-toplevel-form)))
(if (or (symbolp toplevel)
(and only-functional
(not (member (car toplevel)
'(:defun :defgeneric :defmethod
:defmacro :define-compiler-macro)))))
(error "Not in a definition")
(slime-dcase toplevel
(((:defun :defgeneric) symbol)
(format "#'%s" symbol))
(((:defmacro :define-modify-macro) symbol)
(format "(macro-function '%s)" symbol))
((:define-compiler-macro symbol)
(format "(compiler-macro-function '%s)" symbol))
((:defmethod symbol &rest args)
(declare (ignore args))
(format "#'%s" symbol))
(((:defparameter :defvar :defconstant) symbol)
(format "'%s" symbol))
(((:defclass :defstruct) symbol)
(format "(find-class '%s)" symbol))
((:defpackage symbol)
(format "(or (find-package '%s) (error \"Package %s not found\"))"
symbol symbol))
(t
(error "Not in a definition"))))))
(defsubst slime-current-parser-state ()
;; `syntax-ppss' does not save match data as it invokes
;; `beginning-of-defun' implicitly which does not save match
;; data. This issue has been reported to the Emacs maintainer on
;; Feb27.
(syntax-ppss))
(defun slime-inside-string-p ()
(nth 3 (slime-current-parser-state)))
(defun slime-inside-comment-p ()
(nth 4 (slime-current-parser-state)))
(defun slime-inside-string-or-comment-p ()
(let ((state (slime-current-parser-state)))
(or (nth 3 state) (nth 4 state))))
;;; The following two functions can be handy when inspecting
;;; source-location while debugging `M-.'.
;;;
(defun slime-current-tlf-number ()
"Return the current toplevel number."
(interactive)
(let ((original-pos (car (slime-region-for-defun-at-point)))
(n 0))
(save-excursion
;; We use this and no repeated `beginning-of-defun's to get
;; reader conditionals right.
(goto-char (point-min))
(while (progn (slime-forward-sexp)
(< (point) original-pos))
(cl-incf n)))
n))
;;; This is similiar to `slime-enclosing-form-paths' in the
;;; `slime-parse' contrib except that this does not do any duck-tape
;;; parsing, and gets reader conditionals right.
(defun slime-current-form-path ()
"Returns the path from the beginning of the current toplevel
form to the atom at point, or nil if we're in front of a tlf."
(interactive)
(let ((source-path nil))
(save-excursion
;; Moving forward to get reader conditionals right.
(cl-loop for inner-pos = (point)
for outer-pos = (cl-nth-value 1 (slime-current-parser-state))
while outer-pos do
(goto-char outer-pos)
(unless (eq (char-before) ?#) ; when at #(...) continue.
(forward-char)
(let ((n 0))
(while (progn (slime-forward-sexp)
(< (point) inner-pos))
(cl-incf n))
(push n source-path)
(goto-char outer-pos)))))
source-path))
(provide 'slime-parse)