diff options
103 files changed, 786 insertions, 770 deletions
@@ -21,7 +21,6 @@ with Types; use Types; with Name_Table; with Sem; with Std_Names; -with Types; use Types; with Iir_Chains; use Iir_Chains; with Flags; @@ -859,7 +858,7 @@ package body Canon is -- be PROC, or an 'if' statement if the assignment is guarded. -- See LRM93 9.5 procedure Canon_Concurrent_Signal_Assignment - (Stmt: in out Iir; + (Stmt: Iir; Proc: out Iir_Sensitized_Process_Statement; Chain : out Iir) is diff --git a/disp_tree.adb b/disp_tree.adb index cb2349d37..4fc44166d 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -25,7 +25,7 @@ with Files_Map; package body Disp_Tree is procedure Disp_Tab (Tab: Natural) is - Blanks : String (1 .. Tab) := (others => ' '); + Blanks : constant String (1 .. Tab) := (others => ' '); begin Put (Blanks); end Disp_Tab; @@ -549,7 +549,7 @@ package body Disp_Tree is procedure Disp_Tree (Tree: Iir; Tab: Natural := 0; Flat_Decl: Boolean := false) is - Ntab: Natural := Inc_Tab (Tab); + Ntab: constant Natural := Inc_Tab (Tab); Kind : Iir_Kind; procedure Header (Str: String; Nl: Boolean := true) is @@ -1158,7 +1158,7 @@ package body Disp_Tree is Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); Header ("base type:"); declare - Base : Iir := Get_Base_Type (Tree); + Base : constant Iir := Get_Base_Type (Tree); Fl : Boolean; begin if Base /= Null_Iir @@ -1742,6 +1742,10 @@ package body Disp_Tree is Disp_Tree_Flat (Get_Prefix (Tree), Ntab); Header ("type:"); Disp_Tree_Flat (Get_Type (Tree), Ntab); + if Kind /= Iir_Kind_Transaction_Attribute then + Header ("parameter:"); + Disp_Tree (Get_Parameter (Tree), Ntab); + end if; Header ("has_active_flag: ", False); Disp_Flag (Get_Has_Active_Flag (Tree)); when Iir_Kind_Event_Attribute diff --git a/disp_vhdl.adb b/disp_vhdl.adb index 9a9545318..9b09cd49e 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -21,7 +21,6 @@ -- Try to be as pretty as possible, and to keep line numbers and positions -- of the identifiers. with Ada.Text_IO; use Ada.Text_IO; -with Types; use Types; with Std_Package; with Flags; use Flags; with Errorout; use Errorout; @@ -372,9 +371,7 @@ package body Disp_Vhdl is procedure Disp_Enumeration_Subtype_Definition (Def: Iir_Enumeration_Subtype_Definition) is - Base_Type: Iir; begin - Base_Type := Get_Base_Type (Def); Disp_Resolution_Function (Def); Put ("range "); Disp_Range (Def); @@ -385,11 +382,9 @@ package body Disp_Vhdl is (Def: Iir_Array_Subtype_Definition) is Index: Iir; - A_Type: Iir_Array_Type_Definition; begin Disp_Resolution_Function (Def); - A_Type := Get_Base_Type (Def); Put ("array ("); for I in Natural loop Index := Get_Nth_Element (Get_Index_Subtype_List (Def), I); @@ -893,11 +888,8 @@ package body Disp_Vhdl is Put_Line (";"); end Disp_Object_Declaration; - procedure Disp_Subprogram_Declaration (Subprg: Iir) - is - Indent: Count; + procedure Disp_Subprogram_Declaration (Subprg: Iir) is begin - Indent := Col; case Get_Kind (Subprg) is when Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration => @@ -1507,7 +1499,6 @@ package body Disp_Vhdl is is El: Iir; Formal: Iir; - Indent: Count; Need_Comma : Boolean; Conv : Iir; begin @@ -1515,7 +1506,6 @@ package body Disp_Vhdl is return; end if; Put ("("); - Indent := Col; Need_Comma := False; El := Chain; @@ -2315,7 +2305,7 @@ package body Disp_Vhdl is procedure Disp_Int64 (Val: Iir_Int64) is - Str: String := Iir_Int64'Image (Val); + Str: constant String := Iir_Int64'Image (Val); begin if Str(Str'First) = ' ' then Put (Str (Str'First + 1 .. Str'Last)); @@ -2326,7 +2316,7 @@ package body Disp_Vhdl is procedure Disp_Int32 (Val: Iir_Int32) is - Str: String := Iir_Int32'Image (Val); + Str: constant String := Iir_Int32'Image (Val); begin if Str(Str'First) = ' ' then Put (Str (Str'First + 1 .. Str'Last)); @@ -2337,7 +2327,7 @@ package body Disp_Vhdl is procedure Disp_Fp64 (Val: Iir_Fp64) is - Str: String := Iir_Fp64'Image (Val); + Str: constant String := Iir_Fp64'Image (Val); begin if Str(Str'First) = ' ' then Put (Str (Str'First + 1 .. Str'Last)); diff --git a/errorout.adb b/errorout.adb index eed8b6f16..8128dd117 100644 --- a/errorout.adb +++ b/errorout.adb @@ -17,8 +17,6 @@ -- 02111-1307, USA. with Ada.Text_IO; with Ada.Command_Line; -with Types; use Types; -with Iirs; use Iirs; with Scan; with Tokens; use Tokens; with Name_Table; @@ -50,8 +48,9 @@ package body Errorout is Put_Line (Standard_Error, Str); end Put_Line; - procedure Disp_Natural (Val: Natural) is - Str: String := Natural'Image (Val); + procedure Disp_Natural (Val: Natural) + is + Str: constant String := Natural'Image (Val); begin Put (Str(Str'First + 1 .. Str'Last)); end Disp_Natural; @@ -810,8 +809,8 @@ package body Errorout is (Name : Name_Id; Line, Col : Natural; Filename : Boolean) return String is - Line_Str : String := Natural'Image (Line); - Col_Str : String := Natural'Image (Col); + Line_Str : constant String := Natural'Image (Line); + Col_Str : constant String := Natural'Image (Col); begin if Filename then return Name_Table.Image (Name) @@ -861,7 +860,7 @@ package body Errorout is function Image (N : Iir_Int64) return String is - Res : String := Iir_Int64'Image (N); + Res : constant String := Iir_Int64'Image (N); begin if Res (1) = ' ' then return Res (2 .. Res'Last); @@ -917,7 +916,7 @@ package body Errorout is declare use Name_Table; - Id : Name_Id := Get_Identifier (Subprg); + Id : constant Name_Id := Get_Identifier (Subprg); begin Image (Id); case Id is diff --git a/evaluation.adb b/evaluation.adb index 495e59abe..ddb110988 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -15,7 +15,6 @@ -- 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 Types; use Types; with Errorout; use Errorout; with Name_Table; use Name_Table; with Str_Table; @@ -354,7 +353,6 @@ package body Evaluation is function Eval_String_Literal (Str : Iir) return Iir is - use Name_Table; Ptr : String_Fat_Acc; Len : Natural; begin @@ -495,8 +493,8 @@ package body Evaluation is return Iir is use Str_Table; - L_Str : String_Fat_Acc := Get_String_Fat_Acc (Left); - R_Str : String_Fat_Acc := Get_String_Fat_Acc (Right); + L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Left); + R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Right); Len : Natural; Id : String_Id; begin diff --git a/files_map.adb b/files_map.adb index 629911aef..e92cbc788 100644 --- a/files_map.adb +++ b/files_map.adb @@ -22,7 +22,6 @@ with Ada.Unchecked_Deallocation; with GNAT.Table; with GNAT.OS_Lib; with GNAT.Directory_Operations; -with System; with Name_Table; use Name_Table; with Str_Table; with Ada.Calendar; @@ -859,8 +858,8 @@ package body Files_Map is function Is_Eq (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean is use Str_Table; - L_Str : String_Fat_Acc := Get_String_Fat_Acc (String_Id (L)); - R_Str : String_Fat_Acc := Get_String_Fat_Acc (String_Id (R)); + L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (L)); + R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (R)); begin return L_Str (1 .. Time_Stamp_String'Length) = R_Str (1 .. Time_Stamp_String'Length); @@ -869,8 +868,8 @@ package body Files_Map is function Is_Gt (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean is use Str_Table; - L_Str : String_Fat_Acc := Get_String_Fat_Acc (String_Id (L)); - R_Str : String_Fat_Acc := Get_String_Fat_Acc (String_Id (R)); + L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (L)); + R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (R)); begin return L_Str (1 .. Time_Stamp_String'Length) > R_Str (1 .. Time_Stamp_String'Length); @@ -53,7 +53,7 @@ package body Flags is end Option_Warning; function Parse_Option (Opt: String) return Boolean is - Beg: Integer := Opt'First; + Beg: constant Integer := Opt'First; begin if Opt'Length > 5 and then Opt (Beg .. Beg + 5) = "--std=" then if Opt'Length = 8 then diff --git a/ieee-vital_timing.adb b/ieee-vital_timing.adb index c3bdf98f3..bf9ab8221 100644 --- a/ieee-vital_timing.adb +++ b/ieee-vital_timing.adb @@ -417,7 +417,7 @@ package body Ieee.Vital_Timing is use Name_Table; Len : Natural; - P : Natural := Gen_Name_Pos; + P : constant Natural := Gen_Name_Pos; C : Character; begin Len := 0; @@ -969,8 +969,10 @@ package body Ieee.Vital_Timing is (Decl : Iir_Constant_Interface_Declaration) is Oport : Iir; + pragma Unreferenced (Oport); Pos : Natural; Kind : Timing_Generic_Type_Kind; + pragma Unreferenced (Kind); begin if not Check_Timing_Generic_Prefix (Decl, 8) then return; @@ -1012,6 +1014,7 @@ package body Ieee.Vital_Timing is Iport : Iir; Oport : Iir; Cport : Iir; + pragma Unreferenced (Cport); Clock_Start : Natural; Clock_End : Natural; begin diff --git a/iir_chains.ads b/iir_chains.ads index f853df4b4..116ae8466 100644 --- a/iir_chains.ads +++ b/iir_chains.ads @@ -17,7 +17,9 @@ -- 02111-1307, USA. with Iirs; use Iirs; with Iir_Chain_Handling; +pragma Warnings (Off); pragma Elaborate (Iir_Chain_Handling); +pragma Warnings (On); package Iir_Chains is -- Chains are simply linked list of iirs. @@ -15,7 +15,6 @@ -- 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 Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; with Ada.Text_IO; with Errorout; use Errorout; diff --git a/iirs.adb.in b/iirs.adb.in index 3af6920a4..2bde117c8 100644 --- a/iirs.adb.in +++ b/iirs.adb.in @@ -15,7 +15,6 @@ -- 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 Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; with Ada.Text_IO; with Errorout; use Errorout; diff --git a/iirs_utils.adb b/iirs_utils.adb index a3ca40820..4d64f3478 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -15,7 +15,6 @@ -- 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 Types; use Types; with Scan; use Scan; with Tokens; use Tokens; with Errorout; use Errorout; @@ -653,7 +652,7 @@ package body Iirs_Utils is function Is_Unidim_Array_Type (A_Type : Iir) return Boolean is - Base_Type : Iir := Get_Base_Type (A_Type); + Base_Type : constant Iir := Get_Base_Type (A_Type); begin if Get_Kind (Base_Type) = Iir_Kind_Array_Type_Definition and then Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) = 1 diff --git a/libraries.adb b/libraries.adb index b52a11da3..734cccbc9 100644 --- a/libraries.adb +++ b/libraries.adb @@ -29,7 +29,6 @@ with Sem_Scopes; with Tokens; with Files_Map; with Flags; -with Std_Names; with Std_Package; package body Libraries is @@ -114,7 +113,7 @@ package body Libraries is Library: Iir_Library_Declaration) return Boolean is - File_Name : String := Back_End.Library_To_File_Name (Library); + File_Name : constant String := Back_End.Library_To_File_Name (Library); Fe : Source_File_Entry; begin Fe := Files_Map.Load_Source_File (Dir, Get_Identifier (File_Name)); @@ -362,7 +361,8 @@ package body Libraries is if Dir = Null_Identifier then -- Search in the library path. declare - File_Name : String := Back_End.Library_To_File_Name (Library); + File_Name : constant String := + Back_End.Library_To_File_Name (Library); L : Natural; begin for I in Pathes.First .. Pathes.Last loop @@ -580,7 +580,6 @@ package body Libraries is procedure Create_Virtual_Locations is use Files_Map; - use Name_Table; Implicit_Source_File : Source_File_Entry; Command_Source_File : Source_File_Entry; begin @@ -1038,6 +1037,7 @@ package body Libraries is end if; Design_File := Get_Chain (Design_File); end loop; + Last_Design_File := Design_File; end if; if Design_File /= Null_Iir @@ -1140,7 +1140,7 @@ package body Libraries is -- FIXME: directory declare use Files_Map; - File_Name: String := Image (Work_Directory) + File_Name: constant String := Image (Work_Directory) & Back_End.Library_To_File_Name (Library); begin Create (File, Out_File, File_Name); @@ -1415,7 +1415,6 @@ package body Libraries is Line, Off: Natural; Pos: Source_Ptr; Res: Iir; - Library : Iir_Library_Declaration; Design_File : Iir_Design_File; Fe : Source_File_Entry; begin @@ -1425,7 +1424,6 @@ package body Libraries is -- Load and parse the unit. Design_File := Get_Design_File (Design_Unit); - Library := Get_Library (Design_File); Fe := Files_Map.Load_Source_File (Get_Design_File_Directory (Design_File), Get_Design_File_Filename (Design_File)); @@ -36,11 +36,11 @@ package body Lists is Table_Initial => 128, Table_Increment => 100); - function Get_Max_Nbr_Elements (List : List_Type) return Natural; - pragma Inline (Get_Max_Nbr_Elements); + --function Get_Max_Nbr_Elements (List : List_Type) return Natural; + --pragma Inline (Get_Max_Nbr_Elements); - procedure Set_Max_Nbr_Elements (List : List_Type; Max : Natural); - pragma Inline (Set_Max_Nbr_Elements); + --procedure Set_Max_Nbr_Elements (List : List_Type; Max : Natural); + --pragma Inline (Set_Max_Nbr_Elements); procedure List_Set_Nbr_Elements (List : List_Type; Nbr : Natural); pragma Inline (List_Set_Nbr_Elements); @@ -55,15 +55,15 @@ package body Lists is Listt.Table (List).Nbr := Nbr; end List_Set_Nbr_Elements; - function Get_Max_Nbr_Elements (List : List_Type) return Natural is - begin - return Listt.Table (List).Max; - end Get_Max_Nbr_Elements; + --function Get_Max_Nbr_Elements (List : List_Type) return Natural is + --begin + -- return Listt.Table (List).Max; + --end Get_Max_Nbr_Elements; - procedure Set_Max_Nbr_Elements (List : List_Type; Max : Natural) is - begin - Listt.Table (List).Max := Max; - end Set_Max_Nbr_Elements; + --procedure Set_Max_Nbr_Elements (List : List_Type; Max : Natural) is + --begin + -- Listt.Table (List).Max := Max; + --end Set_Max_Nbr_Elements; function Get_Nth_Element (List: List_Type; N: Natural) return Node_Type @@ -152,7 +152,7 @@ package body Lists is -- Add (append) an element only if it was not already present in the list. procedure Add_Element (List: List_Type; El: Node_Type) is - Nbr : Natural := Get_Nbr_Elements (List); + Nbr : constant Natural := Get_Nbr_Elements (List); begin for I in 0 .. Nbr - 1 loop if Listt.Table (List).Els (I) = El then @@ -165,7 +165,7 @@ package body Lists is procedure Remove_Nth_Element (List: List_Type; N: Natural) is - Nbr : Natural := Get_Nbr_Elements (List); + Nbr : constant Natural := Get_Nbr_Elements (List); begin if N >= Nbr then raise Program_Error; @@ -45,10 +45,13 @@ package body Nodes is Free_Chain : Node_Type := Null_Node; + -- Just to have the default value. + pragma Warnings (Off); Init_Short : Node_Record (Format_Short); Init_Medium : Node_Record (Format_Medium); Init_Fp : Node_Record (Format_Fp); Init_Int : Node_Record (Format_Int); + pragma Warnings (On); function Create_Node (Format : Format_Type) return Node_Type is diff --git a/ortho/debug/ortho_debug-disp.adb b/ortho/debug/ortho_debug-disp.adb index 36c1750c4..b97ff50e5 100644 --- a/ortho/debug/ortho_debug-disp.adb +++ b/ortho/debug/ortho_debug-disp.adb @@ -109,6 +109,7 @@ package body Ortho_Debug.Disp is is Status : size_t; Res : int; + pragma Unreferenced (Status, Res); begin if Ctx.Line_Len > 0 then Status := fwrite (Ctx.Line'Address, size_t (Ctx.Line_Len), 1, @@ -176,6 +177,7 @@ package body Ortho_Debug.Disp is procedure New_Line is Status : int; + pragma Unreferenced (Status); begin if Ctx.Line_Len > 0 then Flush; @@ -185,8 +187,9 @@ package body Ortho_Debug.Disp is Ctx.Next_Tab := Ctx.Tab; end New_Line; - procedure Put (C : Character) is - S : String (1 .. 1) := (1 => C); + procedure Put (C : Character) + is + S : constant String (1 .. 1) := (1 => C); begin Put (S); end Put; @@ -364,6 +367,8 @@ package body Ortho_Debug.Disp is end case; end Get_Lnode_Name; + pragma Unreferenced (Get_Lnode_Name); + procedure Disp_Enode_Name (Kind : OE_Kind) is begin Put (Get_Enode_Name (Kind)); @@ -388,7 +393,7 @@ package body Ortho_Debug.Disp is function Image (Lit : Integer) return String is - S : String := Integer'Image (Lit); + S : constant String := Integer'Image (Lit); begin if S (1) = ' ' then return S (2 .. S'Length); @@ -997,4 +1002,7 @@ package body Ortho_Debug.Disp is Disp_Snode (N, null); Pop_Context (Ctx); end Debug_Snode; + + pragma Unreferenced (Debug_Tnode, Debug_Enode, Debug_Fnode, + Debug_Dnode, Debug_Lnode, Debug_Snode); end Ortho_Debug.Disp; diff --git a/ortho/debug/ortho_debug-main.adb b/ortho/debug/ortho_debug-main.adb index 714b85332..b470deaab 100644 --- a/ortho/debug/ortho_debug-main.adb +++ b/ortho/debug/ortho_debug-main.adb @@ -136,6 +136,7 @@ begin if Output /= NULL_Stream then declare Status : int; + pragma Unreferenced (Status); begin Status := fclose (Output); end; diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb index 2cb4d42e0..7ca70c1e6 100644 --- a/ortho/debug/ortho_debug.adb +++ b/ortho/debug/ortho_debug.adb @@ -972,16 +972,7 @@ package body Ortho_Debug is is subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element); Res : O_Lnode; - Rtype : O_Tnode; begin - case Arr.Rtype.Kind is - when ON_Array_Type => - Rtype := Arr.Rtype.El_Type; - when ON_Array_Sub_Type => - Rtype := Arr.Rtype.Base_Type.El_Type; - when others => - raise Type_Error; - end case; Check_Ref (Arr); Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element, Rtype => Get_Base_Type (Arr.Rtype).El_Type, @@ -1231,20 +1222,20 @@ package body Ortho_Debug is procedure New_Debug_Line_Decl (Line : Natural) is - subtype O_Dnode_Line_Decl is O_Dnode (ON_Debug_Line_Decl); - N : O_Dnode_Line_Decl; + subtype O_Dnode_Line_Decl is O_Dnode_Type (ON_Debug_Line_Decl); + N : O_Dnode; begin - N := new O_Dnode_Type (ON_Debug_Line_Decl); + N := new O_Dnode_Line_Decl; N.Line := Line; Add_Decl (N, False); end New_Debug_Line_Decl; procedure New_Debug_Comment_Decl (Comment : String) is - subtype O_Dnode_Comment_Decl is O_Dnode (ON_Debug_Comment_Decl); - N : O_Dnode_Comment_Decl; + subtype O_Dnode_Comment_Decl is O_Dnode_Type (ON_Debug_Comment_Decl); + N : O_Dnode; begin - N := new O_Dnode_Type (ON_Debug_Comment_Decl); + N := new O_Dnode_Comment_Decl; N.Comment := new String'(Comment); Add_Decl (N, False); end New_Debug_Comment_Decl; @@ -1321,6 +1312,8 @@ package body Ortho_Debug is subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value); N : O_Dnode; begin + Const := Const; + if Const.Const_Value /= O_Dnode_Null then -- Constant already has a value. raise Syntax_Error; @@ -1349,6 +1342,8 @@ package body Ortho_Debug is procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is begin + Const := Const; + if Const.Const_Value = O_Dnode_Null then -- Start_Const_Value not called. raise Syntax_Error; diff --git a/ortho/debug/ortho_debug.private.ads b/ortho/debug/ortho_debug.private.ads index ab77b5577..03489c549 100644 --- a/ortho/debug/ortho_debug.private.ads +++ b/ortho/debug/ortho_debug.private.ads @@ -16,9 +16,6 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -with Ortho_Ident; -use Ortho_Ident; - package Ortho_Debug is type O_Enode is private; type O_Cnode is private; diff --git a/ortho/gcc/Makefile b/ortho/gcc/Makefile index 63fb5e362..18fc0b106 100644 --- a/ortho/gcc/Makefile +++ b/ortho/gcc/Makefile @@ -2,9 +2,10 @@ ortho_srcdir=.. orthobe_srcdir=$(ortho_srcdir)/gcc agcc_objdir=. agcc_srcdir=$(ortho_srcdir)/gcc -AGCC_GCCSRC_DIR:=$(HOME)/dist/gcc-4.2.4 +AGCC_GCCSRC_DIR:=$(HOME)/dist/gcc-4.3.1 AGCC_GCCOBJ_DIR:=$(AGCC_GCCSRC_DIR)-objs/ SED=sed +GNATMAKE=gnatmake all: $(ortho_exec) @@ -15,12 +16,13 @@ ORTHO_PACKAGE=Ortho_Gcc $(ortho_exec): $(AGCC_DEPS) $(ORTHO_BASENAME).ads force - gnatmake -m -o $@ -g -aI$(ortho_srcdir) \ + $(GNATMAKE) -m -o $@ -g -aI$(ortho_srcdir) \ -aI$(ortho_srcdir)/gcc $(GNAT_FLAGS) ortho_gcc-main \ - -bargs -E -largs $(AGCC_OBJS) \ + -bargs -E -largs $(AGCC_OBJS) \ $(AGCC_GCCOBJ_DIR)libcpp/libcpp.a \ $(AGCC_GCCOBJ_DIR)libiberty/libiberty.a \ - $(AGCC_GCCOBJ_DIR)libdecnumber/libdecnumber.a #-static + $(AGCC_GCCOBJ_DIR)libdecnumber/libdecnumber.a \ + -lmpfr -lgmp #-static clean: agcc-clean $(RM) -f *.o *.ali ortho_nodes-main diff --git a/ortho/gcc/Makefile.inc b/ortho/gcc/Makefile.inc index ef6080848..8b7289ab4 100644 --- a/ortho/gcc/Makefile.inc +++ b/ortho/gcc/Makefile.inc @@ -27,24 +27,16 @@ AGCC_INC_FLAGS=-I$(AGCC_GCCOBJ_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/include \ -I$(AGCC_GCCSRC_DIR)/libcpp/include AGCC_CFLAGS=-g -Wall -DIN_GCC $(AGCC_INC_FLAGS) -AGCC_LOCAL_OBJS=ortho-lang.o gcc-version.o +AGCC_LOCAL_OBJS=ortho-lang.o AGCC_DEPS := $(AGCC_LOCAL_OBJS) AGCC_OBJS := $(AGCC_LOCAL_OBJS) \ $(AGCC_GCCOBJ_DIR)gcc/toplev.o \ + $(AGCC_GCCOBJ_DIR)gcc/attribs.o \ $(AGCC_GCCOBJ_DIR)gcc/libbackend.a \ $(AGCC_GCCOBJ_DIR)libcpp/libcpp.a \ $(AGCC_GCCOBJ_DIR)libiberty/libiberty.a -gcc-version.c: $(AGCC_GCCSRC_DIR)/gcc/BASE-VER - -$(RM) -f $@ - echo '#include "version.h"' > $@ - echo "const char version_string[] = \""`cat $<` "(ghdl)\";" >> $@ - echo 'const char bug_report_url[] = "<URL:http://gna.org/projects/ghdl>";' >> $@ - -gcc-version.o: gcc-version.c - $(CC) -c -o $@ $< $(AGCC_CFLAGS) - ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \ $(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \ $(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h diff --git a/ortho/gcc/ortho-lang.c b/ortho/gcc/ortho-lang.c index a5037f93f..c37e39168 100644 --- a/ortho/gcc/ortho-lang.c +++ b/ortho/gcc/ortho-lang.c @@ -247,7 +247,7 @@ ortho_init (void) { tree n; - input_location.line = 0; + input_location = BUILTINS_LOCATION; /* Create a global binding. */ push_binding (); @@ -372,13 +372,6 @@ ortho_handle_option (size_t code, const char *arg, int value) } } -#if 0 -void -linemap_init (void *s) -{ -} -#endif - extern int lang_parse_file (const char *filename); static void @@ -391,6 +384,9 @@ ortho_parse_file (int debug) else filename = in_fnames[0]; + linemap_add (line_table, LC_ENTER, 0, filename ? filename :"*no-file*", 1); + input_location = linemap_line_start (line_table, 0, 252); + if (!lang_parse_file (filename)) errorcount++; else @@ -398,19 +394,7 @@ ortho_parse_file (int debug) cgraph_finalize_compilation_unit (); cgraph_optimize (); } -} - -static void -ortho_expand_function (tree fndecl) -{ - if (DECL_CONTEXT (fndecl) != NULL_TREE) - { - push_function_context (); - tree_rest_of_compilation (fndecl); - pop_function_context (); - } - else - tree_rest_of_compilation (fndecl); + linemap_add (line_table, LC_LEAVE, 0, NULL, 1); } /* Called by the back-end or by the front-end when the address of EXP @@ -610,6 +594,7 @@ builtin_function (const char *name, make_decl_rtl (decl); DECL_BUILT_IN_CLASS (decl) = class; DECL_FUNCTION_CODE (decl) = function_code; + DECL_SOURCE_LOCATION (decl) = input_location; return decl; } @@ -653,32 +638,6 @@ type_for_mode (enum machine_mode mode, int unsignedp) return type_for_size (GET_MODE_BITSIZE (mode), unsignedp); } -/* Return the unsigned version of a TYPE_NODE, a scalar type. */ -static tree -unsigned_type (tree type) -{ - return type_for_size (TYPE_PRECISION (type), 1); -} - -/* Return the signed version of a TYPE_NODE, a scalar type. */ -static tree -signed_type (tree type) -{ - return type_for_size (TYPE_PRECISION (type), 0); -} - -/* Return a type the same as TYPE except unsigned or signed according to - UNSIGNEDP. */ -static tree -signed_or_unsigned_type (int unsignedp, tree type) -{ - if (!INTEGRAL_TYPE_P (type) - || TYPE_UNSIGNED (type) == unsignedp) - return type; - else - return type_for_size (TYPE_PRECISION (type), unsignedp); -} - #undef LANG_HOOKS_NAME #define LANG_HOOKS_NAME "vhdl" #undef LANG_HOOKS_IDENTIFIER_SIZE @@ -752,23 +711,24 @@ const char * const tree_code_name[] = { union lang_tree_node GTY((desc ("0"), - chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) + chain_next ("(union lang_tree_node *) GENERIC_NEXT (&%h.generic)"))) { - union tree_node GTY ((tag ("0"), - desc ("tree_node_structure (&%h)"))) - generic; + union tree_node GTY ((tag ("0"))) generic; }; struct lang_decl GTY(()) { + char dummy; }; struct lang_type GTY (()) { + char dummy; }; struct language_function GTY (()) { + char dummy; }; struct chain_constr_type @@ -1004,8 +964,7 @@ new_alloca (tree rtype, tree size) cur_binding_level->save_stack = 1; args = tree_cons (NULL_TREE, fold_convert (size_type_node, size), NULL_TREE); - res = build3 (CALL_EXPR, ptr_type_node, stack_alloc_function_ptr, - args, NULL_TREE); + res = build_call_list (ptr_type_node, stack_alloc_function_ptr, args); return fold_convert (rtype, res); } @@ -1074,9 +1033,9 @@ new_float_literal (tree ltype, double value) else hi = s >> (8 * sizeof (HOST_WIDE_INT)); - res = build_int_cst_wide (ltype, lo, hi); + res = build_int_cst_wide (long_integer_type_node, lo, hi); REAL_VALUE_FROM_INT (r_sign, lo, hi, DFmode); - real_2expN (&r_exp, ex - 60); + real_2expN (&r_exp, ex - 60, DFmode); real_arithmetic (&r, MULT_EXPR, &r_sign, &r_exp); res = build_real (ltype, r); return res; @@ -1496,14 +1455,14 @@ ortho_build_addr (tree lvalue, tree atype) ortho_mark_addressable (base); - offset = fold_build2 (MULT_EXPR, TREE_TYPE (idx), idx, + idx = fold_convert (sizetype, idx); + offset = fold_build2 (MULT_EXPR, sizetype, idx, array_ref_element_size (lvalue)); base = array_to_pointer_conversion (base); base_type = TREE_TYPE (base); - res = build2 (PLUS_EXPR, base_type, - base, convert (base_type, offset)); + res = build2 (POINTER_PLUS_EXPR, base_type, base, offset); } else { @@ -1606,7 +1565,7 @@ new_value (tree lvalue) void new_debug_line_decl (int line) { - input_location.line = line; + input_location = linemap_line_start (line_table, line, 252); } void @@ -1806,6 +1765,8 @@ finish_subprogram_decl (struct o_inter_list *interfaces, tree *res) decl = build_decl (FUNCTION_DECL, interfaces->ident, build_function_type (interfaces->rtype, interfaces->param_list.first)); + DECL_SOURCE_LOCATION (decl) = input_location; + is_global = current_function_decl == NULL_TREE || interfaces->storage == o_storage_external; if (is_global) @@ -1876,7 +1837,7 @@ finish_subprogram_body (void) DECL_SAVED_TREE (func) = bind; /* Initialize the RTL code for the function. */ - allocate_struct_function (func); + allocate_struct_function (func, false); /* Store the end of the function. */ cfun->function_end_locus = input_location; @@ -1898,14 +1859,14 @@ finish_subprogram_body (void) cgraph_finalize_function (func, false); current_function_decl = parent; - cfun = NULL; + set_cfun (NULL); } void new_debug_line_stmt (int line) { - input_location.line = line; + input_location = linemap_line_start (line_table, line, 252); } void @@ -1948,10 +1909,9 @@ new_association (struct o_assoc_list *assocs, tree val) tree new_function_call (struct o_assoc_list *assocs) { - return build3 (CALL_EXPR, - TREE_TYPE (TREE_TYPE (assocs->subprg)), - build_function_ptr (assocs->subprg), - assocs->list.first, NULL_TREE); + return build_call_list (TREE_TYPE (TREE_TYPE (assocs->subprg)), + build_function_ptr (assocs->subprg), + assocs->list.first); } void @@ -1959,10 +1919,9 @@ new_procedure_call (struct o_assoc_list *assocs) { tree res; - res = build3 (CALL_EXPR, - TREE_TYPE (TREE_TYPE (assocs->subprg)), - build_function_ptr (assocs->subprg), - assocs->list.first, NULL_TREE); + res = build_call_list (TREE_TYPE (TREE_TYPE (assocs->subprg)), + build_function_ptr (assocs->subprg), + assocs->list.first); TREE_SIDE_EFFECTS (res) = 1; append_stmt (res); } @@ -1987,7 +1946,8 @@ new_func_return_stmt (tree value) res = DECL_RESULT (current_function_decl); assign = build2 (MODIFY_EXPR, TREE_TYPE (value), res, value); TREE_SIDE_EFFECTS (assign) = 1; - stmt = build1 (RETURN_EXPR, TREE_TYPE (value), assign); + stmt = build1 (RETURN_EXPR, void_type_node, assign); + TREE_SIDE_EFFECTS (stmt) = 1; append_stmt (stmt); } diff --git a/ortho/gcc/ortho_ident.adb b/ortho/gcc/ortho_ident.adb index c8acd58c5..1fac9abf9 100644 --- a/ortho/gcc/ortho_ident.adb +++ b/ortho/gcc/ortho_ident.adb @@ -7,6 +7,7 @@ package body Ortho_Ident is (Id : O_Ident; Str : Address; Size : Integer) return Boolean; pragma Import (C, Compare_Identifier_String); + pragma Warnings (Off, Compare_Identifier_String); function Get_Identifier (Str : String) return O_Ident is begin diff --git a/ortho/mcode/binary_file.adb b/ortho/mcode/binary_file.adb index 488aac8a4..140742416 100644 --- a/ortho/mcode/binary_file.adb +++ b/ortho/mcode/binary_file.adb @@ -16,12 +16,9 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System; -with System.Storage_Elements; with Ada.Text_IO; use Ada.Text_IO; with Ada.Characters.Latin_1; with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with GNAT.Table; with Hex_Images; use Hex_Images; with Disassemble; @@ -169,7 +166,7 @@ package body Binary_File is Resize (Sect, New_Max); end Sect_Prealloc; - procedure Merge_Section (Dest : Section_Acc; Src : in out Section_Acc) + procedure Merge_Section (Dest : Section_Acc; Src : Section_Acc) is Rel : Reloc_Acc; begin @@ -309,7 +306,7 @@ package body Binary_File is while Reloc /= null loop if Reloc.Addr = Off then declare - Str : String := Get_Symbol_Name (Reloc.Sym); + Str : constant String := Get_Symbol_Name (Reloc.Sym); begin Line (Line'First .. Line'First + Str'Length - 1) := Str; Line_Len := Line_Len + Str'Length; @@ -671,9 +668,7 @@ package body Binary_File is Cur_Sect.Pc := Cur_Sect.Pc + Pc_Type (Length); end Gen_Space; - procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean) - is - use Ada.Text_IO; + procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean) is begin case Get_Scope (Sym) is when Sym_Local => @@ -953,9 +948,8 @@ package body Binary_File is -- Tmp := Val + N - 1; -- return Tmp - (Tmp mod N); -- end Align_Pow; - procedure Disp_Stats - is - use Ada.Text_IO; + + procedure Disp_Stats is begin Put_Line ("Number of Symbols: " & Symbol'Image (Symbols.Last)); end Disp_Stats; @@ -964,7 +958,6 @@ package body Binary_File is is Sect : Section_Acc; Rel, N_Rel : Reloc_Acc; - Old_Rel : Reloc_Acc; begin Symbols.Free; Sect := Section_Chain; @@ -973,7 +966,6 @@ package body Binary_File is Rel := Sect.First_Reloc; while Rel /= null loop N_Rel := Rel.Sect_Next; - Old_Rel := Rel; Free (Rel); Rel := N_Rel; end loop; diff --git a/ortho/mcode/binary_file.ads b/ortho/mcode/binary_file.ads index 14336279d..db31cb6c3 100644 --- a/ortho/mcode/binary_file.ads +++ b/ortho/mcode/binary_file.ads @@ -59,7 +59,7 @@ package Binary_File is Align : Natural; Esize : Natural); - procedure Merge_Section (Dest : Section_Acc; Src : in out Section_Acc); + procedure Merge_Section (Dest : Section_Acc; Src : Section_Acc); -- Set the current section. procedure Set_Current_Section (Sect : Section_Acc); diff --git a/ortho/mcode/disa_x86.adb b/ortho/mcode/disa_x86.adb index 24c70cf14..0653ce79f 100644 --- a/ortho/mcode/disa_x86.adb +++ b/ortho/mcode/disa_x86.adb @@ -15,7 +15,6 @@ -- 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 Interfaces; use Interfaces; with System.Address_To_Access_Conversions; package body Disa_X86 is diff --git a/ortho/mcode/ortho_code-decls.adb b/ortho/mcode/ortho_code-decls.adb index 0a8b02cf3..741d2ccbd 100644 --- a/ortho/mcode/ortho_code-decls.adb +++ b/ortho/mcode/ortho_code-decls.adb @@ -231,7 +231,7 @@ package body Ortho_Code.Decls is function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode is - Res : O_Dnode := Decl + 1; + Res : constant O_Dnode := Decl + 1; begin if Get_Decl_Kind (Res) = OD_Interface then return Res; @@ -242,7 +242,7 @@ package body Ortho_Code.Decls is function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode is - Res : O_Dnode := Decl + 1; + Res : constant O_Dnode := Decl + 1; begin if Get_Decl_Kind (Res) = OD_Interface then return Res; diff --git a/ortho/mcode/ortho_code-disps.adb b/ortho/mcode/ortho_code-disps.adb index d01757632..2f29414c8 100644 --- a/ortho/mcode/ortho_code-disps.adb +++ b/ortho/mcode/ortho_code-disps.adb @@ -432,9 +432,6 @@ package body Ortho_Code.Disps is end loop; Put ('}'); end; - when others => - Put_Line (Standard_Error, "disps.disp_type: unknown type " - & OT_Kind'Image (Kind)); end case; end Disp_Type; @@ -549,9 +546,6 @@ package body Ortho_Code.Disps is Disp_Subprg (Indent, Get_Body_Stmt (Decl)); when OD_Block => null; - when others => - Put_Line (Standard_Error, "debug.disp_decl: unknown decl " - & OD_Kind'Image (Kind)); end case; if Nl then New_Line; @@ -743,12 +737,10 @@ package body Ortho_Code.Disps is is Stmt : O_Enode; N_Ident : Natural := Ident; - Kind : OE_Kind; begin Stmt := S_Entry; loop Stmt := Get_Stmt_Link (Stmt); - Kind := Get_Expr_Kind (Stmt); Disp_Stmt (N_Ident, Stmt); exit when Get_Expr_Kind (Stmt) = OE_Leave; end loop; diff --git a/ortho/mcode/ortho_code-dwarf.adb b/ortho/mcode/ortho_code-dwarf.adb index 6f807d00f..681619923 100644 --- a/ortho/mcode/ortho_code-dwarf.adb +++ b/ortho/mcode/ortho_code-dwarf.adb @@ -27,7 +27,6 @@ with Ortho_Code.Consts; with Ortho_Code.Flags; with Ortho_Ident; with Ortho_Code.Binary; -with Binary_File; use Binary_File; package body Ortho_Code.Dwarf is -- Dwarf debugging format. @@ -336,11 +335,7 @@ package body Ortho_Code.Dwarf is Gen_Ua_32 (Orig_Sym, 0); Gen_Ua_32 (End_Sym, 0); Gen_String_Nul ("T.Gingold ortho_mcode (2004)"); - declare - Dir : String := GNAT.Directory_Operations.Get_Current_Dir; - begin - Gen_String_Nul (Dir); - end; + Gen_String_Nul (GNAT.Directory_Operations.Get_Current_Dir); end Init; procedure Emit_Decl (Decl : O_Dnode); diff --git a/ortho/mcode/ortho_code-exprs.adb b/ortho/mcode/ortho_code-exprs.adb index 0724bcc19..e47c75e18 100644 --- a/ortho/mcode/ortho_code-exprs.adb +++ b/ortho/mcode/ortho_code-exprs.adb @@ -638,7 +638,7 @@ package body Ortho_Code.Exprs is is Res : O_Enode := O_Enode_Null; Blk : O_Enode; - Last_Blk : O_Enode := Get_Label_Block (Label); + Last_Blk : constant O_Enode := Get_Label_Block (Label); begin Blk := Cur_Block; while Blk /= Last_Blk loop @@ -1546,7 +1546,6 @@ package body Ortho_Code.Exprs is procedure Disp_Enode (Indent : Natural; N : O_Enode) is use Ada.Text_IO; - use Ortho_Code.Debug; use Ortho_Code.Debug.Int32_IO; begin Set_Col (Count (Indent)); diff --git a/ortho/mcode/ortho_code-opts.adb b/ortho/mcode/ortho_code-opts.adb index 83071b446..0ea6b039b 100644 --- a/ortho/mcode/ortho_code-opts.adb +++ b/ortho/mcode/ortho_code-opts.adb @@ -157,7 +157,7 @@ package body Ortho_Code.Opts is N_Stmt := Next; P_Stmt := Stmt; Label := Get_Jump_Label (Stmt); - Flag_Discard := Kind = OE_Jump; + Flag_Discard := True; loop if N_Stmt = Label then -- Remove STMT. diff --git a/ortho/mcode/ortho_code-types.adb b/ortho/mcode/ortho_code-types.adb index fda7a2123..004b15cbf 100644 --- a/ortho/mcode/ortho_code-types.adb +++ b/ortho/mcode/ortho_code-types.adb @@ -18,7 +18,6 @@ with Ada.Text_IO; with Ada.Unchecked_Conversion; with GNAT.Table; -with Ada.Text_IO; with Ortho_Code.Consts; use Ortho_Code.Consts; with Ortho_Code.Debug; with Ortho_Code.Abi; use Ortho_Code.Abi; diff --git a/ortho/mcode/ortho_code-x86-abi.adb b/ortho/mcode/ortho_code-x86-abi.adb index 5456235fe..ff766b01e 100644 --- a/ortho/mcode/ortho_code-x86-abi.adb +++ b/ortho/mcode/ortho_code-x86-abi.adb @@ -16,7 +16,6 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ortho_Code.Decls; use Ortho_Code.Decls; -with Ortho_Code.Types; use Ortho_Code.Types; with Ortho_Code.Exprs; use Ortho_Code.Exprs; with Ortho_Code.Consts; with Ortho_Code.Debug; @@ -177,8 +176,8 @@ package body Ortho_Code.X86.Abi is is use Ada.Text_IO; use Ortho_Code.Debug.Int32_IO; - Obj : O_Dnode := Get_Addr_Object (Stmt); - Frame : O_Enode := Get_Addrl_Frame (Stmt); + Obj : constant O_Dnode := Get_Addr_Object (Stmt); + Frame : constant O_Enode := Get_Addrl_Frame (Stmt); begin if Frame = O_Enode_Null then Put ("fp"); @@ -550,13 +549,11 @@ package body Ortho_Code.X86.Abi is is use Ada.Text_IO; - Last : O_Enode; Stmt : O_Enode; begin Disp_Subprg_Decl (Get_Body_Decl (Subprg)); Stmt := Get_Body_Stmt (Subprg); - Last := Get_Entry_Leave (Stmt); loop exit when Stmt = O_Enode_Null; Disp_Stmt (Stmt); diff --git a/ortho/mcode/ortho_code-x86-abi.ads b/ortho/mcode/ortho_code-x86-abi.ads index 613e37b2c..eb3b5a121 100644 --- a/ortho/mcode/ortho_code-x86-abi.ads +++ b/ortho/mcode/ortho_code-x86-abi.ads @@ -15,7 +15,6 @@ -- 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 Ortho_Code.Exprs; use Ortho_Code.Exprs; with Ortho_Code.Types; use Ortho_Code.Types; package Ortho_Code.X86.Abi is diff --git a/ortho/mcode/ortho_code-x86-emits.adb b/ortho/mcode/ortho_code-x86-emits.adb index d64d0967b..059711a3f 100644 --- a/ortho/mcode/ortho_code-x86-emits.adb +++ b/ortho/mcode/ortho_code-x86-emits.adb @@ -28,7 +28,6 @@ with Ortho_Code.Binary; use Ortho_Code.Binary; with Ortho_Ident; with Ada.Text_IO; with Interfaces; use Interfaces; -with Binary_File; use Binary_File; package body Ortho_Code.X86.Emits is type Insn_Size is (Sz_8, Sz_16, Sz_32l, Sz_32h); @@ -126,9 +125,7 @@ package body Ortho_Code.X86.Emits is -- end case; -- end Gen_Imm32; - procedure Gen_Imm (N : O_Enode; Sz : Insn_Size) - is - use Interfaces; + procedure Gen_Imm (N : O_Enode; Sz : Insn_Size) is begin case Get_Expr_Kind (N) is when OE_Const => @@ -811,7 +808,7 @@ package body Ortho_Code.X86.Emits is -- addl esp, val Gen_B8 (2#100000_01#); Gen_B8 (2#11_000_100#); - Gen_Le32 (Unsigned_32 (Val)); + Gen_Le32 (Val); end if; End_Insn; end if; @@ -1199,11 +1196,9 @@ package body Ortho_Code.X86.Emits is procedure Gen_Conv_U8 (Stmt : O_Enode) is Op : O_Enode; - Reg_Op : O_Reg; Reg_Res : O_Reg; begin Op := Get_Expr_Operand (Stmt); - Reg_Op := Get_Expr_Reg (Op); Reg_Res := Get_Expr_Reg (Stmt); case Get_Expr_Mode (Stmt) is when Mode_U32 @@ -1223,11 +1218,9 @@ package body Ortho_Code.X86.Emits is procedure Gen_Conv_B2 (Stmt : O_Enode) is Op : O_Enode; - Reg_Op : O_Reg; Reg_Res : O_Reg; begin Op := Get_Expr_Operand (Stmt); - Reg_Op := Get_Expr_Reg (Op); Reg_Res := Get_Expr_Reg (Stmt); case Get_Expr_Mode (Stmt) is when Mode_U32 @@ -1244,12 +1237,8 @@ package body Ortho_Code.X86.Emits is procedure Gen_Conv_I64 (Stmt : O_Enode) is Op : O_Enode; - Reg_Op : O_Reg; - Reg_Res : O_Reg; begin Op := Get_Expr_Operand (Stmt); - Reg_Op := Get_Expr_Reg (Op); - Reg_Res := Get_Expr_Reg (Stmt); case Get_Expr_Mode (Stmt) is when Mode_I32 => -- move dx to reg_helper @@ -1285,11 +1274,8 @@ package body Ortho_Code.X86.Emits is end Gen_Conv_I64; -- Convert FP to xxx. - procedure Gen_Conv_Fp (Stmt : O_Enode) - is - Op : O_Enode; + procedure Gen_Conv_Fp (Stmt : O_Enode) is begin - Op := Get_Expr_Operand (Stmt); case Get_Expr_Mode (Stmt) is when Mode_I32 => -- subl %esp, 4 @@ -1842,9 +1828,11 @@ package body Ortho_Code.X86.Emits is Error_Emit ("emit_insn: oe_arg", Stmt); end case; when OE_Setup_Frame => + pragma Warnings (Off); if Flags.Stack_Boundary > 4 then Emit_Setup_Frame (Stmt); end if; + pragma Warnings (On); when OE_Call => Emit_Call (Stmt); when OE_Intrinsic => @@ -1985,8 +1973,6 @@ package body Ortho_Code.X86.Emits is procedure Emit_Prologue (Subprg : Subprogram_Data_Acc) is use Ortho_Code.Decls; - use Binary_File; - use Interfaces; use Ortho_Code.Flags; use Ortho_Code.X86.Insns; Sym : Symbol; @@ -2070,7 +2056,6 @@ package body Ortho_Code.X86.Emits is procedure Emit_Epilogue (Subprg : Subprogram_Data_Acc) is - use Binary_File; use Ortho_Code.Decls; use Ortho_Code.Types; use Ortho_Code.Flags; diff --git a/ortho/mcode/ortho_code-x86-insns.adb b/ortho/mcode/ortho_code-x86-insns.adb index bfd1635c3..819e6708f 100644 --- a/ortho/mcode/ortho_code-x86-insns.adb +++ b/ortho/mcode/ortho_code-x86-insns.adb @@ -72,8 +72,6 @@ package body Ortho_Code.X86.Insns is -- Swap Stack_Offset with Max_Stack of STMT. procedure Swap_Stack_Offset (Blk : O_Dnode) is - use Ortho_Code.Decls; - Prev_Offset : Uns32; begin Prev_Offset := Get_Block_Max_Stack (Blk); @@ -227,16 +225,16 @@ package body Ortho_Code.X86.Insns is return N; end Insert_Move; - function Insert_Spill (Expr : O_Enode) return O_Enode - is - N : O_Enode; - begin - N := New_Enode (OE_Spill, Get_Expr_Mode (Expr), O_Tnode_Null, - Expr, O_Enode_Null); - Set_Expr_Reg (N, R_Spill); - Link_Stmt (N); - return N; - end Insert_Spill; +-- function Insert_Spill (Expr : O_Enode) return O_Enode +-- is +-- N : O_Enode; +-- begin +-- N := New_Enode (OE_Spill, Get_Expr_Mode (Expr), O_Tnode_Null, +-- Expr, O_Enode_Null); +-- Set_Expr_Reg (N, R_Spill); +-- Link_Stmt (N); +-- return N; +-- end Insert_Spill; procedure Error_Gen_Insn (Stmt : O_Enode; Reg : O_Reg) is @@ -290,9 +288,9 @@ package body Ortho_Code.X86.Insns is Used : Boolean; end record; - Init_Reg_Info : Reg_Info_Type := (Num => O_Free, - Stmt => O_Enode_Null, - Used => False); + Init_Reg_Info : constant Reg_Info_Type := (Num => O_Free, + Stmt => O_Enode_Null, + Used => False); type Reg32_Info_Array is array (Regs_R32) of Reg_Info_Type; Regs : Reg32_Info_Array := (others => Init_Reg_Info); Reg_Cc : Reg_Info_Type := Init_Reg_Info; @@ -349,6 +347,8 @@ package body Ortho_Code.X86.Insns is end loop; end Dump_Regs; + pragma Unreferenced (Dump_Regs); + procedure Error_Reg (Msg : String; Stmt : O_Enode; Reg : O_Reg) is use Ada.Text_IO; @@ -1881,7 +1881,6 @@ package body Ortho_Code.X86.Insns is procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc) is First : O_Enode; - Last : O_Enode; Stmt : O_Enode; N_Stmt : O_Enode; begin @@ -1906,7 +1905,6 @@ package body Ortho_Code.X86.Insns is Stack_Offset := 0; First := Subprg.E_Entry; Expand_Decls (Subprg.D_Body + 1); - Last := Get_Entry_Leave (First); Abi.Last_Link := First; -- Generate instructions. diff --git a/ortho/mcode/ortho_ident.adb b/ortho/mcode/ortho_ident.adb index 59c12768e..034aeae10 100644 --- a/ortho/mcode/ortho_ident.adb +++ b/ortho/mcode/ortho_ident.adb @@ -66,7 +66,7 @@ package body Ortho_Ident is function Get_String (Id : O_Ident) return String is Res : String (1 .. Get_String_Length (Id)); - Start : Natural := Ids.Table (Id); + Start : constant Natural := Ids.Table (Id); begin for I in Res'Range loop Res (I) := Strs.Table (Start + I - 1); @@ -76,8 +76,8 @@ package body Ortho_Ident is function Is_Equal (Id : O_Ident; Str : String) return Boolean is - Start : Natural := Ids.Table (Id); - Len : Natural := Get_String_Length (Id); + Start : constant Natural := Ids.Table (Id); + Len : constant Natural := Get_String_Length (Id); begin if Len /= Str'Length then return False; diff --git a/ortho/mcode/ortho_mcode.adb b/ortho/mcode/ortho_mcode.adb index bc4dc3215..e774483a9 100644 --- a/ortho/mcode/ortho_mcode.adb +++ b/ortho/mcode/ortho_mcode.adb @@ -15,7 +15,6 @@ -- 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 Ortho_Code.Abi; with Ada.Text_IO; with Ortho_Code.Debug; with Ortho_Code.Sysdeps; @@ -61,7 +60,9 @@ package body Ortho_Mcode is null; end Start_Const_Value; - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is + procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) + is + pragma Warnings (Off, Const); begin New_Const_Value (Const, Val); end Finish_Const_Value; @@ -15,6 +15,7 @@ -- 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 Iir_Chains; use Iir_Chains; with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; with Tokens; use Tokens; @@ -25,7 +26,6 @@ with Std_Names; use Std_Names; with Flags; with Name_Table; with Str_Table; -with Iir_Chains; use Iir_Chains; with Xrefs; -- Recursive descendant parser. @@ -97,7 +97,6 @@ package body Parse is -- Otherwise, accept the current_token (ie set it to tok_invalid, unless -- TOKEN is Tok_Identifier). procedure Expect (Token: Token_Type; Msg: String := "") is - use Errorout; begin if Current_Token /= Token then if Msg'Length > 0 then @@ -857,6 +856,7 @@ package body Parse is is Res : Iir; Old : Iir; + pragma Unreferenced (Old); begin Res := Parse_Name (Allow_Indexes => False); if Check_Paren and then Current_Token = Tok_Left_Paren then @@ -3459,7 +3459,7 @@ package body Parse is -- -- [ §9.5 ] -- options ::= [ GUARDED ] [ delay_mechanism ] - procedure Parse_Options (Stmt : in out Iir) is + procedure Parse_Options (Stmt : Iir) is begin if Current_Token = Tok_Guarded then Set_Guard (Stmt, Stmt); @@ -4191,6 +4191,7 @@ package body Parse is Subprg: Iir; Subprg_Body : Iir; Old : Iir; + pragma Unreferenced (Old); begin -- Create the node. case Current_Token is @@ -17,7 +17,6 @@ -- 02111-1307, USA. with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Characters.Handling; -with Tokens; use Tokens; with Errorout; use Errorout; with Name_Table; with Files_Map; use Files_Map; @@ -16,7 +16,6 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ada.Unchecked_Conversion; -with Types; use Types; with Errorout; use Errorout; with Std_Package; use Std_Package; with Libraries; @@ -479,6 +478,7 @@ package body Sem is then declare P : Boolean; + pragma Unreferenced (P); begin P := Check_Port_Association_Restriction (Get_Base_Name (Formal), Prefix, El); @@ -827,7 +827,6 @@ package body Sem is begin El := Get_Declaration_Chain (Block_Conf); while El /= Null_Iir loop - exit when El = Null_Iir; case Get_Kind (El) is when Iir_Kind_Use_Clause => Sem_Use_Clause (El); @@ -1107,7 +1106,7 @@ package body Sem is end if; El_Left := Get_Default_Value (Left); El_Right := Get_Default_Value (Right); - if ((El_Left = Null_Iir) xor (El_Right = Null_Iir)) = True then + if (El_Left = Null_Iir) xor (El_Right = Null_Iir) then return False; end if; if El_Left /= Null_Iir @@ -1513,7 +1512,7 @@ package body Sem is begin -- Set depth. declare - Parent : Iir := Get_Parent (Subprg); + Parent : constant Iir := Get_Parent (Subprg); begin case Get_Kind (Parent) is when Iir_Kind_Function_Declaration @@ -1605,7 +1604,7 @@ package body Sem is procedure Add_Analysis_Checks_List (El : Iir) is - Design : Iir := Get_Current_Design_Unit; + Design : constant Iir := Get_Current_Design_Unit; List : Iir_List; begin List := Get_Analysis_Checks_List (Design); @@ -1752,7 +1751,6 @@ package body Sem is -- Current purity depth of SUBPRG. Depth : Iir_Int32; Depth_Callee : Iir_Int32; - Has_Pure_Errors : Boolean := False; Has_Wait_Errors : Boolean := False; Npos : Natural; Res, Res1 : Update_Pure_Status; @@ -1852,7 +1850,6 @@ package body Sem is Depth_Callee := Iir_Depth_Impure; if Kind = K_Function then Error_Pure (Subprg, Callee, Null_Iir); - Has_Pure_Errors := True; end if; end if; diff --git a/sem_decls.adb b/sem_decls.adb index 12262933b..3d1736c4d 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -31,8 +31,8 @@ with Sem_Scopes; use Sem_Scopes; with Sem_Names; use Sem_Names; with Sem_Specs; use Sem_Specs; with Sem_Types; use Sem_Types; -with Iir_Chains; use Iir_Chains; with Xrefs; use Xrefs; +use Iir_Chains; package body Sem_Decls is -- Emit an error if the type of DECL is a file type, access type, diff --git a/sem_expr.adb b/sem_expr.adb index 820d727ff..ca862b063 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -15,7 +15,6 @@ -- 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 Types; use Types; with Std_Package; use Std_Package; with Errorout; use Errorout; with Flags; @@ -904,7 +903,7 @@ package body Sem_Expr is -- update states. procedure Sem_Subprogram_Call_Finish (Expr : Iir; Imp : Iir) is - Subprg : Iir := Get_Current_Subprogram; + Subprg : constant Iir := Get_Current_Subprogram; begin Set_Implementation (Expr, Imp); Set_Function_Call_Staticness (Expr, Imp); @@ -1225,8 +1224,6 @@ package body Sem_Expr is procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir) is - use Iirs_Utils; - Imp: Iir; Name : Iir; Parameters_Chain : Iir; @@ -1645,7 +1642,7 @@ package body Sem_Expr is function Check_Type_For_String_Literal (A_Type : Iir; Expr : Iir) return Boolean is - Base_Type : Iir := Get_Base_Type (A_Type); + Base_Type : constant Iir := Get_Base_Type (A_Type); El_Bt : Iir; begin -- LRM 7.3.1 @@ -1711,6 +1708,7 @@ package body Sem_Expr is Ptr : String_Fat_Acc; El : Iir; + pragma Unreferenced (El); Len : Natural; begin Len := Get_String_Length (Lit); @@ -2420,7 +2418,7 @@ package body Sem_Expr is procedure Add_Match (El : Iir; Rec_El : Iir_Element_Declaration) is Ass_Type : Iir; - Pos : Natural := Natural (Get_Element_Position (Rec_El)); + Pos : constant Natural := Natural (Get_Element_Position (Rec_El)); begin if Matches (Pos) /= Null_Iir then Error_Msg_Sem @@ -2634,7 +2632,6 @@ package body Sem_Expr is Constrained : Boolean; Dim: Natural) is - Res: Boolean; Assoc_Chain : Iir; Choice: Iir; Is_Positional: Tri_State_Type; @@ -2655,7 +2652,6 @@ package body Sem_Expr is Info : Array_Aggr_Info renames Infos (Dim); begin - Res := True; Index_List := Get_Index_Subtype_List (A_Type); Index_Type := Get_Nth_Element (Index_List, Dim - 1); @@ -2995,8 +2991,8 @@ package body Sem_Expr is is A_Subtype: Iir; Base_Type : Iir; - Index_List : Iir_List := Get_Index_Subtype_List (Aggr_Type); - Nbr_Dim : Natural := Get_Nbr_Elements (Index_List); + Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); Infos : Array_Aggr_Info_Arr (1 .. Nbr_Dim); Aggr_Constrained : Boolean; Info, Prev_Info : Iir_Aggregate_Info; diff --git a/sem_names.adb b/sem_names.adb index 686ff439a..ff5cd7183 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -168,10 +168,10 @@ package body Sem_Names is -- Move elements of result list LIST to result list RES. -- Destroy LIST if necessary. - procedure Add_Result_List (Res : in out Iir; List : in out Iir); + procedure Add_Result_List (Res : in out Iir; List : Iir); pragma Unreferenced (Add_Result_List); - procedure Add_Result_List (Res : in out Iir; List : in out Iir) + procedure Add_Result_List (Res : in out Iir; List : Iir) is El : Iir; List_List : Iir_List; @@ -201,9 +201,9 @@ package body Sem_Names is end Add_Result_List; -- Free interpretations of LIST except KEEP. - procedure Sem_Name_Free_Result (List : in out Iir; Keep : Iir) + procedure Sem_Name_Free_Result (List : Iir; Keep : Iir) is - procedure Sem_Name_Free (El : in out Iir) is + procedure Sem_Name_Free (El : Iir) is begin case Get_Kind (El) is when Iir_Kind_Function_Call @@ -560,7 +560,6 @@ package body Sem_Names is Prefix_Bt : Iir; Index_List: Iir_List; Index_Type: Iir; - Index_Range : Iir; Suffix: Iir; Slice_Type : Iir; Expr_Type : Iir; @@ -591,7 +590,6 @@ package body Sem_Names is end if; Index_Type := Get_First_Element (Index_List); - Index_Range := Get_Range_Constraint (Index_Type); Prefix_Rng := Eval_Range (Index_Type); -- LRM93 6.5 @@ -1085,7 +1083,7 @@ package body Sem_Names is & Disp_Node (Subprg), Loc); end Error_Pure; - Subprg : Iir := Sem_Stmts.Get_Current_Subprogram; + Subprg : constant Iir := Sem_Stmts.Get_Current_Subprogram; Subprg_Body : Iir; Parent : Iir; begin @@ -1336,7 +1334,7 @@ package body Sem_Names is is Sub_Res : Iir; begin - if Get_Is_Within_Flag (Sub_Name) = True then + if Get_Is_Within_Flag (Sub_Name) then Sub_Res := Find_Declarations_In_List (Sub_Name, Name, Keep_Alias); if Sub_Res /= Null_Iir then Add_Result (Res, Sub_Res); diff --git a/sem_scopes.adb b/sem_scopes.adb index fe4bcc77d..88e676075 100644 --- a/sem_scopes.adb +++ b/sem_scopes.adb @@ -17,7 +17,6 @@ -- 02111-1307, USA. with Ada.Text_IO; with GNAT.Table; -with Types; use Types; with Name_Table; -- use Name_Table; with Errorout; use Errorout; with Iirs_Utils; diff --git a/sem_specs.adb b/sem_specs.adb index cd8682157..005ad57b9 100644 --- a/sem_specs.adb +++ b/sem_specs.adb @@ -21,7 +21,6 @@ with Sem_Expr; use Sem_Expr; with Sem_Names; use Sem_Names; with Evaluation; use Evaluation; with Std_Package; use Std_Package; -with Tokens; with Errorout; use Errorout; with Sem; use Sem; with Sem_Scopes; use Sem_Scopes; diff --git a/sem_stmts.adb b/sem_stmts.adb index fc0a3ae4f..6703acf27 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -791,7 +791,7 @@ package body Sem_Stmts is -- Return FALSE in case of violation. function Check_Odcat_Expression (Expr : Iir) return Boolean is - Expr_Type : Iir := Get_Type (Expr); + Expr_Type : constant Iir := Get_Type (Expr); begin -- LRM 8.8 Case Statement -- If the expression is of a one-dimensional character array type, @@ -927,10 +927,8 @@ package body Sem_Stmts is Expr: Iir; Chain : Iir; El: Iir; - Loc : Location_Type; begin Expr := Get_Expression (Stmt); - Loc := Get_Location (Expr); -- FIXME: overload. Expr := Sem_Expression (Expr, Null_Iir); if Expr = Null_Iir then @@ -994,7 +992,7 @@ package body Sem_Stmts is -- signal name, and each name must denote a signal for which -- reading is permitted. if Get_Name_Staticness (Res) < Globally then - Error_Msg_Sem ("sensitivity element " & Disp_Node (El) + Error_Msg_Sem ("sensitivity element " & Disp_Node (Res) & " must be a static name", El); end if; diff --git a/sem_types.adb b/sem_types.adb index 777a245e7..efd14801e 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -1062,6 +1062,7 @@ package body Sem_Types is Res: Iir; El : Iir; List : Iir_List; + Has_Error : Boolean; begin Name := Get_Resolution_Function (Decl); if Name = Null_Iir then @@ -1086,19 +1087,29 @@ package body Sem_Types is if Is_Overload_List (Func) then List := Get_Overload_List (Func); + Has_Error := False; for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; if Is_A_Resolution_Function (El, Decl) then - if Func /= Null_Iir then - Error_Msg_Sem - ("can't resolve overload for resolution function", Decl); - return; + if Res /= Null_Iir then + if not Has_Error then + Has_Error := True; + Error_Msg_Sem + ("can't resolve overload for resolution function", + Decl); + Error_Msg_Sem ("candidate functions are:", Decl); + Error_Msg_Sem (" " & Disp_Subprg (Func), Func); + end if; + Error_Msg_Sem (" " & Disp_Subprg (El), El); else - Func := El; + Res := El; end if; end if; end loop; + if Has_Error then + return; + end if; else if Is_A_Resolution_Function (Func, Decl) then Res := Func; @@ -1478,6 +1489,7 @@ package body Sem_Types is -- constraint. declare Sub_Type : Iir; + pragma Unreferenced (Sub_Type); Base_Type : Iir; begin Base_Type := Get_Designated_Type (Type_Mark); diff --git a/std_package.adb b/std_package.adb index ba6e256cc..074a75d8c 100644 --- a/std_package.adb +++ b/std_package.adb @@ -15,7 +15,6 @@ -- 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 Iirs; use Iirs; with Types; use Types; with Files_Map; with Name_Table; @@ -331,6 +330,7 @@ package body Std_Package is -- characters. declare El: Iir; + pragma Unreferenced (El); begin Character_Type_Definition := Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition); diff --git a/translate/Makefile b/translate/Makefile index 32128c439..1fb63e5be 100644 --- a/translate/Makefile +++ b/translate/Makefile @@ -18,7 +18,7 @@ BE=gcc ortho_srcdir=../ortho -GNAT_FLAGS=-aI.. -gnaty3befhkmr -gnata -gnatf -gnatwlcru +GNAT_FLAGS=-aI.. -gnaty3befhkmr -gnata -gnatf -gnatwa -gnatwe #GNAT_FLAGS+=-O -gnatn LN=ln -s diff --git a/translate/gcc/Make-lang.in b/translate/gcc/Make-lang.in index 0139c2c76..308f400ae 100644 --- a/translate/gcc/Make-lang.in +++ b/translate/gcc/Make-lang.in @@ -79,7 +79,7 @@ ghdl1$(exeext): $(AGCC_OBJS) $(AGCC_DEPS) force -cargs $(CFLAGS) $(GHDL_ADAFLAGS) $(GNATMAKE) -o $@ -aI$(srcdir)/vhdl -aOvhdl ortho_gcc-main \ -bargs -E -cargs $(CFLAGS) $(GHDL_ADAFLAGS) \ - -largs $(AGCC_OBJS) $(LIBS) + -largs $(AGCC_OBJS) $(LIBS) $(GMPLIBS) # The driver for ghdl. ghdl$(exeext): force diff --git a/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh index 46d347816..58c8ba5af 100644 --- a/translate/gcc/dist-common.sh +++ b/translate/gcc/dist-common.sh @@ -158,8 +158,13 @@ grt_files=" grt-cbinding.c grt-cvpi.c grt.adc +grt-astdio.ads +grt-astdio.adb grt-avhpi.adb grt-avhpi.ads +grt-avls.ads +grt-avls.adb +grt-c.ads grt-disp.adb grt-disp.ads grt-disp_rti.adb @@ -176,8 +181,6 @@ grt-hooks.adb grt-hooks.ads grt-images.adb grt-images.ads -grt-values.adb -grt-values.ads grt-lib.adb grt-lib.ads grt-main.adb @@ -208,12 +211,16 @@ grt-stack2.adb grt-stack2.ads grt-stacks.adb grt-stacks.ads -grt-c.ads -grt-zlib.ads +grt-stats.ads +grt-stats.adb grt-stdio.ads -grt-astdio.ads -grt-astdio.adb +grt-table.ads +grt-table.adb grt-types.ads +grt-unithread.ads +grt-unithread.adb +grt-values.adb +grt-values.ads grt-vcd.adb grt-vcd.ads grt-vcdz.adb @@ -224,14 +231,9 @@ grt-vpi.adb grt-vpi.ads grt-vstrings.adb grt-vstrings.ads -grt-stats.ads -grt-stats.adb grt-waves.ads grt-waves.adb -grt-avls.ads -grt-avls.adb -grt-unithread.ads -grt-unithread.adb +grt-zlib.ads grt-threads.ads grt-arch_none.ads grt-arch_none.adb diff --git a/translate/gcc/dist.sh b/translate/gcc/dist.sh index 97dff900f..da78ff039 100755 --- a/translate/gcc/dist.sh +++ b/translate/gcc/dist.sh @@ -39,7 +39,7 @@ set -e # GCC version -GCCVERSION=4.2.4 +GCCVERSION=4.3.1 # Machine name used by GCC MACHINE=i686-pc-linux-gnu # Directory where GCC sources (and objects) stay. @@ -170,7 +170,7 @@ do_compile () rm -rf $GCCDISTOBJ mkdir $GCCDISTOBJ cd $GCCDISTOBJ - ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap + ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="<URL:http://gna.org/projects/ghdl>" make CFLAGS="-O -g" make -C gcc vhdl.info cd $CWD diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile index 9e9e1e071..0d76bc502 100644 --- a/translate/ghdldrv/Makefile +++ b/translate/ghdldrv/Makefile @@ -15,9 +15,11 @@ # 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. -GNATFLAGS=-gnaty3befhkmr -gnata -gnatwu -gnatwl -aI../.. -aI.. -aI../grt -aO.. -g -gnatf +GNATFLAGS=-gnaty3befhkmr -gnata -gnatwae -aI../.. -aI.. -aI../grt -aO.. -g -gnatf GRT_FLAGS=-g LIB_CFLAGS=-g -O2 +GNATMAKE=gnatmake +CC=gcc # Optimize, do not forget to use MODE=--genfast for iirs.adb. #GNATFLAGS+=-O -gnatn @@ -52,13 +54,13 @@ ortho_code-x86-flags.ads: ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force - gnatmake -aI../../ortho/mcode $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) + $(GNATMAKE) -aI../../ortho/mcode $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) -largs -L/usr/lib32 memsegs_c.o: ../../ortho/mcode/memsegs_c.c $(CC) -c -g -o $@ $< ghdl_gcc: default_pathes.ads force - gnatmake $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS) + $(GNATMAKE) $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS) ghdl_simul: default_pathes.ads force gnatmake -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) @@ -116,7 +118,7 @@ install.v87: std.v87 ieee.v87 synopsys.v87 install.standard: $(LIB93_DIR)/std/std_standard.o \ $(LIB87_DIR)/std/std_standard.o -make-lib-links: +grt.links: cd ../lib; ln -sf $(GRTSRCDIR)/grt.lst .; ln -sf $(GRTSRCDIR)/libgrt.a .; ln -sf $(GRTSRCDIR)/grt.ver . install.all: install.v87 install.v93 install.standard diff --git a/translate/ghdldrv/ghdlcomp.adb b/translate/ghdldrv/ghdlcomp.adb index a3895f9a0..4dcd208fa 100644 --- a/translate/ghdldrv/ghdlcomp.adb +++ b/translate/ghdldrv/ghdlcomp.adb @@ -122,9 +122,6 @@ package body Ghdlcomp is end; Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last)); Hooks.Run.all; - exception - when Errorout.Option_Error => - raise; end Perform_Action; @@ -197,7 +194,7 @@ package body Ghdlcomp is Elab_Arg := Natural'Last; for I in Args'Range loop declare - Arg : String := Args (I).all; + Arg : constant String := Args (I).all; Res : Iir_Design_File; Design : Iir; Next_Design : Iir; @@ -246,9 +243,6 @@ package body Ghdlcomp is Error_Msg_Option ("options after unit are ignored"); end if; end if; - exception - when Errorout.Option_Error => - raise; end Perform_Action; -- Command -a @@ -346,8 +340,6 @@ package body Ghdlcomp is else raise; end if; - when Errorout.Option_Error => - raise; end Perform_Action; -- Command -e @@ -427,8 +419,6 @@ package body Ghdlcomp is else raise; end if; - when Errorout.Option_Error => - raise; end Perform_Action; -- Command dispconfig. @@ -636,7 +626,7 @@ package body Ghdlcomp is Put ("GHDLFLAGS="); for I in 2 .. Argument_Count loop declare - Arg : String := Argument (I); + Arg : constant String := Argument (I); begin if Arg (1) = '-' then if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") diff --git a/translate/ghdldrv/ghdldrv.adb b/translate/ghdldrv/ghdldrv.adb index 52b7e5aa3..9de01b4ee 100644 --- a/translate/ghdldrv/ghdldrv.adb +++ b/translate/ghdldrv/ghdldrv.adb @@ -57,9 +57,6 @@ package body Ghdldrv is -- "-o" string. Dash_O : String_Access; - -- "-S" string. - Dash_S : String_Access; - -- "-quiet" option. Dash_Quiet : String_Access; @@ -155,7 +152,8 @@ package body Ghdldrv is -- Compile. declare P : Natural; - Nbr_Args : Natural := Last (Compiler_Args) + Options'Length + 4; + Nbr_Args : constant Natural := + Last (Compiler_Args) + Options'Length + 4; Args : Argument_List (1 .. Nbr_Args); begin P := 0; @@ -199,7 +197,7 @@ package body Ghdldrv is if Compile_Kind = Compile_Debug then declare P : Natural; - Nbr_Args : Natural := Last (Postproc_Args) + 4; + Nbr_Args : constant Natural := Last (Postproc_Args) + 4; Args : Argument_List (1 .. Nbr_Args); begin P := 0; @@ -229,7 +227,7 @@ package body Ghdldrv is elsif not Flag_Asm then declare P : Natural; - Nbr_Args : Natural := Last (Assembler_Args) + 4; + Nbr_Args : constant Natural := Last (Assembler_Args) + 4; Args : Argument_List (1 .. Nbr_Args); Success : Boolean; begin @@ -358,7 +356,6 @@ package body Ghdldrv is is use Files_Map; - Dir : Name_Id; Name : Name_Id; File : Source_File_Entry; @@ -368,7 +365,6 @@ package body Ghdldrv is return False; end if; - Dir := Get_Library_Directory (Get_Library (Design_File)); Name := Get_Design_File_Filename (Design_File); declare Obj_Pathname : String := Get_Object_Filename (Design_File) & Nul; @@ -539,7 +535,6 @@ package body Ghdldrv is Tool_Not_Found (Linker_Cmd); end if; Dash_O := new String'("-o"); - Dash_S := new String'("-S"); Dash_Quiet := new String'("-quiet"); end Locate_Tools; @@ -596,88 +591,87 @@ package body Ghdldrv is Res : out Option_Res) is Str : String_Access; + Opt : constant String (1 .. Option'Length) := Option; begin Res := Option_Bad; - if Option = "-v" and then Flag_Verbose = False then + if Opt = "-v" and then Flag_Verbose = False then -- Note: this is also decoded for command_lib, but we set -- Flag_Disp_Commands too. Flag_Verbose := True; --Flags.Verbose := True; Flag_Disp_Commands := True; Res := Option_Ok; - elsif Option'Length > 8 and then Option (1 .. 8) = "--GHDL1=" then - Compiler_Cmd := new String'(Option (9 .. Option'Last)); + elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then + Compiler_Cmd := new String'(Opt (9 .. Opt'Last)); Res := Option_Ok; - elsif Option = "-S" then + elsif Opt = "-S" then Flag_Asm := True; Res := Option_Ok; - elsif Option = "--post" then + elsif Opt = "--post" then Compile_Kind := Compile_Debug; Res := Option_Ok; - elsif Option = "--mcode" then + elsif Opt = "--mcode" then Compile_Kind := Compile_Mcode; Res := Option_Ok; - elsif Option = "-o" then + elsif Opt = "-o" then if Arg'Length = 0 then Res := Option_Arg_Req; else Output_File := new String'(Arg); Res := Option_Arg; end if; - elsif Option = "-m32" then + elsif Opt = "-m32" then Add_Argument (Compiler_Args, new String'("-m32")); Add_Argument (Assembler_Args, new String'("--32")); Add_Argument (Linker_Args, new String'("-m32")); - Decode_Option (Command_Lib (Cmd), Option, Arg, Res); - elsif Option'Length > 4 - and then Option (2) = 'W' and then Option (4) = ',' + Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); + elsif Opt'Length > 4 + and then Opt (2) = 'W' and then Opt (4) = ',' then - if Option (3) = 'c' then - Add_Arguments (Compiler_Args, Option); - elsif Option (3) = 'a' then - Add_Arguments (Assembler_Args, Option); - elsif Option (3) = 'p' then - Add_Arguments (Postproc_Args, Option); - elsif Option (3) = 'l' then - Add_Arguments (Linker_Args, Option); + if Opt (3) = 'c' then + Add_Arguments (Compiler_Args, Opt); + elsif Opt (3) = 'a' then + Add_Arguments (Assembler_Args, Opt); + elsif Opt (3) = 'p' then + Add_Arguments (Postproc_Args, Opt); + elsif Opt (3) = 'l' then + Add_Arguments (Linker_Args, Opt); else Error - ("unknown tool name in '-W" & Option (3) & ",' option"); + ("unknown tool name in '-W" & Opt (3) & ",' option"); raise Option_Error; end if; Res := Option_Ok; - elsif Option'Length >= 2 and then Option (2) = 'g' then + elsif Opt'Length >= 2 and then Opt (2) = 'g' then -- Debugging option. - Str := new String'(Option); + Str := new String'(Opt); Add_Argument (Compiler_Args, Str); Add_Argument (Linker_Args, Str); Res := Option_Ok; - elsif Option = "-Q" then + elsif Opt = "-Q" then Flag_Not_Quiet := True; Res := Option_Ok; - elsif Option = "--expect-failure" then - Add_Argument (Compiler_Args, new String'(Option)); + elsif Opt = "--expect-failure" then + Add_Argument (Compiler_Args, new String'(Opt)); Flag_Expect_Failure := True; Res := Option_Ok; - elsif Flags.Parse_Option (Option) then - Add_Argument (Compiler_Args, new String'(Option)); + elsif Flags.Parse_Option (Opt) then + Add_Argument (Compiler_Args, new String'(Opt)); Res := Option_Ok; - elsif Option'Length >= 2 - and then (Option (2) = 'O' or Option (2) = 'f') + elsif Opt'Length >= 2 + and then (Opt (2) = 'O' or Opt (2) = 'f') then -- Optimization option. -- This is put after Flags.Parse_Option, since it may catch -fxxx -- options. - Add_Argument (Compiler_Args, new String'(Option)); + Add_Argument (Compiler_Args, new String'(Opt)); Res := Option_Ok; else - Decode_Option (Command_Lib (Cmd), Option, Arg, Res); + Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); end if; end Decode_Option; - procedure Disp_Long_Help (Cmd : Command_Comp) - is - use Ada.Text_IO; + procedure Disp_Long_Help (Cmd : Command_Comp) is begin Disp_Long_Help (Command_Lib (Cmd)); Put_Line (" -v Be verbose"); @@ -719,7 +713,6 @@ package body Ghdldrv is procedure Perform_Action (Cmd : in out Command_Dispconfig; Args : Argument_List) is - use Ada.Text_IO; use Libraries; pragma Unreferenced (Cmd); begin @@ -912,7 +905,7 @@ package body Ghdldrv is -- call the linker declare P : Natural; - Nbr_Args : Natural := Last (Linker_Args) + Filelist.Last + 4; + Nbr_Args : constant Natural := Last (Linker_Args) + Filelist.Last + 4; Args : Argument_List (1 .. Nbr_Args); Obj_File : String_Access; Std_File : String_Access; @@ -997,6 +990,7 @@ package body Ghdldrv is is pragma Unreferenced (Cmd); Success : Boolean; + pragma Unreferenced (Success); begin Set_Elab_Units ("-e", Args); Setup_Compiler (False); @@ -1614,7 +1608,7 @@ package body Ghdldrv is Put ("GHDLFLAGS="); for I in 2 .. Argument_Count loop declare - Arg : String := Argument (I); + Arg : constant String := Argument (I); begin if Arg (1) = '-' then if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb index fb8f5f6d0..6565f9dce 100644 --- a/translate/ghdldrv/ghdllocal.adb +++ b/translate/ghdldrv/ghdllocal.adb @@ -16,7 +16,6 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ada.Text_IO; -with Ghdlmain; with Types; use Types; with Libraries; with Std_Package; @@ -40,7 +39,7 @@ package body Ghdllocal is type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor); Flag_Ieee : Ieee_Lib_Kind; - Flag_Create_Default_Config : Boolean := True; + Flag_Create_Default_Config : constant Boolean := True; -- If TRUE, generate 32bits code on 64bits machines. Flag_32bit : Boolean := False; @@ -108,36 +107,37 @@ package body Ghdllocal is is pragma Unreferenced (Cmd); pragma Unreferenced (Arg); + Opt : constant String (1 .. Option'Length) := Option; begin Res := Option_Bad; - if Option = "-v" and then Flag_Verbose = False then + if Opt = "-v" and then Flag_Verbose = False then Flag_Verbose := True; Res := Option_Ok; - elsif Option'Length > 9 and then Option (1 .. 9) = "--PREFIX=" then - Prefix_Path := new String'(Option (10 .. Option'Last)); + elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then + Prefix_Path := new String'(Opt (10 .. Opt'Last)); Res := Option_Ok; - elsif Option = "--ieee=synopsys" then + elsif Opt = "--ieee=synopsys" then Flag_Ieee := Lib_Synopsys; Res := Option_Ok; - elsif Option = "--ieee=mentor" then + elsif Opt = "--ieee=mentor" then Flag_Ieee := Lib_Mentor; Res := Option_Ok; - elsif Option = "--ieee=none" then + elsif Opt = "--ieee=none" then Flag_Ieee := Lib_None; Res := Option_Ok; - elsif Option = "--ieee=standard" then + elsif Opt = "--ieee=standard" then Flag_Ieee := Lib_Standard; Res := Option_Ok; - elsif Option = "-m32" then + elsif Opt = "-m32" then Flag_32bit := True; Res := Option_Ok; - elsif Option'Length >= 2 - and then (Option (2) = 'g' or Option (2) = 'O') + elsif Opt'Length >= 2 + and then (Opt (2) = 'g' or Opt (2) = 'O') then -- Silently accept -g and -O. Res := Option_Ok; else - if Flags.Parse_Option (Option) then + if Flags.Parse_Option (Opt) then Res := Option_Ok; end if; end if; @@ -326,7 +326,7 @@ package body Ghdllocal is function Append_Suffix (File : String; Suffix : String) return String_Access is use Name_Table; - Basename : String := Get_Base_Name (File); + Basename : constant String := Get_Base_Name (File); begin Image (Libraries.Work_Directory); Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) := @@ -429,7 +429,7 @@ package body Ghdllocal is Design_File : Iir_Design_File; Unit : Iir; Lib : Iir; - Flag_Add : Boolean := False; + Flag_Add : constant Boolean := False; begin Flags.Bootstrap := True; Libraries.Load_Std_Library; @@ -646,7 +646,6 @@ package body Ghdllocal is procedure Delete (Str : String) is - use GNAT.OS_Lib; use Ada.Text_IO; Status : Boolean; begin @@ -659,7 +658,6 @@ package body Ghdllocal is procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List) is pragma Unreferenced (Cmd); - use GNAT.OS_Lib; use Name_Table; procedure Delete_Asm_Obj (Str : String) is @@ -805,6 +803,7 @@ package body Ghdllocal is procedure Extract_Library_Clauses (Unit : Iir_Design_Unit) is Lib1 : Iir_Library_Declaration; + pragma Unreferenced (Lib1); Ctxt_Item : Iir; begin -- Extract library clauses. @@ -1059,7 +1058,7 @@ package body Ghdllocal is if Args'Length >= 2 then declare - Sec : String_Access := Args (Next_Arg); + Sec : constant String_Access := Args (Next_Arg); begin if Sec (Sec'First) /= '-' then Sec_Name := Convert_Name (Sec); diff --git a/translate/ghdldrv/ghdlmain.adb b/translate/ghdldrv/ghdlmain.adb index 0f4392926..b77ceca01 100644 --- a/translate/ghdldrv/ghdlmain.adb +++ b/translate/ghdldrv/ghdlmain.adb @@ -20,7 +20,6 @@ with Ada.Command_Line; with Version; with Flags; with Bug; -with Errorout; package body Ghdlmain is procedure Init (Cmd : in out Command_Type) @@ -275,7 +274,7 @@ package body Ghdlmain is Arg_Index := 2; while Arg_Index <= Argument_Count loop declare - Arg : String := Argument (Arg_Index); + Arg : constant String := Argument (Arg_Index); Res : Option_Res; begin if Arg (1) = '-' then diff --git a/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb index 45750efeb..3dc555044 100644 --- a/translate/ghdldrv/ghdlprint.adb +++ b/translate/ghdldrv/ghdlprint.adb @@ -84,9 +84,6 @@ package body Ghdlprint is Buf : File_Buffer_Acc; Prev_Tok : Token_Type; - -- True if tokens are between 'end' and ';' - In_End : Boolean := False; - -- Current logical column number. Used to expand TABs. Col : Natural; @@ -372,9 +369,7 @@ package body Ghdlprint is Disp_Reserved; when Tok_End => Disp_Reserved; - In_End := True; when Tok_Semi_Colon => - In_End := False; Disp_Spaces; Disp_Text; when Tok_Xnor .. Tok_Ror => @@ -944,9 +939,7 @@ package body Ghdlprint is end if; end Decode_Option; - procedure Disp_Long_Help (Cmd : Command_Html) - is - use Ada.Text_IO; + procedure Disp_Long_Help (Cmd : Command_Html) is begin Disp_Long_Help (Command_Lib (Cmd)); Put_Line ("--format=html2 Use FONT attributes"); @@ -1068,9 +1061,7 @@ package body Ghdlprint is end if; end Decode_Option; - procedure Disp_Long_Help (Cmd : Command_Xref_Html) - is - use Ada.Text_IO; + procedure Disp_Long_Help (Cmd : Command_Xref_Html) is begin Disp_Long_Help (Command_Html (Cmd)); Put_Line ("-o DIR Put generated files into DIR (def: html/)"); @@ -1115,7 +1106,6 @@ package body Ghdlprint is Files : File_Data_Array; Output : File_Type; - Prev_Output : File_Access; begin Xrefs.Init; Flags.Flag_Xref := True; @@ -1220,8 +1210,6 @@ package body Ghdlprint is Filexref_Info (Files (I).Fe).Output := Files (I).Output; end loop; - Prev_Output := Current_Input; - for I in Files'Range loop if Cmd.Output_Dir /= null then Create (Output, Out_File, @@ -1304,7 +1292,7 @@ package body Ghdlprint is and then Cmd.Output_Dir /= null then declare - Css_Filename : String := + Css_Filename : constant String := Cmd.Output_Dir.all & Directory_Separator & "ghdl.css"; begin if not Is_Regular_File (Css_Filename & Nul) then @@ -1427,6 +1415,7 @@ package body Ghdlprint is Loc_File : Source_File_Entry; Loc_Pos : Source_Ptr; C : Character; + Dir : Name_Id; begin New_Line; Cur_Decl := N; @@ -1435,8 +1424,11 @@ package body Ghdlprint is if Loc_File /= Cur_File then Cur_File := Loc_File; Put ("XFILE: "); - Image (Get_Source_File_Directory (Cur_File)); - Put (Name_Buffer (1 .. Name_Length)); + Dir := Get_Source_File_Directory (Cur_File); + if Dir /= Null_Identifier then + Image (Dir); + Put (Name_Buffer (1 .. Name_Length)); + end if; Image (Get_File_Name (Cur_File)); Put (Name_Buffer (1 .. Name_Length)); New_Line; @@ -1537,8 +1529,6 @@ package body Ghdlprint is Emit_Ref (I, 'r'); when Xref_Body => Emit_Ref (I, 'b'); - when others => - null; end case; end if; end loop; diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb index 4bae12dce..f60504ac0 100644 --- a/translate/ghdldrv/ghdlrun.adb +++ b/translate/ghdldrv/ghdlrun.adb @@ -29,7 +29,6 @@ with Binary_File; use Binary_File; with Binary_File.Memory; with Ortho_Mcode; use Ortho_Mcode; with Ortho_Code.Flags; use Ortho_Code.Flags; -with Binary_File; with Interfaces; with System; use System; with Trans_Decls; @@ -46,7 +45,6 @@ with Trans_Be; with Translation; with Std_Names; with Ieee.Std_Logic_1164; -with Interfaces.C; with Binary_File.Elf; @@ -250,8 +248,9 @@ package body Ghdlrun is case Info.Kind is when Foreign_Vhpidirect => declare - Name : String := Name_Table.Name_Buffer (Info.Subprg_First - .. Info.Subprg_Last); + Name : constant String := + Name_Table.Name_Buffer (Info.Subprg_First + .. Info.Subprg_Last); begin Res := Foreigns.Find_Foreign (Name); if Res /= Null_Address then @@ -270,7 +269,6 @@ package body Ghdlrun is procedure Run is - use Binary_File; use Interfaces; use Ortho_Code.Binary; @@ -632,15 +630,16 @@ package body Ghdlrun is function Decode_Option (Option : String) return Boolean is + Opt : constant String (1 .. Option'Length) := Option; begin - if Option = "-g" then + if Opt = "-g" then Flag_Debug := Debug_Dwarf; return True; - elsif Option'Length > 5 and then Option (1 .. 5) = "--be-" then - Ortho_Code.Debug.Set_Be_Flag (Option); + elsif Opt'Length > 5 and then Opt (1 .. 5) = "--be-" then + Ortho_Code.Debug.Set_Be_Flag (Opt); return True; - elsif Option'Length > 7 and then Option (1 .. 7) = "--snap=" then - Snap_Filename := new String'(Option (8 .. Option'Last)); + elsif Opt'Length > 7 and then Opt (1 .. 7) = "--snap=" then + Snap_Filename := new String'(Opt (8 .. Opt'Last)); return True; else return False; diff --git a/translate/grt/Makefile b/translate/grt/Makefile index ff68bc7b0..1c6af4d10 100644 --- a/translate/grt/Makefile +++ b/translate/grt/Makefile @@ -18,7 +18,7 @@ GRT_FLAGS=-g -O GRT_ADAFLAGS=-gnatn -ADAC=gnatgcc +ADAC=gcc GNATFLAGS=$(CFLAGS) -gnatf -gnaty3befhkmr -gnatwlu GHDL1=../ghdl1-gcc GRTSRCDIR=. diff --git a/translate/grt/Makefile.inc b/translate/grt/Makefile.inc index b82e33b7d..3fc736161 100644 --- a/translate/grt/Makefile.inc +++ b/translate/grt/Makefile.inc @@ -33,7 +33,8 @@ # manufacturer, and operating system and assign each of those to its own # variable. -targ:=$(subst -, ,$(target)) +target1:=$(subst -gnu,,$(target)) +targ:=$(subst -, ,$(target1)) arch:=$(word 1,$(targ)) ifeq ($(words $(targ)),2) osys:=$(word 2,$(targ)) @@ -113,10 +114,15 @@ libgrt.a: $(GRT_ADD_OBJS) run-bind.o main.o grt-files # grt-arch.ads $(GRT_RANLIB) $@ run-bind.adb: grt-force - gnatmake -c $(GNATFLAGS) -aI$(GRTSRCDIR) $(GRT_PRAGMA_FLAG) ghdl_main \ - $(GRT_ADAFLAGS) -cargs $(GRT_FLAGS) + gnatmake -c $(GNATFLAGS) -aI$(GRTSRCDIR) $(GRT_PRAGMA_FLAG) \ + ghdl_main $(GRT_ADAFLAGS) -cargs $(GRT_FLAGS) gnatbind -Lgrt_ -o run-bind.adb -n ghdl_main.ali +#system.ads: +# sed -e "/Configurable_Run_Time/s/False/True/" \ +# -e "/Suppress_Standard_Library/s/False/True/" \ +# < `$(ADAC) -print-file-name=adainclude/system.ads` > $@ + run-bind.o: run-bind.adb $(GRT_ADACOMPILE) diff --git a/translate/grt/grt-astdio.adb b/translate/grt/grt-astdio.adb index ee264cf3e..b34744f7a 100644 --- a/translate/grt/grt-astdio.adb +++ b/translate/grt/grt-astdio.adb @@ -21,6 +21,7 @@ package body Grt.Astdio is procedure Put (Stream : FILEs; Str : String) is S : size_t; + pragma Unreferenced (S); begin S := fwrite (Str'Address, Str'Length, 1, Stream); end Put; @@ -28,6 +29,7 @@ package body Grt.Astdio is procedure Put (Stream : FILEs; C : Character) is R : int; + pragma Unreferenced (R); begin R := fputc (Character'Pos (C), Stream); end Put; @@ -36,6 +38,7 @@ package body Grt.Astdio is is Len : Natural; S : size_t; + pragma Unreferenced (S); begin Len := strlen (Str); S := fwrite (Str (1)'Address, size_t (Len), 1, Stream); @@ -49,6 +52,7 @@ package body Grt.Astdio is procedure Put (Str : String) is S : size_t; + pragma Unreferenced (S); begin S := fwrite (Str'Address, Str'Length, 1, stdout); end Put; @@ -56,6 +60,7 @@ package body Grt.Astdio is procedure Put (C : Character) is R : int; + pragma Unreferenced (R); begin R := fputc (Character'Pos (C), stdout); end Put; @@ -64,6 +69,7 @@ package body Grt.Astdio is is Len : Natural; S : size_t; + pragma Unreferenced (S); begin Len := strlen (Str); S := fwrite (Str (1)'Address, size_t (Len), 1, stdout); diff --git a/translate/grt/grt-avhpi.adb b/translate/grt/grt-avhpi.adb index 36826fe14..a5c36e598 100644 --- a/translate/grt/grt-avhpi.adb +++ b/translate/grt/grt-avhpi.adb @@ -126,9 +126,9 @@ package body Grt.Avhpi is case Res.N_Type.Kind is when Ghdl_Rtik_Subtype_Array => declare - St : Ghdl_Rtin_Subtype_Array_Acc := + St : constant Ghdl_Rtin_Subtype_Array_Acc := To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type); - Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); begin Bound_To_Range @@ -155,6 +155,7 @@ package body Grt.Avhpi is El_Type : Ghdl_Rti_Access; Off : Ghdl_Index_Type) return Address is + pragma Unreferenced (Ctxt); Is_Sig : Boolean; El_Size : Ghdl_Index_Type; El_Type1 : Ghdl_Rti_Access; @@ -389,7 +390,6 @@ package body Grt.Avhpi is is Blk : Ghdl_Rtin_Block_Acc; Ch : Ghdl_Rti_Access; - Obj : Ghdl_Rtin_Object_Acc; begin Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); @@ -420,7 +420,6 @@ package body Grt.Avhpi is exit when Iterator.It_Cur >= Blk.Nbr_Child; Ch := Blk.Children (Iterator.It_Cur); - Obj := To_Ghdl_Rtin_Object_Acc (Ch); Iterator.It_Cur := Iterator.It_Cur + 1; @@ -874,11 +873,12 @@ package body Grt.Avhpi is when VhpiSubtypeIndicK => if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then declare - Arr_Subtype : Ghdl_Rtin_Subtype_Array_Acc := + Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc := To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype); - Basetype : Ghdl_Rtin_Type_Array_Acc := + Basetype : constant Ghdl_Rtin_Type_Array_Acc := Arr_Subtype.Basetype; - Idx : Ghdl_Index_Type := Ghdl_Index_Type (Index); + Idx : constant Ghdl_Index_Type := + Ghdl_Index_Type (Index); Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1); Range_Basetype : Ghdl_Rti_Access; begin @@ -961,6 +961,7 @@ package body Grt.Avhpi is case Property is when VhpiLeftBoundP => if Obj.Kind /= VhpiIntRangeK then + Res := 0; Error := AvhpiErrorBadRel; return; end if; @@ -999,6 +1000,7 @@ package body Grt.Avhpi is case Property is when VhpiIsUpP => if Obj.Kind /= VhpiIntRangeK then + Res := False; Error := AvhpiErrorBadRel; return; end if; diff --git a/translate/grt/grt-c.ads b/translate/grt/grt-c.ads index 33fb36cef..6750e7d03 100644 --- a/translate/grt/grt-c.ads +++ b/translate/grt/grt-c.ads @@ -33,4 +33,15 @@ package Grt.C is -- Type int. It is an alias on Integer for simplicity. subtype int is Integer; + + -- Low level memory management. + procedure Free (Addr : System.Address); + function Malloc (Size : size_t) return System.Address; + function Realloc (Ptr : System.Address; Size : size_t) + return System.Address; + +private + pragma Import (C, Free); + pragma Import (C, Malloc); + pragma Import (C, Realloc); end Grt.C; diff --git a/translate/grt/grt-disp.adb b/translate/grt/grt-disp.adb index 075c8b4dc..3a6b3e74c 100644 --- a/translate/grt/grt-disp.adb +++ b/translate/grt/grt-disp.adb @@ -16,8 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System.Storage_Elements; -- Work around GNAT bug. -with Grt.Types; use Grt.Types; -with Grt.Signals; use Grt.Signals; +pragma Unreferenced (System.Storage_Elements); with Grt.Astdio; use Grt.Astdio; with Grt.Stdio; use Grt.Stdio; --with Grt.Errors; use Grt.Errors; diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb index dded64430..c92677564 100644 --- a/translate/grt/grt-disp_rti.adb +++ b/translate/grt/grt-disp_rti.adb @@ -17,7 +17,6 @@ -- 02111-1307, USA. with Grt.Astdio; use Grt.Astdio; with Grt.Errors; use Grt.Errors; -with Grt.Rtis_Addr; use Grt.Rtis_Addr; with Grt.Hooks; use Grt.Hooks; package body Grt.Disp_Rti is @@ -153,7 +152,7 @@ package body Grt.Disp_Rti is Vals : Ghdl_Uc_Array_Acc; Is_Sig : Boolean) is - Nbr_Dim : Ghdl_Index_Type := Rti.Nbr_Dim; + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); Obj : Address; begin @@ -166,7 +165,7 @@ package body Grt.Disp_Rti is procedure Disp_Record_Value (Stream : FILEs; Rti : Ghdl_Rtin_Type_Record_Acc; Ctxt : Rti_Context; - Obj : in out Address; + Obj : Address; Is_Sig : Boolean) is El : Ghdl_Rtin_Element_Acc; @@ -214,9 +213,9 @@ package body Grt.Disp_Rti is To_Ghdl_Uc_Array_Acc (Obj), Is_Sig); when Ghdl_Rtik_Subtype_Array => declare - St : Ghdl_Rtin_Subtype_Array_Acc := + St : constant Ghdl_Rtin_Subtype_Array_Acc := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); B : Address; begin @@ -228,9 +227,9 @@ package body Grt.Disp_Rti is end; when Ghdl_Rtik_Subtype_Array_Ptr => declare - St : Ghdl_Rtin_Subtype_Array_Acc := + St : constant Ghdl_Rtin_Subtype_Array_Acc := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); B : Address; begin diff --git a/translate/grt/grt-disp_signals.adb b/translate/grt/grt-disp_signals.adb index e9011c989..85acb93a0 100644 --- a/translate/grt/grt-disp_signals.adb +++ b/translate/grt/grt-disp_signals.adb @@ -17,18 +17,15 @@ -- 02111-1307, USA. with System; use System; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Ada.Unchecked_Conversion; -with Grt.Types; use Grt.Types; with Grt.Rtis; use Grt.Rtis; with Grt.Rtis_Addr; use Grt.Rtis_Addr; with Grt.Rtis_Utils; use Grt.Rtis_Utils; -with Grt.Rtis; use Grt.Rtis; with Grt.Astdio; use Grt.Astdio; with Grt.Errors; use Grt.Errors; pragma Elaborate_All (Grt.Rtis_Utils); with Grt.Vstrings; use Grt.Vstrings; -with Grt.Stdio; use Grt.Stdio; -with Grt.Signals; use Grt.Signals; with Grt.Options; with Grt.Disp; use Grt.Disp; @@ -231,6 +228,7 @@ package body Grt.Disp_Signals is procedure Disp_All_Signals is Res : Traverse_Result; + pragma Unreferenced (Res); begin if Boolean'(False) then for I in Sig_Table.First .. Sig_Table.Last loop @@ -308,6 +306,7 @@ package body Grt.Disp_Signals is procedure Disp_Signals_Map is Res : Traverse_Result; + pragma Unreferenced (Res); begin Res := Disp_Signals_Map_Blocks (Get_Top_Context); Grt.Stdio.fflush (stdout); @@ -351,7 +350,6 @@ package body Grt.Disp_Signals is procedure Disp_Signals_Table is - use Grt.Disp; Sig : Ghdl_Signal_Ptr; begin for I in Sig_Table.First .. Sig_Table.Last loop @@ -458,6 +456,7 @@ package body Grt.Disp_Signals is (Process_Block); Res_Status : Traverse_Result; + pragma Unreferenced (Res_Status); begin Res_Status := Foreach_Block (Get_Top_Context); if not Found then diff --git a/translate/grt/grt-disp_tree.adb b/translate/grt/grt-disp_tree.adb index e4f55f3d1..3f337ab35 100644 --- a/translate/grt/grt-disp_tree.adb +++ b/translate/grt/grt-disp_tree.adb @@ -83,7 +83,8 @@ package body Grt.Disp_Tree is | Ghdl_Rtik_Block | Ghdl_Rtik_If_Generate => declare - Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); begin Disp_Name (Blk.Name); end; @@ -104,7 +105,8 @@ package body Grt.Disp_Tree is end; when Ghdl_Rtik_For_Generate => declare - Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); Iter : Ghdl_Rtin_Object_Acc; Addr : Address; begin @@ -231,7 +233,8 @@ package body Grt.Disp_Tree is when Ghdl_Rtik_Process | Ghdl_Rtik_Block => declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); Nctxt : Rti_Context; begin Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off, @@ -241,7 +244,8 @@ package body Grt.Disp_Tree is end; when Ghdl_Rtik_For_Generate => declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); Nctxt : Rti_Context; Length : Ghdl_Index_Type; Old_Child2 : Ghdl_Rti_Access; @@ -268,7 +272,8 @@ package body Grt.Disp_Tree is end; when Ghdl_Rtik_If_Generate => declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); Nctxt : Rti_Context; begin Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, @@ -402,8 +407,9 @@ package body Grt.Disp_Tree is end loop; end Disp_Hierarchy; - function Disp_Tree_Option (Opt : String) return Boolean + function Disp_Tree_Option (Option : String) return Boolean is + Opt : constant String (1 .. Option'Length) := Option; begin if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then if Opt'Length = 11 then diff --git a/translate/grt/grt-errors.adb b/translate/grt/grt-errors.adb index 627316119..5b541af1e 100644 --- a/translate/grt/grt-errors.adb +++ b/translate/grt/grt-errors.adb @@ -17,7 +17,6 @@ -- 02111-1307, USA. with Grt.Stdio; use Grt.Stdio; with Grt.Astdio; use Grt.Astdio; -with Grt.Types; use Grt.Types; with Grt.Options; use Grt.Options; package body Grt.Errors is @@ -106,7 +105,7 @@ package body Grt.Errors is procedure Report_C (Str : Ghdl_C_String) is - Len : Natural := strlen (Str); + Len : constant Natural := strlen (Str); begin Put_Err (Str (1 .. Len)); end Report_C; @@ -154,7 +153,7 @@ package body Grt.Errors is procedure Error_C (Str : Ghdl_C_String) is - Len : Natural := strlen (Str); + Len : constant Natural := strlen (Str); begin if not Cont then Error_H; diff --git a/translate/grt/grt-files.adb b/translate/grt/grt-files.adb index 6da675d1b..a1ce0ceb2 100644 --- a/translate/grt/grt-files.adb +++ b/translate/grt/grt-files.adb @@ -18,8 +18,9 @@ with Grt.Errors; use Grt.Errors; with Grt.Stdio; use Grt.Stdio; with Grt.C; use Grt.C; -with GNAT.Table; +with Grt.Table; with System; use System; +pragma Elaborate_All (Grt.Table); package body Grt.Files is subtype C_Files is Grt.Stdio.FILEs; @@ -31,12 +32,11 @@ package body Grt.Files is Is_Alive : Boolean; end record; - package Files_Table is new GNAT.Table + package Files_Table is new Grt.Table (Table_Component_Type => File_Entry_Type, Table_Index_Type => Ghdl_File_Index, Table_Low_Bound => 1, - Table_Initial => 2, - Table_Increment => 100); + Table_Initial => 2); function Get_File (Index : Ghdl_File_Index) return C_Files is @@ -56,17 +56,13 @@ package body Grt.Files is end Check_File_Mode; function Create_File (Is_Text : Boolean; Sig : Ghdl_C_String) - return Ghdl_File_Index - is - Res : Ghdl_File_Index; + return Ghdl_File_Index is begin - Files_Table.Increment_Last; - Res := Files_Table.Last; - Files_Table.Table (Res) := (Stream => NULL_Stream, - Signature => Sig, - Is_Text => Is_Text, - Is_Alive => True); - return Res; + Files_Table.Append ((Stream => NULL_Stream, + Signature => Sig, + Is_Text => Is_Text, + Is_Alive => True)); + return Files_Table.Last; end Create_File; procedure Destroy_File (Is_Text : Boolean; Index : Ghdl_File_Index) is @@ -289,6 +285,7 @@ package body Grt.Files is Res : C_Files; R : size_t; R1 : int; + pragma Unreferenced (R, R1); begin Res := Get_File (File); Check_File_Mode (File, True); @@ -311,6 +308,7 @@ package body Grt.Files is Res : C_Files; R : size_t; R1 : int; + pragma Unreferenced (R1); begin Res := Get_File (File); Check_File_Mode (File, False); diff --git a/translate/grt/grt-files.ads b/translate/grt/grt-files.ads index 1fcce3cd4..b87478042 100644 --- a/translate/grt/grt-files.ads +++ b/translate/grt/grt-files.ads @@ -83,7 +83,7 @@ package Grt.Files is procedure Ghdl_Text_File_Close (File : Ghdl_File_Index); procedure Ghdl_File_Close (File : Ghdl_File_Index); private - pragma Export (C, Ghdl_File_Endfile, "__ghdl_file_endfile"); + pragma Export (Ada, Ghdl_File_Endfile, "__ghdl_file_endfile"); pragma Export (C, Ghdl_Text_File_Elaborate, "__ghdl_text_file_elaborate"); pragma Export (C, Ghdl_File_Elaborate, "__ghdl_file_elaborate"); diff --git a/translate/grt/grt-images.adb b/translate/grt/grt-images.adb index 5f8a081f9..d6efba0c3 100644 --- a/translate/grt/grt-images.adb +++ b/translate/grt/grt-images.adb @@ -17,6 +17,7 @@ -- 02111-1307, USA. with System; use System; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Ada.Unchecked_Conversion; with Grt.Processes; use Grt.Processes; with Grt.Vstrings; use Grt.Vstrings; @@ -98,7 +99,7 @@ package body Grt.Images is Unit := To_Ghdl_Rtin_Unit_Acc (Phys.Units (0)).Name; Unit_Len := strlen (Unit); declare - L : Natural := Str'Last + 1 - First; + L : constant Natural := Str'Last + 1 - First; Str2 : String (1 .. L + 1 + Unit_Len); begin Str2 (1 .. L) := Str (First .. Str'Last); @@ -122,7 +123,7 @@ package body Grt.Images is Unit := To_Ghdl_Rtin_Unit_Acc (Phys.Units (0)).Name; Unit_Len := strlen (Unit); declare - L : Natural := Str'Last + 1 - First; + L : constant Natural := Str'Last + 1 - First; Str2 : String (1 .. L + 1 + Unit_Len); begin Str2 (1 .. L) := Str (First .. Str'Last); diff --git a/translate/grt/grt-images.ads b/translate/grt/grt-images.ads index 74a7bd7e9..0d7224b30 100644 --- a/translate/grt/grt-images.ads +++ b/translate/grt/grt-images.ads @@ -32,7 +32,7 @@ package Grt.Images is procedure Ghdl_Image_P32 (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); private - pragma Export (C, Ghdl_Image_B2, "__ghdl_image_b2"); + pragma Export (Ada, Ghdl_Image_B2, "__ghdl_image_b2"); pragma Export (C, Ghdl_Image_E8, "__ghdl_image_e8"); pragma Export (C, Ghdl_Image_E32, "__ghdl_image_e32"); pragma Export (C, Ghdl_Image_I32, "__ghdl_image_i32"); diff --git a/translate/grt/grt-lib.adb b/translate/grt/grt-lib.adb index 0d1507ff0..dcddcf29b 100644 --- a/translate/grt/grt-lib.adb +++ b/translate/grt/grt-lib.adb @@ -41,7 +41,7 @@ package body Grt.Lib is Unit : Ghdl_Rti_Access) is use Grt.Options; - Level : Integer := Severity mod 256; + Level : constant Integer := Severity mod 256; begin -- Assertions from ieee library can be disabled. if Unit /= null @@ -51,9 +51,11 @@ package body Grt.Lib is and Current_Time = 0)) then declare - Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Unit); - Pkg : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Blk.Parent); - Lib : Ghdl_Rtin_Type_Scalar_Acc := + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Unit); + Pkg : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Blk.Parent); + Lib : constant Ghdl_Rtin_Type_Scalar_Acc := To_Ghdl_Rtin_Type_Scalar_Acc (Pkg.Parent); begin -- Return now if this assert comes from the ieee library. diff --git a/translate/grt/grt-main.adb b/translate/grt/grt-main.adb index 86a388cd6..43166fa0a 100644 --- a/translate/grt/grt-main.adb +++ b/translate/grt/grt-main.adb @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Types; use Grt.Types; with Grt.Errors; with Grt.Stacks; @@ -60,6 +61,9 @@ package body Grt.Main is is Err : Boolean; begin + -- The conditions may be statically known. + pragma Warnings (Off); + Err := False; if (Std_Integer'Size = 32 and Flag_String (3) /= 'i') or else (Std_Integer'Size = 64 and Flag_String (3) /= 'I') @@ -71,6 +75,9 @@ package body Grt.Main is then Err := True; end if; + + pragma Warnings (On); + if Err then Grt.Errors.Error ("GRT is not consistent with the flags used for your design"); diff --git a/translate/grt/grt-modules.adb b/translate/grt/grt-modules.adb index 6fe8eea32..cb43711a0 100644 --- a/translate/grt/grt-modules.adb +++ b/translate/grt/grt-modules.adb @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Vcd; with Grt.Vcdz; with Grt.Vpi; diff --git a/translate/grt/grt-names.adb b/translate/grt/grt-names.adb index 46ed04e2d..8afe1bca0 100644 --- a/translate/grt/grt-names.adb +++ b/translate/grt/grt-names.adb @@ -18,6 +18,7 @@ --with Grt.Errors; use Grt.Errors; with Ada.Unchecked_Conversion; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Processes; use Grt.Processes; with Grt.Rtis_Addr; use Grt.Rtis_Addr; with Grt.Rtis_Utils; use Grt.Rtis_Utils; diff --git a/translate/grt/grt-options.adb b/translate/grt/grt-options.adb index 0cb515e97..a272246be 100644 --- a/translate/grt/grt-options.adb +++ b/translate/grt/grt-options.adb @@ -253,7 +253,7 @@ package body Grt.Options is Arg := Argv (I); Len := strlen (Arg); declare - Argument : String := Arg (1 .. Len); + Argument : constant String := Arg (1 .. Len); begin if Argument = "--" then Last_Opt := I; diff --git a/translate/grt/grt-processes.adb b/translate/grt/grt-processes.adb index 650c0f005..058e8a57b 100644 --- a/translate/grt/grt-processes.adb +++ b/translate/grt/grt-processes.adb @@ -15,14 +15,13 @@ -- 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.Table; +with Grt.Table; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with System.Storage_Elements; -- Work around GNAT bug. -with Grt.Stack2; use Grt.Stack2; +pragma Unreferenced (System.Storage_Elements); with Grt.Disp; with Grt.Astdio; -with Grt.Signals; use Grt.Signals; with Grt.Errors; use Grt.Errors; with Grt.Stacks; use Grt.Stacks; with Grt.Options; @@ -30,28 +29,26 @@ with Grt.Rtis_Addr; use Grt.Rtis_Addr; with Grt.Rtis_Utils; with Grt.Hooks; with Grt.Disp_Signals; -with Grt.Stdio; with Grt.Stats; with Grt.Threads; use Grt.Threads; +pragma Elaborate_All (Grt.Table); package body Grt.Processes is Last_Time : constant Std_Time := Std_Time'Last; -- Table of processes. - package Process_Table is new GNAT.Table + package Process_Table is new Grt.Table (Table_Component_Type => Process_Type, Table_Index_Type => Process_Id, Table_Low_Bound => 1, - Table_Initial => 16, - Table_Increment => 100); + Table_Initial => 16); -- List of non_sensitized processes. - package Non_Sensitized_Process_Table is new GNAT.Table + package Non_Sensitized_Process_Table is new Grt.Table (Table_Component_Type => Process_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, - Table_Initial => 2, - Table_Increment => 100); + Table_Initial => 2); -- List of processes to be resume at next cycle. type Process_Id_Array is array (Natural range <>) of Process_Id; @@ -74,7 +71,7 @@ package body Grt.Processes is procedure Init is begin - Process_Table.Init; + null; end Init; function Get_Nbr_Processes return Natural is @@ -380,7 +377,7 @@ package body Grt.Processes is procedure Ghdl_Protected_Enter (Obj : System.Address) is - Lock : Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; + Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; begin if Lock.Process = Nul_Process_Id then if Lock.Count /= 0 then @@ -398,13 +395,13 @@ package body Grt.Processes is procedure Ghdl_Protected_Leave (Obj : System.Address) is - Lock : Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; + Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; begin if Lock.Process /= Get_Current_Process_Id then Internal_Error ("protected_leave(1)"); end if; - if Lock.Count <= 0 then + if Lock.Count = 0 then Internal_Error ("protected_leave(2)"); end if; Lock.Count := Lock.Count - 1; @@ -415,7 +412,7 @@ package body Grt.Processes is procedure Ghdl_Protected_Init (Obj : System.Address) is - Lock : Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); + Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); begin Lock.all := new Object_Lock'(Process => Nul_Process_Id, Count => 0); @@ -426,7 +423,7 @@ package body Grt.Processes is procedure Deallocate is new Ada.Unchecked_Deallocation (Object => Object_Lock, Name => Object_Lock_Acc); - Lock : Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); + Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); begin if Lock.all.Count /= 0 or Lock.all.Process /= Nul_Process_Id then Internal_Error ("protected_fini"); @@ -455,7 +452,8 @@ package body Grt.Processes is Non_Sensitized_Process_Table.Last loop declare - Pid : Process_Id := Non_Sensitized_Process_Table.Table (I); + Pid : constant Process_Id := + Non_Sensitized_Process_Table.Table (I); Proc : Process_Type renames Process_Table.Table (Pid); begin if Proc.State = State_Wait @@ -488,7 +486,7 @@ package body Grt.Processes is -- pragma Convention (C, Run_Handler); function Run_Through_Longjump (Hand : Run_Handler) return Integer; - pragma Import (C, Run_Through_Longjump, "__ghdl_run_through_longjump"); + pragma Import (Ada, Run_Through_Longjump, "__ghdl_run_through_longjump"); -- Run resumed processes. -- If POSTPONED is true, resume postponed processes, else resume @@ -703,7 +701,8 @@ package body Grt.Processes is Non_Sensitized_Process_Table.Last loop declare - Pid : Process_Id := Non_Sensitized_Process_Table.Table (I); + Pid : constant Process_Id := + Non_Sensitized_Process_Table.Table (I); Proc : Process_Type renames Process_Table.Table (Pid); El : Sensitivity_Acc; begin diff --git a/translate/grt/grt-processes.ads b/translate/grt/grt-processes.ads index 2ef0653c5..a3a2cf0d3 100644 --- a/translate/grt/grt-processes.ads +++ b/translate/grt/grt-processes.ads @@ -205,7 +205,7 @@ private "__ghdl_process_wait_add_sensitivity"); pragma Export (C, Ghdl_Process_Wait_Set_Timeout, "__ghdl_process_wait_set_timeout"); - pragma Export (C, Ghdl_Process_Wait_Suspend, + pragma Export (Ada, Ghdl_Process_Wait_Suspend, "__ghdl_process_wait_suspend"); pragma Export (C, Ghdl_Process_Wait_Close, "__ghdl_process_wait_close"); diff --git a/translate/grt/grt-rtis_addr.adb b/translate/grt/grt-rtis_addr.adb index 84d7c3a5c..4488654d5 100644 --- a/translate/grt/grt-rtis_addr.adb +++ b/translate/grt/grt-rtis_addr.adb @@ -15,7 +15,6 @@ -- 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 Ada.Unchecked_Conversion; with Grt.Errors; use Grt.Errors; package body Grt.Rtis_Addr is diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb index 4fd558e3d..18a5dfe05 100644 --- a/translate/grt/grt-rtis_utils.adb +++ b/translate/grt/grt-rtis_utils.adb @@ -15,9 +15,6 @@ -- 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 System; use System; -with Grt.Rtis; use Grt.Rtis; -with Grt.Types; use Grt.Types; --with Grt.Disp; use Grt.Disp; with Grt.Errors; use Grt.Errors; @@ -318,7 +315,7 @@ package body Grt.Rtis_Utils is procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc; Vals : Ghdl_Uc_Array_Acc) is - Nbr_Dim : Ghdl_Index_Type := Rti.Nbr_Dim; + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); begin Bound_To_Range (Vals.Bounds, Rti, Rngs); @@ -367,9 +364,9 @@ package body Grt.Rtis_Utils is To_Ghdl_Uc_Array_Acc (Addr)); when Ghdl_Rtik_Subtype_Array => declare - St : Ghdl_Rtin_Subtype_Array_Acc := + St : constant Ghdl_Rtin_Subtype_Array_Acc := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); begin Bound_To_Range @@ -385,9 +382,9 @@ package body Grt.Rtis_Utils is end; when Ghdl_Rtik_Subtype_Array_Ptr => declare - St : Ghdl_Rtin_Subtype_Array_Acc := + St : constant Ghdl_Rtin_Subtype_Array_Acc := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); begin Bound_To_Range @@ -521,7 +518,7 @@ package body Grt.Rtis_Utils is Addr : Address; Type_Rti : Ghdl_Rti_Access) is - Value : Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr); + Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr); begin case Type_Rti.Kind is when Ghdl_Rtik_Type_I32 => diff --git a/translate/grt/grt-sdf.adb b/translate/grt/grt-sdf.adb index b56401739..fbf9f3e8c 100644 --- a/translate/grt/grt-sdf.adb +++ b/translate/grt/grt-sdf.adb @@ -16,7 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System.Storage_Elements; -- Work around GNAT bug. -with Grt.Types; use Grt.Types; +pragma Unreferenced (System.Storage_Elements); with Grt.Stdio; use Grt.Stdio; with Grt.C; use Grt.C; with Grt.Errors; use Grt.Errors; diff --git a/translate/grt/grt-signals.adb b/translate/grt/grt-signals.adb index 77a453ba3..505b28198 100644 --- a/translate/grt/grt-signals.adb +++ b/translate/grt/grt-signals.adb @@ -17,8 +17,8 @@ -- 02111-1307, USA. with System; use System; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Ada.Unchecked_Deallocation; -with Ada.Unchecked_Conversion; with Grt.Errors; use Grt.Errors; with Grt.Processes; use Grt.Processes; with Grt.Options; use Grt.Options; @@ -1750,7 +1750,8 @@ package body Grt.Signals is procedure Compute_Resolved_Signal (Resolv : Resolved_Signal_Acc) is - Sig : Ghdl_Signal_Ptr := Sig_Table.Table (Resolv.Sig_Range.First); + Sig : constant Ghdl_Signal_Ptr := + Sig_Table.Table (Resolv.Sig_Range.First); Length : Ghdl_Index_Type; type Bool_Array_Type is array (1 .. Sig.S.Nbr_Drivers) of Boolean; Vec : Bool_Array_Type; @@ -2135,7 +2136,7 @@ package body Grt.Signals is declare S : Ghdl_Signal_Ptr; - Old : Signal_Net_Type := Sig.Net; + Old : constant Signal_Net_Type := Sig.Net; begin -- Merge the old net into NET. S := Sig; diff --git a/translate/grt/grt-signals.ads b/translate/grt/grt-signals.ads index aca2744a3..d16e88716 100644 --- a/translate/grt/grt-signals.ads +++ b/translate/grt/grt-signals.ads @@ -17,9 +17,10 @@ -- 02111-1307, USA. with System; with Ada.Unchecked_Conversion; -with GNAT.Table; +with Grt.Table; with Grt.Types; use Grt.Types; with Grt.Rtis; use Grt.Rtis; +pragma Elaborate_All (Grt.Table); package Grt.Signals is pragma Suppress (All_Checks); @@ -264,12 +265,11 @@ package Grt.Signals is end record; -- Each simple signal declared can be accessed by SIG_TABLE. - package Sig_Table is new GNAT.Table + package Sig_Table is new Grt.Table (Table_Component_Type => Ghdl_Signal_Ptr, Table_Index_Type => Sig_Table_Index, Table_Low_Bound => 0, - Table_Initial => 128, - Table_Increment => 100); + Table_Initial => 128); -- Return the next time at which a driver becomes active. function Find_Next_Time return Std_Time; @@ -380,12 +380,11 @@ package Grt.Signals is end case; end record; - package Propagation is new GNAT.Table + package Propagation is new Grt.Table (Table_Component_Type => Propagation_Type, Table_Index_Type => Signal_Net_Type, Table_Low_Bound => 1, - Table_Initial => 128, - Table_Increment => 100); + Table_Initial => 128); -- Get the signal index of PTR. function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index; @@ -660,22 +659,22 @@ private pragma Export (C, Ghdl_Signal_Disconnect, "__ghdl_signal_disconnect"); - pragma Export (C, Ghdl_Signal_Driving, + pragma Export (Ada, Ghdl_Signal_Driving, "__ghdl_signal_driving"); - pragma Export (C, Ghdl_Create_Signal_B2, + pragma Export (Ada, Ghdl_Create_Signal_B2, "__ghdl_create_signal_b2"); - pragma Export (C, Ghdl_Signal_Init_B2, + pragma Export (Ada, Ghdl_Signal_Init_B2, "__ghdl_signal_init_b2"); - pragma Export (C, Ghdl_Signal_Associate_B2, + pragma Export (Ada, Ghdl_Signal_Associate_B2, "__ghdl_signal_associate_b2"); - pragma Export (C, Ghdl_Signal_Simple_Assign_B2, + pragma Export (Ada, Ghdl_Signal_Simple_Assign_B2, "__ghdl_signal_simple_assign_b2"); - pragma Export (C, Ghdl_Signal_Start_Assign_B2, + pragma Export (Ada, Ghdl_Signal_Start_Assign_B2, "__ghdl_signal_start_assign_b2"); - pragma Export (C, Ghdl_Signal_Next_Assign_B2, + pragma Export (Ada, Ghdl_Signal_Next_Assign_B2, "__ghdl_signal_next_assign_b2"); - pragma Export (C, Ghdl_Signal_Driving_Value_B2, + pragma Export (Ada, Ghdl_Signal_Driving_Value_B2, "__ghdl_signal_driving_value_b2"); pragma Export (C, Ghdl_Create_Signal_E8, @@ -781,7 +780,7 @@ private pragma Export (C, Ghdl_Create_Delayed_Signal, "__ghdl_create_delayed_signal"); - pragma Export (C, Ghdl_Signal_Create_Guard, + pragma Export (Ada, Ghdl_Signal_Create_Guard, "__ghdl_signal_create_guard"); pragma Export (C, Ghdl_Signal_Guard_Dependence, "__ghdl_signal_guard_dependence"); diff --git a/translate/grt/grt-stats.adb b/translate/grt/grt-stats.adb index 973d61766..13a939aac 100644 --- a/translate/grt/grt-stats.adb +++ b/translate/grt/grt-stats.adb @@ -17,6 +17,7 @@ -- 02111-1307, USA. with System; use System; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Stdio; use Grt.Stdio; with Grt.Astdio; use Grt.Astdio; with Grt.Signals; diff --git a/translate/grt/grt-table.adb b/translate/grt/grt-table.adb new file mode 100644 index 000000000..f570b40ca --- /dev/null +++ b/translate/grt/grt-table.adb @@ -0,0 +1,113 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 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 System; use System; +with Grt.C; use Grt.C; + +package body Grt.Table is + + -- Maximum index of table before resizing. + Max : Table_Index_Type := Table_Low_Bound - 1; + + -- Current value of Last + Last_Val : Table_Index_Type; + + function Malloc (Size : size_t) return Table_Ptr; + pragma Import (C, Malloc); + + procedure Free (T : Table_Ptr); + pragma Import (C, Free); + + -- Resize and reallocate the table according to LAST_VAL. + procedure Resize is + function Realloc (T : Table_Ptr; Size : size_t) return Table_Ptr; + pragma Import (C, Realloc); + + New_Size : size_t; + begin + while Max < Last_Val loop + Max := Max + (Max - Table_Low_Bound + 1); + end loop; + + New_Size := size_t ((Max - Table_Low_Bound + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + Table := Realloc (Table, New_Size); + + if Table = null then + raise Storage_Error; + end if; + end Resize; + + procedure Append (New_Val : Table_Component_Type) is + begin + Increment_Last; + Table (Last_Val) := New_Val; + end Append; + + procedure Decrement_Last is + begin + Last_Val := Last_Val - 1; + end Decrement_Last; + + procedure Free is + begin + Free (Table); + Table := null; + end Free; + + procedure Increment_Last is + begin + Last_Val := Last_Val + 1; + + if Last_Val > Max then + Resize; + end if; + end Increment_Last; + + function Last return Table_Index_Type is + begin + return Last_Val; + end Last; + + procedure Release is + begin + Max := Last_Val; + Resize; + end Release; + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if New_Val < Last_Val then + Last_Val := New_Val; + else + Last_Val := New_Val; + + if Last_Val > Max then + Resize; + end if; + end if; + end Set_Last; + +begin + Last_Val := Table_Low_Bound - 1; + Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1; + + Table := Malloc (size_t (Table_Initial * + (Table_Type'Component_Size / Storage_Unit))); +end Grt.Table; diff --git a/translate/grt/grt-table.ads b/translate/grt/grt-table.ads new file mode 100644 index 000000000..528d73b4a --- /dev/null +++ b/translate/grt/grt-table.ads @@ -0,0 +1,68 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 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. + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + +package Grt.Table is + pragma Elaborate_Body; + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + subtype Fat_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + + -- Thin pointer. + type Table_Ptr is access all Fat_Table_Type; + + -- The table itself. + Table : aliased Table_Ptr := null; + + -- Get the high bound. + function Last return Table_Index_Type; + pragma Inline (Last); + + -- Get the low bound. + First : constant Table_Index_Type := Table_Low_Bound; + + -- Increase the length by 1. + procedure Increment_Last; + pragma Inline (Increment_Last); + + -- Decrease the length by 1. + procedure Decrement_Last; + pragma Inline (Decrement_Last); + + -- Set the last bound. + procedure Set_Last (New_Val : Table_Index_Type); + + -- Release extra memory. + procedure Release; + + -- Free all the memory used by the table. + -- The table won't be useable anymore. + procedure Free; + + -- Append a new element. + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); +end Grt.Table; diff --git a/translate/grt/grt-unithread.adb b/translate/grt/grt-unithread.adb index 668e9b71f..3197e2cce 100644 --- a/translate/grt/grt-unithread.adb +++ b/translate/grt/grt-unithread.adb @@ -15,7 +15,6 @@ -- 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 Grt.Types; use Grt.Types; package body Grt.Unithread is procedure Init is diff --git a/translate/grt/grt-unithread.ads b/translate/grt/grt-unithread.ads index 2f244e643..0f8f48a23 100644 --- a/translate/grt/grt-unithread.ads +++ b/translate/grt/grt-unithread.ads @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Signals; use Grt.Signals; with Grt.Stack2; use Grt.Stack2; with Grt.Stacks; use Grt.Stacks; diff --git a/translate/grt/grt-vcd.adb b/translate/grt/grt-vcd.adb index f7aa0d8d0..bf1842da2 100644 --- a/translate/grt/grt-vcd.adb +++ b/translate/grt/grt-vcd.adb @@ -17,53 +17,48 @@ -- 02111-1307, USA. with Interfaces; with Grt.Stdio; use Grt.Stdio; -with System; use System; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Errors; use Grt.Errors; -with Grt.Types; use Grt.Types; with Grt.Signals; use Grt.Signals; -with GNAT.Table; +with Grt.Table; with Grt.Astdio; use Grt.Astdio; with Grt.C; use Grt.C; with Grt.Hooks; use Grt.Hooks; -with Grt.Avhpi; use Grt.Avhpi; with Grt.Rtis; use Grt.Rtis; with Grt.Rtis_Addr; use Grt.Rtis_Addr; with Grt.Rtis_Types; use Grt.Rtis_Types; with Grt.Vstrings; +pragma Elaborate_All (Grt.Table); package body Grt.Vcd is -- If TRUE, put $date in vcd file. -- Can be set to FALSE to make vcd comparaison easier. Flag_Vcd_Date : Boolean := True; - type Vcd_IO_Simple is new Vcd_IO_Handler with record - Stream : FILEs; - end record; - type IO_Simple_Acc is access Vcd_IO_Simple; - procedure Vcd_Put (Handler : access Vcd_IO_Simple; Str : String); - procedure Vcd_Putc (Handler : access Vcd_IO_Simple; C : Character); - procedure Vcd_Close (Handler : access Vcd_IO_Simple); + Stream : FILEs; - procedure Vcd_Put (Handler : access Vcd_IO_Simple; Str : String) + procedure My_Vcd_Put (Str : String) is R : size_t; + pragma Unreferenced (R); begin - R := fwrite (Str'Address, Str'Length, 1, Handler.Stream); - end Vcd_Put; + R := fwrite (Str'Address, Str'Length, 1, Stream); + end My_Vcd_Put; - procedure Vcd_Putc (Handler : access Vcd_IO_Simple; C : Character) + procedure My_Vcd_Putc (C : Character) is R : int; + pragma Unreferenced (R); begin - R := fputc (Character'Pos (C), Handler.Stream); - end Vcd_Putc; + R := fputc (Character'Pos (C), Stream); + end My_Vcd_Putc; - procedure Vcd_Close (Handler : access Vcd_IO_Simple) is + procedure My_Vcd_Close is begin - fclose (Handler.Stream); - Handler.Stream := NULL_Stream; - end Vcd_Close; + fclose (Stream); + Stream := NULL_Stream; + end My_Vcd_Close; -- VCD filename. -- Stream corresponding to the VCD filename. @@ -75,9 +70,8 @@ package body Grt.Vcd is -- Return TRUE if OPT is an option for VCD. function Vcd_Option (Opt : String) return Boolean is - F : Natural := Opt'First; + F : constant Natural := Opt'First; Mode : constant String := "wt" & NUL; - Handler : IO_Simple_Acc; Vcd_Filename : String_Access; begin if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vcd" then @@ -88,7 +82,7 @@ package body Grt.Vcd is return True; end if; if Opt'Length > 6 and then Opt (F + 5) = '=' then - if H /= null then + if Vcd_Close /= null then Error ("--vcd: file already set"); return True; end if; @@ -98,19 +92,20 @@ package body Grt.Vcd is Vcd_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); Vcd_Filename (Vcd_Filename'Last) := NUL; - Handler := new Vcd_IO_Simple; if Vcd_Filename.all = "-" & NUL then - Handler.Stream := stdout; + Stream := stdout; else - Handler.Stream := fopen (Vcd_Filename.all'Address, Mode'Address); - if Handler.Stream = NULL_Stream then + Stream := fopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_Stream then Error_C ("cannot open "); Error_E (Vcd_Filename (Vcd_Filename'First .. Vcd_Filename'Last - 1)); return True; end if; end if; - H := Handler_Acc (Handler); + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; return True; else return False; @@ -123,24 +118,14 @@ package body Grt.Vcd is Put_Line (" --vcd-nodate do not write date in VCD file"); end Vcd_Help; - procedure Vcd_Put (Str : String) is - begin - Vcd_Put (H, Str); - end Vcd_Put; - - procedure Vcd_Putc (C : Character) is - begin - Vcd_Putc (H, C); - end Vcd_Putc; - procedure Vcd_Newline is begin - Vcd_Putc (H, Nl); + Vcd_Putc (Nl); end Vcd_Newline; procedure Vcd_Putline (Str : String) is begin - Vcd_Put (H, Str); + Vcd_Put (Str); Vcd_Newline; end Vcd_Putline; @@ -200,7 +185,7 @@ package body Grt.Vcd is procedure Vcd_Init is begin - if H = null then + if Vcd_Close = null then return; end if; if Flag_Vcd_Date then @@ -236,12 +221,11 @@ package body Grt.Vcd is Vcd_Put_End; end Vcd_Init; - package Vcd_Table is new GNAT.Table + package Vcd_Table is new Grt.Table (Table_Component_Type => Verilog_Wire_Info, Table_Index_Type => Vcd_Index_Type, Table_Low_Bound => 0, - Table_Initial => 32, - Table_Increment => 100); + Table_Initial => 32); procedure Avhpi_Error (Err : AvhpiErrorT) is @@ -306,13 +290,10 @@ package body Grt.Vcd is procedure Get_Verilog_Wire (Sig : VhpiHandleT; Info : out Verilog_Wire_Info) is Sig_Type : VhpiHandleT; - Sig_Rti : Ghdl_Rtin_Object_Acc; Rti : Ghdl_Rti_Access; Error : AvhpiErrorT; Sig_Addr : Address; begin - Sig_Rti := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Sig)); - -- Extract type of the signal. Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Error); if Error /= AvhpiErrorOk then @@ -711,7 +692,7 @@ package body Grt.Vcd is Root : VhpiHandleT; begin -- Do nothing if there is no VCD file to generate. - if H = null then + if Vcd_Close = null then return; end if; @@ -752,8 +733,8 @@ package body Grt.Vcd is -- Called at the end of the simulation. procedure Vcd_End is begin - if H /= null then - Vcd_Close (H); + if Vcd_Close /= null then + Vcd_Close.all; end if; end Vcd_End; diff --git a/translate/grt/grt-vcd.ads b/translate/grt/grt-vcd.ads index a6d79b402..1079e90a4 100644 --- a/translate/grt/grt-vcd.ads +++ b/translate/grt/grt-vcd.ads @@ -21,16 +21,13 @@ with Grt.Avhpi; use Grt.Avhpi; package Grt.Vcd is -- Abstract type for IO. - type Vcd_IO_Handler is abstract tagged null record; - procedure Vcd_Put (Handler : access Vcd_IO_Handler; Str : String) - is abstract; - procedure Vcd_Putc (Handler : access Vcd_IO_Handler; C : Character) - is abstract; - procedure Vcd_Close (Handler : access Vcd_IO_Handler) - is abstract; - - type Handler_Acc is access all Vcd_IO_Handler'Class; - H : Handler_Acc := null; + type Vcd_Put_Acc is access procedure (Str : String); + type Vcd_Putc_Acc is access procedure (C : Character); + type Vcd_Close_Acc is access procedure; + + Vcd_Put : Vcd_Put_Acc; + Vcd_Putc : Vcd_Putc_Acc; + Vcd_Close : Vcd_Close_Acc; type Vcd_Var_Kind is (Vcd_Bad, Vcd_Bool, diff --git a/translate/grt/grt-vcdz.adb b/translate/grt/grt-vcdz.adb index a6ba718e3..aec35a8d7 100644 --- a/translate/grt/grt-vcdz.adb +++ b/translate/grt/grt-vcdz.adb @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Vcd; use Grt.Vcd; with Grt.Errors; use Grt.Errors; with Grt.Types; use Grt.Types; @@ -25,49 +26,44 @@ with Grt.Zlib; use Grt.Zlib; with Grt.C; use Grt.C; package body Grt.Vcdz is - type Vcd_IO_Gzip is new Vcd_IO_Handler with record - Stream : gzFile; - end record; - type IO_Gzip_Acc is access Vcd_IO_Gzip; - procedure Vcd_Put (Handler : access Vcd_IO_Gzip; Str : String); - procedure Vcd_Putc (Handler : access Vcd_IO_Gzip; C : Character); - procedure Vcd_Close (Handler : access Vcd_IO_Gzip); + Stream : gzFile; - procedure Vcd_Put (Handler : access Vcd_IO_Gzip; Str : String) + procedure My_Vcd_Put (Str : String) is R : int; + pragma Unreferenced (R); begin - R := gzwrite (Handler.Stream, Str'Address, Str'Length); - end Vcd_Put; + R := gzwrite (Stream, Str'Address, Str'Length); + end My_Vcd_Put; - procedure Vcd_Putc (Handler : access Vcd_IO_Gzip; C : Character) + procedure My_Vcd_Putc (C : Character) is R : int; + pragma Unreferenced (R); begin - R := gzputc (Handler.Stream, Character'Pos (C)); - end Vcd_Putc; + R := gzputc (Stream, Character'Pos (C)); + end My_Vcd_Putc; - procedure Vcd_Close (Handler : access Vcd_IO_Gzip) is + procedure My_Vcd_Close is begin - gzclose (Handler.Stream); - Handler.Stream := NULL_gzFile; - end Vcd_Close; + gzclose (Stream); + Stream := NULL_gzFile; + end My_Vcd_Close; -- VCD filename. -- Return TRUE if OPT is an option for VCD. function Vcdz_Option (Opt : String) return Boolean is - F : Natural := Opt'First; + F : constant Natural := Opt'First; Vcd_Filename : String_Access := null; - Handler : IO_Gzip_Acc; Mode : constant String := "wb" & NUL; begin if Opt'Length < 7 or else Opt (F .. F + 6) /= "--vcdgz" then return False; end if; if Opt'Length > 7 and then Opt (F + 7) = '=' then - if H /= null then + if Vcd_Close /= null then Error ("--vcdgz: file already set"); return True; end if; @@ -77,15 +73,16 @@ package body Grt.Vcdz is Vcd_Filename (1 .. Opt'Length - 8) := Opt (F + 8 .. Opt'Last); Vcd_Filename (Vcd_Filename'Last) := NUL; - Handler := new Vcd_IO_Gzip; - Handler.Stream := gzopen (Vcd_Filename.all'Address, Mode'Address); - if Handler.Stream = NULL_gzFile then + Stream := gzopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_gzFile then Error_C ("cannot open "); Error_E (Vcd_Filename (Vcd_Filename'First .. Vcd_Filename'Last - 1)); return True; end if; - H := Handler_Acc (Handler); + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; return True; else return False; diff --git a/translate/grt/grt-vital_annotate.adb b/translate/grt/grt-vital_annotate.adb index 5c8c1d0e8..2e7987ca5 100644 --- a/translate/grt/grt-vital_annotate.adb +++ b/translate/grt/grt-vital_annotate.adb @@ -15,7 +15,6 @@ -- 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 Grt.Sdf; with Grt.Types; use Grt.Types; with Grt.Hooks; use Grt.Hooks; with Grt.Astdio; use Grt.Astdio; @@ -32,7 +31,7 @@ package body Grt.Vital_Annotate is Sdf_Inst : VhpiHandleT; Flag_Dump : Boolean := False; - Flag_Verbose : Boolean := False; + Flag_Verbose : constant Boolean := False; function Name_Compare (Handle : VhpiHandleT; Name : String; @@ -140,7 +139,7 @@ package body Grt.Vital_Annotate is end Find_Generic; - procedure Sdf_Header (Context : in out Sdf_Context_Type) + procedure Sdf_Header (Context : Sdf_Context_Type) is begin if Flag_Dump then @@ -156,7 +155,7 @@ package body Grt.Vital_Annotate is end if; end Sdf_Header; - procedure Sdf_Celltype (Context : in out Sdf_Context_Type) + procedure Sdf_Celltype (Context : Sdf_Context_Type) is begin if Flag_Dump then @@ -185,7 +184,7 @@ package body Grt.Vital_Annotate is Find_Instance (Sdf_Inst, Sdf_Inst, Instance, Status); end Sdf_Instance; - procedure Sdf_Instance_End (Context : in out Sdf_Context_Type; + procedure Sdf_Instance_End (Context : Sdf_Context_Type; Status : out Boolean) is begin @@ -319,6 +318,9 @@ package body Grt.Vital_Annotate is Right : VhpiIntT; begin Vhpi_Handle (VhpiSubtype, Port, Port_Type, Error); + Left := 0; + Len := 0; + Up := True; if Error /= AvhpiErrorOk then Internal_Error ("vhpiSubtype - port"); return; @@ -434,10 +436,10 @@ package body Grt.Vital_Annotate is then Generic_Get_Bounds (Port2, Left2, Len2, Up2); Pos := Pos * Len2; - if Up1 then + if Up2 then Pos := Pos + Ghdl_Index_Type (Context.Ports (2).L - Left2); else - Pos := Pos + Ghdl_Index_Type (Left1 - Context.Ports (2).L); + Pos := Pos + Ghdl_Index_Type (Left2 - Context.Ports (2).L); end if; end if; Vhpi_Handle_By_Index @@ -608,8 +610,9 @@ package body Grt.Vital_Annotate is end loop; end Sdf_Start; - function Sdf_Option (Opt : String) return Boolean + function Sdf_Option (Option : String) return Boolean is + Opt : constant String (1 .. Option'Length) := Option; begin if Opt'Length > 11 and then Opt (1 .. 11) = "--sdf-dump=" then Flag_Dump := True; diff --git a/translate/grt/grt-vital_annotate.ads b/translate/grt/grt-vital_annotate.ads index f1a8b0255..6c1d3a6b5 100644 --- a/translate/grt/grt-vital_annotate.ads +++ b/translate/grt/grt-vital_annotate.ads @@ -20,12 +20,12 @@ with Grt.Sdf; use Grt.Sdf; package Grt.Vital_Annotate is pragma Elaborate_Body (Grt.Vital_Annotate); - procedure Sdf_Header (Context : in out Sdf_Context_Type); - procedure Sdf_Celltype (Context : in out Sdf_Context_Type); + procedure Sdf_Header (Context : Sdf_Context_Type); + procedure Sdf_Celltype (Context : Sdf_Context_Type); procedure Sdf_Instance (Context : in out Sdf_Context_Type; Instance : String; Status : out Boolean); - procedure Sdf_Instance_End (Context : in out Sdf_Context_Type; + procedure Sdf_Instance_End (Context : Sdf_Context_Type; Status : out Boolean); procedure Sdf_Generic (Context : in out Sdf_Context_Type; Name : String; diff --git a/translate/grt/grt-vpi.adb b/translate/grt/grt-vpi.adb index 2af34a237..ff311be7b 100644 --- a/translate/grt/grt-vpi.adb +++ b/translate/grt/grt-vpi.adb @@ -40,15 +40,17 @@ with Ada.Unchecked_Deallocation; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Stdio; use Grt.Stdio; with Grt.C; use Grt.C; with Grt.Signals; use Grt.Signals; -with GNAT.Table; +with Grt.Table; with Grt.Astdio; use Grt.Astdio; with Grt.Hooks; use Grt.Hooks; with Grt.Vcd; use Grt.Vcd; with Grt.Errors; use Grt.Errors; with Grt.Rtis_Types; +pragma Elaborate_All (Grt.Table); package body Grt.Vpi is -- The VPI interface requires libdl (dlopen, dlsym) to be linked in. @@ -69,6 +71,7 @@ package body Grt.Vpi is procedure dbgPut (Str : String) is S : size_t; + pragma Unreferenced (S); begin S := fwrite (Str'Address, Str'Length, 1, stderr); end dbgPut; @@ -76,6 +79,7 @@ package body Grt.Vpi is procedure dbgPut (C : Character) is R : int; + pragma Unreferenced (R); begin R := fputc (Character'Pos (C), stderr); end dbgPut; @@ -722,12 +726,11 @@ package body Grt.Vpi is Cb : s_cb_data; end record; - package Vpi_Table is new GNAT.Table + package Vpi_Table is new Grt.Table (Table_Component_Type => Vpi_Var_Type, Table_Index_Type => Vpi_Index_Type, Table_Low_Bound => 0, - Table_Initial => 32, - Table_Increment => 100); + Table_Initial => 32); function vpi_register_cb (Data : p_cb_data) return vpiHandle is @@ -865,7 +868,7 @@ package body Grt.Vpi is -- Return TRUE if OPT is an option for VPI. function Vpi_Option (Opt : String) return Boolean is - F : Natural := Opt'First; + F : constant Natural := Opt'First; begin if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then return False; @@ -918,6 +921,7 @@ package body Grt.Vpi is procedure Vpi_Start is Res : Integer; + pragma Unreferenced (Res); begin if Vpi_Filename = null then return; @@ -935,6 +939,7 @@ package body Grt.Vpi is procedure Vpi_Cycle is Res : Integer; + pragma Unreferenced (Res); begin if g_cbReadOnlySync /= null and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000) @@ -959,6 +964,7 @@ package body Grt.Vpi is procedure Vpi_End is Res : Integer; + pragma Unreferenced (Res); begin if g_cbEndOfSimulation /= null then Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation); diff --git a/translate/grt/grt-vstrings.adb b/translate/grt/grt-vstrings.adb index d17cc87ea..bb62d28ca 100644 --- a/translate/grt/grt-vstrings.adb +++ b/translate/grt/grt-vstrings.adb @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Errors; use Grt.Errors; with Grt.C; use Grt.C; @@ -41,7 +42,7 @@ package body Grt.Vstrings is procedure Grow (Vstr : in out Vstring; Sum : Natural) is - Nlen : Natural := Vstr.Len + Sum; + Nlen : constant Natural := Vstr.Len + Sum; Nmax : Natural; begin Vstr.Len := Nlen; @@ -72,7 +73,7 @@ package body Grt.Vstrings is procedure Append (Vstr : in out Vstring; Str : String) is - S : Natural := Vstr.Len; + S : constant Natural := Vstr.Len; begin Grow (Vstr, Str'Length); Vstr.Str (S + 1 .. S + Str'Length) := Str; @@ -80,8 +81,8 @@ package body Grt.Vstrings is procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String) is - S : Natural := Vstr.Len; - L : Natural := strlen (Str); + S : constant Natural := Vstr.Len; + L : constant Natural := strlen (Str); begin Grow (Vstr, L); Vstr.Str (S + 1 .. S + L) := Str (1 .. L); @@ -125,8 +126,8 @@ package body Grt.Vstrings is procedure Grow (Rstr : in out Rstring; Min : Natural) is - Len : Natural := Length (Rstr); - Nlen : Natural := Len + Min; + Len : constant Natural := Length (Rstr); + Nlen : constant Natural := Len + Min; Nstr : Fat_String_Acc; Nfirst : Natural; Nmax : Natural; @@ -171,7 +172,7 @@ package body Grt.Vstrings is procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String) is - L : Natural := strlen (Str); + L : constant Natural := strlen (Str); begin Grow (Rstr, L); Rstr.First := Rstr.First - L; @@ -199,6 +200,7 @@ package body Grt.Vstrings is procedure Put (Stream : FILEs; Rstr : Rstring) is S : size_t; + pragma Unreferenced (S); begin S := fwrite (Get_Address (Rstr), size_t (Length (Rstr)), 1, Stream); end Put; diff --git a/translate/grt/grt-waves.adb b/translate/grt/grt-waves.adb index c2c01387a..fc109500e 100644 --- a/translate/grt/grt-waves.adb +++ b/translate/grt/grt-waves.adb @@ -19,16 +19,15 @@ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces; use Interfaces; with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); with Grt.Types; use Grt.Types; with Grt.Avhpi; use Grt.Avhpi; with Grt.Stdio; use Grt.Stdio; with Grt.C; use Grt.C; with Grt.Errors; use Grt.Errors; -with Grt.Types; use Grt.Types; with Grt.Astdio; use Grt.Astdio; with Grt.Hooks; use Grt.Hooks; -with Grt.Avhpi; use Grt.Avhpi; -with GNAT.Table; +with Grt.Table; with Grt.Avls; use Grt.Avls; with Grt.Rtis; use Grt.Rtis; with Grt.Rtis_Addr; use Grt.Rtis_Addr; @@ -39,6 +38,7 @@ with System; use System; with Grt.Vstrings; use Grt.Vstrings; pragma Elaborate_All (Grt.Rtis_Utils); +pragma Elaborate_All (Grt.Table); package body Grt.Waves is -- Waves filename. @@ -62,10 +62,13 @@ package body Grt.Waves is Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port + pragma Unreferenced (Ghw_Hie_Design); + pragma Unreferenced (Ghw_Hie_Generic); + -- Return TRUE if OPT is an option for wave. function Wave_Option (Opt : String) return Boolean is - F : Natural := Opt'First; + F : constant Natural := Opt'First; begin if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then return False; @@ -89,6 +92,7 @@ package body Grt.Waves is procedure Wave_Put (Str : String) is R : size_t; + pragma Unreferenced (R); begin R := fwrite (Str'Address, Str'Length, 1, Wave_Stream); end Wave_Put; @@ -96,6 +100,7 @@ package body Grt.Waves is procedure Wave_Putc (C : Character) is R : int; + pragma Unreferenced (R); begin R := fputc (Character'Pos (C), Wave_Stream); end Wave_Putc; @@ -109,6 +114,7 @@ package body Grt.Waves is is V : Unsigned_8 := B; R : size_t; + pragma Unreferenced (R); begin R := fwrite (V'Address, 1, 1, Wave_Stream); end Wave_Put_Byte; @@ -180,6 +186,7 @@ package body Grt.Waves is is V : Ghdl_I32 := Val; R : size_t; + pragma Unreferenced (R); begin R := fwrite (V'Address, 4, 1, Wave_Stream); end Wave_Put_I32; @@ -188,6 +195,7 @@ package body Grt.Waves is is V : Ghdl_I64 := Val; R : size_t; + pragma Unreferenced (R); begin R := fwrite (V'Address, 8, 1, Wave_Stream); end Wave_Put_I64; @@ -196,6 +204,7 @@ package body Grt.Waves is is V : Ghdl_F64 := F64; R : size_t; + pragma Unreferenced (R); begin R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream); end Wave_Put_F64; @@ -229,12 +238,11 @@ package body Grt.Waves is Pos : long; end record; - package Section_Table is new GNAT.Table + package Section_Table is new Grt.Table (Table_Component_Type => Header_Type, Table_Index_Type => Natural, Table_Low_Bound => 1, - Table_Initial => 16, - Table_Increment => 100); + Table_Initial => 16); -- Create a new section. -- Write the header in the file. @@ -270,13 +278,7 @@ package body Grt.Waves is Wave_Put_Byte (V); end; -- Word size, 1 byte. - if Integer'Size = 32 then - Wave_Put_Byte (4); - elsif Integer'Size = 64 then - Wave_Put_Byte (8); - else - Wave_Put_Byte (0); - end if; + Wave_Put_Byte (Integer'Size / 8); -- File offset size, 1 byte Wave_Put_Byte (1); -- Unused, must be zero (MBZ). @@ -347,19 +349,17 @@ package body Grt.Waves is null; end Avhpi_Error; - package Str_Table is new GNAT.Table + package Str_Table is new Grt.Table (Table_Component_Type => Ghdl_C_String, Table_Index_Type => AVL_Value, Table_Low_Bound => 1, - Table_Initial => 16, - Table_Increment => 100); + Table_Initial => 16); - package Str_AVL is new GNAT.Table + package Str_AVL is new Grt.Table (Table_Component_Type => AVL_Node, Table_Index_Type => AVL_Nid, Table_Low_Bound => AVL_Root, - Table_Initial => 16, - Table_Increment => 100); + Table_Initial => 16); Strings_Len : Natural := 0; @@ -394,6 +394,8 @@ package body Grt.Waves is New_Line (stdout); end Disp_Str_Avl; + pragma Unreferenced (Disp_Str_Avl); + function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value is Res : AVL_Nid; @@ -414,6 +416,8 @@ package body Grt.Waves is return Str_AVL.Table (Res).Val; end Create_Str_Index; + pragma Unreferenced (Create_Str_Index); + procedure Create_String_Id (Str : Ghdl_C_String) is Res : AVL_Nid; @@ -472,23 +476,20 @@ package body Grt.Waves is Context : Rti_Context; end record; - package Types_Table is new GNAT.Table + package Types_Table is new Grt.Table (Table_Component_Type => Type_Node, Table_Index_Type => AVL_Value, Table_Low_Bound => 1, - Table_Initial => 16, - Table_Increment => 100); + Table_Initial => 16); - package Types_AVL is new GNAT.Table + package Types_AVL is new Grt.Table (Table_Component_Type => AVL_Node, Table_Index_Type => AVL_Nid, Table_Low_Bound => AVL_Root, - Table_Initial => 16, - Table_Increment => 100); + Table_Initial => 16); function Type_Compare (L, R : AVL_Value) return Integer is - use System; function To_Ia is new Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address); @@ -1049,6 +1050,8 @@ package body Grt.Waves is fflush (Wave_Stream); end Write_Strings; + pragma Unreferenced (Write_Strings); + procedure Freeze_Strings is type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String; @@ -1380,18 +1383,19 @@ package body Grt.Waves is end Write_Known_Types; -- Table of signals to be dumped. - package Dump_Table is new GNAT.Table + package Dump_Table is new Grt.Table (Table_Component_Type => Ghdl_Signal_Ptr, Table_Index_Type => Natural, Table_Low_Bound => 1, - Table_Initial => 32, - Table_Increment => 100); + Table_Initial => 32); function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is begin return Dump_Table.Table (N); end Get_Dump_Entry; + pragma Unreferenced (Get_Dump_Entry); + procedure Write_Hierarchy (Root : VhpiHandleT) is N : Natural; diff --git a/translate/grt/grt.adc b/translate/grt/grt.adc index 54b06c05d..586a54ebc 100644 --- a/translate/grt/grt.adc +++ b/translate/grt/grt.adc @@ -28,10 +28,12 @@ -- This files is *not* names gnat.adc, in order to ease the possibility of -- not using it. pragma Restrictions (No_Exception_Handlers); -pragma restrictions (No_Exceptions); +--pragma restrictions (No_Exceptions); pragma Restrictions (No_Secondary_Stack); --pragma Restrictions (No_Elaboration_Code); pragma Restrictions (No_Io); +pragma restrictions (no_dependence => Ada.Tags); +pragma restrictions (no_dependence => GNAT); pragma Restrictions (Max_Tasks => 0); pragma Restrictions (No_Implicit_Heap_Allocations); pragma No_Run_Time; diff --git a/translate/trans_analyzes.adb b/translate/trans_analyzes.adb index a6d5619d9..43d7508a1 100644 --- a/translate/trans_analyzes.adb +++ b/translate/trans_analyzes.adb @@ -33,6 +33,7 @@ package body Trans_Analyzes is function Extract_Driver_Stmt (Stmt : Iir) return Walk_Status is Status : Walk_Status; + pragma Unreferenced (Status); We : Iir; begin case Get_Kind (Stmt) is @@ -91,6 +92,7 @@ package body Trans_Analyzes is procedure Extract_Drivers_Sequential_Stmt_Chain (Chain : Iir) is Status : Walk_Status; + pragma Unreferenced (Status); begin Status := Walk_Sequential_Stmt_Chain (Chain, Extract_Driver_Stmt'Access); end Extract_Drivers_Sequential_Stmt_Chain; diff --git a/translate/trans_be.adb b/translate/trans_be.adb index 13b82fcab..0725fb727 100644 --- a/translate/trans_be.adb +++ b/translate/trans_be.adb @@ -135,6 +135,7 @@ package body Trans_Be is is use Translation; Fi : Foreign_Info_Type; + pragma Unreferenced (Fi); begin case Get_Kind (Decl) is when Iir_Kind_Design_Unit => diff --git a/translate/translation.adb b/translate/translation.adb index 72d45774b..fb269abd5 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -70,7 +70,6 @@ package body Translation is -- Global declarations. Ghdl_Ptr_Type : O_Tnode; - Const_Ptr_Type_Node : O_Tnode; Sizetype : O_Tnode; Ghdl_I32_Type : O_Tnode; Ghdl_I64_Type : O_Tnode; @@ -3114,7 +3113,7 @@ package body Translation is procedure Copy_Fat_Pointer (D : O_Dnode; S : O_Dnode; Ftype : Iir; Is_Sig : Object_Kind_Type) is - Info : Type_Info_Acc := Get_Info (Ftype); + Info : constant Type_Info_Acc := Get_Info (Ftype); begin New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (D), Info.T.Base_Field (Is_Sig)), @@ -3830,12 +3829,9 @@ package body Translation is procedure Translate_Entity_Init (Entity : Iir) is - Info : Block_Info_Acc; El : Iir; El_Type : Iir; begin - Info := Get_Info (Entity); - Push_Local_Factory; -- Generics. @@ -4716,7 +4712,6 @@ package body Translation is is Inter : Iir; Inter_Type : Iir; - Inter_Kind : Iir_Kind; Info : Subprg_Info_Acc; Arg_Info : Ortho_Info_Acc; Tinfo : Type_Info_Acc; @@ -4791,7 +4786,6 @@ package body Translation is while Inter /= Null_Iir loop Arg_Info := Add_Info (Inter, Kind_Interface); Inter_Type := Get_Type (Inter); - Inter_Kind := Get_Kind (Inter_Type); Tinfo := Get_Info (Inter_Type); if Get_Kind (Inter) = Iir_Kind_Variable_Interface_Declaration and then Get_Mode (Inter) in Iir_Out_Modes @@ -5206,6 +5200,7 @@ package body Translation is is Info : Ortho_Info_Acc; Final : Boolean; + pragma Unreferenced (Final); begin Info := Get_Info (Spec); Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); @@ -5963,7 +5958,7 @@ package body Translation is return; end if; declare - Len : Natural := Get_File_Signature_Length (Type_Name); + Len : constant Natural := Get_File_Signature_Length (Type_Name); Sig : String (1 .. Len + 2); Off : Natural := 1; begin @@ -6822,6 +6817,7 @@ package body Translation is Mark : Id_Mark_Type; Info : Type_Info_Acc; Lock_Field : O_Fnode; + pragma Unreferenced (Lock_Field); begin Decl := Get_Protected_Type_Declaration (Bod); Info := Get_Info (Decl); @@ -7308,7 +7304,6 @@ package body Translation is Subtype_Info : Type_Info_Acc; Base_Info : Type_Info_Acc) is - Base_Type : Iir; Rng : Iir; Lo, Hi : Iir; begin @@ -7325,7 +7320,6 @@ package body Translation is Subtype_Info.T.Nocheck_Low := False; else -- Bounds are locally static. - Base_Type := Get_Base_Type (Def); Get_Low_High_Limit (Rng, Lo, Hi); Subtype_Info.T.Nocheck_Hi := Is_Equal_Limit (Hi, True, Def, Base_Info.Type_Mode); @@ -7456,7 +7450,7 @@ package body Translation is when Iir_Kind_Access_Type_Definition => declare - Dtype : Iir := Get_Designated_Type (Def); + Dtype : constant Iir := Get_Designated_Type (Def); begin -- Translate the subtype if Is_Anonymous_Type_Definition (Dtype) then @@ -7487,10 +7481,7 @@ package body Translation is procedure Translate_Bool_Type_Definition (Def : Iir) is - Decl : Iir; - Id : Name_Id; Info : Type_Info_Acc; - Base_Type : Iir; begin -- If the definition is already translated, return now. Info := Get_Info (Def); @@ -7499,10 +7490,6 @@ package body Translation is end if; Info := Add_Info (Def, Kind_Type); - Base_Type := Get_Base_Type (Def); - Decl := Get_Type_Declarator (Def); - - Id := Get_Identifier (Decl); if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then raise Internal_Error; @@ -7577,9 +7564,7 @@ package body Translation is procedure Elab_Type_Definition (Def : Iir); procedure Elab_Type_Definition_Depend is new Handle_Anonymous_Subtypes (Handle_A_Subtype => Elab_Type_Definition); - procedure Elab_Type_Definition (Def : Iir) - is - Info : Type_Info_Acc; + procedure Elab_Type_Definition (Def : Iir) is begin case Get_Kind (Def) is when Iir_Kind_Incomplete_Type_Definition => @@ -7604,8 +7589,6 @@ package body Translation is return; end if; - Info := Get_Info (Def); - Elab_Type_Definition_Depend (Def); Create_Type_Definition_Type_Range (Def); @@ -7865,13 +7848,10 @@ package body Translation is function Get_Array_Type_Length (Atype : Iir) return O_Enode is Index_List : Iir_List; - Index_Type : Iir; Nbr_Dim : Natural; Dim_Length : O_Enode; Res : O_Enode; Type_Info : Type_Info_Acc; - Binfo : Type_Info_Acc; - Index_Info : Type_Info_Acc; Bounds : Mnode; begin Index_List := Get_Index_Subtype_List (Atype); @@ -7891,10 +7871,7 @@ package body Translation is raise Internal_Error; end case; - Binfo := Get_Info (Get_Base_Type (Atype)); for Dim in 1 .. Nbr_Dim loop - Index_Type := Get_Nth_Element (Index_List, Dim - 1); - Index_Info := Get_Info (Get_Base_Type (Index_Type)); Dim_Length := M2E (Range_To_Length (Bounds_To_Range (Bounds, Atype, Dim))); if Dim = 1 then @@ -7909,13 +7886,10 @@ package body Translation is function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode is Index_List : Iir_List; - Index_Type : Iir; Nbr_Dim : Natural; Dim_Length : O_Enode; Res : O_Enode; Type_Info : Type_Info_Acc; - Binfo : Type_Info_Acc; - Index_Info : Type_Info_Acc; B : Mnode; begin Index_List := Get_Index_Subtype_List (Atype); @@ -7933,10 +7907,7 @@ package body Translation is raise Internal_Error; end case; - Binfo := Get_Info (Get_Base_Type (Atype)); for Dim in 1 .. Nbr_Dim loop - Index_Type := Get_Nth_Element (Index_List, Dim - 1); - Index_Info := Get_Info (Get_Base_Type (Index_Type)); B := Get_Array_Bounds (Arr); Dim_Length := M2E (Range_To_Length (Bounds_To_Range (B, Atype, Dim))); @@ -7958,11 +7929,9 @@ package body Translation is when Type_Mode_Fat_Array | Type_Mode_Fat_Acc => declare - F : O_Fnode; Kind : Object_Kind_Type; begin Kind := Get_Object_Kind (Arr); - F := Info.T.Base_Field (Get_Object_Kind (Arr)); return Lp2M (New_Selected_Element (M2Lv (Arr), Info.T.Base_Field (Kind)), @@ -9364,7 +9333,7 @@ package body Translation is if Get_Info (Obj).Object_Static then return; end if; - if Get_Deferred_Declaration_Flag (Obj) = True then + if Get_Deferred_Declaration_Flag (Obj) then -- No code generation for a deferred constant. return; end if; @@ -9801,7 +9770,6 @@ package body Translation is (Decl : Iir; Parent : Iir; Check_Null : Boolean) is Sig_Type : Iir; - Type_Info : Type_Info_Acc; Name_Node : Mnode; Val : Iir; Data : Elab_Signal_Data; @@ -9812,7 +9780,6 @@ package body Translation is Open_Temp; Sig_Type := Get_Type (Decl); - Type_Info := Get_Info (Sig_Type); Base_Decl := Get_Base_Name (Decl); -- Set the name of the signal. @@ -10231,7 +10198,6 @@ package body Translation is Name : Iir; Name_Node : Mnode; Alias_Node : Mnode; - N_Info : Type_Info_Acc; Alias_Info : Alias_Info_Acc; Name_Type : Iir; Tinfo : Type_Info_Acc; @@ -10248,7 +10214,6 @@ package body Translation is Name_Type := Get_Type (Name); Name_Node := Chap6.Translate_Name (Name); Kind := Get_Object_Kind (Name_Node); - N_Info := Get_Info (Name_Type); case Tinfo.Type_Mode is when Type_Mode_Fat_Array => @@ -12086,13 +12051,11 @@ package body Translation is Open_Temp; declare Actual_Type : Iir; - Tinfo : Type_Info_Acc; Bounds : Mnode; Formal_Node : Mnode; begin Actual_Type := Get_Type (Get_Default_Value (Formal)); Chap3.Create_Array_Subtype (Actual_Type, True); - Tinfo := Get_Info (Actual_Type); Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); Formal_Node := Chap6.Translate_Name (Formal); New_Assign_Stmt @@ -12104,13 +12067,11 @@ package body Translation is Open_Temp; declare Actual_Type : Iir; - Tinfo : Type_Info_Acc; Bounds : Mnode; Formal_Node : Mnode; begin Actual_Type := Get_Actual_Type (Assoc); Chap3.Create_Array_Subtype (Actual_Type, False); - Tinfo := Get_Info (Actual_Type); Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); Formal_Node := Chap6.Translate_Name (Formal); New_Assign_Stmt @@ -12522,7 +12483,6 @@ package body Translation is Index : O_Enode; Index_Base_Type : Iir; Index_Range : Iir; - Index_Info : Type_Info_Acc; V : Iir_Int64; B : Iir_Int64; begin @@ -12539,8 +12499,6 @@ package body Translation is (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (B))); else Index_Base_Type := Get_Base_Type (Index_Type); - Index_Info := Get_Info (Index_Base_Type); - Index := Chap7.Translate_Expression (Expr, Index_Base_Type); if Get_Direction (Index_Range) = Iir_To then @@ -12598,7 +12556,6 @@ package body Translation is Ibasetype : Iir; Prefix_Info : Type_Info_Acc; Nbr_Dim : Natural; - Fat_Ptr : O_Lnode; Range_Ptr : Mnode; begin Prefix_Type := Get_Type (Get_Prefix (Expr)); @@ -12610,7 +12567,6 @@ package body Translation is Prefix := Prefix_Orig; when Type_Mode_Ptr_Array => -- FIXME: should save the bounds address ? - Fat_Ptr := O_Lnode_Null; Prefix := Prefix_Orig; when others => raise Internal_Error; @@ -12725,7 +12681,6 @@ package body Translation is -- Type of the slice. Slice_Type : Iir; Slice_Info : Type_Info_Acc; - Slice_Binfo : Type_Info_Acc; -- Type of the first (and only) index of the prefix array type. Index_Type : Iir; @@ -12822,8 +12777,6 @@ package body Translation is Data.Is_Off := False; - Slice_Binfo := Get_Info (Get_Base_Type (Slice_Type)); - -- Save prefix. Prefix_Var := Stabilize (Prefix); @@ -12938,12 +12891,6 @@ package body Translation is (Prefix : Mnode; Expr : Iir_Slice_Name; Data : Slice_Name_Data) return Mnode is - -- Type of the prefix. - Prefix_Type : Iir; - - -- Type info of the prefix. - Prefix_Info : Type_Info_Acc; - -- Type of the slice. Slice_Type : Iir; Slice_Info : Type_Info_Acc; @@ -12956,11 +12903,9 @@ package body Translation is begin -- Evaluate the prefix. Slice_Type := Get_Type (Expr); - Prefix_Type := Get_Type (Get_Prefix (Expr)); Kind := Get_Object_Kind (Prefix); - Prefix_Info := Get_Info (Prefix_Type); Slice_Info := Get_Info (Slice_Type); if Data.Is_Off then @@ -14150,14 +14095,12 @@ package body Translation is is Res : O_Dnode; Type_Info : Type_Info_Acc; - Expr_Type_Info : Type_Info_Acc; begin -- FIXME: to do. -- Be sure the bounds variable was created. -- This may be necessary for on-the-fly types, such as strings. Chap3.Create_Array_Subtype (Expr_Type, True); - Expr_Type_Info := Get_Info (Expr_Type); Type_Info := Get_Info (Atype); Res := Create_Temp (Type_Info.Ortho_Type (Kind)); New_Assign_Stmt @@ -14372,7 +14315,6 @@ package body Translation is Res : O_Dnode; Res_Type : O_Tnode; If_Blk : O_If_Block; - Op : ON_Op_Kind; Val : Integer; V : O_Cnode; Kind : Iir_Predefined_Functions; @@ -14391,22 +14333,18 @@ package body Translation is case Kind is when Iir_Predefined_Bit_And | Iir_Predefined_Boolean_And => - Op := ON_And; Invert := False; Val := 1; when Iir_Predefined_Bit_Nand | Iir_Predefined_Boolean_Nand => - Op := ON_And; Invert := True; Val := 1; when Iir_Predefined_Bit_Or | Iir_Predefined_Boolean_Or => - Op := ON_Or; Invert := False; Val := 0; when Iir_Predefined_Bit_Nor | Iir_Predefined_Boolean_Nor => - Op := ON_Or; Invert := True; Val := 0; when others => @@ -15292,10 +15230,10 @@ package body Translation is procedure Translate_Record_Aggregate (Target : Mnode; Aggr : Iir) is Targ : Mnode; - Aggr_Type : Iir := Get_Type (Aggr); - Aggr_Base_Type : Iir_Record_Type_Definition := + Aggr_Type : constant Iir := Get_Type (Aggr); + Aggr_Base_Type : constant Iir_Record_Type_Definition := Get_Base_Type (Aggr_Type); - Nbr_El : Iir_Index32 := + Nbr_El : constant Iir_Index32 := Get_Number_Element_Declaration (Aggr_Base_Type); -- Record which elements of the record have been set. The 'others' @@ -15360,7 +15298,6 @@ package body Translation is Bounds : Mnode; Var_Index : O_Dnode; Targ : Mnode; - Tinfo : Type_Info_Acc; Range_Ptr : Mnode; Rinfo : Type_Info_Acc; @@ -15400,7 +15337,6 @@ package body Translation is If_Blk : O_If_Block; Op : ON_Op_Kind; begin - Tinfo := Get_Info (Target_Type); Open_Temp; Targ := Stabilize (Target); Base := Stabilize (Chap3.Get_Array_Base (Targ)); @@ -16034,7 +15970,6 @@ package body Translation is declare Unit : Iir; Unit_Info : Object_Info_Acc; - Unit_Type : Type_Info_Acc; begin Unit := Get_Unit_Name (Expr); Unit_Info := Get_Info (Unit); @@ -16043,7 +15978,6 @@ package body Translation is (Translate_Static_Expression (Expr, Rtype)); else -- Time units might be not locally static. - Unit_Type := Get_Info (Expr_Type); return New_Dyadic_Op (ON_Mul_Ov, New_Lit (New_Signed_Literal @@ -16057,7 +15991,6 @@ package body Translation is declare Unit : Iir; Unit_Info : Object_Info_Acc; - Unit_Type : Type_Info_Acc; L, R : O_Enode; begin Unit := Get_Unit_Name (Expr); @@ -16067,7 +16000,6 @@ package body Translation is (Translate_Static_Expression (Expr, Rtype)); else -- Time units might be not locally static. - Unit_Type := Get_Info (Expr_Type); L := New_Lit (New_Float_Literal (Ghdl_Real_Type, IEEE_Float_64 (Get_Fp_Value (Expr)))); @@ -16207,11 +16139,9 @@ package body Translation is | Iir_Kind_Attribute_Value => declare L : Mnode; - Expr_Type_Info : Type_Info_Acc; begin L := Chap6.Translate_Name (Expr); - Expr_Type_Info := Get_Info (Expr_Type); Res := M2E (L); if Get_Object_Kind (L) = Mode_Signal then Res := Translate_Signal (Res, Expr_Type); @@ -19406,7 +19336,6 @@ package body Translation is is Constr : O_Assoc_List; Conv_Info : Subprg_Info_Acc; - Res_Info : Type_Info_Acc; Res : O_Dnode; Imp : Iir; begin @@ -19441,7 +19370,6 @@ package body Translation is New_Association (Constr, M2E (Src)); - Res_Info := Get_Info (Get_Return_Type (Imp)); if Conv_Info.Res_Interface /= O_Dnode_Null then -- Composite result. New_Procedure_Call (Constr); @@ -19464,8 +19392,9 @@ package body Translation is is type Mnode_Array is array (Natural range <>) of Mnode; type O_Enode_Array is array (Natural range <>) of O_Enode; - Assoc_Chain : Iir := Get_Parameter_Association_Chain (Stmt); - Nbr_Assoc : Natural := Iir_Chains.Get_Chain_Length (Assoc_Chain); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Nbr_Assoc : constant Natural := + Iir_Chains.Get_Chain_Length (Assoc_Chain); Params : Mnode_Array (0 .. Nbr_Assoc - 1); E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); Imp : Iir; @@ -19480,7 +19409,6 @@ package body Translation is Base_Formal : Iir; Formal_Type : Iir; Ftype_Info : Type_Info_Acc; - Atype_Info : Type_Info_Acc; Formal_Info : Ortho_Info_Acc; Val : O_Enode; Param : Mnode; @@ -19592,7 +19520,6 @@ package body Translation is | Iir_Kind_Signal_Interface_Declaration => Param := Chap6.Translate_Name (Act); -- Atype may not have been set (eg: slice). - Atype_Info := Get_Info (Actual_Type); if Base_Formal /= Formal then Stabilize (Param); Params (Pos) := Param; @@ -20697,6 +20624,7 @@ package body Translation is when Iir_Kind_Procedure_Call_Statement => declare Assocs : Iir; + pragma Unreferenced (Assocs); -- FIXME Call : Iir_Procedure_Call; Imp : Iir; begin @@ -20752,8 +20680,8 @@ package body Translation is package body Chap9 is procedure Set_Direct_Drivers (Proc : Iir) is - Proc_Info : Proc_Info_Acc := Get_Info (Proc); - Drivers : Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; Info : Ortho_Info_Acc; Var : Var_Acc; Sig : Iir; @@ -20777,8 +20705,8 @@ package body Translation is procedure Reset_Direct_Drivers (Proc : Iir) is - Proc_Info : Proc_Info_Acc := Get_Info (Proc); - Drivers : Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; Info : Ortho_Info_Acc; Var : Var_Acc; Sig : Iir; @@ -21640,7 +21568,7 @@ package body Translation is end if; end Get_Arch_Name; - Str : String := + Str : constant String := Image_Identifier (Get_Library (Get_Design_File (Entity_Unit))) & "__" & Image_Identifier (Entity) & "__" & Get_Arch_Name & "__"; @@ -23260,28 +23188,22 @@ package body Translation is return Translate_Low_High_Type_Attribute (Atype, True); end Translate_Low_Type_Attribute; - function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode - is - Info : Type_Info_Acc; + function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode is begin if Get_Type_Staticness (Atype) = Locally then return New_Lit (Chap7.Translate_Static_Range_Left (Get_Range_Constraint (Atype), Atype)); else - Info := Get_Info (Atype); return M2E (Chap3.Range_To_Left (Chap3.Type_To_Range (Atype))); end if; end Translate_Left_Type_Attribute; - function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode - is - Info : Type_Info_Acc; + function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode is begin if Get_Type_Staticness (Atype) = Locally then return New_Lit (Chap7.Translate_Static_Range_Right (Get_Range_Constraint (Atype), Atype)); else - Info := Get_Info (Atype); return M2E (Chap3.Range_To_Right (Chap3.Type_To_Range (Atype))); end if; end Translate_Right_Type_Attribute; @@ -25149,8 +25071,9 @@ package body Translation is end if; declare - Lit_List : Iir_List := Get_Enumeration_Literal_List (Atype); - Nbr_Lit : Integer := Get_Nbr_Elements (Lit_List); + Lit_List : constant Iir_List := + Get_Enumeration_Literal_List (Atype); + Nbr_Lit : constant Integer := Get_Nbr_Elements (Lit_List); Lit : Iir; type Dnode_Array is array (Natural range <>) of O_Dnode; @@ -25491,6 +25414,7 @@ package body Translation is Nbr_Indexes : Integer; Index : Iir; Tmp : O_Dnode; + pragma Unreferenced (Tmp); Arr_Type : O_Tnode; Arr_Aggr : O_Array_Aggr_List; Val : O_Cnode; @@ -25563,6 +25487,7 @@ package body Translation is declare Mark : Id_Mark_Type; El_Rti : O_Dnode; + pragma Unreferenced (El_Rti); begin Push_Identifier_Prefix (Mark, "EL"); El_Rti := Generate_Type_Definition (Element); @@ -25603,6 +25528,7 @@ package body Translation is Aggr : O_Record_Aggr_List; Val : O_Cnode; Base_Rti : O_Dnode; + pragma Unreferenced (Base_Rti); Bounds : Var_Acc; Name : O_Dnode; Kind : O_Cnode; @@ -25950,6 +25876,7 @@ package body Translation is declare Mark : Id_Mark_Type; Tmp : O_Dnode; + pragma Unreferenced (Tmp); begin Push_Identifier_Prefix (Mark, "OT"); Tmp := Generate_Type_Definition (Decl_Type); @@ -27015,7 +26942,6 @@ package body Translation is -- Generic pointer. Ghdl_Ptr_Type := New_Access_Type (Char_Type_Node); - Const_Ptr_Type_Node := Ghdl_Ptr_Type; New_Type_Decl (Get_Identifier ("__ghdl_ptr"), Ghdl_Ptr_Type); -- Create record @@ -28252,6 +28178,7 @@ package body Translation is is Lib_Mark, Unit_Mark : Id_Mark_Type; Info : Ortho_Info_Acc; + pragma Unreferenced (Info); begin Update_Node_Infos; @@ -28518,6 +28445,7 @@ package body Translation is procedure Gen_Setup_Info is Cst : O_Dnode; + pragma Unreferenced (Cst); begin Cst := Create_String (Flags.Flag_String, Get_Identifier ("__ghdl_flag_string"), @@ -28831,6 +28759,7 @@ package body Translation is F : FILEs; R : int; S : size_t; + pragma Unreferenced (R, S); -- FIXME Id : Name_Id; Lib : Iir_Library_Declaration; File : Iir_Design_File; |