diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-06-22 15:28:59 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-06-22 15:28:59 +0200 |
commit | f61580d461bc5773ef4b894852195630b007c601 (patch) | |
tree | 4b42ff27b8bbc52a2a7f6a8d4867f75dbaf294aa | |
parent | 6823270cb98959be5157725c7e0efd87c0b61e23 (diff) | |
download | gcc-f61580d461bc5773ef4b894852195630b007c601.zip gcc-f61580d461bc5773ef4b894852195630b007c601.tar.gz gcc-f61580d461bc5773ef4b894852195630b007c601.tar.bz2 |
[multiple changes]
2009-06-22 Jose Ruiz <ruiz@adacore.com>
* sysdep.c (__gnat_localtime_tzoff for RTX):
SystemTimeToTzSpecificLocalTime is not supported by RTX. Use
GetTimeZoneInformation instead.
2009-06-22 Robert Dewar <dewar@adacore.com>
* sem_res.adb (Check_No_Direct_Boolean_Operators): New procedure
2009-06-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Collect_Previous_Instances): Do not collect
instantiations declared in a previous generic package body.
2009-06-22 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Add doc that X=True and X=False is allowed for the
restriction No_Direct_Boolean_Operators.
2009-06-22 Thomas Quinot <quinot@adacore.com>
* bindusg.adb: Minor fixes to gnatbind usage message
* sem_eval.adb: Minor reformatting
From-SVN: r148794
-rw-r--r-- | gcc/ada/ChangeLog | 26 | ||||
-rw-r--r-- | gcc/ada/bindusg.adb | 6 | ||||
-rw-r--r-- | gcc/ada/gnat_rm.texi | 4 | ||||
-rw-r--r-- | gcc/ada/sem_ch12.adb | 118 | ||||
-rw-r--r-- | gcc/ada/sem_eval.adb | 8 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 53 | ||||
-rw-r--r-- | gcc/ada/sysdep.c | 18 |
7 files changed, 149 insertions, 84 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3fd0df3..8499c84 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2009-06-22 Jose Ruiz <ruiz@adacore.com> + + * sysdep.c (__gnat_localtime_tzoff for RTX): + SystemTimeToTzSpecificLocalTime is not supported by RTX. Use + GetTimeZoneInformation instead. + +2009-06-22 Robert Dewar <dewar@adacore.com> + + * sem_res.adb (Check_No_Direct_Boolean_Operators): New procedure + +2009-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Collect_Previous_Instances): Do not collect + instantiations declared in a previous generic package body. + +2009-06-22 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Add doc that X=True and X=False is allowed for the + restriction No_Direct_Boolean_Operators. + +2009-06-22 Thomas Quinot <quinot@adacore.com> + + * bindusg.adb: Minor fixes to gnatbind usage message + + * sem_eval.adb: Minor reformatting + 2009-06-22 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Analyze_Object_Declaration, Freeze_Entity): Move to the diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index 19d0c14..2529c35 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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- -- @@ -99,7 +99,7 @@ package body Bindusg is -- Line for D switch Write_Line (" -Dnn[k|m] Default secondary stack " & - "size = nnn [kilo|mega] bytes"); + "size = nn [kilo|mega] bytes"); -- Line for -e switch @@ -108,7 +108,7 @@ package body Bindusg is -- Line for -E switch - Write_Line (" -E Store tracebacks in Exception occurrences"); + Write_Line (" -E Store tracebacks in exception occurrences"); -- The -f switch is voluntarily omitted, because it is obsolete diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index ba84ee1..97c4d2b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -8431,7 +8431,9 @@ This restriction ensures that no logical (and/or/xor) or comparison operators are used on operands of type Boolean (or any type derived from Boolean). This is intended for use in safety critical programs where the certification protocol requires the use of short-circuit -(and then, or else) forms for all composite boolean operations. +(and then, or else) forms for all composite boolean operations. An +exception is that an explicit equality test with True or False as the +right operand is not considered to violate this restriction. @item No_Dispatching_Calls @findex No_Dispatching_Calls diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a3f7cde..f7d5a1a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -10465,15 +10465,16 @@ package body Sem_Ch12 is -- declared without a box (see Instantiate_Formal_Package). Such -- an instantiation does not generate any code (the actual code -- comes from actual) and thus does not need to be analyzed here. + -- If the instantiation appears with a generic package body it is + -- not analyzed here either. elsif Nkind (Decl) = N_Package_Instantiation and then not Is_Internal (Defining_Entity (Decl)) then Append_Elmt (Decl, Previous_Instances); - -- For a subprogram instantiation, omit instantiations of - -- intrinsic operations (Unchecked_Conversions, etc.) that - -- have no bodies. + -- For a subprogram instantiation, omit instantiations intrinsic + -- operations (Unchecked_Conversions, etc.) that have no bodies. elsif Nkind_In (Decl, N_Function_Instantiation, N_Procedure_Instantiation) @@ -10487,7 +10488,9 @@ package body Sem_Ch12 is Collect_Previous_Instances (Private_Declarations (Specification (Decl))); - elsif Nkind (Decl) = N_Package_Body then + elsif Nkind (Decl) = N_Package_Body + and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package + then Collect_Previous_Instances (Declarations (Decl)); end if; @@ -10520,8 +10523,8 @@ package body Sem_Ch12 is and then Nkind (True_Parent) /= N_Compilation_Unit loop if Nkind (True_Parent) = N_Package_Declaration - and then - Nkind (Original_Node (True_Parent)) = N_Package_Instantiation + and then + Nkind (Original_Node (True_Parent)) = N_Package_Instantiation then -- Parent is a compilation unit that is an instantiation. -- Instantiation node has been replaced with package decl. @@ -10572,9 +10575,9 @@ package body Sem_Ch12 is Set_Unit (Parent (True_Parent), Inst_Node); end if; - -- Now complete instantiation of enclosing body, if it appears - -- in some other unit. If it appears in the current unit, the - -- body will have been instantiated already. + -- Now complete instantiation of enclosing body, if it appears in + -- some other unit. If it appears in the current unit, the body + -- will have been instantiated already. if No (Corresponding_Body (Instance_Spec (Inst_Node))) then @@ -10605,8 +10608,8 @@ package body Sem_Ch12 is Scop := Scope (Scop); end loop; - -- Collect previous instantiations in the unit that - -- contains the desired generic. + -- Collect previous instantiations in the unit that contains + -- the desired generic. if Nkind (Parent (True_Parent)) /= N_Compilation_Unit and then not Body_Optional @@ -10635,7 +10638,7 @@ package body Sem_Ch12 is (Private_Declarations (Specification (Par))); else - -- Enclosing unit is a subprogram body, In this + -- Enclosing unit is a subprogram body. In this -- case all instance bodies are processed in order -- and there is no need to collect them separately. @@ -10753,9 +10756,7 @@ package body Sem_Ch12 is E1 := First_Entity (Form); E2 := First_Entity (Act); - while Present (E1) - and then E1 /= First_Private_Entity (Form) - loop + while Present (E1) and then E1 /= First_Private_Entity (Form) loop -- Could this test be a single condition??? -- Seems like it could, and isn't FPE (Form) a constant anyway??? @@ -10764,9 +10765,7 @@ package body Sem_Ch12 is and then not Is_Class_Wide_Type (E1) and then not Is_Internal_Name (Chars (E1)) then - while Present (E2) - and then Chars (E2) /= Chars (E1) - loop + while Present (E2) and then Chars (E2) /= Chars (E1) loop Next_Entity (E2); end loop; @@ -10775,21 +10774,15 @@ package body Sem_Ch12 is else Set_Instance_Of (E1, E2); - if Is_Type (E1) - and then Is_Tagged_Type (E2) - then - Set_Instance_Of - (Class_Wide_Type (E1), Class_Wide_Type (E2)); + if Is_Type (E1) and then Is_Tagged_Type (E2) then + Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); end if; if Is_Constrained (E1) then - Set_Instance_Of - (Base_Type (E1), Base_Type (E2)); + Set_Instance_Of (Base_Type (E1), Base_Type (E2)); end if; - if Ekind (E1) = E_Package - and then No (Renamed_Object (E1)) - then + if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then Map_Formal_Package_Entities (E1, E2); end if; end if; @@ -10881,24 +10874,23 @@ package body Sem_Ch12 is -- recurse. Nested generic packages will have been processed from the -- inside out. - if Nkind (Decl) = N_Package_Declaration then - Spec := Specification (Decl); + case Nkind (Decl) is + when N_Package_Declaration => + Spec := Specification (Decl); - elsif Nkind (Decl) = N_Task_Type_Declaration then - Spec := Task_Definition (Decl); + when N_Task_Type_Declaration => + Spec := Task_Definition (Decl); - elsif Nkind (Decl) = N_Protected_Type_Declaration then - Spec := Protected_Definition (Decl); + when N_Protected_Type_Declaration => + Spec := Protected_Definition (Decl); - else - Spec := Empty; - end if; + when others => + Spec := Empty; + end case; if Present (Spec) then - Move_Freeze_Nodes (Out_Of, Next_Node, - Visible_Declarations (Spec)); - Move_Freeze_Nodes (Out_Of, Next_Node, - Private_Declarations (Spec)); + Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); + Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); end if; Next (Decl); @@ -11054,9 +11046,9 @@ package body Sem_Ch12 is procedure Remove_Parent (In_Body : Boolean := False) is S : Entity_Id := Current_Scope; - -- S is the scope containing the instantiation just completed. The - -- scope stack contains the parent instances of the instantiation, - -- followed by the original S. + -- S is the scope containing the instantiation just completed. The scope + -- stack contains the parent instances of the instantiation, followed by + -- the original S. E : Entity_Id; P : Entity_Id; @@ -11084,19 +11076,18 @@ package body Sem_Ch12 is and then P /= Current_Scope then -- We are within an instance of some sibling. Retain - -- visibility of parent, for proper subsequent cleanup, - -- and reinstall private declarations as well. + -- visibility of parent, for proper subsequent cleanup, and + -- reinstall private declarations as well. Set_In_Private_Part (P); Install_Private_Declarations (P); end if; -- If the ultimate parent is a top-level unit recorded in - -- Instance_Parent_Unit, then reset its visibility to what - -- it was before instantiation. (It's not clear what the - -- purpose is of testing whether Scope (P) is In_Open_Scopes, - -- but that test was present before the ultimate parent test - -- was added.???) + -- Instance_Parent_Unit, then reset its visibility to what is was + -- before instantiation. (It's not clear what the purpose is of + -- testing whether Scope (P) is In_Open_Scopes, but that test was + -- present before the ultimate parent test was added.???) elsif not In_Open_Scopes (Scope (P)) or else (P = Instance_Parent_Unit @@ -11111,9 +11102,7 @@ package body Sem_Ch12 is -- subunit of a generic contains an instance of a child unit of -- its generic parent unit. - elsif S = Current_Scope - and then Is_Generic_Instance (S) - then + elsif S = Current_Scope and then Is_Generic_Instance (S) then declare Par : constant Entity_Id := Generic_Parent @@ -11141,9 +11130,9 @@ package body Sem_Ch12 is end loop; else - -- Each body is analyzed separately, and there is no context - -- that needs preserving from one body instance to the next, - -- so remove all parent scopes that have been installed. + -- Each body is analyzed separately, and there is no context that + -- needs preserving from one body instance to the next, so remove all + -- parent scopes that have been installed. while Present (S) loop End_Package_Scope (S); @@ -11163,7 +11152,6 @@ package body Sem_Ch12 is begin if No (Current_Instantiated_Parent.Act_Id) then - -- Restore environment after subprogram inlining Restore_Private_Views (Empty); @@ -11196,8 +11184,8 @@ package body Sem_Ch12 is Dep_Typ : Node_Id; procedure Restore_Nested_Formal (Formal : Entity_Id); - -- Hide the generic formals of formal packages declared with box - -- which were reachable in the current instantiation. + -- Hide the generic formals of formal packages declared with box which + -- were reachable in the current instantiation. --------------------------- -- Restore_Nested_Formal -- @@ -11241,9 +11229,9 @@ package body Sem_Ch12 is -- Subtypes of types whose views have been exchanged, and that -- are defined within the instance, were not on the list of - -- Private_Dependents on entry to the instance, so they have to - -- be exchanged explicitly now, in order to remain consistent with - -- the view of the parent type. + -- Private_Dependents on entry to the instance, so they have to be + -- exchanged explicitly now, in order to remain consistent with the + -- view of the parent type. if Ekind (Typ) = E_Private_Type or else Ekind (Typ) = E_Limited_Private_Type @@ -11272,8 +11260,8 @@ package body Sem_Ch12 is return; end if; - -- Make the generic formal parameters private, and make the formal - -- types into subtypes of the actuals again. + -- Make the generic formal parameters private, and make the formal types + -- into subtypes of the actuals again. E := First_Entity (Pack_Id); while Present (E) loop diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 19abf4b..fb18cf3 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -706,7 +706,7 @@ package body Sem_Eval is return Unknown; -- For access types, the only time we know the result at compile time - -- (apart from identical operands, which we handled already, is if we + -- (apart from identical operands, which we handled already) is if we -- know one operand is null and the other is not, or both operands are -- known null. @@ -720,9 +720,7 @@ package body Sem_Eval is return Unknown; end if; - elsif Known_Non_Null (L) - and then Known_Null (R) - then + elsif Known_Non_Null (L) and then Known_Null (R) then return NE; else @@ -792,7 +790,7 @@ package body Sem_Eval is -- For remaining scalar cases we know exactly (note that this does -- include the fixed-point case, where we know the run time integer - -- values now) + -- values now). else declare diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index d6113d8..e1a934b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -119,6 +119,11 @@ package body Sem_Res is -- initialization of individual components within the init proc itself. -- Could be optimized away perhaps? + procedure Check_No_Direct_Boolean_Operators (N : Node_Id); + -- N is the node for a comparison or logical operator. If the operator + -- is predefined, and the root type of the operands is Standard.Boolean, + -- then a check is made for restriction No_Direct_Boolean_Operators. + function Is_Definite_Access_Type (E : Entity_Id) return Boolean; -- Determine whether E is an access type declared by an access -- declaration, and not an (anonymous) allocator type. @@ -926,6 +931,38 @@ package body Sem_Res is end if; end Check_Initialization_Call; + --------------------------------------- + -- Check_No_Direct_Boolean_Operators -- + --------------------------------------- + + procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is + begin + if Scope (Entity (N)) = Standard_Standard + and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean + then + -- Restriction does not apply to generated code + + if not Comes_From_Source (N) then + null; + + -- Restriction does not apply for A=False, A=True + + elsif Nkind (N) = N_Op_Eq + and then (Is_Entity_Name (Right_Opnd (N)) + and then (Entity (Right_Opnd (N)) = Standard_True + or else + Entity (Right_Opnd (N)) = Standard_False)) + then + null; + + -- Otherwise restriction applies + + else + Check_Restriction (No_Direct_Boolean_Operators, N); + end if; + end if; + end Check_No_Direct_Boolean_Operators; + ------------------------------ -- Check_Parameterless_Call -- ------------------------------ @@ -5431,6 +5468,8 @@ package body Sem_Res is T : Entity_Id; begin + Check_No_Direct_Boolean_Operators (N); + -- If this is an intrinsic operation which is not predefined, use the -- types of its declared arguments to resolve the possibly overloaded -- operands. Otherwise the operands are unambiguous and specify the @@ -6154,6 +6193,8 @@ package body Sem_Res is -- Start of processing for Resolve_Equality_Op begin + Check_No_Direct_Boolean_Operators (N); + Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); @@ -6609,9 +6650,10 @@ package body Sem_Res is procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is B_Typ : Entity_Id; - N_Opr : constant Node_Kind := Nkind (N); begin + Check_No_Direct_Boolean_Operators (N); + -- Predefined operations on scalar types yield the base type. On the -- other hand, logical operations on arrays yield the type of the -- arguments (and the context). @@ -6654,15 +6696,6 @@ package body Sem_Res is Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); - - -- Check for violation of restriction No_Direct_Boolean_Operators - -- if the operator was not eliminated by the Eval_Logical_Op call. - - if Nkind (N) = N_Opr - and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean - then - Check_Restriction (No_Direct_Boolean_Operators, N); - end if; end Resolve_Logical_Op; --------------------------- diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index df3bee2..c048950 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -764,6 +764,22 @@ __gnat_localtime_tzoff (const time_t *timer, long *off) (*Lock_Task) (); +#ifdef RTX + + tzi_status = GetTimeZoneInformation (&tzi); + *off = tzi.Bias; + if (tzi_status == TIME_ZONE_ID_STANDARD) + /* The system is operating in the range covered by the StandardDate + member. */ + *off = *off + tzi.StandardBias; + else if (tzi_status == TIME_ZONE_ID_DAYLIGHT) + /* The system is operating in the range covered by the DaylightDate + member. */ + *off = *off + tzi.DaylightBias; + *off = *off * -60; + +#else + /* First convert unix time_t structure to windows FILETIME format. */ utc_time.ull_time = ((unsigned long long) *timer + w32_epoch_offset) * 10000000ULL; @@ -792,6 +808,8 @@ __gnat_localtime_tzoff (const time_t *timer, long *off) else *off = - (long) ((utc_time.ull_time - local_time.ull_time) / 10000000ULL); +#endif + (*Unlock_Task) (); } |