diff options
Diffstat (limited to 'xtools/check_iirs_pkg.adb')
| -rw-r--r-- | xtools/check_iirs_pkg.adb | 1217 |
1 files changed, 1217 insertions, 0 deletions
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; + |