bug#8628: 24.0.50; `thing-at-point-bounds-of-list-at-point' - no good

[Drew Adams]

FWIW, you can find new definitions of the list-at-point functions, which work
correctly, in my library thingatpt+.el:
http://www.emacswiki.org/emacs/download/thingatpt%2b.el

The definitions are general.
They handle correctly all cases; i.e., where point is:

a. within a list,
b. just after/before or at a list end/beginning, and
c. outside any list.

They return the non-nil list in (a) and (b), and nil in (c).

For the current question, which concerns (bounds-of-thing-at-point 'list), this
is the code I use, in case you want to test:

(put 'list 'bounds-of-thing-at-point 'bounds-of-list-at-point)
(defun bounds-of-list-at-point (&optional up unquotedp)
  "Return (START . END), boundaries of the `list-at-point'.
Return nil if no non-empty list is found.
UP (default: 0) is the number of list levels to go up to start with.
Non-nil UNQUOTEDP means remove the car if it is `quote' or
 `backquote-backquote-symbol'."
  (let ((thing+bds  (list-at-point-with-bounds up unquotedp)))
    (and thing+bds (cdr thing+bds))))

(defun list-at-point-with-bounds (&optional up unquotedp)
  "Return (LIST START . END), boundaries of the `list-at-point'.
Return nil if no non-empty list is found.
UP (default: 0) is the number of list levels to go up to start with.
Non-nil UNQUOTEDP means remove the car if it is `quote' or
 `backquote-backquote-symbol'."
  (list-at/nearest-point-with-bounds
   'sexp-at-point-with-bounds up unquotedp))

(defun list-at/nearest-point-with-bounds (at/near &optional up unquotedp)
  "Helper for `list-at-point-with-bounds' and similar functions.
AT/NEAR is a function called to grab the initial list and its bounds.
UP (default: 0) is the number of list levels to go up to start with.
Non-nil UNQUOTEDP means remove the car if it is `quote' or
 `backquote-backquote-symbol'.
Return (LIST START . END) with START and END of the LIST.
Return nil if no non-empty list is found."
  (save-excursion
    (unless (eq at/near 'sexp-at-point-with-bounds)
      (cond ((looking-at "\\s-*\\s(") (skip-syntax-forward "-"))
            ((looking-at "\\s)\\s-*") (skip-syntax-backward "-"))))
    (let ((sexp+bnds  (funcall at/near)))
      (condition-case nil               ; Handle an `up-list' error.
          (progn
            (when up
              (up-list (- up))
              (setq sexp+bnds  (sexp-at-point-with-bounds)))
            (while (not (consp (car sexp+bnds)))
              (up-list -1)
              (setq sexp+bnds  (sexp-at-point-with-bounds)))
            (when (and unquotedp (consp (car sexp+bnds))
                       (memq (caar sexp+bnds)
                             (list backquote-backquote-symbol 'quote)))
              (cond ((eq 'quote (caar sexp+bnds))
                     (setq sexp+bnds
                           (cons (cadr (car sexp+bnds))
                                 (cons (+ 5 (cadr sexp+bnds))
                                       (cddr sexp+bnds)))))
                    ((eq backquote-backquote-symbol (caar sexp+bnds))
                     (setq sexp+bnds  (cons (cadr (car sexp+bnds))
                                            (cons (+ 1 (cadr sexp+bnds)) 
                                                  (cddr sexp+bnds)))))))
            (while (not (consp (car sexp+bnds)))
              (up-list -1)
              (setq sexp+bnds  (sexp-at-point-with-bounds))))
        (error (setq sexp+bnds  nil)))
      sexp+bnds)))

(defun sexp-at-point-with-bounds (&optional pred syntax-table)
  "Return (SEXP START . END), boundaries of the `sexp-at-point'.
Return nil if no sexp is found.
Optional args are the same as for `form-at-point-with-bounds'."
  (form-at-point-with-bounds 'sexp pred syntax-table))

(defun form-at-point-with-bounds (&optional thing pred syntax-table)
  "Return (FORM START . END), START and END the char positions of FORM.
FORM is the `form-at-point'.  Return nil if no form is found.
Optional arguments:
  THING is the kind of form desired (default: `sexp').
  PRED is a predicate that THING must satisfy to qualify.
  SYNTAX-TABLE is a syntax table to use."
  (condition-case nil              ; E.g. error if tries to read `.'.
      (let* ((thing+bds  (thing-at-point-with-bounds
                          (or thing 'sexp) syntax-table))
             (bounds     (cdr thing+bds))
             (sexp       (and bounds (read-from-whole-string
                                      (car thing+bds)))))
        (and bounds (or (not pred) (funcall pred sexp))
             (cons sexp bounds)))
    (error nil)))

(defun thing-at-point-with-bounds (thing &optional syntax-table)
  "Return (THING START . END) with START and END of THING.
Return nil if no such THING is found.
THING is the `thing-at-point' (which see).
START and END are the car and cdr of the `bounds-of-thing-at-point'.
SYNTAX-TABLE is a syntax table to use."
  (let ((bounds  (bounds-of-thing-at-point thing syntax-table)))
    (and bounds
         (cons (buffer-substring (car bounds) (cdr bounds)) bounds))))

(defun bounds-of-thing-at-point (thing &optional syntax-table)
  "Determine the start and end buffer locations for the THING at point.
Return a consp `(START . END)' giving the START and END positions,
where START /= END.  Return nil if no such THING is found.
THING is an entity for which there is a either a corresponding
`forward-'THING operation, or corresponding `beginning-of-'THING and
`end-of-'THING operations.  THING examples include `word', `sentence',
`defun'.
SYNTAX-TABLE is a syntax table to use.
See the commentary of library `thingatpt.el' for how to define a
symbol as a valid THING."
  (if syntax-table
      (let ((buffer-syntax  (syntax-table)))
        (unwind-protect
             (progn (set-syntax-table syntax-table)
                    (bounds-of-thing-at-point-1 thing))
          (set-syntax-table buffer-syntax)))
    (bounds-of-thing-at-point-1 thing)))

;; This is the original `bounds-of-thing-at-point',
;; but with bug #8667 fixed.
(defun bounds-of-thing-at-point-1 (thing)
  "Helper for `bounds-of-thing-at-point'.
Do all except handle the optional SYNTAX-TABLE arg."
  (if (get thing 'bounds-of-thing-at-point)
      (funcall (get thing 'bounds-of-thing-at-point))
    (let ((orig  (point)))
      (condition-case nil
          (save-excursion
            ;; Try moving forward, then back.
            (funcall (or (get thing 'end-op) ; Move to end.
                         (lambda () (forward-thing thing 1))))
            (funcall (or (get thing 'beginning-op) ; Move to beg.
                         (lambda () (forward-thing thing -1))))
            (let ((beg  (point)))
              (if (<= beg orig)
                  ;; If that brings us all the way back to ORIG,
                  ;; it worked.  But END may not be the real end.
                  ;; So find the real end that corresponds to BEG.
                  ;; FIXME:
                  ;; in which cases can `real-end' differ from `end'?
                  (let ((real-end  (progn
                                     (funcall
                                      (or (get thing 'end-op)
                                          (lambda ()
                                           (forward-thing thing 1))))
                                     (point))))
                    (and (<= orig real-end) (< beg real-end)
                         (cons beg real-end)))
                (goto-char orig)
                ;; Try a second time, moving first backward then forward,
                ;; so that we can find a thing that ends at ORIG.
                (funcall (or (get thing 'beginning-op) ; Move to beg.
                             (lambda () (forward-thing thing -1))))
                (funcall (or (get thing 'end-op) ; Move to end.
                             (lambda () (forward-thing thing 1))))
                (let ((end       (point))
                      (real-beg  (progn
                                   (funcall
                                    (or (get thing 'beginning-op)
                                        (lambda ()
                                         (forward-thing thing -1))))
                                   (point))))
                  (and (<= real-beg orig) (<= orig end) (< real-beg end)
                       (cons real-beg end))))))
        (error nil)))))