bug#5728: Byte compile doesn't work right on macro

[Tom Breton]

When I byte-compile certain code, the results are different than when
it's not byte-compiled.  It seems to wrongly merge lists.  The one
unusual thing I was doing with the code is using a macro to generate a
call to a ctor (as generated by defstruct)

I have attached two elisp files which demonstrate the buggy behavior.
The first, "byte-compile-bug.el", is meant to be alternately loaded
plain or loaded byte-compiled.  The second, "demo-byte-compile-bug.el"
is partly a script which demonstartes that the behavior is indeed
different when byte-compiled, and partly a collection of
(quote-protected) calls to slightly different examples of the bug and
examples of similar code which does not exhibit the bug, all defined
in the first file.




In GNU Emacs 22.2.1 (i486-pc-linux-gnu, X toolkit, Xaw3d scroll bars)
 of 2008-11-09 on raven, modified by Debian
Windowing system distributor `The X.Org Foundation', version 11.0.10402000
configured using `configure  '--build=i486-linux-gnu' '--host=i486-linux-gnu' 
'--prefix=/usr' '--sharedstatedir=/var/lib' '--libexecdir=/usr/lib' 
'--localstatedir=/var/lib' '--infodir=/usr/share/info' 
'--mandir=/usr/share/man' '--with-pop=yes' 
'--enable-locallisppath=/etc/emacs22:/etc/emacs:/usr/local/share/emacs/22.2/site-lisp:/usr/local/share/emacs/site-lisp:/usr/share/emacs/22.2/site-lisp:/usr/share/emacs/site-lisp:/usr/share/emacs/22.2/leim'
 '--with-x=yes' '--with-x-toolkit=athena' '--with-toolkit-scroll-bars' 
'build_alias=i486-linux-gnu' 'host_alias=i486-linux-gnu' 'CFLAGS=-DDEBIAN -g 
-O2' 'LDFLAGS=-g' 'CPPFLAGS=''

Important settings:
  value of $LC_ALL: nil
  value of $LC_COLLATE: nil
  value of $LC_CTYPE: nil
  value of $LC_MESSAGES: nil
  value of $LC_MONETARY: nil
  value of $LC_NUMERIC: nil
  value of $LC_TIME: nil
  value of $LANG: nil
  locale-coding-system: nil
  default-enable-multibyte-characters: t

Major mode: Lisp Interaction

Minor modes in effect:
  tooltip-mode: t
  tool-bar-mode: t
  mouse-wheel-mode: t
  menu-bar-mode: t
  file-name-shadow-mode: t
  global-font-lock-mode: t
  font-lock-mode: t
  blink-cursor-mode: t
  unify-8859-on-encoding-mode: t
  utf-translate-cjk-mode: t
  auto-compression-mode: t
  line-number-mode: t

Recent input:
M-x r e p o <tab> r t <tab> <return>

Recent messages:
("emacs" "-Q")
For information about GNU Emacs and the GNU system, type C-h C-a.
Making completion list...
Loading help-mode...done
Loading emacsbug...
Loading regexp-opt...done
Loading emacsbug...done
next-history-element: Beginning of history; no preceding item

===File ~/projects/elisp/bugs/byte-compile-bug.el============
;;;_ byte-compile-bug.el --- File to reproduce byte-compile bug

;;;_. Headers
;;;_ , Commentary:

;;Bug report by Tom Breton (Tehom)

;; The bug seems to involve:
;;   defstruct
;;   macro that builds a ctor.  
;;   a while loop
;;   The byte compiler

;;Observe that it occurs only in compiled code.

;;The macro is made by defmacro* but the same occurs with defmacro
;;feeding defun*

;;;_ , Requires

