From 95081e99e234224e4bff070f2b0c332097f0901e Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 5 Oct 2012 16:29:57 +0200 Subject: [PATCH] [multiple changes] 2012-10-05 Thomas Quinot * sem_dim.adb, errout.adb, errout.ads (Analyze_Dimension_Call): Add guard against abnormal tree resulting from a previously diagnosed illegality. 2012-10-05 Hristian Kirtchev * freeze.adb (Freeze_Expression): Rename local variable Cspc to Spec and update all refs to it. Do not freeze an entity outside a subprogram body when the original context is an expression function. 2012-10-05 Robert Dewar * gnat1drv.adb (Adjust_Global_Switches): Default for overflow checking is suppressed, even if backend overflow/divide checks are enabled. 2012-10-05 Ed Schonberg * einfo.adb (Set_Invariant_Procedure, Set_Predicate_Function): chain properly subprograms on Subprograms_For_Type list. * sem_ch13.ads; (Build_Invariant_Procedure_Declaration): new procedure, to create declaration for invariant procedure independently of the construction of the body, so that it can be called within expression functions. * sem_ch13.adb (Build_Invariant_Procedure): code cleanup. The declaration may already have been generated at the point an explicit invariant aspect is encountered. * sem_prag.adb; (Analyze_Pragma, case Invariant): create declaration for invariant procedure. * sem_ch7.adb (Analyze_Package_Specification): clean up call to build invariant procedure. (Preserve_Full_Attributes): propagate information about invariants if they appear on a completion, 2012-10-05 Pascal Obry * gnat_ugn.texi: Update documentation to lift Microsoft C restriction. From-SVN: r192128 --- gcc/ada/ChangeLog | 40 +++++++++++++++ gcc/ada/einfo.adb | 6 +-- gcc/ada/errout.adb | 15 ++++++ gcc/ada/errout.ads | 7 +++ gcc/ada/freeze.adb | 58 ++++++++++++++------- gcc/ada/gnat1drv.adb | 19 ++++--- gcc/ada/gnat_ugn.texi | 18 ++++--- gcc/ada/sem_ch13.adb | 115 ++++++++++++++++++++++++++++-------------- gcc/ada/sem_ch13.ads | 8 +++ gcc/ada/sem_ch7.adb | 25 ++++++++- gcc/ada/sem_dim.adb | 9 ++++ gcc/ada/sem_prag.adb | 8 ++- 12 files changed, 252 insertions(+), 76 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a17998a15953..ea4667fb2ce7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2012-10-05 Thomas Quinot + + * sem_dim.adb, errout.adb, errout.ads (Analyze_Dimension_Call): Add + guard against abnormal tree resulting from a previously diagnosed + illegality. + +2012-10-05 Hristian Kirtchev + + * freeze.adb (Freeze_Expression): Rename local variable Cspc to Spec + and update all refs to it. Do not freeze an entity outside a subprogram + body when the original context is an expression function. + +2012-10-05 Robert Dewar + + * gnat1drv.adb (Adjust_Global_Switches): Default for overflow checking + is suppressed, even if backend overflow/divide checks are enabled. + +2012-10-05 Ed Schonberg + + * einfo.adb (Set_Invariant_Procedure, Set_Predicate_Function): + chain properly subprograms on Subprograms_For_Type list. + * sem_ch13.ads; (Build_Invariant_Procedure_Declaration): new + procedure, to create declaration for invariant procedure + independently of the construction of the body, so that it can + be called within expression functions. + * sem_ch13.adb (Build_Invariant_Procedure): code cleanup. The + declaration may already have been generated at the point an + explicit invariant aspect is encountered. + * sem_prag.adb; (Analyze_Pragma, case Invariant): create declaration + for invariant procedure. + * sem_ch7.adb (Analyze_Package_Specification): clean up call to + build invariant procedure. + (Preserve_Full_Attributes): propagate information about invariants + if they appear on a completion, + +2012-10-05 Pascal Obry + + * gnat_ugn.texi: Update documentation to lift Microsoft C + restriction. + 2012-10-05 Robert Dewar * sem_util.adb (Has_One_Matching_Field): Handle case of lone diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e7c9146d6f00..bfa7593dc5d3 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -7113,6 +7113,7 @@ package body Einfo is S := Subprograms_For_Type (Id); Set_Subprograms_For_Type (Id, V); + Set_Subprograms_For_Type (V, S); while Present (S) loop if Has_Invariants (S) then @@ -7121,8 +7122,6 @@ package body Einfo is S := Subprograms_For_Type (S); end if; end loop; - - Set_Subprograms_For_Type (Id, V); end Set_Invariant_Procedure; ---------------------------- @@ -7137,6 +7136,7 @@ package body Einfo is S := Subprograms_For_Type (Id); Set_Subprograms_For_Type (Id, V); + Set_Subprograms_For_Type (V, S); while Present (S) loop if Has_Predicates (S) then @@ -7145,8 +7145,6 @@ package body Einfo is S := Subprograms_For_Type (S); end if; end loop; - - Set_Subprograms_For_Type (Id, V); end Set_Predicate_Function; ----------------- diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 6f450200ef95..64062b29e9ce 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -198,6 +198,21 @@ package body Errout is -- spec for precise definition of the conversion that is performed by this -- routine in OpenVMS mode. + -------------------- + -- Cascaded_Error -- + -------------------- + + procedure Cascaded_Error is + begin + -- An anomaly has been detected which is assumed to be a consequence of + -- a previous error. Raise an exception if no serious error has been + -- found so far. + + if Serious_Errors_Detected = 0 then + raise Program_Error; + end if; + end Cascaded_Error; + ----------------------- -- Change_Error_Text -- ----------------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 212eea4a1161..7da6493e453b 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -727,6 +727,13 @@ package Errout is -- This routine can only be called during semantic analysis. It may not -- be called during parsing. + procedure Cascaded_Error; + -- When an anomaly is detected, many semantic routines silently bail out, + -- assuming that the anomaly was caused by a previously detected error. + -- This routine should be called in these cases, and will raise an + -- exception if no serious error has been detected. This ensure that the + -- anomaly is never allowed to go unnoticed. + procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String); -- The error message text of the message identified by Id is replaced by -- the given text. This text may contain insertion characters in the diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 039325afbcfd..9e0cbcacf80f 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5156,43 +5156,63 @@ package body Freeze is -- subprogram body that we are inside. if In_Exp_Body (Parent_P) then - - -- However, we *do* want to freeze at this point if we have - -- an entity to freeze, and that entity is declared *inside* - -- the body of the expander generated procedure. This case - -- is recognized by the scope of the type, which is either - -- the spec for some enclosing body, or (in the case of - -- init_procs, for which there are no separate specs) the - -- current scope. - declare Subp : constant Node_Id := Parent (Parent_P); - Cspc : Entity_Id; + Spec : Entity_Id; begin + -- Freeze the entity only when it is declared inside the + -- body of the expander generated procedure. This case + -- is recognized by the scope of the entity or its type, + -- which is either the spec for some enclosing body, or + -- (in the case of init_procs, for which there are no + -- separate specs) the current scope. + if Nkind (Subp) = N_Subprogram_Body then - Cspc := Corresponding_Spec (Subp); + Spec := Corresponding_Spec (Subp); - if (Present (Typ) and then Scope (Typ) = Cspc) + if (Present (Typ) and then Scope (Typ) = Spec) or else - (Present (Nam) and then Scope (Nam) = Cspc) + (Present (Nam) and then Scope (Nam) = Spec) then exit; elsif Present (Typ) and then Scope (Typ) = Current_Scope - and then Current_Scope = Defining_Entity (Subp) + and then Defining_Entity (Subp) = Current_Scope then exit; end if; end if; - end; - -- If not that exception to the exception, then this is - -- where we delay the freeze till outside the body. + -- An expression function may act as a completion of + -- a function declaration. As such, it can reference + -- entities declared between the two views: - Parent_P := Parent (Parent_P); - Freeze_Outside := True; + -- Hidden []; -- 1 + -- function F return ...; + -- private + -- function Hidden return ...; + -- function F return ... is (Hidden); -- 2 + + -- Refering to the example above, freezing the expression + -- of F (2) would place Hidden's freeze node (1) in the + -- wrong place. Avoid explicit freezing and let the usual + -- scenarios do the job - for example, reaching the end + -- of the private declarations. + + if Nkind (Original_Node (Subp)) = + N_Expression_Function + then + null; + + -- Freeze outside the body + + else + Parent_P := Parent (Parent_P); + Freeze_Outside := True; + end if; + end; -- Here if normal case where we are in handled statement -- sequence and want to do the insertion right there. diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 2d79edfeca93..a4d01c9f8bad 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -328,12 +328,17 @@ procedure Gnat1drv is Exception_Mechanism := Back_End_Exceptions; end if; - -- Set proper status for overflow checks. If already set (by -gnato or - -- -gnatp) then we have nothing to do. + -- Set proper status for overflow checks + + -- If already set (by - gnato or -gnatp) then we have nothing to do if Opt.Suppress_Options.Overflow_Checks_General /= Not_Set then null; + -- Otherwise set appropriate default mode. Note: at present we set + -- SUPPRESSED in all three of the following cases. They are separated + -- because in the future we may make different choices. + -- By default suppress overflow checks in -gnatg mode elsif GNAT_Mode then @@ -341,16 +346,18 @@ procedure Gnat1drv is Suppress_Options.Overflow_Checks_Assertions := Suppressed; -- If we have backend divide and overflow checks, then by default - -- overflow checks are minimized, which is a reasonable setting. + -- overflow checks are suppressed. Historically this code used to + -- activate overflow checks, although no target currently has these + -- flags set, so this was dead code anyway. elsif Targparm.Backend_Divide_Checks_On_Target and Targparm.Backend_Overflow_Checks_On_Target then - Suppress_Options.Overflow_Checks_General := Minimized; - Suppress_Options.Overflow_Checks_Assertions := Minimized; + Suppress_Options.Overflow_Checks_General := Suppressed; + Suppress_Options.Overflow_Checks_Assertions := Suppressed; - -- Otherwise for now, default is checks are suppressed. This is likely + -- Otherwise for now, default is checks are suppressed. This is subject -- to change in the future, but for now this is the compatible behavior -- with previous versions of GNAT. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 45c02d84b18c..b94f035ba918 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -28212,9 +28212,15 @@ success. It should be possible to use @code{GetLastError} and features are not used, but it is not guaranteed to work. @item -It is not possible to link against Microsoft libraries except for +It is not possible to link against Microsoft C++ libraries except for import libraries. Interfacing must be done by the mean of DLLs. +@item +It is possible to link against Microsoft C libraries. Yet the preferred +solution is to use C/C++ compiler that comes with @value{EDITION}, since it +doesn't require having two different development environments and makes the +inter-language debugging experience smoother. + @item When the compilation environment is located on FAT32 drives, users may experience recompilations of the source files that have not changed if @@ -28302,14 +28308,14 @@ application that contains a mix of Ada and C/C++, the choice of your Windows C/C++ development environment conditions your overall interoperability strategy. -If you use @command{gcc} to compile the non-Ada part of your application, -there are no Windows-specific restrictions that affect the overall -interoperability with your Ada code. If you do want to use the -Microsoft tools for your non-Ada code, you have two choices: +If you use @command{gcc} or Microsoft C to compile the non-Ada part of +your application, there are no Windows-specific restrictions that +affect the overall interoperability with your Ada code. If you do want +to use the Microsoft tools for your C++ code, you have two choices: @enumerate @item -Encapsulate your non-Ada code in a DLL to be linked with your Ada +Encapsulate your C++ code in a DLL to be linked with your Ada application. In this case, use the Microsoft or whatever environment to build the DLL and use GNAT to build your executable (@pxref{Using DLLs with GNAT}). diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d75b70b68d23..521eb80b1744 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4902,6 +4902,48 @@ package body Sem_Ch13 is end if; end Analyze_Record_Representation_Clause; + ------------------------------------------- + -- Build_Invariant_Procedure_Declaration -- + ------------------------------------------- + + function Build_Invariant_Procedure_Declaration + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + Spec : Node_Id; + SId : Entity_Id; + + begin + Set_Etype (Object_Entity, Typ); + + -- Check for duplicate definiations. + + if Has_Invariants (Typ) + and then Present (Invariant_Procedure (Typ)) + then + return Empty; + end if; + + SId := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Invariant")); + Set_Has_Invariants (SId); + Set_Has_Invariants (Typ); + Set_Ekind (SId, E_Procedure); + Set_Invariant_Procedure (Typ, SId); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + return Make_Subprogram_Declaration (Loc, Specification => Spec); + end Build_Invariant_Procedure_Declaration; + ------------------------------- -- Build_Invariant_Procedure -- ------------------------------- @@ -4936,12 +4978,11 @@ package body Sem_Ch13 is -- "inherited" to the exception message and generating an informational -- message about the inheritance of an invariant. - Object_Name : constant Name_Id := New_Internal_Name ('I'); + Object_Name : Name_Id; -- Name for argument of invariant procedure - Object_Entity : constant Node_Id := - Make_Defining_Identifier (Loc, Object_Name); - -- The procedure declaration entity for the argument + Object_Entity : Node_Id; + -- The entity of the formal for the procedure -------------------- -- Add_Invariants -- @@ -5140,7 +5181,29 @@ package body Sem_Ch13 is Stmts := No_List; PDecl := Empty; PBody := Empty; - Set_Etype (Object_Entity, Typ); + SId := Empty; + + -- If the aspect specification exists for some view of the type, the + -- declaration for the procedure has been created. + + if Has_Invariants (Typ) then + SId := Invariant_Procedure (Typ); + end if; + + if Present (SId) then + PDecl := Unit_Declaration_Node (SId); + + else + PDecl := Build_Invariant_Procedure_Declaration (Typ); + end if; + + -- Recover formal of procedure, for use in the calls to invariant + -- functions (including inherited ones). + + Object_Entity := + Defining_Identifier + (First (Parameter_Specifications (Specification (PDecl)))); + Object_Name := Chars (Object_Entity); -- Add invariants for the current type @@ -5174,38 +5237,7 @@ package body Sem_Ch13 is if Stmts /= No_List then - -- Build procedure declaration - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Invariant")); - Set_Has_Invariants (SId); - Set_Invariant_Procedure (Typ, SId); - - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc)))); - - PDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); - - -- Build procedure body - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Invariant")); - - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + Spec := Copy_Separate_Tree (Specification (PDecl)); PBody := Make_Subprogram_Body (Loc, @@ -5216,14 +5248,18 @@ package body Sem_Ch13 is Statements => Stmts)); -- Insert procedure declaration and spec at the appropriate points. + -- If declaration is already analyzed, it was processed by the + -- generated pragma. if Present (Private_Decls) then -- The spec goes at the end of visible declarations, but they have -- already been analyzed, so we need to explicitly do the analyze. - Append_To (Visible_Decls, PDecl); - Analyze (PDecl); + if not Analyzed (PDecl) then + Append_To (Visible_Decls, PDecl); + Analyze (PDecl); + end if; -- The body goes at the end of the private declarations, which we -- have not analyzed yet, so we do not need to perform an explicit @@ -5523,6 +5559,7 @@ package body Sem_Ch13 is Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), "Predicate")); Set_Has_Predicates (SId); + Set_Ekind (SId, E_Function); Set_Predicate_Function (Typ, SId); -- The predicate function is shared between views of a type. diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 0ac7386e8782..611f3f1c6172 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -46,6 +46,14 @@ package Sem_Ch13 is -- order is specified and there is at least one component clause. Adjusts -- component positions according to either Ada 95 or Ada 2005 (AI-133). + function Build_Invariant_Procedure_Declaration + (Typ : Entity_Id) return Node_Id; + -- If a type declaration has a specified invariant aspect, build the + -- declaration for the procedure at once, so that calls to it can be + -- generated before the body of the invariant procedure is built. This + -- is needed in the presence of public expression functions that return + -- the type in question. + procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id); -- Typ is a private type with invariants (indicated by Has_Invariants being -- set for Typ, indicating the presence of pragma Invariant entries on the diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 326219d1fc64..103aa5b2bdd5 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -28,6 +28,7 @@ -- handling of private and full declarations, and the construction of dispatch -- tables for tagged types. +with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; @@ -1387,7 +1388,21 @@ package body Sem_Ch7 is and then Nkind (Parent (E)) = N_Full_Type_Declaration and then Has_Aspects (Parent (E)) then - Build_Invariant_Procedure (E, N); + declare + ASN : Node_Id; + begin + ASN := First (Aspect_Specifications (Parent (E))); + while Present (ASN) loop + if Chars (Identifier (ASN)) = Name_Invariant + or else Chars (Identifier (ASN)) = Name_Type_Invariant + then + Build_Invariant_Procedure (E, N); + exit; + end if; + + Next (ASN); + end loop; + end; end if; Next_Entity (E); @@ -2143,6 +2158,14 @@ package body Sem_Ch7 is Set_Freeze_Node (Priv, Freeze_Node (Full)); + -- Propagate information of type invariants, which may be specified + -- for the full view. + + if Has_Invariants (Full) and not Has_Invariants (Priv) then + Set_Has_Invariants (Priv); + Set_Subprograms_For_Type (Priv, Subprograms_For_Type (Full)); + end if; + if Is_Tagged_Type (Priv) and then Is_Tagged_Type (Full) and then not Error_Posted (Full) diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index afe7d85ae6ae..9b9de0a102ba 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1629,6 +1629,15 @@ package body Sem_Dim is Formal := First_Formal (Nam); while Present (Formal) loop + + -- A missing corresponding actual indicates that the analysis of + -- the call was aborted due to a previous error. + + if No (Actual) then + Cascaded_Error; + return; + end if; + Formal_Typ := Etype (Formal); Dims_Of_Formal := Dimensions_Of (Formal_Typ); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c791c3344a75..1739673bf06c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10329,6 +10329,7 @@ package body Sem_Prag is when Pragma_Invariant => Invariant : declare Type_Id : Node_Id; Typ : Entity_Id; + PDecl : Node_Id; Discard : Boolean; pragma Unreferenced (Discard); @@ -10380,8 +10381,13 @@ package body Sem_Prag is -- Note that the type has at least one invariant, and also that -- it has inheritable invariants if we have Invariant'Class. + -- Build the corresponding invariant procedure declaration, so + -- that calls to it can be generated before the body is built + -- (for example wihin an expression function). - Set_Has_Invariants (Typ); + PDecl := Build_Invariant_Procedure_Declaration (Typ); + Insert_After (N, PDecl); + Analyze (PDecl); if Class_Present (N) then Set_Has_Inheritable_Invariants (Typ); -- 2.47.2