Compiler Bug or what I'm doing wrong?

[M E Leypold <development-2006-8ecbb5cc8aREMOVETHIS@ANDTHATm-e-leypold.de>]

Hi all,

the following happens with GNAT 3.15p on Debian. My impression is,
that finalization during reading with the compiler generated
'Read-Attribute is not handled right in variant records, but I might
be wrong. Let me first expose the problem and my sample code.

I have the following Program (explanations below):


    with Sf.Cases;
    use  Sf.Cases;

    with Sf.Fieldtypes;
    use  Sf.Fieldtypes;

    with Ada.Streams.Stream_IO;
    use  Ada.Streams.Stream_IO;


    procedure Demo.Bug3 is

       procedure Write_Record
       is
         R : Fall_Datensatz;

         F : File_Type;
         S : Stream_Access;
       begin
          Create( F , Name => "tmp-bug3" );
          S := Stream(F);
          Set_Zugang(R, SelbstMelderIn);          -- [**]
          -- Fall_Datensatz'Output(S,R); -- [2a]
          Fall_Datensatz'Write(S,R);     -- [1a]
          Close(F);
       end;

       Function Get_Record return Fall_Datensatz
       is
          R: Fall_Datensatz;
          F : File_Type;
          S : Stream_Access;
       begin
          Open( F , Mode => In_File, Name => "tmp-bug3" );
          S := Stream(F);

          -- R := Fall_Datensatz'Input(S); -- [2b]
          Fall_Datensatz'Read(S,R);        -- [1b]
          Close( F );
          return R;
       end;

       R : Fall_Datensatz;

    begin
       Write_Record;
       R := Get_Record;
    end;


It instantiated a record with default initialization, changes a
discriminant in a which controls a variant part in the record (at [**]
Set_Zugang will be explained later), and then stores the record in a
file. When rereading the file (Get_Record), I get the following
exception:


   "raised PROGRAM_ERROR : demo-bug3.adb:38 finalize raised exception"

Running it under debugger control I get 

   (gdb) exec-file demo-bug3
   (gdb) run
   Starting program: /home/mel/cvswork/statfix/src2/demo-bug3

   Program received signal SIGSEGV, Segmentation fault.
   0x4098d354 in mallopt () from /lib/libc.so.6
   (gdb)

   (gdb) bt 5
   #0  0x4098d354 in mallopt () from /lib/libc.so.6
   #1  0x4098c15f in free () from /lib/libc.so.6
   #2  0x408f4e84 in __gnat_free () from /usr/lib/libgnat-3.15p.so.1
   #3  0x4082ac79 in ada__strings__unbounded__finalize__2 ()
      from /usr/lib/libgnat-3.15p.so.1
   #4  0x080c9fe5 in <demo__bug3__get_record___read654___read1116___read1147> (
       s=0x80e2e00, v=@0xbfffc39c, <sF>=0) at demo-bug3.adb:38
   (More stack frames follow...)
   (gdb)

