diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgk.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgo.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbo.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgso.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 55 | ||||
| -rw-r--r-- | gcc/ada/init.c | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/xgnatugn.adb | 94 |
16 files changed, 226 insertions, 110 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 19a47005d3f..e1125f7a567 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * init.c (RETURN_ADDR_OFFSET): Delete as unused. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * a-crbtgk.adb, a-ciorse.adb, a-crbtgo.adb, a-coorse.adb, a-rbtgbo.adb, + a-cborse.adb, a-rbtgso.adb, exp_ch3.adb: Minor reformatting. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * exp_ch4.adb (Expand_N_Selected_Component): Do not expand + discriminant check for Unchecked_Union. + * sem_res.adb (Resolve_Selected_Component): Set flag + Do_Discriminant_Check even when expansion is not performed. + * sinfo.ads (Do_Discriminant_Check): Update documentation for the case + of Unchecked_Union. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * sem_ch13.adb (Same_Representation): Two types with different scalar + storage order never have the same representation. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * xgnatugn.adb (Push_Conditional): Simplify handling, + no longer need to keep track of "excluding" sections. + (Currently_Excluding): Removed. + (Process_Source_File): + Set unw/vms flag so that texinfo can do the whole handling of + @ifset/@ifclear sections. Fix handling of nested @ifset/@ifclear + sections. + * gnat_ugn.texi: Add a section on performing unassisted install + on Windows. + 2013-04-11 Johannes Kanig <kanig@adacore.com> * debug.adb: Document usage of -gnatd.Q switch. diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index ed34b69195a..64220f91ef2 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -1768,6 +1768,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -1776,6 +1777,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is end; if Compare then + -- Item is equivalent to the node's element, so we will not have to -- move the node. @@ -1808,6 +1810,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -1815,7 +1818,10 @@ package body Ada.Containers.Bounded_Ordered_Sets is raise; end; - if not Compare then -- Item is equivalent to Nodes (Hint).Element + -- Item is equivalent to Nodes (Hint).Element + + if not Compare then + -- Ceiling returns an element that is equivalent or greater than -- Item. If Item is "not less than" the element, then by -- elimination we know that Item is equivalent to the element. diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 4d918a5b45d..3b1ffb43022 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -494,14 +494,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Delete (Container : in out Set; Item : Element_Type) is X : Node_Access := Element_Keys.Find (Container.Tree, Item); - begin if X = null then raise Constraint_Error with "attempt to delete element not in set"; + else + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); end Delete; ------------------ @@ -1924,6 +1923,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -1975,6 +1975,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -1982,10 +1983,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise; end; - if not Compare then -- Item >= Hint.Element - -- Ceiling returns an element that is equivalent or greater than - -- Item. If Item is "not less than" the element, then by - -- elimination we know that Item is equivalent to the element. + -- Item >= Hint.Element + + if not Compare then + + -- Ceiling returns an element that is equivalent or greater + -- than Item. If Item is "not less than" the element, then + -- by elimination we know that Item is equivalent to the element. -- But this means that it is not possible to assign the value of -- Item to the specified element (on Node), because a different diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 3f2537367bb..43d4ec9a3e8 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -1757,6 +1757,7 @@ package body Ada.Containers.Ordered_Sets is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -1797,6 +1798,7 @@ package body Ada.Containers.Ordered_Sets is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -1804,10 +1806,13 @@ package body Ada.Containers.Ordered_Sets is raise; end; - if not Compare then -- Item >= Hint.Element - -- Ceiling returns an element that is equivalent or greater than - -- Item. If Item is "not less than" the element, then by - -- elimination we know that Item is equivalent to the element. + -- Item >= Hint.Element + + if not Compare then + + -- Ceiling returns an element that is equivalent or greater + -- than Item. If Item is "not less than" the element, then + -- by elimination we know that Item is equivalent to the element. -- But this means that it is not possible to assign the value of -- Item to the specified element (on Node), because a different diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index 0e27e0a46de..f1762f8be83 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -65,6 +65,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; return Y; + exception when others => B := B - 1; @@ -116,6 +117,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; return Result; + exception when others => B := B - 1; @@ -155,6 +157,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; return Y; + exception when others => B := B - 1; @@ -214,6 +217,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -258,6 +262,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -321,11 +326,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is B := B + 1; L := L + 1; - Compare := Tree.Last = null - or else Is_Greater_Key_Node (Key, Tree.Last); + Compare := + Tree.Last = null or else Is_Greater_Key_Node (Key, Tree.Last); L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -370,6 +376,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -395,6 +402,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -418,11 +426,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return; end if; - -- We know that Key isn't less than the hint so we try again, - -- this time to see if it's greater than the hint. If so we - -- compare Key to the node that follows the hint. If Key is both - -- greater than the hint and less than the hint's next neighbor, - -- then we're done; otherwise we must search. + -- We know that Key isn't less than the hint so we try again, this time + -- to see if it's greater than the hint. If so we compare Key to the + -- node that follows the hint. If Key is both greater than the hint and + -- less than the hint's next neighbor, then we're done; otherwise we + -- must search. begin B := B + 1; @@ -432,6 +440,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -457,6 +466,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is L := L - 1; B := B - 1; + exception when others => L := L - 1; @@ -480,10 +490,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return; end if; - -- We know that Key is neither less than the hint nor greater - -- than the hint, and that's the definition of equivalence. - -- There's nothing else we need to do, since a search would just - -- reach the same conclusion. + -- We know that Key is neither less than the hint nor greater than the + -- hint, and that's the definition of equivalence. There's nothing else + -- we need to do, since a search would just reach the same conclusion. Node := Position; Inserted := False; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index adc9ab27966..6cce55d25ab 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -675,6 +675,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is LR := LR - 1; return Result; + exception when others => BL := BL - 1; diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb index 27106205fba..d1c26778128 100644 --- a/gcc/ada/a-rbtgbo.adb +++ b/gcc/ada/a-rbtgbo.adb @@ -654,6 +654,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is LR := LR - 1; return Result; + exception when others => BL := BL - 1; diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index 700832e710e..06a78e922c3 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -149,6 +149,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is BS := BS - 1; LS := LS - 1; + exception when others => BT := BT - 1; @@ -265,6 +266,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is LR := LR - 1; return Tree; + exception when others => BL := BL - 1; @@ -340,6 +342,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is BS := BS - 1; LS := LS - 1; + exception when others => BT := BT - 1; @@ -447,6 +450,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is LR := LR - 1; return Tree; + exception when others => BL := BL - 1; @@ -532,6 +536,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is LR := LR - 1; return Result; + exception when others => BL := BL - 1; @@ -605,6 +610,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is LR := LR - 1; return Result; + exception when others => BL := BL - 1; @@ -689,6 +695,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is BS := BS - 1; LS := LS - 1; + exception when others => BT := BT - 1; @@ -826,6 +833,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is LR := LR - 1; return Tree; + exception when others => BL := BL - 1; @@ -886,6 +894,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is BS := BS - 1; LS := LS - 1; + exception when others => BS := BS - 1; @@ -957,6 +966,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is LR := LR - 1; return Tree; + exception when others => BL := BL - 1; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 35d7a9f3029..980cc3cd489 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4846,9 +4846,8 @@ package body Exp_Ch3 is begin Full_Type := Typ; - if Is_Private_Type (Typ) - and then Present (Full_View (Typ)) - then + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then Full_Type := Full_View (Typ); end if; @@ -5169,9 +5168,9 @@ package body Exp_Ch3 is (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); return; - -- If type has discriminants, try to build equivalent - -- aggregate using discriminant values from the declaration. - -- This is a useful optimization, in particular if restriction + -- If type has discriminants, try to build equivalent aggregate + -- using discriminant values from the declaration. This + -- is a useful optimization, in particular if restriction -- No_Elaboration_Code is active. elsif Build_Equivalent_Aggregate then diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index be5d17f2960..3a701838185 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -9198,6 +9198,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Par : constant Node_Id := Parent (N); P : constant Node_Id := Prefix (N); + S : constant Node_Id := Selector_Name (N); Ptyp : Entity_Id := Underlying_Type (Etype (P)); Disc : Entity_Id; New_N : Node_Id; @@ -9273,18 +9274,27 @@ package body Exp_Ch4 is -- Deal with discriminant check required if Do_Discriminant_Check (N) then + if Present (Discriminant_Checking_Func + (Original_Record_Component (Entity (S)))) + then + -- Present the discriminant checking function to the backend, so + -- that it can inline the call to the function. + + Add_Inlined_Body + (Discriminant_Checking_Func + (Original_Record_Component (Entity (S)))); - -- Present the discriminant checking function to the backend, so that - -- it can inline the call to the function. + -- Now reset the flag and generate the call - Add_Inlined_Body - (Discriminant_Checking_Func - (Original_Record_Component (Entity (Selector_Name (N))))); + Set_Do_Discriminant_Check (N, False); + Generate_Discriminant_Check (N); - -- Now reset the flag and generate the call + -- In the case of Unchecked_Union, no discriminant checking is + -- actually performed. - Set_Do_Discriminant_Check (N, False); - Generate_Discriminant_Check (N); + else + Set_Do_Discriminant_Check (N, False); + end if; end if; -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index dadf4d1ad27..519890f1764 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -655,7 +655,11 @@ Compatibility and Porting Guide @ifset unw Microsoft Windows Topics +@ifclear FSFEDITION +* Installing from the Command Line:: +@end ifclear * Using GNAT on Windows:: +* Using a network installation of GNAT:: * CONSOLE and WINDOWS subsystems:: * Temporary Files:: * Mixed-Language Programming on Windows:: @@ -29091,6 +29095,9 @@ This chapter describes topics that are specific to the Microsoft Windows platforms (NT, 2000, and XP Professional). @menu +@ifclear FSFEDITION +* Installing from the Command Line:: +@end ifclear * Using GNAT on Windows:: * Using a network installation of GNAT:: * CONSOLE and WINDOWS subsystems:: @@ -29108,6 +29115,54 @@ platforms (NT, 2000, and XP Professional). * Setting Heap Size from gnatlink:: @end menu +@ifclear FSFEDITION +@node Installing from the Command Line +@section Installing from the Command Line +@cindex Batch installation +@cindex Silent installation +@cindex Unassisted installation + +@noindent +By default the @value{EDITION} installers display a GUI that prompts the user +to enter installation path and similar information, and guide him through the +installation process. It is also possible to perform silent installations +using the command-line interface. + +In order to install one of the @value{EDITION} installers from the command +line you should pass parameter @code{/S} (and, optionally, +@code{/D=<directory>}) as command-line arguments. + +@ifset PROEDITION +For example, for an unattended installation of +@value{EDITION} 7.0.2 into the default directory +@code{C:\GNATPRO\7.0.2} you would run: + +@smallexample +gnatpro-7.0.2-i686-pc-mingw32-bin.exe /S +@end smallexample + +To install into a custom directory, say, @code{C:\TOOLS\GNATPRO\7.0.2}: + +@smallexample +gnatpro-7.0.2-i686-pc-mingw32-bin /S /D=C:\TOOLS\GNATPRO\7.0.2 +@end smallexample +@end ifset + +@ifset GPLEDITION +For example, for an unattended installation of +@value{EDITION} 2012 into @code{C:\GNAT\2012}: + +@smallexample +gnat-gpl-2012-i686-pc-mingw32-bin /S /D=C:\GNAT\2012 +@end smallexample +@end ifset + +You can use the same syntax for all installers. + +Note that unattended installations don't modify system path, nor create file +associations, so such activities need to be done by hand. +@end ifclear + @node Using GNAT on Windows @section Using GNAT on Windows diff --git a/gcc/ada/init.c b/gcc/ada/init.c index ef9087c63c4..8473ff03ff2 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -711,15 +711,6 @@ __gnat_install_handler(void) #include <sys/ucontext.h> #include <sys/regset.h> -/* The code below is common to SPARC and x86. Beware of the delay slot - differences for signal context adjustments. */ - -#if defined (__sparc) -#define RETURN_ADDR_OFFSET 8 -#else -#define RETURN_ADDR_OFFSET 0 -#endif - static void __gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) { diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 6c19a551408..832e7c24aa4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9448,12 +9448,16 @@ package body Sem_Ch13 is return False; end if; - -- Representations are different if component alignments differ + -- Representations are different if component alignments or scalar + -- storage orders differ. if (Is_Record_Type (T1) or else Is_Array_Type (T1)) and then (Is_Record_Type (T2) or else Is_Array_Type (T2)) - and then Component_Alignment (T1) /= Component_Alignment (T2) + and then + (Component_Alignment (T1) /= Component_Alignment (T2) + or else + Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) then return False; end if; @@ -9530,7 +9534,7 @@ package body Sem_Ch13 is function Same_Rep return Boolean; -- CD1 and CD2 are either components or discriminants. This - -- function tests whether the two have the same representation + -- function tests whether they have the same representation. -------------- -- Same_Rep -- @@ -9540,8 +9544,11 @@ package body Sem_Ch13 is begin if No (Component_Clause (CD1)) then return No (Component_Clause (CD2)); - else + -- Note: at this point, component clauses have been + -- normalized to the default bit order, so that the + -- comparison of Component_Bit_Offsets is meaningful. + return Present (Component_Clause (CD2)) and then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c93b7528b15..c6e8dca4820 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8798,8 +8798,6 @@ package body Sem_Res is and then Ekind_In (Entity (S), E_Component, E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component - and then Present (Discriminant_Checking_Func - (Original_Record_Component (Entity (S)))) and then not Discriminant_Checks_Suppressed (T) and then not Init_Component then diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 59c60b9644b..3be0f5833f2 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -807,7 +807,10 @@ package Sinfo is -- This flag is set on N_Selected_Component nodes to indicate that a -- discriminant check is required using the discriminant check routine -- associated with the selector. The actual check is generated by the - -- expander when processing selected components. + -- expander when processing selected components. In the case of + -- Unchecked_Union, the flag is also set, but no discriminant check + -- routine is associated with the selector, and the expander does not + -- generate a check. -- Do_Division_Check (Flag13-Sem) -- This flag is set on a division operator (/ mod rem) to indicate diff --git a/gcc/ada/xgnatugn.adb b/gcc/ada/xgnatugn.adb index ab168170f0c..3403ad4d871 100644 --- a/gcc/ada/xgnatugn.adb +++ b/gcc/ada/xgnatugn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-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- -- @@ -129,6 +129,7 @@ procedure Xgnatugn is procedure Put_Line (F : Sfile; S : String); -- Local version of Put_Line ensures Unix style line endings + First_Time : Boolean := True; Number_Of_Warnings : Natural := 0; Number_Of_Errors : Natural := 0; Warnings_Enabled : Boolean; @@ -237,15 +238,11 @@ procedure Xgnatugn is -- It relies on information in Source_File to generate error messages. type Conditional is (Set, Clear); - procedure Push_Conditional (Cond : Conditional; Flag : Target_Type); + 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 Currently_Excluding return Boolean; - -- Returns true if conditional processing directives imply that the - -- current line should not be included in the output. - 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 @@ -266,7 +263,6 @@ procedure Xgnatugn is Starting_Line : Positive; Cond : Conditional; Flag : Flag_Type; - Excluding : Boolean; end record; Conditional_Stack_Depth : constant := 3; @@ -972,6 +968,14 @@ procedure Xgnatugn is 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; @@ -1002,6 +1006,14 @@ procedure Xgnatugn is 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; @@ -1011,8 +1023,7 @@ procedure Xgnatugn is end; end if; - if Have_Conditional and (Flag in Target_Type) then - + if Have_Conditional then -- We create a new conditional context and suppress the -- directive in the output. @@ -1020,7 +1031,6 @@ procedure Xgnatugn is elsif Line'Length >= Endsetclear'Length and then Line (1 .. Endsetclear'Length) = Endsetclear - and then (Flag in Target_Type) then -- The '@end ifset'/'@end ifclear' case is handled here. We -- have to pop the conditional context. @@ -1049,6 +1059,10 @@ procedure Xgnatugn is 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 @@ -1058,14 +1072,7 @@ procedure Xgnatugn is end; end if; -- Have_Conditional - if (not Have_Conditional) or (Flag in Edition_Type) then - - -- The ordinary case - - if not Currently_Excluding then - Put_Line (Output_File, Rewritten); - end if; - end if; + Put_Line (Output_File, Rewritten); end; end loop; @@ -1156,42 +1163,27 @@ procedure Xgnatugn is -- Push_Conditional -- ---------------------- - procedure Push_Conditional (Cond : Conditional; Flag : Target_Type) is - Will_Exclude : Boolean; - + procedure Push_Conditional (Cond : Conditional; Flag : Flag_Type) is begin - -- If we are already in an excluding context, inherit this property, - -- otherwise calculate it from scratch. + if Flag in Target_Type then - if Conditional_TOS > 0 - and then Conditional_Stack (Conditional_TOS).Excluding - then - Will_Exclude := True; - else - case Cond is - when Set => - Will_Exclude := Flag /= Target; - when Clear => - Will_Exclude := Flag = Target; - end case; - end if; + -- Check if the current directive is pointless because of a previous, + -- enclosing directive. - -- 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; + 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, - Excluding => Will_Exclude); + Flag => Flag); end Push_Conditional; --------------------- @@ -1234,16 +1226,6 @@ procedure Xgnatugn is end if; end Pop_Conditional; - ------------------------- - -- Currently_Excluding -- - ------------------------- - - function Currently_Excluding return Boolean is - begin - return Conditional_TOS > 0 - and then Conditional_Stack (Conditional_TOS).Excluding; - end Currently_Excluding; - ---------------------------- -- VMS_Context_Determined -- ---------------------------- |