diff options
Diffstat (limited to 'xtools/check_iirs_pkg.adb')
| -rw-r--r-- | xtools/check_iirs_pkg.adb | 1234 |
1 files changed, 0 insertions, 1234 deletions
diff --git a/xtools/check_iirs_pkg.adb b/xtools/check_iirs_pkg.adb deleted file mode 100644 index 219c13276..000000000 --- a/xtools/check_iirs_pkg.adb +++ /dev/null @@ -1,1234 +0,0 @@ --- 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 : constant Pattern := Span (' '); - - -- "type Iir_Kind is". - Type_Iir_Kind_Pat : constant Pattern := - Wsp & "type" & Wsp & "Iir_Kind" & Wsp & "is" & Rpos (0); - - -- "(" - Lparen_Pat : constant Pattern := Wsp & '(' & Rpos (0); - - -- Comment. - Comment_Pat : constant Pattern := Wsp & "--"; - - -- End of ada line - Eol_Pat : constant Pattern := Comment_Pat or Rpos (0); - - -- A-Za-z - Basic_Pat : constant Pattern := Span (Basic_Set); - - -- A-Za-z0-9 - Alnum_Pat : constant Pattern := Span (Alphanumeric_Set); - - -- Ada identifier. - Ident_Pat : constant Pattern := Basic_Pat & Arbno (('_' or "") & Alnum_Pat); - -- Basic_Pat & Arbno (Alnum_Pat) & Arbno ('_' & Alnum_Pat); - - -- Eat the ada identifier. - Getident_Pat : constant Pattern := Ident_Pat * Ident; - Getident2_Pat : constant Pattern := Ident_Pat * Ident_2; - Getident3_Pat : constant Pattern := Ident_Pat * Ident_3; - Getident4_Pat : constant Pattern := Ident_Pat * Ident_4; - Getident5_Pat : constant Pattern := Ident_Pat * Ident_5; - - -- Get an enumeration elements. - Enumel_Pat : constant Pattern := Wsp & Getident_Pat - & ((',' & Setcur (Comma_Pos'Access)) or "") & Eol_Pat; - - -- End of an enumeration declaration. - End_Enum_Pat : constant Pattern := Wsp & ");" & Eol_Pat; - - Format_Pat : constant Pattern := " Format_" & Getident_Pat - & ((',' & Setcur (Comma_Pos'Access)) or "") & Eol_Pat; - - Fields_Of_Format_Pat : constant Pattern := - " -- Fields of Format_" & Getident_Pat & ":" & Rpos (0); - - -- "subtype XX is Iir_Kind range". - Iir_Kind_Subtype_Pat : constant Pattern := - Wsp & "subtype" & Wsp & Getident_Pat & Wsp & "is" & Wsp & "Iir_Kind" - & Wsp & "range" & Eol_Pat; - - -- Pattern for a range. - Start_Range_Pat : constant Pattern := - Wsp & Getident_Pat & Wsp & ".." & Eol_Pat; - Comment_Range_Pat : constant Pattern := - Wsp & "--" & Getident_Pat & Rpos (0); - End_Range_Pat : constant Pattern := Wsp & Getident_Pat & ";" & Eol_Pat; - - -- End of public package part. - End_Pat : constant Pattern := "end Iirs;" & Rpos (0); - - -- Pattern for a function field. - Func_Decl_Pat : constant Pattern := " -- Field: " & Getident_Pat - & ( "" or (" (" & Getident2_Pat & ")")) & Rpos (0); - - -- function Get_XXX. - Function_Get_Pat : constant Pattern := " function Get_" & Getident_Pat - & " (" & Getident2_Pat & " : " & Getident3_Pat & ") return " - & Getident4_Pat & ";" & Rpos (0); - - -- procedure Set_XXX. - Procedure_Set_Pat : constant Pattern := " procedure Set_" & Getident_Pat - & " (" & Getident2_Pat & " : " & Getident3_Pat - & "; " & Getident4_Pat & " : " & Getident5_Pat & ");" & Rpos (0); - - Field_Decl_Pat : constant Pattern := " -- " & Getident_Pat & " : "; - Field_Type_Pat : constant 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 : String_Access; - -- 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; - - Flag_Disp_Format : constant Boolean := False; - Flag_Disp_Field : constant 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 : constant 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 : constant VString := Ident; - begin - Line := Get_Line (In_Iirs); - if not Match (Line, Start_Range_Pat) then - -- Bad pattern for left bound. - Put_Line (Standard_Error, "bad pattern"); - 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 (Standard_Error, "** 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. - Put_Line (Standard_Error, "** missing node in range"); - 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 (Standard_Error, - "*** 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 (Standard_Error, "*** 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 (Standard_Error, "*** 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 => new String'(To_String (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 (Standard_Error, - "*** 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 (Standard_Error, - "*** procedure target type name mismatch"); - raise Err; - end if; - if Func_Table.Table (F).Value_Type.all /= Ident_5 then - Put_Line (Standard_Error, - "*** 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 (Standard_Error, - "*** 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 (Standard_Error, - "*** 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 : constant Pattern := - " -- Start of Iir_Kind." & Rpos (0); - End_Of_Iir_Kind_Pat : constant Pattern := - " -- End of Iir_Kind." & Rpos (0); - - -- Box ("----------") delimiters. - Desc_Box_Comment_Pat : constant Pattern := " --" & Span ('-') & Rpos (0); - - -- A comment ("-- XXXX") - Desc_Comment_Pat : constant Pattern := " -- " & Arb & Rpos (0); - Desc_Empty_Comment_Pat : constant Pattern := " --" & Rpos (0); - - -- Get a iir_kind identifier. - Desc_Iir_Kind_Pat : constant Pattern := - " -- " & Getident_Pat - & ("" or ( " (" & Getident2_Pat & ")")) - & Rpos (0); - - Subprogram_Pat : constant Pattern := - " -- Get" & ("_" or "/Set_") & Getident_Pat - & ((" " & Arb) or "") & Rpos (0); - - Desc_Only_For_Pat : constant Pattern := - " -- Only for " & Getident_Pat & ":" & Rpos (0); - Desc_Subprogram_Pat : constant Pattern := - " -- " & ("function" or "procedure"); - - Field_Pat : constant Pattern := Arb & "(" & Getident_Pat & ")"; - Alias_Field_Pat : constant Pattern := Arb & "(Alias " & Getident_Pat & ")"; - - Disp_Desc : constant 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 - - -- Look for a description - - loop - Line := Get_Line (In_Iirs); - - -- The description - exit when Match (Line, " -- Iir_Kind"); - - -- End of descriptions - exit L1 when Match (Line, End_Of_Iir_Kind_Pat); - - -- Skip over comments - if Match (Line, Desc_Box_Comment_Pat) - or else Match (Line, Desc_Comment_Pat) - then - loop - Line := Get_Line (In_Iirs); - exit when Match (Line, Rpos (0)); - if Match (Line, Desc_Comment_Pat) - or else Match (Line, Desc_Empty_Comment_Pat) - or else Match (Line, Desc_Box_Comment_Pat) - then - null; - else - raise Err; - end if; - end loop; - end if; - end loop; - - -- 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 (Standard_Error, - "*** no format for " & S (Ident)); - raise Err; - end if; - P_Num := Get (Format2pos, Ident_2); - if P_Num < 0 then - Put_Line (Standard_Error, "*** 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 (Standard_Error, "*** " & 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 (Standard_Error, "** no field for format"); - raise Err; - end if; - if Is_Alias then - if Iir_Table.Table (N).Func (Field) = No_Func - then - Put_Line (Standard_Error, - "** 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 (Standard_Error, - "** 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 (Standard_Error, - "*** 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 (Standard_Error, - "** field redefined for function " - & Func_Table.Table (Func).Name.all); - 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 (Standard_Error, - "** 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 (Standard_Error, "*** " & 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 (Standard_Error, "** bad 'Only' for line"); - raise Err; - elsif Match (Line, Desc_Comment_Pat) then - null; - elsif Match (Line, Desc_Empty_Comment_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 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 (Standard_Error, - "*** not described: " & Iir_Table.Table (I).Name.all); - raise Err; - end if; - end loop; - - Close (In_Iirs); - exception - when Err => - Put_Line (Standard_Error, - "*** Fatal error (2) at line" - & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs) - 1)); - Put_Line (Standard_Error, "*** 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.all = Field_Table.Table (F.Field).Name.all; - if Flag_Checks then - Put (" procedure Check_Kind_For_"); - Put (F.Name.all); - 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.all); - Put_Line (""", Target);"); - Put_Line (" end case;"); - Put (" end Check_Kind_For_"); - Put (F.Name.all); - Put_Line (";"); - New_Line; - end if; - - Put (" function Get_"); - Put (F.Name.all); - 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.all); - 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.all); - Put (";"); - New_Line; - New_Line; - - if F.Value_Name /= null then - Put (" procedure Set_"); - Put (F.Name.all); - 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.all); - 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.all); - 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; |