[slime-cvs] CVS slime/contrib
CVS User heller
heller at common-lisp.net
Fri May 28 10:49:45 UTC 2010
Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv17679/contrib
Modified Files:
slime-fancy-inspector.el slime-parse.el
Log Message:
Move wacky parsing code to contrib.
* slime.el (slime-extract-context, slime-parse-context)
(slime-in-expression-p, slime-pattern-path)
(slime-beginning-of-list, slime-end-of-list)
(slime-parse-toplevel-form, slime-arglist-specializers)
(slime-definition-at-point, slime-current-parser-state): Moved to
contrib/slime-parse.el
(slime-inspect-definition, slime-disassemble-definition): Moved to
contrib/slime-fancy-inspector.el
--- /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2010/05/13 15:31:07 1.5
+++ /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2010/05/28 10:49:45 1.6
@@ -4,3 +4,15 @@
(:authors "Marco Baringer <mb at bese.it> and others")
(:license "GPL")
(:swank-dependencies swank-fancy-inspector))
+
+
+(defun slime-inspect-definition ()
+ "Inspect definition at point"
+ (interactive)
+ (slime-inspect (slime-definition-at-point)))
+
+(defun slime-disassemble-definition ()
+ "Disassemble definition at point"
+ (interactive)
+ (slime-eval-describe `(swank:disassemble-form
+ ,(slime-definition-at-point t))))
--- /project/slime/cvsroot/slime/contrib/slime-parse.el 2010/05/13 15:31:07 1.35
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el 2010/05/28 10:49:45 1.36
@@ -149,4 +149,250 @@
(unless skip-trailing-test-p
(insert ")") (backward-char)
(slime-check-buffer-form result-form))
- ))
\ No newline at end of file
+ ))
+
+(defun slime-trace-query (spec)
+ "Ask the user which function to trace; SPEC is the default.
+The result is a string."
+ (cond ((null spec)
+ (slime-read-from-minibuffer "(Un)trace: "))
+ ((stringp spec)
+ (slime-read-from-minibuffer "(Un)trace: " spec))
+ ((symbolp spec) ; `slime-extract-context' can return symbols.
+ (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+ (t
+ (destructure-case spec
+ ((setf n)
+ (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+ ((:defun n)
+ (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
+ ((:defgeneric n)
+ (let* ((name (prin1-to-string n))
+ (answer (slime-read-from-minibuffer "(Un)trace: " name)))
+ (cond ((and (string= name answer)
+ (y-or-n-p (concat "(Un)trace also all "
+ "methods implementing "
+ name "? ")))
+ (prin1-to-string `(:defgeneric ,n)))
+ (t
+ answer))))
+ ((:defmethod &rest _)
+ (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+ ((:call caller callee)
+ (let* ((callerstr (prin1-to-string caller))
+ (calleestr (prin1-to-string callee))
+ (answer (slime-read-from-minibuffer "(Un)trace: "
+ calleestr)))
+ (cond ((and (string= calleestr answer)
+ (y-or-n-p (concat "(Un)trace only when " calleestr
+ " is called by " callerstr "? ")))
+ (prin1-to-string `(:call ,caller ,callee)))
+ (t
+ answer))))
+ (((:labels :flet) &rest _)
+ (slime-read-from-minibuffer "(Un)trace local function: "
+ (prin1-to-string spec)))
+ (t (error "Don't know how to trace the spec %S" spec))))))
+
+(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)
+ (loop for e = (read (current-buffer))
+ until (listp e) do (push e qualifiers)
+ finally (setq arglist e))
+ `(:defmethod ,name , at 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))))
+ (loop for p in path
+ always (ignore-errors
+ (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)
+ '()
+ (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 (first arglist) '(&optional &key &rest &aux)))
+ (list))
+ ((consp (first arglist))
+ (cons (second (first arglist))
+ (slime-arglist-specializers (rest arglist))))
+ (t
+ (cons 't
+ (slime-arglist-specializers (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")
+ (destructure-case 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"))))))
+
+;; FIXME: not used here; move it away
+(if (and (featurep 'emacs) (>= emacs-major-version 22))
+ ;; N.B. The 2nd, and 6th return value cannot be relied upon.
+ (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))
+ (defsubst slime-current-parser-state ()
+ (let ((original-pos (point)))
+ (save-excursion
+ (beginning-of-defun)
+ (parse-partial-sexp (point) original-pos)))))
+
+(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))))
+
More information about the slime-cvs
mailing list