which makes me suspect that a finalizer is run on non-appropriate data
(i.e. on the wrong part of a variant). I'll attach more stack traces
below, but first let me explain the data structure Fall_Datensatz
(which is defined in SF.Cases). I'm showing only the parts that are
actually touched by the program:


   type PA_Kontakt_Ergebnis ( Erfolg : Di_State := Keine_Angabe ) is record

      case Erfolg is
         when Ja     => Kontakt_Ergebnis : Auswahl_Kontakt_Ergebnis := Keine_Angabe;         
         when others => null;
      end case;
   end record;


   type PA_Kontakt_Verlauf
     ( Kontakt_Methode : Auswahl_Kontakt_Methode := Keine_Angabe )
   is record
      case Kontakt_Methode is
         when Keine_Angabe => null;
         when Keinen       => null;
         when Others       => Ergebnis : PA_Kontakt_Ergebnis;
      end case;
   end record;


   type Zugangs_Daten( KlientIn_Zugang : Auswahl_KlientIn_Zugang := Keine_Angabe ) is record

      case KlientIn_Zugang is

         when  Proaktiver_Kontakt  =>

            Kontakt_Vermittlung : Angabe_Kontakt_Vermittlung ;
            PA_Kontakt          : PA_Kontakt_Verlauf         ;

         when      SelbstmelderIn  =>

            KlientIn_Aufmerksamkeit : Angabe_Klientin_Aufmerksamkeit;

         when              others  =>  null;
      end case;
   end record;




   type Fall_Datensatz
     ( KJB_Verf�gbar : Boolean := True ; Notizen_Verf�gbar : Boolean := True )
   is record

      Aktenzeichen  : Fall_Aktenzeichen;
      Tat           : Fall_Merkmale     (Notizen_Verf�gbar);

      Opfer         : Personen_Merkmale (Notizen_Verf�gbar);
      T�ter         : Personen_Merkmale (Notizen_Verf�gbar);

      Zugang        : Zugangs_Daten;
      Polizei       : Angaben_Polizei_Einsatz;

      Beratung      : Beratungsverlauf  (Notizen_Verf�gbar);

      Kinder        : Kinder_Daten; -- (KJB_Verf�gbar, Notizen_Verf�gbar);

      case KJB_Verf�gbar is
         when  True   => null; -- KJB : ...
         when  False  => null;
      end case;
   end record;


The Unbounded Strings are hidden in Angabe_Kontakt_Vermittlung and
Angabe_Klientin_Aufmerksamkeit which are actually Types defined via a
generic package as an enumeration type with an optional comment (only
to be given in some cases):


   type Data is record
      Choice  : Choice_Type      := Choice_Type'First;
      Comment : Unbounded_String := Null_Unbounded_String;
   end record;


