[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Fri May 28 10:49:45 UTC 2010
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv17679
Modified Files:
ChangeLog slime.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/ChangeLog 2010/05/27 15:00:58 1.2101
+++ /project/slime/cvsroot/slime/ChangeLog 2010/05/28 10:49:44 1.2102
@@ -1,3 +1,16 @@
+2010-05-28 Helmut Eller <heller at common-lisp.net>
+
+ 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
+
2010-05-27 Helmut Eller <heller at common-lisp.net>
* slime.el ([test] interactive-eval): Fix test.
--- /project/slime/cvsroot/slime/slime.el 2010/05/27 15:00:58 1.1322
+++ /project/slime/cvsroot/slime/slime.el 2010/05/28 10:49:44 1.1323
@@ -4236,208 +4236,12 @@
(interactive)
(slime-eval `(swank:untrace-all)))
-(defun slime-toggle-trace-fdefinition (&optional using-context-p)
+(defun slime-toggle-trace-fdefinition (spec)
"Toggle trace."
- (interactive "P")
- (let* ((spec (if using-context-p
- (slime-extract-context)
- (slime-symbol-at-point)))
- (spec (slime-trace-query spec)))
- (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))))
-
-
-;; FIXME: move this to contrib
-
-(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))
+ (interactive (list (slime-read-from-minibuffer
+ "(Un)trace: " (slime-symbol-at-point))))
+ (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec))))
-(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-disassemble-symbol (symbol-name)
@@ -6535,46 +6339,6 @@
(slime-sexp-at-point))))
(slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector))
-(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"))))))
-
-(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))))
-
(define-derived-mode slime-inspector-mode fundamental-mode
"Slime-Inspector"
"
@@ -8550,18 +8314,6 @@
until (= (point) (point-max))
maximizing column)))
-(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))))
-
-
-
;;;;; CL symbols vs. Elisp symbols.
(defun slime-cl-symbol-name (symbol)
@@ -8774,21 +8526,6 @@
(and (not (featurep 'xemacs))
(= emacs-major-version 21)))
-;; 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)))))
-
;;; `getf', `get', `symbol-plist' do not work on malformed plists
;;; on Emacs21. On later versions they do.
(when (slime-emacs-21-p)
@@ -8800,7 +8537,6 @@
when (eq prop property) return (car val)
finally (return default))))
-
(defun slime-split-string (string &optional separators omit-nulls)
"This is like `split-string' in Emacs22, but also works in 21."
(let ((splits (split-string string separators)))
@@ -9222,8 +8958,6 @@
slime-symbol-constituent-at
slime-beginning-of-symbol
slime-end-of-symbol
- ;; Used implicitly during fontification:
- slime-current-parser-state
slime-eval-feature-expression
slime-forward-sexp
slime-forward-cruft
More information about the slime-cvs
mailing list