First import from sources

4 files changed, 1353 insertions, 0 deletions

diff --git a/xtools/Makefile b/xtools/Makefile
new file mode 100644
index 000000000..0704f9973
--- /dev/null
+++ b/xtools/Makefile
@@ -0,0 +1,34 @@
+--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+all: check_iirs
+
+check_iirs: force
+	gnatmake -g check_iirs
+
+MODE=--generate
+
+../iirs.adb: ../iirs.adb.in ../iirs.ads ../nodes.ads ./check_iirs
+	$(RM) $@
+	./check_iirs $(MODE) > subprg.ada
+	sed -e "/^   --  Subprograms/r subprg.ada" \
+	  < ../iirs.adb.in > $@
+	chmod -w $@
+
+force:
+
+clean:
+	$(RM) *.o *.ali *~ check_iirs
diff --git a/xtools/check_iirs.adb b/xtools/check_iirs.adb
new file mode 100644
index 000000000..3b28dfee8
--- /dev/null
+++ b/xtools/check_iirs.adb
@@ -0,0 +1,64 @@
+--  Tool to check the coherence of the iirs package.
+--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+with Check_Iirs_Pkg;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Check_Iirs
+is
+   type Prg_Mode is (Mode_Generate, Mode_Genfast, Mode_Free);
+   Mode : Prg_Mode;
+   procedure Usage is
+   begin
+      Put_Line ("usage: " & Command_Name & " MODE");
+      Put_Line ("MODE is one of:");
+      Put_Line (" --generate");
+      Put_Line (" --genfast");
+      Put_Line (" --list-free-fields");
+   end Usage;
+begin
+   if Argument_Count /= 1 then
+      Usage;
+      Set_Exit_Status (Failure);
+      return;
+   end if;
+   if Argument (1) = "--generate" then
+      Mode := Mode_Generate;
+   elsif Argument (1) = "--genfast" then
+      Mode := Mode_Genfast;
+   elsif Argument (1) = "--list-free-fields" then
+      Mode := Mode_Free;
+   else
+      Usage;
+      Set_Exit_Status (Failure);
+      return;
+   end if;
+
+   Check_Iirs_Pkg.Read_Fields;
+   Check_Iirs_Pkg.Check_Iirs;
+   Check_Iirs_Pkg.Read_Desc;
+   case Mode is
+      when Mode_Generate =>
+         Check_Iirs_Pkg.Gen_Func;
+      when Mode_Genfast =>
+         Check_Iirs_Pkg.Flag_Checks := False;
+         Check_Iirs_Pkg.Gen_Func;
+      when Mode_Free =>
+         Check_Iirs_Pkg.List_Free_Fields;
+   end case;
+end Check_Iirs;
diff --git a/xtools/check_iirs_pkg.adb b/xtools/check_iirs_pkg.adb
new file mode 100644
index 000000000..6f705f701
--- /dev/null
+++ b/xtools/check_iirs_pkg.adb
@@ -0,0 +1,1217 @@
+--  Tool to check the coherence of the iirs package.
+--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+with GNAT.Spitbol; use GNAT.Spitbol;
+with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
+with GNAT.Spitbol.Table_Integer; use GNAT.Spitbol.Table_Integer;
+with GNAT.Table;
+
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
+with Ada.Command_Line; use Ada.Command_Line;
+
+package body Check_Iirs_Pkg is
+   --  Exception raise in case of error.
+   Err : exception;
+
+   --  Identifier get by getident_pat.
+   Ident : VString := Nul;
+   Ident_2 : VString := Nul;
+   Ident_3 : VString := Nul;
+   Ident_4 : VString := Nul;
+   Ident_5 : VString := Nul;
+
+   --  Enumel_Pat set this variable to the position of the comma.
+   --  Used to detect the absence of a comma.
+   Comma_Pos : aliased Natural;
+
+   --  Patterns
+   --  Space.
+   Wsp : Pattern := Span (' ');
+
+   --  "type Iir_Kind is".
+   Type_Iir_Kind_Pat : Pattern :=
+     Wsp & "type" & Wsp & "Iir_Kind" & Wsp & "is" & Rpos (0);
+
+   --  "("
+   Lparen_Pat : Pattern := Wsp & '(' & Rpos (0);
+
+   --  Comment.
+   Comment_Pat : Pattern := Wsp & "--";
+
+   --  End of ada line
+   Eol_Pat : Pattern := Comment_Pat or Rpos (0);
+
+   --  "," followed by EOL.
+   Comma_Eol_Pat : Pattern := ',' & Eol_Pat;
+
+   --  A-Za-z
+   Basic_Pat : Pattern := Span (Basic_Set);
+
+   --  A-Za-z0-9
+   Alnum_Pat : Pattern := Span (Alphanumeric_Set);
+
+   --  Ada identifier.
+   Ident_Pat : Pattern := Basic_Pat & Arbno (('_' or "") & Alnum_Pat);
+   -- Basic_Pat & Arbno (Alnum_Pat) & Arbno ('_' & Alnum_Pat);
+
+   --  Eat the ada identifier.
+   Getident_Pat : Pattern := Ident_Pat * Ident;
+   Getident2_Pat : Pattern := Ident_Pat * Ident_2;
+   Getident3_Pat : Pattern := Ident_Pat * Ident_3;
+   Getident4_Pat : Pattern := Ident_Pat * Ident_4;
+   Getident5_Pat : Pattern := Ident_Pat * Ident_5;
+
+   --  Get an enumeration elements.
+   Enumel_Pat : Pattern := Wsp & Getident_Pat
+     & ((',' & Setcur (Comma_Pos'Access)) or "") & Eol_Pat;
+
+   --  End of an enumeration declaration.
+   End_Enum_Pat : Pattern := Wsp & ");" & Eol_Pat;
+
+   Format_Pat : Pattern := "      Format_" & Getident_Pat
+     & ((',' & Setcur (Comma_Pos'Access)) or "") & Eol_Pat;
+
+   Fields_Of_Format_Pat : Pattern := "   -- Fields of Format_" & Getident_Pat
+     & ":" & Rpos (0);
+
+   --  "subtype XX is Iir_Kind range".
+   Iir_Kind_Subtype_Pat : Pattern :=
+     Wsp & "subtype" & Wsp & Getident_Pat & Wsp & "is" & Wsp & "Iir_Kind"
+     & Wsp & "range" & Eol_Pat;
+
+   --  Pattern for a range.
+   Start_Range_Pat : Pattern := Wsp & Getident_Pat & Wsp & ".." & Eol_Pat;
+   Comment_Range_Pat : Pattern := Wsp & "--" & Getident_Pat & Rpos (0);
+   End_Range_Pat : Pattern := Wsp & Getident_Pat & ";" & Eol_Pat;
+
+   --  End of public package part.
+   End_Pat : Pattern := "end Iirs;" & Rpos (0);
+
+   --  Pattern for a function field.
+   Func_Decl_Pat : Pattern := "   --  Field: " & Getident_Pat
+     & ( "" or (" (" & Getident2_Pat & ")")) & Rpos (0);
+
+   --  function Get_XXX.
+   Function_Get_Pat : Pattern := "   function Get_"  & Getident_Pat
+     & " (" & Getident2_Pat & " : " & Getident3_Pat & ") return "
+     & Getident4_Pat & ";" & Rpos (0);
+
+   --  procedure Set_XXX.
+   Procedure_Set_Pat : Pattern := "   procedure Set_"  & Getident_Pat
+     & " (" & Getident2_Pat & " : " & Getident3_Pat
+     & "; " & Getident4_Pat & " : " & Getident5_Pat & ");" & Rpos (0);
+
+   Field_Decl_Pat : Pattern := "   --   " & Getident_Pat & " : ";
+   Field_Type_Pat : Pattern := "   --   " & Ident_Pat & " : "
+     & Getident_Pat & ("" or (" (" & Arb & ")")) & Rpos (0);
+
+   --  Formats of nodes.
+   type Format_Type is range 0 .. 7;
+   No_Format : constant Format_Type := 0;
+   Format_Pos : Format_Type := No_Format;
+
+   Format2pos : GNAT.Spitbol.Table_Integer.Table (8);
+
+   type Format_Info is record
+      Name : String_Access;
+   end record;
+
+   Formats : array (Format_Type) of Format_Info := (others => (Name => null));
+
+   type Format_Mask_Type is array (Format_Type) of Boolean;
+   pragma Pack (Format_Mask_Type);
+
+   --  Type of a IIR name.
+   type Iir_Type is new Natural range 0 .. 255;
+   No_Iir : constant Iir_Type := 0;
+
+   --  Table to convert an Iir name to its position.
+   Iir_Kind2pos : GNAT.Spitbol.Table_Integer.Table (256);
+   --  Last iir used during table construction.
+   Iir_Pos : Iir_Type := No_Iir;
+
+   --  Table of Get_ functions.
+   Function2pos : GNAT.Spitbol.Table_Integer.Table (256);
+
+   --  Table of field.
+   Field2pos : GNAT.Spitbol.Table_Integer.Table (32);
+
+   type Range_Type is record
+     L : Iir_Type;
+     H : Iir_Type;
+   end record;
+
+   Null_Range : constant Range_Type := (No_Iir, No_Iir);
+
+   function Img (Rng : Range_Type) return String is
+   begin
+      return "(" & Iir_Type'Image (Rng.L) & ", "
+        & Iir_Type'Image (Rng.H) & ")";
+   end Img;
+
+   package Table_Range is new GNAT.Spitbol.Table (Range_Type, Null_Range, Img);
+   use Table_Range;
+
+   Iir_Kinds2pos : Table_Range.Table (32);
+
+   --  Field type.  They represent a raw field.
+   type Field_Type is new Integer range 0 .. 64;
+   No_Field : constant Field_Type := 0;
+   --  Position of the last field.
+   Field_Pos : Field_Type := No_Field;
+
+   type Field_Info is record
+      --  Name of the field.
+      Name : String_Access;
+      --  Type of the field.
+      Ftype : String_Access;
+      --  Formats in which the field is valid.
+      Formats : Format_Mask_Type;
+   end record;
+
+   package Field_Table is new GNAT.Table
+     (Table_Component_Type => Field_Info,
+      Table_Index_Type => Field_Type,
+      Table_Low_Bound => 1,
+      Table_Initial => 32,
+      Table_Increment => 100);
+
+   --  Function type.  They represent a field name.
+   type Func_Type is new Natural;
+   No_Func : constant Func_Type := 0;
+   --  Last function known; used during the construction of the func_table.
+   Function_Pos : Func_Type := No_Func;
+
+   type Field2Func_Array is array (Field_Type) of Func_Type;
+
+   --  Information for each Iir node.
+   type Iir_Info is record
+      --  Name of the Kind.
+      Name : String_Access;
+
+      --  If TRUE, the node was described.
+      Described : Boolean;
+
+      --  Format used by the node.
+      Format : Format_Type;
+
+      --  Function used to get the value of each field.
+      Func : Field2Func_Array;
+   end record;
+
+   --  Table of IIr.
+   package Iir_Table is new GNAT.Table
+     (Table_Component_Type => Iir_Info,
+      Table_Index_Type => Iir_Type,
+      Table_Low_Bound => 1,
+      Table_Initial => 256,
+      Table_Increment => 100);
+
+   --  Table of functions.
+   type Iir_Bool_Array is array (Iir_Type) of Boolean;
+   pragma Pack (Iir_Bool_Array);
+
+   type Conversion_Type is (None, Via_Pos_Attr, Via_Unchecked);
+
+   type Func_Info is record
+      --  Name of the function.
+      Name : Vstring;
+      --  Field get/set by the function.
+      Field : Field_Type;
+      --  If true, the iir use this function.
+      Uses : Iir_Bool_Array;
+      --  Name of the target.
+      Target_Name : String_Access;
+      --  Type of the target.
+      Target_Type : String_Access;
+      --  Name of the value.
+      Value_Name : String_Access;
+      --  Type of the value.
+      Value_Type : String_Access;
+      --  Conversion;
+      Conv : Conversion_Type;
+   end record;
+
+   package Func_Table is new GNAT.Table
+     (Table_Component_Type => Func_Info,
+      Table_Index_Type => Func_Type,
+      Table_Low_Bound => 1,
+      Table_Initial => 256,
+      Table_Increment => 100);
+
+   --  Get the position of IIR V.
+   function Get_Iir_Pos (V : VString) return Iir_Type
+   is
+      P : Integer;
+   begin
+      P := Get (Iir_Kind2pos, V);
+
+      if P < 0 then
+         --  Identifier unknown.
+         raise Err;
+      end if;
+      return Iir_Type (P);
+   end Get_Iir_Pos;
+
+   Disp_Func : Boolean := False;
+
+   Flag_Disp_Format : Boolean := False;
+   Flag_Disp_Field : Boolean := False;
+
+   procedure Read_Fields
+   is
+      In_Node : File_Type;
+      Line : VString := Nul;
+
+      Format_Mask : Format_Mask_Type;
+
+      procedure Parse_Field
+      is
+         P : Integer;
+         Name : Vstring := Ident;
+      begin
+         if not Match (Line, Field_Type_Pat) then
+            Put_Line ("**  field declaration without type");
+            raise Err;
+         end if;
+
+         --  Check if the field is not already known.
+         P := Get (Field2pos, Name);
+         if P > 0 then
+            if Ident /= Field_Table.Table (Field_Type (P)).Ftype.all then
+               Put_Line ("*** field type mismatch");
+               raise Err;
+            end if;
+            for I in Format_Mask'Range loop
+               if Format_Mask (I) then
+                  Field_Table.Table (Field_Type (P)).Formats (I) := True;
+               end if;
+            end loop;
+            return;
+         end if;
+
+         Field_Pos := Field_Pos + 1;
+         Set (Field2pos, Name, Natural (Field_Pos));
+         Field_Table.Set_Last (Field_Pos);
+         Field_Table.Table (Field_Pos) :=
+           (Name => new String'(To_String (Name)),
+            Ftype => new String'(To_String (Ident)),
+            Formats => Format_Mask);
+         if Flag_Disp_Field then
+            Put_Line ("found field '"
+                      & Field_Table.Table (Field_Pos).Name.all & "'");
+         end if;
+      end Parse_Field;
+   begin
+      Open (In_Node, In_File, "../nodes.ads");
+
+      Anchored_Mode := True;
+
+      --  Read lines until "type format_type is":
+      loop
+         Line := Get_Line (In_Node);
+         exit when Match (Line, "   type Format_Type is" & Rpos (0));
+      end loop;
+      --  Expect '('.
+      Line := Get_Line (In_Node);
+      if not Match (Line, "     (" & Rpos (0)) then
+         raise Err;
+      end if;
+
+      --  Read all formats.
+      loop
+         Line := Get_Line (In_Node);
+
+         --  Read the identifier.
+         Comma_Pos := 0;
+         if not Match (Line, Format_Pat) then
+            raise Err;
+         end if;
+
+         --  Put it into the table.
+         Format_Pos := Format_Pos + 1;
+         Set (Format2Pos, Ident, Natural (Format_Pos));
+         Formats (Format_Pos) := (Name => new String'(To_String (Ident)));
+         if Flag_Disp_Format then
+            Put_Line ("found format " & S (Ident));
+         end if;
+
+         --  If there is no comma, then this is the end of enumeration.
+         exit when Comma_Pos = 0;
+      end loop;
+
+      --  Read ");"
+      Line := Get_Line (In_Node);
+      if not Match (Line, "     );" & Rpos (0)) then
+         raise Err;
+      end if;
+
+      --  Read fields.
+
+      loop
+         Line := Get_Line (In_Node);
+         exit when Match (Line, "   -- Common fields are:" & Rpos (0));
+      end loop;
+      Format_Mask := (others => True);
+      loop
+         Line := Get_Line (In_Node);
+         if Match (Line, Field_Decl_Pat) then
+            Parse_Field;
+         elsif Match (Line, Rpos (0)) then
+            Line := Get_Line (In_Node);
+            exit when not Match (Line, Fields_Of_Format_Pat);
+            declare
+               P : Integer;
+            begin
+               P := Get (Format2pos, Ident);
+               if P < 0 then
+                  Put_Line ("*** unknown format");
+                  raise Err;
+               end if;
+               Format_Mask := (others => False);
+               Format_Mask (Format_Type (P)) := True;
+            end;
+         else
+            Put_Line ("**  bad line in field declarations");
+            raise Err;
+         end if;
+      end loop;
+      Close (In_Node);
+
+      if False then
+        Put_Line ("Fields:");
+        for I in 1 .. Field_Pos loop
+           Put (Field_Table.Table (I).Name.all);
+           Put (": ");
+           Put (Field_Table.Table (I).Ftype.all);
+           Put ("  ");
+           for J in Format_Mask_Type'Range loop
+              if Field_Table.Table (I).Formats (J)
+                and then Formats (J).Name /= null
+              then
+                 Put (" ");
+                 Put (Formats (J).Name.all);
+              end if;
+           end loop;
+           New_Line;
+        end loop;
+      end if;
+   end Read_Fields;
+
+   --  Read all Iir_Kind_* names and put them into Iir_Table.
+   --  Fill Iir_Kinds2pos
+   --  Fill Func_Table.
+   procedure Check_Iirs
+   is
+      --  iirs.ads file.
+      In_Iirs : File_Type;
+
+      --  Line read from In_Iirs.
+      Line : VString := Nul;
+   begin
+      --  Open the file.
+      Open (In_Iirs, In_File, "../iirs.ads");
+
+      Anchored_Mode := True;
+
+      --  Read lines until "type Iir_Kind is"
+      loop
+         Line := Get_Line (In_Iirs);
+         exit when Match (Line, Type_Iir_Kind_Pat);
+      end loop;
+
+      if Flag_Disp_Iir then
+         Put_Line ("found iir_kind at line"
+                   & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs)));
+      end if;
+
+      --Debug_Mode := True;
+
+      --  Read '('
+      Line := Get_Line (In_Iirs);
+      if not Match (Line, Lparen_Pat) then
+         raise Err;
+      end if;
+
+      --  Read all kind.
+      loop
+         Line := Get_Line (In_Iirs);
+
+         --  Skip comments and empty lines.
+         if Match (Line, Eol_Pat) then
+            goto Continue;
+         end if;
+
+         --  Read the identifier.
+         Comma_Pos := 0;
+         if not Match (Line, Enumel_Pat) then
+            raise Err;
+         end if;
+
+         --  Put it into the table.
+         Iir_Pos := Iir_Pos + 1;
+         Set (Iir_Kind2pos, Ident, Natural (Iir_Pos));
+         Iir_Table.Set_Last (Iir_Pos);
+         Iir_Table.Table (Iir_Pos) := (Name => new String'(To_String (Ident)),
+                                       Described => False,
+                                       Format => No_Format,
+                                       Func => (others => No_Func));
+         if Flag_Disp_Iir then
+            Put_Line ("found " & S (Ident) & Iir_Type'Image (Iir_Pos));
+         end if;
+
+         --  If there is no comma, then this is the end of enumeration.
+         exit when Comma_Pos = 0;
+         << Continue >> null;
+      end loop;
+
+      --  Read ");"
+      Line := Get_Line (In_Iirs);
+      if not Match (Line, End_Enum_Pat) then
+         raise Err;
+      end if;
+
+      --  Look for iir_kind subtype.
+      loop
+         Line := Get_Line (In_Iirs);
+         exit when Match (Line, End_Pat);
+
+         Ident_2 := Null_Unbounded_String;
+
+         if Match (Line, Iir_Kind_Subtype_Pat) then
+            declare
+               Start : Iir_Type;
+               Pos : Iir_Type;
+               P : Iir_Type;
+               Rng_Ident : VString := Ident;
+            begin
+               Line := Get_Line (In_Iirs);
+               if not Match (Line, Start_Range_Pat) then
+                  --  Bad pattern for left bound.
+                  raise Err;
+               end if;
+               Start := Get_Iir_Pos (Ident);
+               Pos := Start;
+               if Flag_Disp_Subtype then
+                  Put_Line ("found subtype " & S (Rng_Ident));
+                  Put_Line ("     " & S (Ident) & " .."
+                            & Iir_Type'Image (Pos));
+               end if;
+
+               loop
+                  Line := Get_Line (In_Iirs);
+                  if Match (Line, End_Range_Pat) then
+                     P := Get_Iir_Pos (Ident);
+                     if P /= Pos + 1 and then Flag_Disp_Subtype Then
+                        Put_Line ("** missing comments");
+                        for I in Pos + 1 .. P - 1 loop
+                           Put_Line ("   --" & Iir_Table.Table (I).Name.all);
+                        end loop;
+                     end if;
+                     Set (Iir_Kinds2pos, Rng_Ident, Range_Type'(Start, P));
+                     if Flag_Disp_Subtype then
+                        Put_Line ("     " & S (Ident) & Iir_Type'Image (P));
+                     end if;
+                     exit;
+                  elsif Match (Line, Comment_Range_Pat) then
+                     P := Get_Iir_Pos (Ident);
+                     if P /= Pos + 1 then
+                        --  Bad order.
+                        raise Err;
+                     else
+                        Pos := Pos + 1;
+                     end if;
+                  else
+                     --  Comment (with identifier) or end of range expected.
+                     raise Err;
+                  end if;
+               end loop;
+            end;
+         elsif Match (Line, Func_Decl_Pat) then
+            declare
+               Field_Pos : Integer;
+               F : Func_Type;
+               Conv : Conversion_Type;
+            begin
+               Field_Pos := Get (Field2pos, Ident);
+               if Field_Pos < 0 then
+                  Put_Line ("*** field not found: '" & S (Ident) & "'");
+                  raise Err;
+               end if;
+
+               if Ident_2 /= Null_Unbounded_String then
+                  if Ident_2 = "pos" then
+                     Conv := Via_Pos_Attr;
+                  elsif Ident_2 = "uc" then
+                     Conv := Via_Unchecked;
+                  else
+                     Put_Line ("*** bad conversion");
+                     raise Err;
+                  end if;
+               else
+                  Conv := None;
+               end if;
+
+               Line := Get_Line (In_Iirs);
+               if not Match (Line, Function_Get_Pat) then
+                  Put_Line ("*** function expected");
+                  raise Err;
+               end if;
+
+               if False then
+                  Put_Line ("found function " & S (Ident));
+               end if;
+               Function_Pos := Function_Pos + 1;
+               F := Function_Pos;
+               Set (Function2pos, Ident, Integer (Function_Pos));
+               Func_Table.Set_Last (Function_Pos);
+               Func_Table.Table (Function_Pos) :=
+                 (Name => Ident,
+                  Field => Field_Type (Field_Pos),
+                  Uses => (others => False),
+                  Target_Name => new String'(To_String (Ident_2)),
+                  Target_Type => new String'(To_String (Ident_3)),
+                  Value_Name => null,
+                  Value_Type => new String'(To_String (Ident_4)),
+                  Conv => Conv);
+
+               Line := Get_Line (In_Iirs);
+               if Match (Line, Procedure_Set_Pat) then
+                  if Func_Table.Table (F).Target_Name.all /= Ident_2 then
+                     Put_Line ("*** procedure target name mismatch ("
+                               & Func_Table.Table (F).Target_Name.all
+                               & " vs " & S (Ident_2) &")");
+                     raise Err;
+                  end if;
+                  if Func_Table.Table (F).Target_Type.all /= Ident_3 then
+                     Put_Line ("*** procedure target type name mismatch");
+                     raise Err;
+                  end if;
+                  if Func_Table.Table (F).Value_Type.all /= Ident_5 then
+                     Put_Line ("*** procedure target type name mismatch");
+                     raise Err;
+                  end if;
+                  Func_Table.Table (F).Value_Name :=
+                    new String'(To_String (Ident_4));
+               else
+                  if not Match (Line, Rpos (0)) then
+                     Put_Line ("*** procedure or empty line expected");
+                     raise Err;
+                  end if;
+               end if;
+            end;
+         end if;
+      end loop;
+      Close (In_Iirs);
+      Set_Exit_Status (Success);
+   exception
+      when Err =>
+         Put_Line ("*** Fatal error at line"
+                   & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs)));
+         Set_Exit_Status (Failure);
+         raise;
+   end Check_Iirs;
+
+   --  Start of node description.
+   Start_Of_Iir_Kind_Pat : Pattern := "   -- Start of Iir_Kind." & Rpos (0);
+   End_Of_Iir_Kind_Pat : Pattern := "   -- End of Iir_Kind." & Rpos (0);
+
+   --  Box ("----------") delimiters.
+   Box_Delim_Pat : Pattern := "   --" & Span ('-') & Rpos (0);
+
+   --  Inside a box ("-- XXX --").
+   Box_Inside_Pat : Pattern := "   --" & Arb & "--" & Rpos (0);
+
+   --  Get a iir_kind identifier.
+   Desc_Iir_Kind_Pat : Pattern :=
+     "   -- " & Getident_Pat
+     & ("" or ( " (" & Getident2_Pat & ")"))
+     & Rpos (0);
+
+   Subprogram_Pat : Pattern := "   --   Get" & ("_" or "/Set_") & Getident_Pat
+     & ((" " & Arb) or "") & Rpos (0);
+
+   Desc_Only_For_Pat : Pattern := "   -- Only for " & Getident_Pat & ":"
+     & Rpos (0);
+   Desc_Comment_Pat : Pattern := "   -- " & (Alnum_Pat or Any ("*_(.|"));
+   Desc_Empty_Pat : Pattern := "   --" & Rpos (0);
+   Desc_Subprogram_Pat : Pattern := "   --   " & ("function" or "procedure");
+
+   Field_Pat : Pattern := Arb & "(" & Getident_Pat & ")";
+   Alias_Field_Pat : Pattern := Arb & "(Alias " & Getident_Pat & ")";
+
+   Disp_Desc : Boolean := False;
+
+   --  Check descriptions.
+   procedure Read_Desc
+   is
+      --  iirs.ads file.
+      In_Iirs : File_Type;
+
+      --  Current line.
+      Line : VString;
+
+      --  IIR being described.
+      type Iir_Array is array (Natural range <>) of Iir_Type;
+      Iir_Desc : Iir_Array (1 .. 32);
+      Nbr_Desc : Natural := 0;
+
+      Only_For : Iir_Array (1 .. 16) := (others => No_Iir);
+      Nbr_Only_For : Natural := 0;
+
+      --  Just say IIR N is being described.
+      procedure Add_Desc (N : Iir_Type; Format : Format_Type) is
+      begin
+         if Iir_Table.Table (N).Described then
+            Put_Line ("*** iir already described");
+            raise Err;
+         end if;
+
+         Iir_Table.Table (N).Described := True;
+         Iir_Table.Table (N).Format := Format;
+         Nbr_Desc := Nbr_Desc + 1;
+         Iir_Desc (Nbr_Desc) := N;
+      end Add_Desc;
+
+   begin
+      --  Open the file.
+      Open (In_Iirs, In_File, "../iirs.ads");
+
+      Anchored_Mode := True;
+
+      if False then
+         --  List of fields.
+         Set (Field2pos, "Field1", 1);
+         Set (Field2pos, "Field2", 2);
+         Set (Field2pos, "Field3", 3);
+         Set (Field2pos, "Field4", 4);
+         Set (Field2pos, "Field5", 5);
+         Set (Field2pos, "Field6", 6);
+         Set (Field2pos, "Field7", 7);
+         Set (Field2pos, "Nbr2", 6);
+         Set (Field2pos, "Nbr3", 7);
+
+         Set (Field2pos, "Ident", 8);
+         Set (Field2pos, "Field0", 9);
+         Set (Field2pos, "Attr", 10);
+         Set (Field2pos, "Chain", 11);
+
+         Set (Field2pos, "Flag1", 12);
+         Set (Field2pos, "Flag2", 13);
+         Set (Field2pos, "Flag3", 14);
+         Set (Field2pos, "Flag4", 15);
+         Set (Field2pos, "Flag5", 16);
+         Set (Field2pos, "Odigit_1", 17);
+         Set (Field2pos, "Odigit_2", 18);
+         Set (Field2pos, "State1", 19);
+         Set (Field2pos, "Staticness_1", 20);
+         Set (Field2pos, "Staticness_2", 21);
+      end if;
+
+      --  Read lines until "-- Start of Iir_Kind."
+      loop
+         Line := Get_Line (In_Iirs);
+         exit when Match (Line, Start_Of_Iir_Kind_Pat);
+      end loop;
+
+      --Debug_Mode := True;
+
+      --  Read descriptions.
+      L1 : loop
+
+         --  Empty lines.
+         loop
+            Line := Get_Line (In_Iirs);
+            exit when not Match (Line, Rpos (0));
+         end loop;
+
+         if Match (Line, Box_Delim_Pat) then
+            --  A box.
+            Line := Get_Line (In_Iirs);
+            if not Match (Line, Box_Inside_Pat) then
+               raise Err;
+            end if;
+            Line := Get_Line (In_Iirs);
+            if not Match (Line, Box_Delim_Pat) then
+               raise Err;
+            end if;
+         else
+            --  A description.
+            if not Match (Line, "   -- Iir_Kind") then
+               if Match (Line, End_Of_Iir_Kind_Pat) then
+                  exit L1;
+               elsif Match (Line, "   -- For Iir_Kinds_") then
+                  null;
+               else
+                  raise Err;
+               end if;
+            end if;
+
+            --  Get iir_kind.
+            declare
+               P_Num : Integer;
+               Rng : Range_Type;
+               Format : Format_Type;
+            begin
+               --  No iir being described.
+               Nbr_Desc := 0;
+               loop
+                  Ident_2 := Nul;
+                  exit when not Match (Line, Desc_Iir_Kind_Pat);
+
+                  --  Check format.
+                  if Ident_2 = Nul then
+                     Put_Line ("*** no format for " & S (Ident));
+                     raise Err;
+                  end if;
+                  P_Num := Get (Format2pos, Ident_2);
+                  if P_Num < 0 then
+                     Put_Line ("*** unknown format");
+                     raise Err;
+                  end if;
+                  Format := Format_Type (P_Num);
+
+                  --  Handle nodes.
+                  P_Num := Get (Iir_Kind2pos, Ident);
+                  if P_Num >= 0 then
+                     Add_Desc (Iir_Type (P_Num), Format);
+                  else
+                     Rng := Get (Iir_Kinds2pos, Ident);
+                     if Rng = Null_Range then
+                        Put_Line ("*** " & S (Ident));
+                        raise Err;
+                     end if;
+                     for I in Rng.L .. Rng.H loop
+                        Add_Desc (I, Format);
+                     end loop;
+                  end if;
+
+                  if Disp_Desc then
+                     Put_Line ("desc for " & S (Ident));
+                  end if;
+
+                  Line := Get_Line (In_Iirs);
+               end loop;
+            end;
+
+            --Debug_Mode := True;
+
+            --  Read the functions.
+            loop
+               if not Match (Line, Comment_Pat) then
+                  if Match (Line, Rpos (0)) then
+                     exit;
+                  else
+                     raise Err;
+                  end if;
+               end if;
+               declare
+                  Func : Func_Type;
+                  Func_Num : Integer;
+                  Field : Field_Type;
+                  Field_Num : Integer;
+                  Is_Alias : Boolean;
+
+                  procedure Add_Field (N : Iir_Type) is
+                  begin
+                     if not Field_Table.Table (Field).
+                       Formats (Iir_Table.Table (N).Format)
+                     then
+                        Put_Line ("** no field for format");
+                        raise Err;
+                     end if;
+                     if Is_Alias then
+                        if Iir_Table.Table (N).Func (Field) = No_Func
+                        then
+                           Put_Line ("**  aliased field not yet used");
+                           raise Err;
+                        end if;
+                     else
+                        if Iir_Table.Table (N).Func (Field) /= No_Func
+                          --and then
+                          --Iir_Table.Table (N).Func (Field) /= Func
+                        then
+                           Put_Line ("**  Field already used");
+                           raise Err;
+                        end if;
+                        Iir_Table.Table (N).Func (Field) := Func;
+                     end if;
+                     Func_Table.Table (Func).Uses (N) := True;
+                  end Add_Field;
+               begin
+                  if Match (Line, Subprogram_Pat) then
+                     if Disp_Desc then
+                        Put ("subprg: " & S (Ident));
+                     end if;
+                     Func_Num := Get (Function2pos, Ident);
+                     if Func_Num < 0 then
+                        Put_Line (Standard_Error,
+                                  "*** function not found: " & S (Ident));
+                        raise Err;
+                     end if;
+                     Func := Func_Type (Func_Num);
+                     if Match (Line, Field_Pat) then
+                        Is_Alias := False;
+                     elsif Match (Line, Alias_Field_Pat) then
+                        Is_Alias := True;
+                     else
+                        raise Err;
+                     end if;
+                     if Disp_Desc then
+                        Put_Line ("  (" & S (Ident) & ")");
+                     end if;
+                     Field_Num := Get (Field2pos, Ident);
+                     if Field_Num < 0 then
+                        Put_Line ("*** unknown field: " & S (Ident));
+                        raise Err;
+                     end if;
+                     Field := Field_Type (Field_Num);
+                     if Func_Table.Table (Func).Field /= Field then
+                        if Func_Table.Table (Func).Field = No_Field then
+                           Func_Table.Table (Func).Field := Field;
+                        else
+                           --  Field redefined for the function.
+                           Put_Line ("**  field redefined for the function");
+                           raise Err;
+                        end if;
+                     end if;
+
+                     --  Check the field is not already used by another func.
+                     if Nbr_Only_For > 0 then
+                        for I in 1 .. Nbr_Only_For loop
+                           Add_Field (Only_For (I));
+                        end loop;
+                        Nbr_Only_For := 0;
+                     else
+                        for I in 1 .. Nbr_Desc loop
+                           Add_Field (Iir_Desc (I));
+                        end loop;
+                     end if;
+                  elsif Match (Line, Desc_Only_For_Pat) then
+                     declare
+                        P_Num : Integer;
+                        Rng : Range_Type;
+
+                        procedure Add_Only_For (N : Iir_Type) is
+                        begin
+                           for I in 1 .. Nbr_Desc loop
+                              if Iir_Desc (I) = N then
+                                 Nbr_Only_For := Nbr_Only_For + 1;
+                                 Only_For (Nbr_Only_For) := N;
+                                 return;
+                              end if;
+                           end loop;
+                           Put_Line ("**  not currently described");
+                           raise Err;
+                        end Add_Only_For;
+                     begin
+                        P_Num := Get (Iir_Kind2pos, Ident);
+                        if P_Num >= 0 then
+                           Add_Only_For (Iir_Type (P_Num));
+                        else
+                           Rng := Get (Iir_Kinds2pos, Ident);
+                           if Rng = Null_Range then
+                              Put_Line ("*** " & S (Ident));
+                              raise Err;
+                           end if;
+                           for I in Rng.L .. Rng.H loop
+                              Add_Only_For (I);
+                           end loop;
+                        end if;
+                     end;
+                  elsif Match (Line, "   -- Only") then
+                     Put_Line ("**  bad only for line");
+                     raise Err;
+                  elsif Match (Line, Desc_Comment_Pat) then
+                     null;
+                  elsif Match (Line, Desc_Empty_Pat) then
+                     null;
+                  elsif Match (Line, Desc_Subprogram_Pat) then
+                     null;
+                  else
+                     raise Err;
+                  end if;
+               end;
+               Line := Get_Line (In_Iirs);
+            end loop;
+         end if;
+      end loop L1;
+
+      --  Check each Iir was described.
+      for I in Iir_Table.First .. Iir_Table.Last loop
+         if not Iir_Table.Table (I).Described then
+            Put_Line ("*** not described: " & Iir_Table.Table (I).Name.all);
+            raise Err;
+         end if;
+      end loop;
+
+      Close (In_Iirs);
+   exception
+      when Err =>
+         Put_Line ("*** Fatal error at line"
+                   & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs) - 1));
+         Put_Line ("*** Line is " & S (Line));
+         Set_Exit_Status (Failure);
+         raise;
+   end Read_Desc;
+
+   procedure Gen_Func
+   is
+      function Is_Used (F : Func_Type) return Boolean
+      is
+      begin
+         for I in Func_Table.Table (F).Uses'Range loop
+            if Func_Table.Table (F).Uses (I) then
+               return True;
+            end if;
+         end loop;
+         return False;
+      end Is_Used;
+      Is_First : Boolean;
+      Same_Name : Boolean;
+   begin
+      Put_Line ("   function Get_Format (Kind : Iir_Kind) "
+                & "return Format_Type is");
+      Put_Line ("   begin");
+      Put_Line ("      case Kind is");
+      for I in 1 .. Format_Pos loop
+         Is_First := True;
+         Put      ("         when ");
+         for J in Iir_Table.First .. Iir_Table.Last loop
+            if Iir_Table.Table (J).Format = I then
+               if not Is_First then
+                  New_Line;
+                  Put ("           | ");
+               end if;
+               Is_First := False;
+               Put (Iir_Table.Table (J).Name.all);
+            end if;
+         end loop;
+         Put_Line (" =>");
+         Put      ("            return Format_");
+         Put (Formats (I).Name.all);
+         Put_Line (";");
+      end loop;
+      Put_Line ("      end case;");
+      Put_Line ("   end Get_Format;");
+      New_Line;
+
+      --  Builder.
+      Put_Line ("   function Create_Iir (Kind : Iir_Kind) return Iir");
+      Put_Line ("   is");
+      Put_Line ("      Res : Iir;");
+      Put_Line ("      Format : Format_Type;");
+      Put_Line ("   begin");
+      Put_Line ("      Format := Get_Format (Kind);");
+      Put_Line ("      Res := Create_Node (Format);");
+      Put_Line ("      Set_Nkind (Res, Iir_Kind'Pos (Kind));");
+      Put_Line ("      return Res;");
+      Put_Line ("   end Create_Iir;");
+      New_Line;
+
+      for I in Func_Table.First .. Func_Table.Last loop
+         declare
+            F : Func_Info renames Func_Table.Table (I);
+         begin
+            --  Avoid bug get_parent.
+            if Is_Used (I) then
+               Same_Name := F.Name = Field_Table.Table (F.Field).Name.all;
+               if Flag_Checks then
+                  Put ("   procedure Check_Kind_For_");
+                  Put (F.Name);
+                  Put (" (Target : Iir) is");
+                  New_Line;
+                  Put_Line ("   begin");
+                  Put_Line ("      case Get_Kind (Target) is");
+                  Put ("         when ");
+                  Is_First := True;
+                  for J in F.Uses'Range loop
+                     if F.Uses (J) then
+                        if not Is_First then
+                           New_Line;
+                           Put ("           | ");
+                        else
+                           Is_First := False;
+                        end if;
+                        Put (Iir_Table.Table (J).Name.all);
+                     end if;
+                  end loop;
+                  Put_Line (" =>");
+                  Put_Line ("            null;");
+                  Put_Line ("         when others =>");
+                  Put ("            Failed (""");
+                  Put (F.Name);
+                  Put_Line (""", Target);");
+                  Put_Line ("      end case;");
+                  Put ("   end Check_Kind_For_");
+                  Put (F.Name);
+                  Put_Line (";");
+                  New_Line;
+               end if;
+
+               Put ("   function Get_");
+               Put (F.Name);
+               Put (" (");
+               Put (F.Target_Name.all);
+               Put (" : ");
+               Put (F.Target_Type.all);
+               Put (") return ");
+               Put (F.Value_Type.all);
+               if Col > 76 then
+                  New_Line;
+                  Put ("     ");
+               end if;
+               Put (" is");
+               New_Line;
+               Put_Line ("   begin");
+               if Flag_Checks then
+                  Put ("      Check_Kind_For_");
+                  Put (F.Name);
+                  Put (" (");
+                  Put (F.Target_Name.all);
+                  Put (");");
+                  New_Line;
+               end if;
+               Put ("      return ");
+               case F.Conv is
+                  when None =>
+                     null;
+                  when Via_Pos_Attr =>
+                     Put (F.Value_Type.all);
+                     Put ("'Val (");
+                  when Via_Unchecked =>
+                     Put (Field_Table.Table (F.Field).Ftype.all);
+                     Put ("_To_");
+                     Put (F.Value_Type.all);
+                     Put (" (");
+               end case;
+               if Same_Name then
+                  Put ("Nodes.");
+               end if;
+               Put ("Get_");
+               Put (Field_Table.Table (F.Field).Name.all);
+               Put (" (");
+               Put (F.Target_Name.all);
+               Put (")");
+               case F.Conv is
+                  when None =>
+                     null;
+                  when Via_Pos_Attr
+                    | Via_Unchecked =>
+                     Put (")");
+               end case;
+               Put (";");
+               New_Line;
+               Put ("   end Get_");
+               Put (F.Name);
+               Put (";");
+               New_Line;
+               New_Line;
+
+               if F.Value_Name /= null then
+                  Put ("   procedure Set_");
+                  Put (F.Name);
+                  Put (" (");
+                  Put (F.Target_Name.all);
+                  Put (" : ");
+                  Put (F.Target_Type.all);
+                  Put ("; ");
+                  Put (F.Value_Name.all);
+                  Put (" : ");
+                  Put (F.Value_Type.all);
+                  Put (")");
+                  if Col > 76 then
+                     New_Line;
+                     Put ("     ");
+                  end if;
+                  Put (" is");
+                  New_Line;
+                  Put_Line ("   begin");
+                  if Flag_Checks then
+                     Put ("      Check_Kind_For_");
+                     Put (F.Name);
+                     Put (" (");
+                     Put (F.Target_Name.all);
+                     Put (");");
+                     New_Line;
+                  end if;
+                  Put ("      ");
+                  if Same_Name then
+                     Put ("Nodes.");
+                  end if;
+                  Put ("Set_");
+                  Put (Field_Table.Table (F.Field).Name.all);
+                  Put (" (");
+                  Put (F.Target_Name.all);
+                  Put (", ");
+                  case F.Conv is
+                     when None =>
+                        null;
+                     when Via_Pos_Attr =>
+                        Put (F.Value_Type.all);
+                        Put ("'Pos (");
+                     when Via_Unchecked =>
+                        Put (F.Value_Type.all);
+                        Put ("_To_");
+                        Put (Field_Table.Table (F.Field).Ftype.all);
+                        Put (" (");
+                  end case;
+                  Put (F.Value_Name.all);
+                  case F.Conv is
+                     when None =>
+                        null;
+                     when Via_Pos_Attr
+                       | Via_Unchecked =>
+                        Put (")");
+                  end case;
+                  Put (");");
+                  New_Line;
+                  Put ("   end Set_");
+                  Put (F.Name);
+                  Put (";");
+                  New_Line;
+                  New_Line;
+               end if;
+            end if;
+         end;
+      end loop;
+   end Gen_Func;
+
+   procedure List_Free_Fields
+   is
+   begin
+      for I in Iir_Table.First .. Iir_Table.Last loop
+         declare
+            Info : Iir_Info renames Iir_Table.Table (I);
+         begin
+            Put_Line (Info.Name.all);
+            for J in 1 .. Field_Pos loop
+               if Info.Func (J) = No_Func
+                 and then Field_Table.Table (J).Formats (Info.Format)
+               then
+                  Put (" ");
+                  Put_Line (Field_Table.Table (J).Name.all);
+               end if;
+            end loop;
+         end;
+      end loop;
+   end List_Free_Fields;
+end Check_Iirs_Pkg;
+
diff --git a/xtools/check_iirs_pkg.ads b/xtools/check_iirs_pkg.ads
new file mode 100644
index 000000000..e03abab4a
--- /dev/null
+++ b/xtools/check_iirs_pkg.ads
@@ -0,0 +1,38 @@
+--  Tool to check the coherence of the iirs package.
+--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+
+package Check_Iirs_Pkg is
+   --  If set, disp all Iir kind.
+   Flag_Disp_Iir : Boolean := False;
+
+   --  If set, disp Iir_Kinds subtype.
+   Flag_Disp_Subtype : Boolean := False;
+
+   --  If set, generate checks.
+   Flag_Checks : Boolean := True;
+
+   procedure Read_Fields;
+
+   procedure Check_Iirs;
+
+   procedure Read_Desc;
+
+   procedure Gen_Func;
+
+   procedure List_Free_Fields;
+end Check_Iirs_Pkg;