Patch/enhancement: highlight CL flet/label function names with font-lock-function-name-face

Patch/enhancement: highlight CL flet/label function names with font-lock-function-name-face

[Max Mikhanosha]

This is not a formal patch to font-lock.el, as I don't think it will
be accepted as is, but more of an idea.

Here is how end result looks like (the local functions x, y and
reduce-angle2 are in function name face): http://i.imgur.com/eDo2e.png

Problems I see with it are:

1. Its limited to a hard-coded number of local functions.

2. There may be possible performance penalty, (although in my brief
testing on large flet/labels forms I did not notice much
slowdown). I'm not sure what is the best way to allow user to toggle it
on/off, maybe "(> font-lock-maximum-decoration 3)" 

I had initially tried to accomplish the same task by using the
multi-line highlighting method suggested in Emacs Lisp manual, and
also by using anchored matches, but had to abandon it due to
complexity.

The proposed solution while suffering from above limitations seems to work
reasonably well in practice.

Code:  

;; Highlighting of flet/labels/macrolet local functions/macros with
;; font-lock-function-name-face

(defun mm/match-labels (bound)
  (when (re-search-forward "(\\<\\(labels\\|flet\\|macrolet\\)\\>" bound t)
    (let ((local-functions '())
          (all-start (match-beginning 0))
          (all-end (match-end 0))
          (kw-start (match-beginning 1))
          (kw-end (match-end 1))
          (parse-sexp-ignore-comments t))
      (catch 'done
        (condition-case e
            (progn
              ;; go inside the local functions list
              (goto-char (scan-lists all-end 1 -1))
              (while t
                (save-excursion 
                  ;; down into local function definition
                  (goto-char (scan-lists (point) 1 -1))
                  (let* ((name-end (scan-sexps (point) 1))
                         (name-start (scan-sexps name-end -1)))
                    (push name-end local-functions)
                    (push name-start local-functions)))
                ;; advance to the next local function
                (goto-char (scan-sexps (point) 1))))
          (error
           ;; (message "got error %s" e)
           (throw 'done nil))))
      (set-match-data (append
                       (list all-start all-end
                             kw-start kw-end)
                       (nreverse local-functions)
                       (list (current-buffer))))
      (goto-char all-end)
      t)))

(font-lock-add-keywords
 'lisp-mode
 `((mm/match-labels
    (1 font-lock-keyword-face nil)
    (2 font-lock-function-name-face nil t)
    (3 font-lock-function-name-face nil t)
    (4 font-lock-function-name-face nil t)
    (5 font-lock-function-name-face nil t)
    (6 font-lock-function-name-face nil t)
    (7 font-lock-function-name-face nil t)
    (8 font-lock-function-name-face nil t))))