klimi
/
dotfiles


								(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)