(eval-when-compile (require 'cl))

;;;_. Body
;;;_ , Type
(defstruct (BUG:structure
              (:conc-name BUG:structure->)
              (:constructor BUG:make-structure))
   
   "An ADT make by defstruct"
   edits
   a)

;;;_ , BUG:helper

(defun BUG:helper (accessor oobj form)
   ""
   (subst
      (list accessor oobj)
      '-old-
      (copy-tree form)))

(defmacro* BUG:make-form (oobj &key edits a)
   "Construct an BUG:structure object adapted from CAND.
Syntax is almost that of a ctor, but in each form, the symbol `-old-'
is replaced by the value of the respective field of OOBJ."

   `(BUG:make-structure
       :edits
       ,(BUG:helper
           'BUG:structure->edits 
           oobj
           edits)
       :a
       ,(BUG:helper
           'BUG:structure->a 
           oobj
           a)))


;;;_ , BUG

(defun BUG (a)
   "Contains a bug involving the byte-compiler"

   (let
      (
         (cand
            (BUG:make-structure
               :edits '()
               :a a)))

      (catch 'BUG:answer
         (while t
            (let
               (  
                  (a (BUG:structure->a cand)))
               
               (unless a
                  (throw 'BUG:answer 
                     (reverse
                        (BUG:structure->edits cand))))
               (setq cand
                  (BUG:make-form cand
                     :edits
                     (cons (car a) -old-)
                     :a
                     (cdr -old-))))))))
(defun BUG-2 (a)
   "Equivalent to BUG except no catch/throw.  Still a bug."

   (let
      (  (done nil)
         (cand
            (BUG:make-structure
               :edits '()
               :a a)))

      (while (not done)
         (let
            (  
               (a (BUG:structure->a cand)))
               
            (if a
               (setq cand
                  (BUG:make-form cand
                     :edits
                     (cons (car a) -old-)
                     :a
                     (cdr -old-)))
               (setq done t))))
      (reverse
         (BUG:structure->edits cand))))

(defun BUG-3 (a)
   "Equivalent to BUG.  Also buggy, slightly different manifestation.
Slightly different form not involving the second field `a' of BUG:structure."

   (let
      (
         (cand
            (BUG:make-structure
               :edits '())))
      
      (catch 'BUG:answer
         (while t
            (unless a
               (throw 'BUG:answer 
                  (reverse
                     (BUG:structure->edits cand))))
            (setq cand
               (BUG:make-form cand
                  :edits
                  (cons (car a) -old-)))
            (pop a)))))

(defun BUG-4 (a)
   "Equivalent to BUG.  Also buggy, slightly different manifestation.
Slightly different form not directly using a while loop."

   (let
      (
         (cand
            (BUG:make-structure
               :edits '())))
      (dotimes (i (length a))
         (setq cand
            (BUG:make-form cand
               :edits
               (cons (car a) -old-)))
         (pop a))
      (reverse
         (BUG:structure->edits cand))))

(defun NOBUG (a)
   "Equivalent to BUG.
This form extracts elements from list `a' before using them.

No buggy behavior."

   (let
      (
         (cand
            (BUG:make-structure
               :edits '()
               :a a)))

      (catch 'BUG:answer
         (progn
            (dolist (x a)
               (setq cand
                  (BUG:make-form cand
                     :edits
                     (cons x -old-)
                     :a
                     (cdr -old-))))
            (throw 'BUG:answer 
               (reverse
                  (BUG:structure->edits cand)))))))

(defun NOBUG-2 (a)
   "Equivalent to BUG except doesn't use the second field `a' of
BUG:structure and extracts elements from list `a' before using
them.

No buggy behavior."

   (let
      (
         (cand
            (BUG:make-structure
               :edits '())))
      
      (catch 'BUG:answer
         (while t
            (let
               ((x (pop a)))
               
               (unless x
                  (throw 'BUG:answer 
                     (reverse
                        (BUG:structure->edits cand))))
               (setq cand
                  (BUG:make-form cand
                     :edits
                     (cons x -old-))))))))




;;;_. Footers
;;;_ , Provides

(provide 'byte-compile-bug)

;;;_ * Local emacs vars.
;;;_  + Local variables:
;;;_  + mode: allout
;;;_  + End:

;;;_ , End
;;; byte-compile-bug.el ends here
============================================================

===File ~/projects/elisp/bugs/demo-byte-compile-bug.el======
;;File to demonstrate this bug.  eval-buffer to see it.  Also various
;;examples of it are included for easy C-x C-e exploration.


(defun BUG:assert-works-ok (str)
   ""
   (message str)
   (assert
      (equal
         (BUG
            '(a b c d))
         '(a b c d))
      t))

(progn
   (load-file "byte-compile+cl.el")
   (BUG:assert-works-ok "Uncompiled version works OK")
   (byte-compile-file "byte-compile+cl.el")
   (load-file "byte-compile+cl.elc")
   (BUG:assert-works-ok "Compiled version doesn't"))

;;For comparison:

;;Buggy equivalents

'
(assert
   (equal
      (BUG-2
         '(a b c d))
      '(a b c d))
   t)

'
(assert
   (equal
      (BUG-3
         '(a b c d))
      '(a b c d))
   t)

'
(assert
   (equal
      (BUG-4
         '(a b c d))
      '(a b c d))
   t)

;;Non-buggy equivalents

'
(assert
   (equal
      (NOBUG
         '(a b c d))
      '(a b c d))
   t)

'
(assert
   (equal
      (NOBUG-2
         '(a b c d))
      '(a b c d))
   t)============================================================