From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Alan Mackenzie Newsgroups: gmane.emacs.devel Subject: Re: Is there a "selective setq locator/highlighter" anywhere? There is now! Date: Fri, 23 Jan 2009 15:58:57 +0000 Message-ID: <20090123155857.GE3056@muc.de> References: <20090122135425.GA3719@muc.de> <42394.128.165.123.18.1232647588.squirrel@webmail.lanl.gov> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: ger.gmane.org 1232725363 7516 80.91.229.12 (23 Jan 2009 15:42:43 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Fri, 23 Jan 2009 15:42:43 +0000 (UTC) Cc: emacs-devel@gnu.org To: Davis Herring Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Fri Jan 23 16:43:51 2009 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1LQOCB-0005MM-4i for ged-emacs-devel@m.gmane.org; Fri, 23 Jan 2009 16:43:48 +0100 Original-Received: from localhost ([127.0.0.1]:35741 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1LQOAt-0001bE-Lu for ged-emacs-devel@m.gmane.org; Fri, 23 Jan 2009 10:42:27 -0500 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1LQO8w-0000fz-7X for emacs-devel@gnu.org; Fri, 23 Jan 2009 10:40:26 -0500 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1LQO8v-0000fW-GW for emacs-devel@gnu.org; Fri, 23 Jan 2009 10:40:25 -0500 Original-Received: from [199.232.76.173] (port=34924 helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1LQO8v-0000fQ-72 for emacs-devel@gnu.org; Fri, 23 Jan 2009 10:40:25 -0500 Original-Received: from colin.muc.de ([193.149.48.1]:1484 helo=mail.muc.de) by monty-python.gnu.org with esmtps (TLS-1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.60) (envelope-from ) id 1LQO8u-0003PI-Fe for emacs-devel@gnu.org; Fri, 23 Jan 2009 10:40:25 -0500 Original-Received: (qmail 25764 invoked by uid 3782); 23 Jan 2009 15:40:22 -0000 Original-Received: from acm.muc.de (pD9E51D5E.dip.t-dialin.net [217.229.29.94]) by colin2.muc.de (tmda-ofmipd) with ESMTP; Fri, 23 Jan 2009 16:40:19 +0100 Original-Received: (qmail 8160 invoked by uid 1000); 23 Jan 2009 15:58:57 -0000 Content-Disposition: inline In-Reply-To: <42394.128.165.123.18.1232647588.squirrel@webmail.lanl.gov> User-Agent: Mutt/1.5.9i X-Delivery-Agent: TMDA/1.1.5 (Fettercairn) X-Primary-Address: acm@muc.de X-detected-operating-system: by monty-python.gnu.org: FreeBSD 4.6-4.9 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:108152 Archived-At: Hi, Davis! On Thu, Jan 22, 2009 at 10:06:28AM -0800, Davis Herring wrote: > > I would like a tool which would highlight these: > > (setq foo bar > > c-state-cache (cdr c-state-cache)) > > (setcar c-state-cache (caar c-state-cache)) > > , but not this: > > (setq old-cache c-state-cache) > Not a polished tool, by any means, but can't you just do [ .... ] > Wrap in defuns/commands as desired. Thanks! In the end, I just threw it together, and it rapidly converged to something functional. It handles setq, setc[ad]r and let\*?, arbitrarily nested. For some reason, I was thinking of a solution which would first read (as in read/eval/print loop) a defun and then step through the structure. This was silly. ;-) Anyhow, here it is for anybody interested. It uses hi-lock-mode a little bit: ######################################################################### ;; Selective setq highlighting: ;; ;; Given a symbol, locate and/or highlight all places where the symbol's value ;; is changed; currently this means "(setq foo" (including multiple versions ;; of it), "(setcar foo" or "(setcdr foo", or "(let (...(foo ..)" or ;; "(let*...". (defun sshi-forward-WS () (save-match-data (forward-comment 1048575) (search-forward-regexp "[[:space:]]*"))) (defun sshi-sym-value () "Parse the symbol followed by a sexp at point. Return the positions of the symbol/sexp as a dotted pair of dotted pairs like this ((SYM-START . SYM-END) . (SEXP-START . SEXP-END)). Point is left after any WS/comments at sexp-end. On error, throw an error." (let (sym-pos sexp-start) (if (looking-at "\\(\\(\\w\\|\\s_\\)+\\_>\\)") ; a symbol. ;; 1 2 2 1 (progn (setq sym-pos (cons (match-beginning 1) (match-end 1))) (goto-char (match-end 0)) (sshi-forward-WS) (setq sexp-start (point)) (condition-case nil (forward-sexp) (error (error "sshi-sym-value: invalid sexp at %s" (point))))) (error "sshi-sym-value: missing symbol at %s" (point))) (prog1 (cons sym-pos (cons sexp-start (point))) (sshi-forward-WS)))) (defun sshi-push-sym-sexps (sym places) " Push the locations of SYM settings onto PLACES, returning PLACES. This includes any setq's etc. recursively contained in the sexp. Point should be at a symbol in a \"setq\" type construct. Point is left after WS/comments after the sexp." (let ((sym-val (sshi-sym-value))) (if (string= (buffer-substring-no-properties (caar sym-val) (cdar sym-val)) sym) (push (car sym-val) places)) (when (eq (char-after (cadr sym-val)) ?\() (goto-char (cadr sym-val)) (setq places (append (save-restriction (narrow-to-region (cadr sym-val) (cddr sym-val)) (sshi-list sym)) places)) (sshi-forward-WS)) places)) (defun sshi-list (sym) "Return a list of places within the current restriction where SYM is set. This is a list of dotted pairs of the form (BEGIN-SYM . END-SYM). The current restriction should exactly contain a list, and point should be at (point-min) on entry. Point is left at (point-max) at exit." (let (places sym-start) (forward-char) ; over ?\( (sshi-forward-WS) (while (/= (char-after) ?\)) (cond ((looking-at "(\\(setc[ad]r\\_>\\)") (goto-char (match-end 0)) (sshi-forward-WS) (setq places (sshi-push-sym-sexps sym places)) (sshi-forward-WS) (forward-char) ; over ?\) (sshi-forward-WS)) ((looking-at "(\\(setq\\_>\\)") (goto-char (match-end 0)) (sshi-forward-WS) (while (/= (char-after) ?\)) (setq places (sshi-push-sym-sexps sym places)) (sshi-forward-WS)) (forward-char) (sshi-forward-WS)) ; over ?\) ((looking-at "(\\(let\\*?\\_>\\)") (goto-char (match-end 0)) (sshi-forward-WS) (or (eq (char-after) ?\() (error "sshi: missing bindings list at %s" (point))) (forward-char) (sshi-forward-WS) ; over ?\( (while (/= (char-after) ?\)) (if (eq (char-after) ?\() ; binding with initialisation (progn (forward-char) (sshi-forward-WS) ; over ?\( of a single binding. (setq places (sshi-push-sym-sexps sym places)) (forward-char)) ; over terminating ?\) of the binding (setq sym-start (point)) ; symbol (initialised implicitly to nil) (forward-sexp) (if (string= (buffer-substring sym-start (point)) sym) (push (cons sym-start (point)) places)) (sshi-forward-WS))) (forward-char) (sshi-forward-WS)) ; over ?\) enclosing all bindings ((eq (char-after) ?\() (mark-sexp) (save-restriction (narrow-to-region (point) (mark)) (setq places (append (sshi-list sym) places))) (sshi-forward-WS)) (t (forward-sexp) (sshi-forward-WS)))) (forward-char) ; over ?\) places)) (defvar sshi-symbol-hist nil "The symbol history list used by selective-setq") (defun sshi-defun (arg sym face) "Highlight SYM each place within the current defun where it is setq'd or setc[ad]r'd. With a prefix arg, remove the highlighting for SYM." (interactive (list current-prefix-arg (let* ((sym (symbol-at-point)) (s (and sym (symbol-name sym)))) (read-string "Symbol: " ; prompt s ; initial-input 'sshi-symbol-hist ; history s)) (unless current-prefix-arg (hi-lock-read-face-name)))) (save-excursion (save-restriction (narrow-to-defun) ;(beginning-of-defun) (goto-char (point-min)) ; beginning-of-defun drops a mark. :-( (let ((places (sshi-list sym))) (mapc (lambda (elt) (let* (ov ovs) (setq ovs (overlays-at (car elt))) (while (and ovs (setq ov (car ovs)) (not (overlay-get ov 'sshi))) (setq ovs (cdr ovs))) (when ovs (delete-overlay ov)) (unless arg (setq ov (make-overlay (car elt) (cdr elt) nil nil nil)) (overlay-put ov 'sshi t) (overlay-put ov 'face face)))) places))))) (define-key emacs-lisp-mode-map "\C-xwz" 'sshi-defun) ######################################################################### > Davis -- Alan Mackenzie (Nuremberg, Germany).