diff options
Diffstat (limited to 'xtools')
| -rw-r--r-- | xtools/Makefile | 23 | ||||
| -rw-r--r-- | xtools/check_iirs.adb | 64 | ||||
| -rw-r--r-- | xtools/check_iirs_pkg.adb | 1234 | ||||
| -rw-r--r-- | xtools/check_iirs_pkg.ads | 38 | ||||
| -rwxr-xr-x | xtools/pnodes.py | 718 |
5 files changed, 730 insertions, 1347 deletions
diff --git a/xtools/Makefile b/xtools/Makefile index e1546ec20..599e0da81 100644 --- a/xtools/Makefile +++ b/xtools/Makefile @@ -14,21 +14,22 @@ # 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: ../iirs.adb -check_iirs: force - gnatmake -g -gnatwa check_iirs +DEPS=../iirs.ads ../nodes.ads ./pnodes.py -MODE=--generate +all: ../iirs.adb ../disp_tree.adb ../nodes_gc.adb -../iirs.adb: ../iirs.adb.in ../iirs.ads ../nodes.ads ./check_iirs +../iirs.adb: ../iirs.adb.in $(DEPS) $(RM) $@ - ./check_iirs $(MODE) > subprg.ada - sed -e "/^ -- Subprograms/r subprg.ada" \ - < ../iirs.adb.in > $@ + ./pnodes.py body > $@ chmod -w $@ -force: +../disp_tree.adb: ../disp_tree.adb.in $(DEPS) + $(RM) $@ + ./pnodes.py disp_tree > $@ + chmod -w $@ -clean: - $(RM) *.o *.ali *~ check_iirs +../nodes_gc.adb: ../nodes_gc.adb.in $(DEPS) + $(RM) $@ + ./pnodes.py mark_tree > $@ + chmod -w $@ diff --git a/xtools/check_iirs.adb b/xtools/check_iirs.adb deleted file mode 100644 index 3b28dfee8..000000000 --- a/xtools/check_iirs.adb +++ /dev/null @@ -1,64 +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 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 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; diff --git a/xtools/check_iirs_pkg.ads b/xtools/check_iirs_pkg.ads deleted file mode 100644 index e03abab4a..000000000 --- a/xtools/check_iirs_pkg.ads +++ /dev/null @@ -1,38 +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. - -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; diff --git a/xtools/pnodes.py b/xtools/pnodes.py new file mode 100755 index 000000000..a9fbc214b --- /dev/null +++ b/xtools/pnodes.py @@ -0,0 +1,718 @@ +#!/usr/bin/env python + +import re +import sys +import argparse + +field_file = "../nodes.ads" +spec_file = "../iirs.ads" +template_file = "../iirs.adb.in" +template_disp_file = "../disp_tree.adb.in" +template_mark_file = "../nodes_gc.adb.in" +prefix_name = "Iir_Kind_" +prefix_range_name = "Iir_Kinds_" +type_name = "Iir_Kind" +conversions = ['uc', 'pos'] + +class FuncDesc: + def __init__(self, name, field, conv, acc, display, + pname, ptype, rname, rtype): + self.name = name + self.field = field + self.conv = conv + self.acc = acc + self.display = display # List of display attributes + self.pname = pname # Parameter mame + self.ptype = ptype # Parameter type + self.rname = rname # value name (for procedure) + self.rtype = rtype # value type + +class NodeDesc: + def __init__(self, name, format, fields, attrs): + self.name = name + self.format = format + self.fields = fields # {field: FuncDesc} dict, defined for all fields + self.attrs = attrs # A {attr: FuncDesc} dict + +class line: + def __init__(self, string, no): + self.l = string + self.n = no + +class EndOfFile(Exception): + def __init__(self,filename): + self.filename = filename + + def __str__(self): + return "end of file " + self.filename + +class linereader: + def __init__(self, filename): + self.filename = filename + self.f = open (filename) + self.lineno = 0 + self.l = '' + + def get(self): + self.l = self.f.readline() + if not self.l: + raise EndOfFile(self.filename) + self.lineno = self.lineno + 1 + return self.l + +class ParseError(Exception): + def __init__(self, lr, msg): + self.lr = lr; + self.msg = msg + + def __str__(self): + return 'Error: ' + self.msg + return 'Parse error at ' + self.lr.filname + ':' + self.lr.lineno + \ + ': ' + self.msg + +# Return fields description. +# This is a dictionary. The keys represent the possible format of a node. +# The values are dictionnaries representing fields. Keys are fields name, and +# values are fields type. +def read_fields(file): + fields = {} + formats = [] + lr = linereader(file) + + # Search for 'type Format_Type is' + while lr.get() != ' type Format_Type is\n': + pass + + # Skip '(' + if lr.get() != ' (\n': + raise 'no open parenthesis after Format_Type'; + + # Read formats + l = lr.get() + pat_field_name = re.compile(' Format_(\w+),?\n') + while l != ' );\n': + m = pat_field_name.match(l) + if m == None: + print l + raise 'bad literal within Format_Type' + name = m.group(1) + formats.append(name) + fields[name] = {} + l = lr.get() + + # Read fields + l = lr.get() + pat_fields = re.compile(' -- Fields of Format_(\w+):\n') + pat_field_desc = re.compile(' -- (\w+) : (\w+).*\n') + format_name = '' + common_desc = {} + try: + while True: + # 1) Search for description + while True: + # The common one + if l == ' -- Common fields are:\n': + format_name = 'Common' + break + # One for a format + m = pat_fields.match(l) + if m != None: + format_name = m.group(1) + if not format_name in fields: + raise ParseError( + lr, 'Format ' + format_name + ' is unknown'); + break + l = lr.get() + + # 2) Read field description + l = lr.get() + desc = common_desc + while True: + m = pat_field_desc.match(l) + if m == None: + break + desc[m.group(1)] = m.group(2) + l = lr.get() + + # 3) Disp + if format_name == 'Common': + common_desc = desc + else: + fields[format_name] = desc + except EndOfFile: + pass + + return (formats, fields) + +# Read kinds, kinds ranges and methods +def read_kinds(filename): + lr = linereader(filename) + kinds = [] + # Search for 'type Iir_Kind is' + while lr.get() != ' type ' + type_name + ' is\n': + pass + # Skip '(' + if lr.get() != ' (\n': + raise ParseError(lr, + 'no open parenthesis after "type ' + type_name +'"') + + # Read literals + pat_node = re.compile(' ' + prefix_name + '(\w+),?( +-- .*)?\n') + pat_comment = re.compile('( +-- .*)?\n') + while True: + l = lr.get() + if l == ' );\n': + break + m = pat_node.match(l) + if m: + kinds.append(m.group(1)) + continue + m = pat_comment.match(l) + if not m: + raise ParseError(lr, 'Unknow line within kind declaration') + + # Check subtypes + pat_subtype = re.compile(' subtype ' + prefix_range_name \ + + '(\w+) is ' + type_name + ' range\n') + pat_first = re.compile(' ' + prefix_name + '(\w+) ..\n') + pat_last = re.compile(' ' + prefix_name + '(\w+);\n') + pat_middle = re.compile(' --' + prefix_name + '(\w+)\n') + kinds_ranges={} + while True: + l = lr.get() + # Start of methods is also end of subtypes. + if l == ' -- General methods.\n': + break + # Found a subtype. + m = pat_subtype.match(l) + if m: + # Check first bound + name = m.group(1) + l = lr.get() + mf = pat_first.match(l) + if not mf: + raise ParseError(lr, 'badly formated first bound of subtype') + first = kinds.index(mf.group(1)) + idx = first + has_middle = None + # Read until last bound + while True: + l = lr.get() + ml = pat_middle.match(l) + if ml: + # Check element in the middle + if kinds.index(ml.group(1)) != idx + 1: + raise ParseError(lr, + "missing " + kinds[idx] + " in subtype") + has_middle = True + idx = idx + 1 + else: + # Check last bound + ml = pat_last.match(l) + if ml: + last = kinds.index(ml.group(1)) + if last != idx + 1 and has_middle: + raise ParseError(lr, + "missing " + kinds[idx] + " in subtype") + break + raise ParseError(lr, + "unhandled line in subtype") + kinds_ranges[name] = kinds[first:last+1] + + # Read functions + funcs = [] + pat_display = re.compile(' -- Display:(.*)\n') + pat_field = re.compile(' -- Field: (\w+)' + + '( Ref| Chain_Next| Chain)?( .*)?\n') + pat_conv = re.compile(' \((\w+)\)') + pat_func = \ + re.compile(' function Get_(\w+) \((\w+) : (\w+)\) return (\w+);\n') + pat_proc = \ + re.compile(' procedure Set_(\w+) \((\w+) : (\w+); (\w+) : (\w+)\);\n') + while True: + l = lr.get() + if l == 'end Iirs;\n': + break + md = pat_display.match(l) + if md: + display = md.group(1).split() + l = lr.get() + m = pat_field.match(l) + if not m: + raise ParseError(lr, 'Field: expected after Display:') + else: + display = [] + m = pat_field.match(l) + if m: + # Extract conversion + acc = m.group(2) + if acc: + acc = acc.strip() + conv = m.group(3) + if conv: + mc = pat_conv.match(conv) + if not mc: + raise ParseError(lr, 'conversion ill formed') + conv = mc.group(1) + if conv not in conversions: + raise ParseError(lr, 'unknown conversion ' + conv) + else: + conv = None + + # Read function + l = lr.get() + mf = pat_func.match(l) + if not mf: + raise ParseError(lr, + 'function declaration expected after Field') + # Read procedure + l = lr.get() + mp = pat_proc.match(l) + if not mp: + raise ParseError(lr, + 'procedure declaration expected after function') + # Consistency check between function and procedure + if mf.group(1) != mp.group(1): + raise ParseError(lr, 'function and procedure name mismatch') + if mf.group(2) != mp.group(2): + raise ParseError(lr, 'parameter name mismatch with function') + if mf.group(3) != mp.group(3): + raise ParseError(lr, 'parameter type mismatch with function') + if mf.group(4) != mp.group(5): + raise ParseError(lr, 'result type mismatch with function') + funcs.append(FuncDesc(mf.group(1), m.group(1), conv, acc, display, + mp.group(2), mp.group(3), + mp.group(4), mp.group(5))) + + return (kinds, kinds_ranges, funcs) + +# Read description for one node +def read_nodes_fields(lr, names, fields, nodes, funcs_dict): + pat_only = re.compile(' -- Only for ' + prefix_name + '(\w+):\n') + pat_field = re.compile(' -- Get/Set_(\w+) \((Alias )?(\w+)\)\n') + pat_comment = re.compile(' --.*\n') + pat_start = re.compile (' -- \w.*\n') + + # Create nodes + cur_nodes = [] + for (nm, fmt) in names: + if fmt not in fields: + raise ParseError(lr, 'unknown format') + n = NodeDesc(nm, fmt, {x: None for x in fields[fmt]}, {}) + nodes[nm] = n + cur_nodes.append(n) + + # Look for fields + only_nodes = cur_nodes + l = lr.l + while l != '\n': + # Handle 'Only ...' + while True: + m = pat_only.match(l) + if not m: + break + name = m.group(1) + if name not in [x.name for x in cur_nodes]: + raise ParseError(lr, 'node not currently described') + if only_nodes == cur_nodes: + only_nodes = [] + only_nodes.append(nodes[name]) + l = lr.get() + # Handle field + m = pat_field.match(l) + if m: + # 1) Check the function exists + func = m.group(1) + alias = m.group(2) + field = m.group(3) + if func not in funcs_dict: + raise ParseError(lr, 'unknown function') + func = funcs_dict[func] + if func.field != field: + raise ParseError(lr, 'field mismatch') + for c in only_nodes: + if field not in c.fields: + raise ParseError(lr, 'field does not exist in node') + if not alias: + if c.fields[field]: + raise ParseError(lr, 'field already used') + c.fields[field] = func + c.attrs[func.name] = func + only_nodes = cur_nodes + elif pat_start.match(l): + raise ParseError(lr, 'bad line in node description') + elif not pat_comment.match(l): + raise ParseError(lr, 'bad line in node description') + l = lr.get() + +# Read description for all nodes +def read_nodes(filename, kinds_ranges, fields, funcs): + lr = linereader(filename) + funcs_dict = {x.name:x for x in funcs} + nodes = {} + + # Skip until start + while lr.get() != ' -- Start of ' + type_name + '.\n': + pass + + pat_decl = re.compile(' -- ' + prefix_name + '(\w+) \((\w+)\)\n') + pat_decls = re.compile(' -- ' + prefix_range_name + '(\w+) \((\w+)\)\n') + pat_comment_line = re.compile(' --+\n') + pat_comment_box = re.compile(' --( .*)?\n') + while True: + l = lr.get() + if l == ' -- End of ' + type_name + '.\n': + return nodes + if l == '\n': + continue + m = pat_decl.match(l) + if m: + # List of nodes being described by the current description. + names = [] + + # Declaration of the first node + while True: + name=m.group(1) + fmt=m.group(2) + names.append((name,fmt)) + # There might be several nodes described at once. + l = lr.get() + m = pat_decl.match(l) + if not m: + break + read_nodes_fields(lr, names, fields, nodes, funcs_dict) + continue + m = pat_decls.match(l) + if m: + # List of nodes being described by the current description. + name=m.group(1) + fmt=m.group(2) + names = [(k,fmt) for k in kinds_ranges[name]] + l = lr.get() + read_nodes_fields(lr, names, fields, nodes, funcs_dict) + continue + if pat_comment_line.match(l) or pat_comment_box.match(l): + continue + raise ParseError(lr, 'bad line in node description') + return nodes + +# Generate a choice 'when A | B ... Z =>' using elements of CHOICES. +def gen_choices(choices): + is_first=True + for c in choices: + if is_first: + print ' ', + print 'when', + else: + print + print ' ', + print ' |', + print prefix_name + c, + is_first=None + print '=>' + +# Generate the Get_Format function. +def gen_get_format(formats, nodes, kinds): + print ' function Get_Format (Kind : ' + type_name + ') ' + \ + 'return Format_Type is' + print ' begin' + print ' case Kind is' + for f in formats: + choices = [k for k in kinds if nodes[k].format == f] + gen_choices(choices) + print ' return Format_' + f + ';' + print ' end case;' + print ' end Get_Format;' + +# Generate the Check_Kind_For_XXX function +def gen_check_kind(func, nodes, kinds): + pname = 'Target' + ptype = 'Iir' + print ' procedure Check_Kind_For_' + func.name + ' (' + pname \ + + ' : ' + ptype + ') is' + print ' begin' + print ' case Get_Kind (' + pname + ') is' + choices = [k for k in kinds if func.name in nodes[k].attrs] + gen_choices(choices) + print ' null;' + print ' when others =>' + print ' Failed ("' + func.name + '", ' + pname + ');' + print ' end case;' + print ' end Check_Kind_For_' + func.name + ';' + print + +def gen_subprg_header(decl): + if len(decl) < 76: + print decl + ' is' + else: + print decl + print ' is' + print ' begin' + +# Generate Get_XXX/Set_XXX subprograms for FUNC. +def gen_get_set(func, nodes, fields): + g = 'Get_' + func.field + ' (' + func.pname + ')' + s = func.rname + if func.conv: + field_type = None + for fld in fields.values(): + if func.field in fld: + field_type = fld[func.field] + break + if func.conv == 'uc': + g = field_type + '_To_' + func.rtype + ' (' + g + ')' + s = func.rtype + '_To_' + field_type + ' (' + s + ')' + elif func.conv == 'pos': + g = func.rtype + "'Val (" + g + ')' + s = func.rtype + "'Pos (" + s + ')' + + subprg = ' function Get_' + func.name + ' (' + func.pname \ + + ' : ' + func.ptype + ') return ' + func.rtype + gen_subprg_header(subprg) + print ' Check_Kind_For_' + func.name + ' (' + func.pname + ');' + print ' return ' + g + ';' + print ' end Get_' + func.name + ';' + print + subprg = ' procedure Set_' + func.name + ' (' \ + + func.pname + ' : ' + func.ptype + '; ' \ + + func.rname + ' : ' + func.rtype + ')' + gen_subprg_header(subprg) + print ' Check_Kind_For_' + func.name + ' (' + func.pname + ');' + print ' Set_' + func.field + ' (' + func.pname + ', ' \ + + s + ');' + print ' end Set_' + func.name + ';' + print + +def gen_image_field(func, param): + getter = 'Get_' + func.name + ' (' + param + ')' + if 'Image' in func.display: + return func.rtype + '\'Image (' + getter + ')' + else: + return 'Image_' + func.rtype + ' (' + getter + ')' + +def gen_disp_header(kinds, nodes): + print ' procedure Disp_Header (N : Iir) is' + print ' begin' + print ' if N = Null_Iir then' + print ' Put_Line ("*null*");' + print ' return;' + print ' end if;' + print + print ' case Get_Kind (N) is' + for k in kinds: + inlines = [f for f in nodes[k].attrs.values() if 'Inline' in f.display] + if len(inlines) > 1: + raise Error + print ' when ' + prefix_name + k + ' =>' + if inlines: + print ' Put ("' + k.lower() + ' " &' + print ' ' + \ + gen_image_field(inlines[0], 'N') + ');' + else: + print ' Put ("' + k.lower() + '");' + print ' end case;' + print ' Put (\' \');' + print ' Disp_Iir_Number (N);' + print ' New_Line;' + print ' end Disp_Header;' + print + +def funcs_of_node(n): + return sorted([fv.name for fv in n.fields.values() if fv]) + +def gen_disp(kinds, nodes): + print ' procedure Disp_Iir (N : Iir;' + print ' Indent : Natural := 1;' + print ' Flat : Boolean := False)' + print ' is' + print ' Sub_Indent : constant Natural := Indent + 1;' + print ' begin' + print ' Disp_Header (N);' + print + print ' if Flat or else N = Null_Iir then' + print ' return;' + print ' end if;' + print + print ' Header ("location: ", Indent);' + print ' Put_Line (Image_Location_Type (Get_Location (N)));' + print + print ' -- Protect against infinite recursions.' + print ' if Indent > 20 then' + print ' Put_Indent (Indent);' + print ' Put_Line ("...");' + print ' return;' + print ' end if;' + print + print ' case Get_Kind (N) is' + done = [] + for k in kinds: + if k in done: + continue + v = nodes[k] + # Find other kinds with the same set of functions. + vfuncs = funcs_of_node(v) + ks = [k1 for k1 in kinds if \ + k1 not in done and funcs_of_node(nodes[k1]) == vfuncs] + gen_choices(ks) + done += ks + flds = [fk for fk, fv in v.fields.items() if fv] + if flds: + for fk in sorted(flds): + func = v.fields[fk] + if func.acc == 'Chain_Next': + continue + print ' ' + \ + 'Header ("' + func.name.lower() + ': ", Indent);' + str = ' ' + if func.acc == 'Chain': + str += 'Disp_Chain (Get_' + func.name \ + + ' (N), Sub_Indent);' + print str + elif func.rtype in [ 'Iir', 'Iir_List', 'PSL_Node', 'PSL_NFA' ]: + str += 'Disp_' + func.rtype + \ + ' (Get_' + func.name + ' (N), Sub_Indent' + if func.acc == 'Ref': + str += ', True' + str += ');' + print str + else: + str += 'Put_Line (' + if len(func.rtype) <= 20: + str += gen_image_field(func, 'N') + print str + ');' + else: + # Inline version due to length + str += 'Image_' + func.rtype + print str + print ' (' + \ + 'Get_' + func.name + ' (N)));' + else: + print ' null;' + print ' end case;' + print ' end Disp_Iir;' + print + +def gen_mark(kinds, nodes): + print ' procedure Mark_Iir (N : Iir) is' + print ' begin' + print ' if N = Null_Iir then' + print ' return;' + print ' elsif Markers (N) then' + print ' Already_Marked (N);' + print ' return;' + print ' else' + print ' Markers (N) := True;' + print ' end if;' + print + print ' case Get_Kind (N) is' + done = [] + for k in kinds: + if k in done: + continue + v = nodes[k] + # Find other kinds with the same set of functions. + vfuncs = funcs_of_node(v) + ks = [k1 for k1 in kinds if \ + k1 not in done and funcs_of_node(nodes[k1]) == vfuncs] + gen_choices(ks) + done += ks + flds = [fk for fk, fv in v.fields.items() if fv] + empty = True + for fk in sorted(flds): + func = v.fields[fk] + if func.acc in ['Ref', 'Chain_Next']: + continue + elif func.acc in [ 'Chain' ]: + print ' ' + \ + 'Mark_Chain (Get_' + func.name + ' (N));' + empty = False + elif func.rtype in [ 'Iir', 'Iir_List', 'PSL_Node', 'PSL_NFA' ]: + print ' ' + \ + 'Mark_' + func.rtype + ' (Get_' + func.name + ' (N));' + empty = False + if empty: + print ' null;' + print ' end case;' + print ' end Mark_Iir;' + print + +parser = argparse.ArgumentParser(description='Meta-grammar processor') +parser.add_argument('action', choices=['disp-nodes', 'disp-kinds', + 'disp-fields', 'disp-funcs', + 'disp_tree', 'mark_tree', + 'get_format', 'body'], + default='disp-nodes') +args = parser.parse_args() + +try: + (formats, fields) = read_fields(field_file) + (kinds, kinds_ranges, funcs) = read_kinds(spec_file) + nodes = read_nodes(spec_file,kinds_ranges,fields,funcs) + +except ParseError as e: + print >> sys.stderr, e + print >> sys.stderr, \ + "in {0}:{1}:{2}".format(e.lr.filename, e.lr.lineno, e.lr.l) + sys.exit(1) + +if args.action == 'disp-fields': + for fmt in fields: + print "Fields of Format_"+fmt + fld=fields[fmt] + for k in fld: + print ' ' + k + ' (' + fld[k] + ')' +elif args.action == 'disp-kinds': + print "Kinds are:" + for k in kinds: + print ' ' + prefix_name + k +elif args.action == 'disp-funcs': + print "Functions are:" + for f in funcs: + s = '{0} ({1}'.format(f.name, f.field) + if f.acc: + s += ' acc:' + f.acc + if f.conv: + s += ' conv:' + f.conv + s += ')' + print s +elif args.action == 'disp-nodes': + for k in kinds: + v = nodes[k] + print prefix_name + k + ' (' + v.format + ')' + flds = [fk for fk, fv in v.fields.items() if fv] + for fk in sorted(flds): + print ' ' + fk + ': '+ v.fields[fk].name +elif args.action == 'get_format': + gen_get_format(formats, nodes) +elif args.action == 'body': + lr = linereader(template_file) + while True: + l = lr.get().rstrip() + print l + if l == ' -- Subprograms': + gen_get_format(formats, nodes, kinds) + print + for f in funcs: + gen_check_kind(f, nodes, kinds) + gen_get_set(f, nodes, fields) + if l[0:3] == 'end': + break +elif args.action == 'disp_tree': + lr = linereader(template_disp_file) + while True: + l = lr.get().rstrip() + print l + if l == ' -- Subprograms': + gen_disp_header(kinds, nodes) + gen_disp(kinds, nodes) + if l[0:3] == 'end': + break +elif args.action == 'mark_tree': + lr = linereader(template_mark_file) + while True: + l = lr.get().rstrip() + print l + if l == ' -- Subprograms': + gen_mark(kinds,nodes) + if l[0:3] == 'end': + break |