From da1c23dd6f53ba955f2b0aefc00ff66bbbcfb11f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 11 Apr 2013 15:05:15 +0200 Subject: [multiple changes] 2013-04-11 Doug Rupp * gnatlink.adb: Fold program basename to lower case on VMS for consistency. 2013-04-11 Matthew Heaney * a-rbtgbo.adb (Generic_Equal): Initialize Result variable before entering loop. 2013-04-11 Arnaud Charlet * xgnatugn.adb: Remove dead code (handling of @ifset/@ifclear). 2013-04-11 Arnaud Charlet * gnat_ugn.texi: Remove some use of ifset in menus. Not strictly needed, and seems to confuse some versions of makeinfo. 2013-04-11 Javier Miranda * einfo.adb (Is_Thunk): Remove assertion. (Set_Is_Thunk): Add assertion. * einfo.ads (Is_Thunk): Complete documentation. * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Code cleanup. * exp_ch3.ad[sb] (Is_Variable_Size_Array): Moved to sem_util (Is_Variable_Size_Record): Moved to sem_util * exp_ch6.adb (Expand_Call): Code cleanup. (Expand_N_Extended_Return_Statement): Code cleanup. (Expand_Simple_Function_Return): Code cleanup. * exp_disp.adb Remove dependency on exp_ch3 (Expand_Interface_Thunk): Add minimum decoration needed to set attribute Is_Thunk. * sem_ch3.ad[sb] (Is_Constant_Bound): moved to sem_util * sem_util.ad[sb] (Is_Constant_Bound): Moved from sem_ch3 (Is_Variable_Size_Array): Moved from exp_ch3 (Is_Variable_Size_Record): Moved from exp_ch3 From-SVN: r197787 --- gcc/ada/ChangeLog | 38 ++++++ gcc/ada/a-rbtgbo.adb | 1 + gcc/ada/einfo.adb | 2 +- gcc/ada/einfo.ads | 19 +-- gcc/ada/exp_ch11.adb | 3 +- gcc/ada/exp_ch3.adb | 66 ---------- gcc/ada/exp_ch3.ads | 3 - gcc/ada/exp_ch6.adb | 13 +- gcc/ada/exp_disp.adb | 2 +- gcc/ada/gnat_ugn.texi | 7 -- gcc/ada/gnatlink.adb | 48 +++++++- gcc/ada/sem_ch3.adb | 25 ---- gcc/ada/sem_ch3.ads | 8 +- gcc/ada/sem_util.adb | 88 ++++++++++++++ gcc/ada/sem_util.ads | 12 ++ gcc/ada/xgnatugn.adb | 327 +------------------------------------------------- 16 files changed, 207 insertions(+), 455 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index be71cdf..232c818 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2013-04-11 Doug Rupp + + * gnatlink.adb: Fold program basename to lower case on VMS for + consistency. + +2013-04-11 Matthew Heaney + + * a-rbtgbo.adb (Generic_Equal): Initialize Result variable before + entering loop. + +2013-04-11 Arnaud Charlet + + * xgnatugn.adb: Remove dead code (handling of @ifset/@ifclear). + +2013-04-11 Arnaud Charlet + + * gnat_ugn.texi: Remove some use of ifset in menus. Not strictly + needed, and seems to confuse some versions of makeinfo. + +2013-04-11 Javier Miranda + + * einfo.adb (Is_Thunk): Remove assertion. + (Set_Is_Thunk): Add assertion. + * einfo.ads (Is_Thunk): Complete documentation. + * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Code cleanup. + * exp_ch3.ad[sb] (Is_Variable_Size_Array): Moved to sem_util + (Is_Variable_Size_Record): Moved to sem_util + * exp_ch6.adb (Expand_Call): Code cleanup. + (Expand_N_Extended_Return_Statement): Code cleanup. + (Expand_Simple_Function_Return): Code cleanup. + * exp_disp.adb Remove dependency on exp_ch3 + (Expand_Interface_Thunk): Add minimum decoration needed to set + attribute Is_Thunk. + * sem_ch3.ad[sb] (Is_Constant_Bound): moved to sem_util + * sem_util.ad[sb] (Is_Constant_Bound): Moved from + sem_ch3 (Is_Variable_Size_Array): Moved from exp_ch3 + (Is_Variable_Size_Record): Moved from exp_ch3 + 2013-04-11 Javier Miranda * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Do diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb index d1c2677..d6df756 100644 --- a/gcc/ada/a-rbtgbo.adb +++ b/gcc/ada/a-rbtgbo.adb @@ -637,6 +637,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is L_Node := Left.First; R_Node := Right.First; + Result := True; while L_Node /= 0 loop if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then Result := False; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index b81a1c6..cd38451 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -2271,7 +2271,6 @@ package body Einfo is function Is_Thunk (Id : E) return B is begin - pragma Assert (Is_Subprogram (Id)); return Flag225 (Id); end Is_Thunk; @@ -4880,6 +4879,7 @@ package body Einfo is procedure Set_Is_Thunk (Id : E; V : B := True) is begin + pragma Assert (Is_Subprogram (Id)); Set_Flag225 (Id, V); end Set_Is_Thunk; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 9b32e8b..6b56b9e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2843,14 +2843,17 @@ package Einfo is -- Applies to all entities. True for task types and subtypes -- Is_Thunk (Flag225) --- Defined in all entities for subprograms (functions, procedures, and --- operators). True for subprograms that are thunks, that is small --- subprograms built by the expander for tagged types that cover --- interface types. At run-time thunks displace the pointer to the object --- (pointer named "this" in the C++ terminology) from a secondary --- dispatch table to the primary dispatch table associated with a given --- tagged type. Set by Expand_Interface_Thunk and used by Expand_Call to --- handle extra actuals associated with accessibility level. +-- Applies to all entities. True for subprograms that are thunks: that is +-- small subprograms built by the expander for tagged types that cover +-- interface types. As part of the runtime call to an interface, thunks +-- displace the pointer to the object (pointer named "this" in the C++ +-- terminology) from a secondary dispatch table to the primary dispatch +-- table associated with a given tagged type; if the thunk is a function +-- that returns an object which covers an interface type then the thunk +-- displaces the pointer to the object from the primary dispatch table to +-- the secondary dispatch table associated with the interface type. Set +-- by Expand_Interface_Thunk and used by Expand_Call to handle extra +-- actuals associated with accessibility level. -- Is_Trivial_Subprogram (Flag235) -- Defined in all entities. Set in subprograms where either the body diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 7378885..2f25069 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1410,8 +1410,7 @@ package body Exp_Ch11 is -- No cleanup action needed in thunks associated with interfaces -- because they only displace the pointer to the object. - and then not (Is_Subprogram (Current_Scope) - and then Is_Thunk (Current_Scope)) + and then not Is_Thunk (Current_Scope) then Expand_Cleanup_Actions (Parent (N)); else diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6369d44..5637c2f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -229,9 +229,6 @@ package body Exp_Ch3 is function Is_User_Defined_Equality (Prim : Node_Id) return Boolean; -- Returns true if Prim is a user defined equality function - function Is_Variable_Size_Array (E : Entity_Id) return Boolean; - -- Returns true if E has variable size components - function Make_Eq_Body (Typ : Entity_Id; Eq_Name : Name_Id) return Node_Id; @@ -8311,69 +8308,6 @@ package body Exp_Ch3 is and then Base_Type (Etype (Prim)) = Standard_Boolean; end Is_User_Defined_Equality; - ---------------------------- - -- Is_Variable_Size_Array -- - ---------------------------- - - function Is_Variable_Size_Array (E : Entity_Id) return Boolean is - Idx : Node_Id; - - begin - pragma Assert (Is_Array_Type (E)); - - -- Check if some index is initialized with a non-constant value - - Idx := First_Index (E); - while Present (Idx) loop - if Nkind (Idx) = N_Range then - if not Is_Constant_Bound (Low_Bound (Idx)) - or else not Is_Constant_Bound (High_Bound (Idx)) - then - return True; - end if; - end if; - - Idx := Next_Index (Idx); - end loop; - - return False; - end Is_Variable_Size_Array; - - ----------------------------- - -- Is_Variable_Size_Record -- - ----------------------------- - - function Is_Variable_Size_Record (E : Entity_Id) return Boolean is - Comp : Entity_Id; - Comp_Typ : Entity_Id; - - begin - pragma Assert (Is_Record_Type (E)); - - Comp := First_Entity (E); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - -- Recursive call if the record type has discriminants - - if Is_Record_Type (Comp_Typ) - and then Has_Discriminants (Comp_Typ) - and then Is_Variable_Size_Record (Comp_Typ) - then - return True; - - elsif Is_Array_Type (Comp_Typ) - and then Is_Variable_Size_Array (Comp_Typ) - then - return True; - end if; - - Next_Entity (Comp); - end loop; - - return False; - end Is_Variable_Size_Record; - ---------------------------------------- -- Make_Controlling_Function_Wrappers -- ---------------------------------------- diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 6ad53ad..de767fc 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -104,9 +104,6 @@ package Exp_Ch3 is -- then tags components located at variable positions of Target are -- initialized. - function Is_Variable_Size_Record (E : Entity_Id) return Boolean; - -- Returns true if E has variable size components (move to sem_util???) - function Needs_Simple_Initialization (T : Entity_Id; Consider_IS : Boolean := True) return Boolean; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 931782a..eccdf21 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2691,9 +2691,7 @@ package body Exp_Ch6 is -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of -- accessibility levels. - if Ekind (Current_Scope) in Subprogram_Kind - and then Is_Thunk (Current_Scope) - then + if Is_Thunk (Current_Scope) then declare Parm_Ent : Entity_Id; @@ -5493,8 +5491,7 @@ package body Exp_Ch6 is -- the pointer to the object) they are always handled by means of -- simple return statements. - pragma Assert (not Is_Subprogram (Current_Scope) - or else not Is_Thunk (Current_Scope)); + pragma Assert (not Is_Thunk (Current_Scope)); if Nkind (Ret_Obj_Decl) = N_Object_Declaration then Exp := Expression (Ret_Obj_Decl); @@ -7144,8 +7141,7 @@ package body Exp_Ch6 is -- handled by means of simple return statements. This leaves their -- expansion simple and clean. - and then not (Is_Subprogram (Current_Scope) - and then Is_Thunk (Current_Scope)) + and then not Is_Thunk (Current_Scope) then declare Return_Object_Entity : constant Entity_Id := @@ -7225,8 +7221,7 @@ package body Exp_Ch6 is -- the object is returned by reference and the maximum functionality -- required is just to displace the pointer. - elsif Is_Subprogram (Current_Scope) - and then Is_Thunk (Current_Scope) + elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then null; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 2df3a94..52047d7 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Atag; use Exp_Atag; -with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_CG; use Exp_CG; with Exp_Dbug; use Exp_Dbug; @@ -1884,6 +1883,7 @@ package body Exp_Disp is end loop; Thunk_Id := Make_Temporary (Loc, 'T'); + Set_Ekind (Thunk_Id, Ekind (Prim)); Set_Is_Thunk (Thunk_Id); Set_Convention (Thunk_Id, Convention (Prim)); diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 519890f..6d6376a 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -212,10 +212,8 @@ AdaCore@* * Conditional Compilation:: * Inline Assembler:: * Compatibility and Porting Guide:: -@ifset unw * Microsoft Windows Topics:: * Mac OS Topics:: -@end ifset * GNU Free Documentation License:: * Index:: @@ -652,7 +650,6 @@ Compatibility and Porting Guide * Transitioning to 64-Bit GNAT for OpenVMS:: @end ifset -@ifset unw Microsoft Windows Topics @ifclear FSFEDITION @@ -675,7 +672,6 @@ Microsoft Windows Topics Mac OS Topics * Codesigning the Debugger:: -@end ifset * Index:: @end menu @@ -29083,7 +29079,6 @@ without sacrificing the capabilities of the 64-bit architecture. @end ifset @c ************************************************ -@ifset unw @node Microsoft Windows Topics @appendix Microsoft Windows Topics @cindex Windows NT @@ -31203,8 +31198,6 @@ codesign -f -s "gdb-cert" /bin/gdb name chosen above, and should be replaced by the location where you installed GNAT. -@end ifset - @c ********************************** @c * GNU Free Documentation License * @c ********************************** diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 87ad072..503c2f7 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -153,6 +153,8 @@ procedure Gnatlink is Binder_Ali_File : String_Access; Binder_Obj_File : String_Access; + Base_Command_Name : String_Access; + Tname : Temp_File_Name; Tname_FD : File_Descriptor := Invalid_FD; -- Temporary file used by linker to pass list of object files on @@ -226,6 +228,12 @@ procedure Gnatlink is procedure Process_Binder_File (Name : String); -- Reads the binder file and extracts linker arguments + function To_Lower (A : Character) return Character; + -- Fold a character to lower case; + + procedure To_Lower (A : in out String); + -- Fold a string to lower case; + procedure Usage; -- Display usage @@ -314,7 +322,7 @@ procedure Gnatlink is procedure Error_Msg (Message : String) is begin - Write_Str (Base_Name (Command_Name)); + Write_Str (Base_Command_Name.all); Write_Str (": "); Write_Str (Message); Write_Eol; @@ -1406,6 +1414,31 @@ procedure Gnatlink is Status := fclose (Fd); end Process_Binder_File; + -------------- + -- To_Lower -- + -------------- + + function To_Lower (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); + + begin + if A in 'A' .. 'Z' + or else A_Val in 16#C0# .. 16#D6# + or else A_Val in 16#D8# .. 16#DE# + then + return Character'Val (A_Val + 16#20#); + else + return A; + end if; + end To_Lower; + + procedure To_Lower (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Lower (A (J)); + end loop; + end To_Lower; + ----------- -- Usage -- ----------- @@ -1413,7 +1446,7 @@ procedure Gnatlink is procedure Usage is begin Write_Str ("Usage: "); - Write_Str (Base_Name (Command_Name)); + Write_Str (Base_Command_Name.all); Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]"); Write_Eol; Write_Eol; @@ -1501,6 +1534,15 @@ begin end; end if; + Base_Command_Name := new String'(Base_Name (Command_Name)); + + -- Fold to lower case "GNATLINK" on VMS to be consistent with output + -- from other GNAT utilities. + + if Hostparm.OpenVMS then + To_Lower (Base_Command_Name.all); + end if; + Process_Args; if Argument_Count = 0 @@ -1737,7 +1779,7 @@ begin -- Assume this is a cross tool if the executable name is not gnatlink - if Base_Name (Command_Name) = "gnatlink" + if Base_Command_Name.all = "gnatlink" and then Output_File_Name.all = "test" then Error_Msg ("warning: executable name """ & Output_File_Name.all diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2e0cdf7..fc74bee 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16332,31 +16332,6 @@ package body Sem_Ch3 is end Inherit_Components; ----------------------- - -- Is_Constant_Bound -- - ----------------------- - - function Is_Constant_Bound (Exp : Node_Id) return Boolean is - begin - if Compile_Time_Known_Value (Exp) then - return True; - - elsif Is_Entity_Name (Exp) - and then Present (Entity (Exp)) - then - return Is_Constant_Object (Entity (Exp)) - or else Ekind (Entity (Exp)) = E_Enumeration_Literal; - - elsif Nkind (Exp) in N_Binary_Op then - return Is_Constant_Bound (Left_Opnd (Exp)) - and then Is_Constant_Bound (Right_Opnd (Exp)) - and then Scope (Entity (Exp)) = Standard_Standard; - - else - return False; - end if; - end Is_Constant_Bound; - - ----------------------- -- Is_Null_Extension -- ----------------------- diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 98a8dbc..a0b37ea 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -174,12 +174,6 @@ package Sem_Ch3 is -- Given a discriminant somewhere in the Typ_For_Constraint tree and a -- Constraint, return the value of that discriminant. - function Is_Constant_Bound (Exp : Node_Id) return Boolean; - -- Exp is the expression for an array bound. Determines whether the - -- bound is a compile-time known value, or a constant entity, or an - -- enumeration literal, or an expression composed of constant-bound - -- subexpressions which are evaluated by means of standard operators. - function Is_Null_Extension (T : Entity_Id) return Boolean; -- Returns True if the tagged type T has an N_Full_Type_Declaration that -- is a null extension, meaning that it has an extension part without any diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1be6c84..6cba060 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7747,6 +7747,31 @@ package body Sem_Util is or else Is_Task_Interface (T)); end Is_Concurrent_Interface; + ----------------------- + -- Is_Constant_Bound -- + ----------------------- + + function Is_Constant_Bound (Exp : Node_Id) return Boolean is + begin + if Compile_Time_Known_Value (Exp) then + return True; + + elsif Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + then + return Is_Constant_Object (Entity (Exp)) + or else Ekind (Entity (Exp)) = E_Enumeration_Literal; + + elsif Nkind (Exp) in N_Binary_Op then + return Is_Constant_Bound (Left_Opnd (Exp)) + and then Is_Constant_Bound (Right_Opnd (Exp)) + and then Scope (Entity (Exp)) = Standard_Standard; + + else + return False; + end if; + end Is_Constant_Bound; + -------------------------------------- -- Is_Controlling_Limited_Procedure -- -------------------------------------- @@ -9481,6 +9506,69 @@ package body Sem_Util is and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; + ---------------------------- + -- Is_Variable_Size_Array -- + ---------------------------- + + function Is_Variable_Size_Array (E : Entity_Id) return Boolean is + Idx : Node_Id; + + begin + pragma Assert (Is_Array_Type (E)); + + -- Check if some index is initialized with a non-constant value + + Idx := First_Index (E); + while Present (Idx) loop + if Nkind (Idx) = N_Range then + if not Is_Constant_Bound (Low_Bound (Idx)) + or else not Is_Constant_Bound (High_Bound (Idx)) + then + return True; + end if; + end if; + + Idx := Next_Index (Idx); + end loop; + + return False; + end Is_Variable_Size_Array; + + ----------------------------- + -- Is_Variable_Size_Record -- + ----------------------------- + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean is + Comp : Entity_Id; + Comp_Typ : Entity_Id; + + begin + pragma Assert (Is_Record_Type (E)); + + Comp := First_Entity (E); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + -- Recursive call if the record type has discriminants + + if Is_Record_Type (Comp_Typ) + and then Has_Discriminants (Comp_Typ) + and then Is_Variable_Size_Record (Comp_Typ) + then + return True; + + elsif Is_Array_Type (Comp_Typ) + and then Is_Variable_Size_Array (Comp_Typ) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + end Is_Variable_Size_Record; + --------------------- -- Is_VMS_Operator -- --------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 11fe654..5cd1ab6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -853,6 +853,12 @@ package Sem_Util is -- True if T is a bounded string type. Used to make sure "=" composes -- properly for bounded string types. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; + -- Exp is the expression for an array bound. Determines whether the + -- bound is a compile-time known value, or a constant entity, or an + -- enumeration literal, or an expression composed of constant-bound + -- subexpressions which are evaluated by means of standard operators. + function Is_Controlling_Limited_Procedure (Proc_Nam : Entity_Id) return Boolean; -- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure @@ -1044,6 +1050,12 @@ package Sem_Util is -- object that is accessed directly, as opposed to the other CIL objects -- that are accessed through managed pointers. + function Is_Variable_Size_Array (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + function Is_VMS_Operator (Op : Entity_Id) return Boolean; -- Determine whether an operator is one of the intrinsics defined -- in the DEC system extension. diff --git a/gcc/ada/xgnatugn.adb b/gcc/ada/xgnatugn.adb index 3403ad4..e1dc7ef 100644 --- a/gcc/ada/xgnatugn.adb +++ b/gcc/ada/xgnatugn.adb @@ -149,10 +149,6 @@ procedure Xgnatugn is (Input : Input_File; At_Character : Natural; Message : String); - procedure Warning - (Input : Input_File; - Message : String); - -- Like Error, but just print a warning message Dictionary_File : aliased Input_File; procedure Read_Dictionary_File; @@ -181,7 +177,6 @@ procedure Xgnatugn is -- Conditional commands for edition are passed through unchanged subtype Target_Type is Flag_Type range UNW .. VMS; - subtype Edition_Type is Flag_Type range FSFEDITION .. GPLEDITION; Target : Target_Type; -- The Target variable is initialized using the command line @@ -237,42 +232,6 @@ procedure Xgnatugn is -- This subprogram takes a line and rewrites it according to Target. -- It relies on information in Source_File to generate error messages. - type Conditional is (Set, Clear); - procedure Push_Conditional (Cond : Conditional; Flag : Flag_Type); - procedure Pop_Conditional (Cond : Conditional); - -- These subprograms deal with conditional processing (@ifset/@ifclear). - -- They rely on information in Source_File to generate error messages. - - function VMS_Context_Determined return Boolean; - -- Returns true if, in the current conditional preprocessing context, we - -- always have a VMS or a non-VMS version, regardless of the value of - -- Target. - - function In_VMS_Section return Boolean; - -- Returns True if in an "@ifset vms" section - - procedure Check_No_Pending_Conditional; - -- Checks that all preprocessing directives have been properly matched by - -- their @end counterpart. If this is not the case, print an error - -- message. - - -- The following definitions implement a stack to track the conditional - -- preprocessing context. - - type Conditional_Context is record - Starting_Line : Positive; - Cond : Conditional; - Flag : Flag_Type; - end record; - - Conditional_Stack_Depth : constant := 3; - - Conditional_Stack : - array (1 .. Conditional_Stack_Depth) of Conditional_Context; - - Conditional_TOS : Natural := 0; - -- Pointer to the Top Of Stack for Conditional_Stack - ----------- -- Usage -- ----------- @@ -411,16 +370,6 @@ procedure Xgnatugn is ------------- procedure Warning - (Input : Input_File; - Message : String) - is - begin - if Warnings_Enabled then - Warning (Input, 0, Message); - end if; - end Warning; - - procedure Warning (Input : Input_File; At_Character : Natural; Message : String) @@ -883,17 +832,6 @@ procedure Xgnatugn is Maybe_Rewrite_Extension; when VMS_Alternative => - if VMS_Context_Determined then - if (not In_VMS_Section) - or else - Line (Token.VMS.First .. Token.VMS.Last) /= - Line (Token.Non_VMS.First .. Token.Non_VMS.Last) - then - Warning (Source_File, Token.First, - "VMS alternative already determined " - & "by conditionals"); - end if; - end if; if Target = VMS then Append (Rewritten_Line, Line (Token.VMS.First .. Token.VMS.Last)); @@ -917,11 +855,6 @@ procedure Xgnatugn is ------------------------- procedure Process_Source_File is - Ifset : constant String := "@ifset "; - Ifclear : constant String := "@ifclear "; - Endsetclear : constant String := "@end "; - -- Strings to be recognized for conditional processing - begin while not End_Of_File (Source_File.Data) loop declare @@ -931,152 +864,17 @@ procedure Xgnatugn is -- syntax of all lines, and not only those which are actually -- included in the output. - Have_Conditional : Boolean := False; - -- True if we have encountered a conditional preprocessing - -- directive. - - Cond : Conditional; - -- The kind of the directive - - Flag : Flag_Type; - -- Its flag - begin - -- If the line starts with @ifset or @ifclear, we try to convert - -- the following flag to one of our flag types. If we fail, - -- Have_Conditional remains False. - - if Line'Length >= Ifset'Length - and then Line (1 .. Ifset'Length) = Ifset - then - Cond := Set; - - declare - Arg : constant String := - Trim (Line (Ifset'Length + 1 .. Line'Last), Both); - - begin - Flag := Flag_Type'Value (Arg); - Have_Conditional := True; - - case Flag is - when Target_Type => - if Translate (Target_Type'Image (Flag), - Lower_Case_Map) - /= Arg - then - Error (Source_File, "flag has to be lowercase"); - end if; - - -- Set unw/vms flag in the output file so that - -- @ifset/@ifclear will work as expected. - - if First_Time then - Put_Line (Output_File, "@set " & Argument (1)); - First_Time := False; - end if; - - when Edition_Type => - null; - end case; - exception - when Constraint_Error => - Error (Source_File, "unknown flag for '@ifset'"); - end; - - elsif Line'Length >= Ifclear'Length - and then Line (1 .. Ifclear'Length) = Ifclear + if First_Time + and then Line'Length > 3 and then Line (1 .. 3) = "@if" then - Cond := Clear; - - declare - Arg : constant String := - Trim (Line (Ifclear'Length + 1 .. Line'Last), Both); - - begin - Flag := Flag_Type'Value (Arg); - Have_Conditional := True; - - case Flag is - when Target_Type => - if Translate (Target_Type'Image (Flag), - Lower_Case_Map) - /= Arg - then - Error (Source_File, "flag has to be lowercase"); - end if; - - -- Set unw/vms flag in the output file so that - -- @ifset/@ifclear will work as expected. - - if First_Time then - Put_Line (Output_File, "@set " & Argument (1)); - First_Time := False; - end if; - - when Edition_Type => - null; - end case; - exception - when Constraint_Error => - Error (Source_File, "unknown flag for '@ifclear'"); - end; + Put_Line (Output_File, "@set " & Argument (1)); + First_Time := False; end if; - if Have_Conditional then - -- We create a new conditional context and suppress the - -- directive in the output. - - Push_Conditional (Cond, Flag); - - elsif Line'Length >= Endsetclear'Length - and then Line (1 .. Endsetclear'Length) = Endsetclear - then - -- The '@end ifset'/'@end ifclear' case is handled here. We - -- have to pop the conditional context. - - declare - First, Last : Natural; - - begin - Find_Token (Source => Line (Endsetclear'Length + 1 - .. Line'Length), - Set => Letter_Set, - Test => Inside, - First => First, - Last => Last); - - if Last = 0 then - Error (Source_File, "'@end' without argument"); - else - if Line (First .. Last) = "ifset" then - Have_Conditional := True; - Cond := Set; - elsif Line (First .. Last) = "ifclear" then - Have_Conditional := True; - Cond := Clear; - end if; - - if Have_Conditional then - Pop_Conditional (Cond); - - if Conditional_TOS > 0 then - Flag := Conditional_Stack (Conditional_TOS).Flag; - end if; - end if; - - -- We fall through to the ordinary case for other @end - -- directives. - - end if; -- @end without argument - end; - end if; -- Have_Conditional - Put_Line (Output_File, Rewritten); end; end loop; - - Check_No_Pending_Conditional; end Process_Source_File; --------------------------- @@ -1159,123 +957,6 @@ procedure Xgnatugn is return S (Get (Ug_Words, Word)); end Get_Replacement_Word; - ---------------------- - -- Push_Conditional -- - ---------------------- - - procedure Push_Conditional (Cond : Conditional; Flag : Flag_Type) is - begin - if Flag in Target_Type then - - -- Check if the current directive is pointless because of a previous, - -- enclosing directive. - - for J in 1 .. Conditional_TOS loop - if Conditional_Stack (J).Flag = Flag then - Warning - (Source_File, "directive without effect because of line" - & Integer'Image (Conditional_Stack (J).Starting_Line)); - end if; - end loop; - end if; - - Conditional_TOS := Conditional_TOS + 1; - Conditional_Stack (Conditional_TOS) := - (Starting_Line => Source_File.Line, - Cond => Cond, - Flag => Flag); - end Push_Conditional; - - --------------------- - -- Pop_Conditional -- - --------------------- - - procedure Pop_Conditional (Cond : Conditional) is - begin - if Conditional_TOS > 0 then - case Cond is - when Set => - if Conditional_Stack (Conditional_TOS).Cond /= Set then - Error (Source_File, - "'@end ifset' does not match '@ifclear' at line" - & Integer'Image (Conditional_Stack - (Conditional_TOS).Starting_Line)); - end if; - - when Clear => - if Conditional_Stack (Conditional_TOS).Cond /= Clear then - Error (Source_File, - "'@end ifclear' does not match '@ifset' at line" - & Integer'Image (Conditional_Stack - (Conditional_TOS).Starting_Line)); - end if; - end case; - - Conditional_TOS := Conditional_TOS - 1; - - else - case Cond is - when Set => - Error (Source_File, - "'@end ifset' without corresponding '@ifset'"); - - when Clear => - Error (Source_File, - "'@end ifclear' without corresponding '@ifclear'"); - end case; - end if; - end Pop_Conditional; - - ---------------------------- - -- VMS_Context_Determined -- - ---------------------------- - - function VMS_Context_Determined return Boolean is - begin - for J in 1 .. Conditional_TOS loop - if Conditional_Stack (J).Flag = VMS then - return True; - end if; - end loop; - - return False; - end VMS_Context_Determined; - - -------------------- - -- In_VMS_Section -- - -------------------- - - function In_VMS_Section return Boolean is - begin - for J in 1 .. Conditional_TOS loop - if Conditional_Stack (J).Flag = VMS then - return Conditional_Stack (J).Cond = Set; - end if; - end loop; - - return False; - end In_VMS_Section; - - ---------------------------------- - -- Check_No_Pending_Conditional -- - ---------------------------------- - - procedure Check_No_Pending_Conditional is - begin - for J in 1 .. Conditional_TOS loop - case Conditional_Stack (J).Cond is - when Set => - Error (Source_File, "Missing '@end ifset' for '@ifset' at line" - & Integer'Image (Conditional_Stack (J).Starting_Line)); - - when Clear => - Error (Source_File, - "Missing '@end ifclear' for '@ifclear' at line" - & Integer'Image (Conditional_Stack (J).Starting_Line)); - end case; - end loop; - end Check_No_Pending_Conditional; - -- Start of processing for Xgnatugn Valid_Command_Line : Boolean; -- cgit v1.1