(I'll give the complete interface below, but this post becomes pretty
longish, so I'll restrict myself to what I consider the relevant parts).

The procedure Set_Zugang modifies the diosriminant of Zugangs_Daten in
the following way:


   procedure Set_Zugang ( D :  in out Zugangs_Daten ; Z : Auswahl_KlientIn_Zugang )
   is begin

      if Z /= D.KlientIn_Zugang then

         case Z is

            when Selbstmelderin      =>
               declare New_D : Zugangs_Daten(Selbstmelderin);
               begin
                  D := New_D ;
               end;

            when Proaktiver_Kontakt  =>
               declare New_D : Zugangs_Daten(Proaktiver_Kontakt);
               begin   D := New_D ; end;

            when Keine_Angabe        => D := (KlientIn_Zugang => Keine_Angabe ) ;
         end case;
      end if;
   end;


   procedure Set_Zugang ( DS :  in out Fall_Datensatz ; Z : Auswahl_KlientIn_Zugang) is begin

      Set_Zugang( DS.Zugang, Z );
   end;

(The idea is to have the initialisation defaults if and only if the
discrimant is changed).

If  (in gdb) I step up some stackframes and print the record R in
Get_Record I get the following


  (...)  zugang => (klientin_zugang => selbstmelderin,
         klientin_aufmerksamkeit => ( choice => keine_angabe, comment
         => (prev => 0x0, next => 0x0, reference => Cannot access
         memory at address 0x7a9f08

This is also what led me to the impression that first the discriminant
is overwritten and the the finalizer(s) for the new variant part
("when SelbstMelderIn") are run (on random bit patterns) instead of
the finalizers for the default variant part ("when Keine_Angabe
..."). 

(Actually I'd have expected in the case of discriminant records that
the whole thingy works like this: Run all finalizers in variant parts
if any, only then read the discriminant, run the initializers in the
new variant parts, then read the rest of the record).

After having a look into Barnes "Programming in Ada 95" again, I
thought, that perhaps I should use 'Input and 'Output instead of 'Read
an 'Write. This fixed the problem in the case above (options [2a] and
[2b]), but unfortunately failed to fix the the problem in the larger
program from which these fragments come.

Of course the bug is a Heisenbug so small changes in Fall_Datensatz or
the order of code execuation in the larger program make it disappear
which made it difficult in the first place to construct a relatively
small example w/o GUI which succeeds in reproducing the bug. 

Therefore I think (but again I'm not sure) that the fact that the bug
goes away with 'Input and Output instead of 'Read/'Write is just part
of it's elusive character not evidence of a fix. Also, since records
with default discriminants are definite I think 'Read and 'Write
should be OK for IO. Am I not right?

I've googled a bit, but didn't find anything on that, eehm,
"effect". But maybe I didn't use the right keywords. 

Is this a known bug with GNAT 3.15p or am I doing anything wrong?

Your help/input (also suggestions for workaround or confirmation that
this indeed a GNAT bug) would be greatly appreciated.

(Ludovico: I'll file an entry into Debian bug tracking soon. Just
looking for confirmation here first).

Regards -- Markus



ATTACHEMENTS: Backtraces and more code
--------------------------------------

  Sf.Single-Choices (Unit interface from which the types Angabe_* are instantiated) 
  ------------------
  
     with Ada.Strings.Unbounded;
     use  Ada.Strings.Unbounded;

     generic

        type Choice_Type   is (<>);
        type Choice_List   is array (Integer range <>) of Choice_Type;

        Allow_Comment_List : Choice_List;

     package Sf.Single_Choice is

        type Data is private;

        procedure Set( D : in out Data ; C : Choice_Type );
        function  Get( D : Data ) return Choice_Type;
        function  ID ( D : Data ) return Integer;

        function  Get_Comment( D : Data ) return String;
        procedure Set_Comment( D : in out Data; S : String );

        procedure Set_From_Integer( D : in out Data ; I : Integer );

        procedure Set( D : in out Data ; I : Integer ) renames Set_From_Integer;

        procedure Reset ( D : in out Data );

     private

        type Flags is array (Choice_Type) of Boolean;

        function Get_Comment_Allowed_Vector return Flags;

        Comment_Allowed : constant Flags := Get_Comment_Allowed_Vector;

        type Data is record
           Choice  : Choice_Type      := Choice_Type'First;
           Comment : Unbounded_String := Null_Unbounded_String;
        end record;
     end;



  complete backtrace
  ------------------

  #0  0x4098d354 in mallopt () from /lib/libc.so.6
  #1  0x4098c15f in free () from /lib/libc.so.6
  #2  0x408f4e84 in __gnat_free () from /usr/lib/libgnat-3.15p.so.1
  #3  0x4082ac79 in ada__strings__unbounded__finalize__2 ()
     from /usr/lib/libgnat-3.15p.so.1
  #4  0x080c9fe5 in <demo__bug3__get_record___read654___read1116___read1147> (
      s=0x80e2e00, v=@0xbfffc39c, <sF>=0) at demo-bug3.adb:38
  #5  0x080ca136 in <demo__bug3__get_record___read654___read1116> (s=0x80e2e00,
      v=@0xbfffc384, <sF>=0, <vF>=false) at demo-bug3.adb:38
  #6  0x080d5997 in <demo__bug3__get_record___read654> (s=0x80e2e00, v=@0xbfffc108,
      <sF>=0, <vF>=false) at demo-bug3.adb:38
  #7  0x080d869f in demo.bug3.get_record () at demo-bug3.adb:38
  #8  0x080dd625 in demo.bug3 () at demo-bug3.adb:48
  #9  0x080640dd in main (argc=1, argv=(system.address) 0xbffff8a4,
      envp=(system.address) 0xbffff8ac) at b~demo-bug3.adb:244
  #10 0x40930e36 in __libc_start_main () from /lib/libc.so.6


  more information
  ----------------

  I've generated a core and also can reproduce the SIGSEGV in this
  configuration 100% of the time. Don't hesitate to ask for more
  debugger output or more code.