diff options
Diffstat (limited to 'gcc/ada')
32 files changed, 514 insertions, 324 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 806a2ca..bd1e2ae 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,71 @@ +2025-10-27 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/29958 + * sem_ch7.adb (Declare_Inherited_Private_Subprograms): Deal with + formal types specially. + +2025-10-27 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/25988 + * sem_ch12.adb (Save_Global_References.Reset_Entity): Also call + Save_Global_Defaults for instances with an expanded name. + (Save_Global_References.Save_References): Minor code cleanup. + +2025-10-27 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/15800 + * freeze.adb (Freeze_Entity.Freeze_Record_Type): Small cleanup + in code and comments. + * gcc-interface/utils.cc (create_field_decl): Assert that the type + of the field is frozen at this point. + +2025-10-26 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/13370 + * sem_prag.adb (Analyze_Pragma) <Pragma_Machine_Attribute>: Set the + Has_Delayed_Freeze flag if the argument is not a literal. + +2025-10-24 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/80033 + * gcc-interface/Makefile.in (force): Restore. + +2025-10-24 Nicolas Boulenguez <nicolas@debian.org> + + PR ada/80033 + * gcc-interface/Makefile.in (deftarg.o): Delete. + (init-vxsim.o): Likewise. + (force): Likewise. + +2025-10-24 Mivirl <octoberstargazer7405@mivirl.dev> + + PR ada/122367 + * rtinit.c (__gnat_runtime_initialize) [__MINGW32__]: Fix detection + of quoted arguments. + +2025-10-24 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/118782 + * styleg.adb (Is_Box_Comment): Also stop the loop at EOF. + +2025-10-24 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/113516 + * s-oscons-tmplt.c [_WIN32]: Undefine POLLPRI before redefining it. + +2025-10-24 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/98879 + * terminals.c (__gnat_setup_child_communication) [_WIN32]: Add else + blocks in the processing of the data returned by ReadFile. + +2025-10-24 Nicolas Boulenguez <nicolas@debian.org> + + PR ada/81087 + * gnatlink.adb (Is_Prefix): Move around, streamline and return false + when the prefix is not strict. + (Gnatlink): Fix other instances of incorrect lower bound assumption. + 2025-10-20 Eric Botcazou <ebotcazou@adacore.com> PR ada/102078 diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 7b78d91..adc3951 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -107,7 +107,6 @@ #ifdef __QNX__ #include <sys/syspage.h> #include <sys/time.h> -#include <signal.h> #endif #ifdef IN_RTS @@ -3720,68 +3719,6 @@ void __gnat_killprocesstree (int pid, int sig_num) */ } -#if defined (__QNX__) - -static __thread sigset_t set; -static __thread sigset_t oset; -static __thread int signals_disabled = 0; - -int __gnat_disable_signals(void) -{ - sigemptyset(&set); - sigaddset(&set, SIGHUP); - sigaddset(&set, SIGINT); - sigaddset(&set, SIGQUIT); - sigaddset(&set, SIGILL); - sigaddset(&set, SIGTRAP); - sigaddset(&set, SIGIOT); - sigaddset(&set, SIGABRT); - sigaddset(&set, SIGEMT); - sigaddset(&set, SIGDEADLK); - sigaddset(&set, SIGFPE); - sigaddset(&set, SIGKILL); - sigaddset(&set, SIGBUS); - sigaddset(&set, SIGSEGV); - sigaddset(&set, SIGSYS); - sigaddset(&set, SIGPIPE); - sigaddset(&set, SIGALRM); - sigaddset(&set, SIGTERM); - sigaddset(&set, SIGUSR1); - sigaddset(&set, SIGUSR2); - sigaddset(&set, SIGCHLD); - sigaddset(&set, SIGCLD); - sigaddset(&set, SIGPWR); - sigaddset(&set, SIGWINCH); - sigaddset(&set, SIGURG); - sigaddset(&set, SIGPOLL); - sigaddset(&set, SIGIO); - sigaddset(&set, SIGSTOP); - sigaddset(&set, SIGTSTP); - sigaddset(&set, SIGCONT); - sigaddset(&set, SIGTTIN); - sigaddset(&set, SIGTTOU); - sigaddset(&set, SIGVTALRM); - sigaddset(&set, SIGPROF); - sigaddset(&set, SIGXCPU); - sigaddset(&set, SIGXFSZ); - sigaddset(&set, SIGDOOM); - - int ret = sigprocmask(SIG_BLOCK, &set, &oset); - signals_disabled = !ret; - return ret; -} - -int __gnat_enable_signals(void) -{ - if (!signals_disabled) { - return 0; - } - signals_disabled = 0; - return sigprocmask(SIG_SETMASK, &oset, 0); -} - -#endif - #ifdef __cplusplus } #endif diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index c9eaea1..aecbbe2 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -282,7 +283,9 @@ package body Aspects is begin -- Aspect Unsigned_Base_Range temporarily disabled - if Name = Name_Unsigned_Base_Range then + if Name = Name_Unsigned_Base_Range + and then not Debug_Flag_Dot_U + then return No_Aspect; end if; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 14d9ba4..327bc2d 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2766,14 +2766,14 @@ package body Atree is -- it is global and hence a tree traversal with parents must be finished -- before the next tree traversal with parents starts. - pragma Assert (Parents_Stack.Last = 0); - Parents_Stack.Set_Last (0); + pragma Assert (Parents_Stack.Is_Empty); + Parents_Stack.Clear; Parents_Stack.Append (Parent (Node)); Result := Traverse (Node); Parents_Stack.Decrement_Last; - pragma Assert (Parents_Stack.Last = 0); + pragma Assert (Parents_Stack.Is_Empty); return Result; end Traverse_Func_With_Parent; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index b7c54a0..ffe4adc 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -105,7 +105,7 @@ package body Debug is -- d.r Disable reordering of components in record types -- d.s Strict secondary stack management -- d.t Disable static allocation of library level dispatch tables - -- d.u + -- d.u Enable Unsigned_Base_Range aspect language extension -- d.v Enforce SPARK elaboration rules in SPARK code -- d.w Do not check for infinite loops -- d.x No exception handlers @@ -800,7 +800,8 @@ package body Debug is -- previous dynamic construction of tables. It is there as a possible -- work around if we run into trouble with the new implementation. - -- d.u + -- d.u Enable the support for Unsigned_Base_Range aspect, attribute, and + -- pragma. -- d.v This flag enforces the elaboration rules defined in the SPARK -- Reference Manual, chapter 7.7, to all SPARK code within a unit. As diff --git a/gcc/ada/doc/gnat_rm/obsolescent_features.rst b/gcc/ada/doc/gnat_rm/obsolescent_features.rst index d78d986f..f1e2061 100644 --- a/gcc/ada/doc/gnat_rm/obsolescent_features.rst +++ b/gcc/ada/doc/gnat_rm/obsolescent_features.rst @@ -14,7 +14,7 @@ historical compatibility purposes. PolyORB ======== -AWS is a deprecated product. It will be baselined with the GNAT Pro +PolyORB is a deprecated product. It will be baselined with the GNAT Pro release 28. After this release, there will be no new versions of this product. Contact your sales representative or send a message to sales@adacore.com to get recommendations for replacements. diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 290ae33..b0acb25 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -333,7 +333,8 @@ package body Einfo.Utils is function Is_Modular_Integer_Type (Id : E) return B is begin - return Ekind (Id) in Modular_Integer_Kind; + return Ekind (Id) in Modular_Integer_Kind + and then not Has_Unsigned_Base_Range_Aspect (Base_Type (Id)); end Is_Modular_Integer_Type; function Is_Named_Access_Type (Id : E) return B is @@ -393,7 +394,10 @@ package body Einfo.Utils is function Is_Signed_Integer_Type (Id : E) return B is begin - return Ekind (Id) in Signed_Integer_Kind; + return Ekind (Id) in Signed_Integer_Kind + or else + (Ekind (Id) in Modular_Integer_Kind + and then Has_Unsigned_Base_Range_Aspect (Base_Type (Id))); end Is_Signed_Integer_Type; function Is_Subprogram (Id : E) return B is diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b5d9c1c..b9548a7 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -5757,6 +5757,7 @@ package Einfo is -- Non_Binary_Modulus (base type only) -- Has_Biased_Representation -- Has_Shift_Operator (base type only) + -- Has_Unsigned_Base_Range_Aspect (base type only) -- No_Predicate_On_Actual -- No_Dynamic_Predicate_On_Actual -- Type_Low_Bound (synth) diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 8759099..1107af3 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -595,7 +595,8 @@ package body Exp_Fixd is Defining_Identifier => Dnn, Object_Definition => New_Occurrence_Of (QR_Typ, Loc), Constant_Present => True, - Expression => Build_Multiply (N, Y, Z))); + Expression => + Build_Conversion (N, QR_Typ, Build_Multiply (N, Y, Z)))); Quo := Build_Divide (N, @@ -656,8 +657,8 @@ package body Exp_Fixd is function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); - Left_Type : constant Entity_Id := Etype (L); - Right_Type : constant Entity_Id := Etype (R); + Left_Type : constant Entity_Id := Base_Type (Etype (L)); + Right_Type : constant Entity_Id := Base_Type (Etype (R)); Left_Size : Int; Right_Size : Int; Result_Type : Entity_Id; @@ -746,8 +747,8 @@ package body Exp_Fixd is function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); - Left_Type : constant Entity_Id := Etype (L); - Right_Type : constant Entity_Id := Etype (R); + Left_Type : constant Entity_Id := Base_Type (Etype (L)); + Right_Type : constant Entity_Id := Base_Type (Etype (R)); Result_Type : Entity_Id; Rnode : Node_Id; @@ -959,7 +960,8 @@ package body Exp_Fixd is Defining_Identifier => Nnn, Object_Definition => New_Occurrence_Of (QR_Typ, Loc), Constant_Present => True, - Expression => Build_Multiply (N, X, Y)), + Expression => + Build_Conversion (N, QR_Typ, Build_Multiply (N, X, Y))), Make_Object_Declaration (Loc, Defining_Identifier => Dnn, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 30b2461..4d88626 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -12613,8 +12613,12 @@ package body Exp_Util is -- Local variables Loc : constant Source_Ptr := Sloc (Exp); - Exp_Type : constant Entity_Id := Etype (Exp); Svg_Suppress : constant Suppress_Record := Scope_Suppress; + Typ : constant Entity_Id := Etype (Exp); + Und_Typ : constant Entity_Id := + (if Present (Typ) then Underlying_Type (Typ) else Typ); + -- The underlying type that drives part of the processing + Def_Id : Entity_Id; E : Node_Id; New_Exp : Node_Id; @@ -12640,8 +12644,9 @@ package body Exp_Util is -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke -- Remove_Side_Effects). - elsif No (Exp_Type) - or else Ekind (Exp_Type) = E_Access_Attribute_Type + elsif No (Typ) + or else No (Und_Typ) + or else Ekind (Und_Typ) = E_Access_Attribute_Type then return; @@ -12690,12 +12695,12 @@ package body Exp_Util is -- anyway, see below). Also do it if we have a volatile reference and -- Name_Req is not set (see comments for Side_Effect_Free). - elsif (Is_Elementary_Type (Exp_Type) - or else (Is_Record_Type (Exp_Type) - and then Known_Static_RM_Size (Exp_Type) - and then RM_Size (Exp_Type) <= System_Max_Integer_Size - and then not Has_Discriminants (Exp_Type) - and then not Is_By_Reference_Type (Exp_Type))) + elsif (Is_Elementary_Type (Und_Typ) + or else (Is_Record_Type (Und_Typ) + and then Known_Static_RM_Size (Und_Typ) + and then RM_Size (Und_Typ) <= System_Max_Integer_Size + and then not Has_Discriminants (Und_Typ) + and then not Is_By_Reference_Type (Und_Typ))) and then (Variable_Ref or else (not Is_Name_Reference (Exp) and then Nkind (Exp) /= N_Type_Conversion) @@ -12703,7 +12708,7 @@ package body Exp_Util is and then Is_Volatile_Reference (Exp))) then Def_Id := Build_Temporary (Loc, 'R', Exp); - Set_Etype (Def_Id, Exp_Type); + Set_Etype (Def_Id, Typ); Res := New_Occurrence_Of (Def_Id, Loc); -- If the expression is a packed reference, it must be reanalyzed and @@ -12719,7 +12724,7 @@ package body Exp_Util is end if; -- Generate: - -- Rnn : Exp_Type renames Expr; + -- Rnn : Typ renames Expr; -- In GNATprove mode, we prefer to use renamings for intermediate -- variables to definition of constants, due to the implicit move @@ -12730,22 +12735,22 @@ package body Exp_Util is if Renaming_Req or else (GNATprove_Mode and then Is_Object_Reference (Exp) - and then not Is_Scalar_Type (Exp_Type)) + and then not Is_Scalar_Type (Und_Typ)) then E := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Def_Id, - Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), Name => Relocate_Node (Exp)); -- Generate: - -- Rnn : constant Exp_Type := Expr; + -- Rnn : constant Typ := Expr; else E := Make_Object_Declaration (Loc, Defining_Identifier => Def_Id, - Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Object_Definition => New_Occurrence_Of (Typ, Loc), Constant_Present => True, Expression => Relocate_Node (Exp)); @@ -12801,7 +12806,7 @@ package body Exp_Util is elsif Nkind (Exp) = N_Unchecked_Type_Conversion and then not Safe_Unchecked_Type_Conversion (Exp) then - if CW_Or_Needs_Finalization (Exp_Type) then + if CW_Or_Needs_Finalization (Und_Typ) then -- Use a renaming to capture the expression, rather than create -- a controlled temporary. @@ -12812,18 +12817,18 @@ package body Exp_Util is Insert_Action (Exp, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Def_Id, - Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), Name => Relocate_Node (Exp))); else Def_Id := Build_Temporary (Loc, 'R', Exp); - Set_Etype (Def_Id, Exp_Type); + Set_Etype (Def_Id, Typ); Res := New_Occurrence_Of (Def_Id, Loc); E := Make_Object_Declaration (Loc, Defining_Identifier => Def_Id, - Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Object_Definition => New_Occurrence_Of (Typ, Loc), Constant_Present => not Is_Variable (Exp), Expression => Relocate_Node (Exp)); @@ -12853,7 +12858,7 @@ package body Exp_Util is -- type and we do not have Name_Req set true (see comments for -- Side_Effect_Free). - and then (Name_Req or else not Treat_As_Volatile (Exp_Type))) + and then (Name_Req or else not Treat_As_Volatile (Und_Typ))) then Def_Id := Build_Temporary (Loc, 'R', Exp); Res := New_Occurrence_Of (Def_Id, Loc); @@ -12861,7 +12866,7 @@ package body Exp_Util is Insert_Action (Exp, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Def_Id, - Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), Name => Relocate_Node (Exp))); -- Avoid generating a variable-sized temporary, by generating the @@ -12871,7 +12876,7 @@ package body Exp_Util is elsif Nkind (Exp) = N_Selected_Component and then Nkind (Prefix (Exp)) = N_Function_Call - and then Is_Array_Type (Exp_Type) + and then Is_Array_Type (Und_Typ) then Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref); goto Leave; @@ -12890,9 +12895,9 @@ package body Exp_Util is -- to the object in the latter case. if Nkind (Exp) = N_Function_Call - and then (Is_Build_In_Place_Result_Type (Exp_Type) + and then (Is_Build_In_Place_Result_Type (Und_Typ) or else - Is_Constr_Array_Subt_Of_Unc_With_Controlled (Exp_Type)) + Is_Constr_Array_Subt_Of_Unc_With_Controlled (Und_Typ)) and then Nkind (Parent (Exp)) /= N_Object_Declaration and then not Is_Expression_Of_Func_Return (Exp) then @@ -12904,11 +12909,11 @@ package body Exp_Util is Decl := Make_Object_Declaration (Loc, Defining_Identifier => Obj, - Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Exp)); Insert_Action (Exp, Decl); - Set_Etype (Obj, Exp_Type); + Set_Etype (Obj, Typ); Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); goto Leave; end; @@ -12924,7 +12929,7 @@ package body Exp_Util is if GNATprove_Mode then Res := New_Occurrence_Of (Def_Id, Loc); - Ref_Type := Exp_Type; + Ref_Type := Typ; -- Regular expansion utilizing an access type and 'reference @@ -12934,7 +12939,7 @@ package body Exp_Util is Prefix => New_Occurrence_Of (Def_Id, Loc)); -- Generate: - -- type Ann is access all <Exp_Type>; + -- type Ann is access all Typ; Ref_Type := Make_Temporary (Loc, 'A'); @@ -12944,8 +12949,7 @@ package body Exp_Util is Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, - Subtype_Indication => - New_Occurrence_Of (Exp_Type, Loc))); + Subtype_Indication => New_Occurrence_Of (Typ, Loc))); Insert_Action (Exp, Ptr_Typ_Decl); end if; @@ -12974,16 +12978,16 @@ package body Exp_Util is if not Analyzed (Exp) and then Nkind (Exp) = N_Aggregate - and then (Is_Array_Type (Exp_Type) - or else Has_Discriminants (Exp_Type)) - and then Is_Constrained (Exp_Type) + and then (Is_Array_Type (Und_Typ) + or else Has_Discriminants (Und_Typ)) + and then Is_Constrained (Und_Typ) then -- Do not suppress checks associated with the qualified -- expression we are about to introduce (unless those -- checks were already suppressed when Remove_Side_Effects -- was called). - if Is_Array_Type (Exp_Type) then + if Is_Array_Type (Und_Typ) then Scope_Suppress.Suppress (Length_Check) := Svg_Suppress.Suppress (Length_Check); else @@ -12991,9 +12995,10 @@ package body Exp_Util is Svg_Suppress.Suppress (Discriminant_Check); end if; - E := Make_Qualified_Expression (Loc, - Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), - Expression => E); + E := + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => E); end if; New_Exp := Make_Reference (Loc, E); @@ -13041,7 +13046,7 @@ package body Exp_Util is -- Finally rewrite the original expression and we are done Rewrite (Exp, Res); - Analyze_And_Resolve (Exp, Exp_Type); + Analyze_And_Resolve (Exp, Typ); <<Leave>> Scope_Suppress := Svg_Suppress; diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 4f20231..0ad24b3 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -191,8 +191,8 @@ package body Fmap is begin Unit_Hash_Table.Reset; File_Hash_Table.Reset; - Path_Mapping.Set_Last (0); - File_Mapping.Set_Last (0); + Path_Mapping.Clear; + File_Mapping.Clear; Last_In_Table := 0; end Empty_Tables; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 346789f..d8fdc30 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5646,14 +5646,9 @@ package body Freeze is -- If the component is an access type with an allocator as default -- value, the designated type will be frozen by the corresponding - -- expression in init_proc. In order to place the freeze node for - -- the designated type before that for the current record type, - -- freeze it now. - - -- Same process if the component is an array of access types, - -- initialized with an aggregate. If the designated type is - -- private, it cannot contain allocators, and it is premature - -- to freeze the type, so we check for this as well. + -- expression in the initialization procedure. In order to place + -- the freeze node for the designated type ahead of that for the + -- current record type, freeze the designated type right now. elsif Is_Access_Type (Etype (Comp)) and then Present (Parent (Comp)) @@ -5665,17 +5660,16 @@ package body Freeze is declare Alloc : constant Node_Id := Unqualify (Expression (Parent (Comp))); - + Desig_Typ : constant Entity_Id := + Designated_Type (Etype (Comp)); begin if Nkind (Alloc) = N_Allocator then - -- If component is pointer to a class-wide type, freeze -- the specific type in the expression being allocated. -- The expression may be a subtype indication, in which -- case freeze the subtype mark. - if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) - then + if Is_Class_Wide_Type (Desig_Typ) then if Is_Entity_Name (Expression (Alloc)) then Freeze_And_Append (Entity (Expression (Alloc)), N, Result); @@ -5686,21 +5680,24 @@ package body Freeze is (Entity (Subtype_Mark (Expression (Alloc))), N, Result); end if; - elsif Is_Itype (Designated_Type (Etype (Comp))) then + elsif Is_Itype (Desig_Typ) then Check_Itype (Etype (Comp)); else - Freeze_And_Append - (Designated_Type (Etype (Comp)), N, Result); + Freeze_And_Append (Desig_Typ, N, Result); end if; end if; end; + elsif Is_Access_Type (Etype (Comp)) and then Is_Itype (Designated_Type (Etype (Comp))) then Check_Itype (Etype (Comp)); - -- Freeze the designated type when initializing a component with - -- an aggregate in case the aggregate contains allocators. + -- Likewise if the component is an array of access types that is + -- initialized with an aggregate, in case the aggregate contains + -- allocators. But if the designated type is private, it cannot + -- contain allocators, and it is premature to freeze the type, + -- so we check for this as well. -- type T is ...; -- type T_Ptr is access all T; @@ -5712,13 +5709,15 @@ package body Freeze is elsif Is_Array_Type (Etype (Comp)) and then Is_Access_Type (Component_Type (Etype (Comp))) + and then Present (Parent (Comp)) + and then Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp))) + and then Nkind (Expression (Parent (Comp))) = N_Aggregate then declare - Comp_Par : constant Node_Id := Parent (Comp); Desig_Typ : constant Entity_Id := Designated_Type (Component_Type (Etype (Comp))); - begin -- The only case when this sort of freezing is not done is -- when the designated type is class-wide and the root type @@ -5740,12 +5739,7 @@ package body Freeze is then null; - elsif Is_Fully_Defined (Desig_Typ) - and then Present (Comp_Par) - and then Nkind (Comp_Par) = N_Component_Declaration - and then Present (Expression (Comp_Par)) - and then Nkind (Expression (Comp_Par)) = N_Aggregate - then + elsif Is_Fully_Defined (Desig_Typ) then Freeze_And_Append (Desig_Typ, N, Result); end if; end; diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index d456ac1..964a4d1 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -905,7 +905,6 @@ adadecode.o : adadecode.c adadecode.h aux-io.o : aux-io.c argv.o : argv.c cal.o : cal.c -deftarg.o : deftarg.c errno.o : errno.c exit.o : adaint.h exit.c expect.o : expect.c @@ -938,10 +937,6 @@ init.o : init.c adaint.h raise.h $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) -init-vxsim.o : init-vxsim.c - $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) - initialize.o : initialize.c raise.h $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index f176ca9..83b9e82 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -3226,6 +3226,9 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos, { tree field_decl = build_decl (input_location, FIELD_DECL, name, type); + /* The type must be frozen at this point. */ + gcc_assert (COMPLETE_TYPE_P (type)); + DECL_CONTEXT (field_decl) = record_type; TREE_READONLY (field_decl) = TYPE_READONLY (type); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 7351515..68a3c14 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Sep 29, 2025 +GNAT Reference Manual , Oct 17, 2025 AdaCore @@ -33627,7 +33627,7 @@ historical compatibility purposes. @section PolyORB -AWS is a deprecated product. It will be baselined with the GNAT Pro +PolyORB is a deprecated product. It will be baselined with the GNAT Pro release 28. After this release, there will be no new versions of this product. Contact your sales representative or send a message to @email{sales@@adacore.com} to get recommendations for replacements. diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 527aa7f..406147b 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -266,6 +266,9 @@ procedure Gnatlink is function Index (S, Pattern : String) return Natural; -- Return the last occurrence of Pattern in S, or 0 if none + function Is_Prefix (S, Prefix : String) return Boolean; + -- Return whether Prefix is a strict prefix of S + procedure Search_Library_Path (Next_Line : String; Nfirst : Integer; @@ -395,6 +398,16 @@ procedure Gnatlink is return 0; end Index; + --------------- + -- Is_Prefix -- + --------------- + + function Is_Prefix (S, Prefix : String) return Boolean is + begin + return Prefix'Length < S'Length + and then S (S'First .. S'First + Prefix'Length - 1) = Prefix; + end Is_Prefix; + ------------------ -- Process_Args -- ------------------ @@ -1292,13 +1305,8 @@ procedure Gnatlink is else for J in reverse 1 .. Linker_Options.Last loop if Linker_Options.Table (J) /= null - and then - Linker_Options.Table (J)'Length - > Run_Path_Opt'Length - and then - Linker_Options.Table (J) - (1 .. Run_Path_Opt'Length) = - Run_Path_Opt + and then Is_Prefix + (Linker_Options.Table (J).all, Run_Path_Opt) then -- We have found an already specified -- run_path_option: we will add to this switch, @@ -1887,31 +1895,12 @@ begin Shared_Libgcc_Seen : Boolean := False; Static_Libgcc_Seen : Boolean := False; - function Is_Prefix - (Complete_String : String; Prefix : String) return Boolean; - -- Returns whether Prefix is a prefix of Complete_String - - --------------- - -- Is_Prefix -- - --------------- - - function Is_Prefix - (Complete_String : String; Prefix : String) return Boolean - is - S : String renames Complete_String; - P : String renames Prefix; - begin - return P'Length <= S'Length - and then S (S'First .. S'First + P'Length - 1) = P; - end Is_Prefix; - begin J := Linker_Options.First; while J <= Linker_Options.Last loop if Linker_Options.Table (J).all = "-Xlinker" and then J < Linker_Options.Last - and then Linker_Options.Table (J + 1)'Length > 8 - and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack=" + and then Is_Prefix (Linker_Options.Table (J + 1).all, "--stack=") then if Stack_Op then Linker_Options.Table (J .. Linker_Options.Last - 2) := @@ -1956,12 +1945,8 @@ begin -- Here we just check for a canonical form that matches the -- pragma Linker_Options set in the NT runtime. - if Is_Prefix - (Complete_String => Linker_Options.Table (J).all, - Prefix => "-Xlinker --stack=") - or else Is_Prefix - (Complete_String => Linker_Options.Table (J).all, - Prefix => "-Wl,--stack=") + if Is_Prefix (Linker_Options.Table (J).all, "-Xlinker --stack=") + or else Is_Prefix (Linker_Options.Table (J).all, "-Wl,--stack=") then if Stack_Op then Linker_Options.Table (J .. Linker_Options.Last - 1) := diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb index b51f2b5..c9a98e9 100644 --- a/gcc/ada/libgnarl/s-taprop__qnx.adb +++ b/gcc/ada/libgnarl/s-taprop__qnx.adb @@ -96,6 +96,22 @@ package body System.Task_Primitives.Operations is Unblocked_Signal_Mask : aliased sigset_t; -- The set of signals that should unblocked in all tasks + Default_Signal_Mask : aliased sigset_t; + -- Default signal mask, used to restore signal mask after thread creation + + Default_Signal_Mask_Initialized : Boolean := False; + -- Allow to not enable default signals if the default signal mask failed to + -- initialize. + + procedure Disable_Signals; + -- Disable signals before calling pthread_create to avoid a potential + -- memory leak on QNX. + + procedure Enable_Signals; + -- Enable signals after pthread_create and in the created task. Since the + -- created task inherits the disabled signals from the parent they have to + -- be enabled for each task separately. + -- The followings are internal configuration constants needed Next_Serial_Number : Task_Serial_Number := 100; @@ -654,6 +670,7 @@ package body System.Task_Primitives.Operations is procedure Enter_Task (Self_ID : Task_Id) is begin + Enable_Signals; Self_ID.Common.LL.LWP := lwp_self; Specific.Set (Self_ID); @@ -765,17 +782,6 @@ package body System.Task_Primitives.Operations is function Thread_Body_Access is new Ada.Unchecked_Conversion (System.Address, Thread_Body); - - function Disable_Signals return Interfaces.C.int with - Import, - Convention => C, - External_Name => "__gnat_disable_signals"; - - function Enable_Signals return Interfaces.C.int with - Import, - Convention => C, - External_Name => "__gnat_enable_signals"; - begin Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); @@ -862,20 +868,17 @@ package body System.Task_Primitives.Operations is -- Restricted.Stages is used). One can verify that by inspecting the -- Task_Wrapper procedures. - Result := Disable_Signals; - pragma Assert (Result = 0); + Disable_Signals; Result := pthread_create (T.Common.LL.Thread'Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); pragma Assert (Result = 0 or else Result = EAGAIN); + Enable_Signals; Succeeded := Result = 0; - Result := Enable_Signals; - pragma Assert (Result = 0); - Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); end Create_Task; @@ -1292,6 +1295,10 @@ package body System.Task_Primitives.Operations is end if; end loop; + Result := pthread_sigmask + (SIG_SETMASK, null, Default_Signal_Mask'Access); + Default_Signal_Mask_Initialized := Result = 0; + -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); @@ -1378,4 +1385,56 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end Set_Task_Affinity; + --------------------- + -- Disable_Signals -- + --------------------- + + procedure Disable_Signals + is + Set : aliased sigset_t; + Result : Interfaces.C.int; + begin + -- If the default signal mask is not initialized there is no point in + -- disabling signals since we can't enable them again. Not enabling them + -- might impact the runtimes functionality so we rather accept the + -- possible memory leak. + if not Default_Signal_Mask_Initialized then + return; + end if; + + -- If any of the operations of setting up the signal mask fails we abort + -- disabling the signals. The function to enable the signals doesn't + -- need to care about this. It will simply restore the default signal + -- mask if it was successfully initialized. If the signals are not + -- disabled this is a no-op. + Result := sigemptyset (Set'Access); + if Result /= 0 then + return; + end if; + for S in SIGHUP .. SIGXFSZ loop + Result := sigaddset (Set'Access, Signal (S)); + if Result /= 0 then + return; + end if; + end loop; + Result := pthread_sigmask (SIG_BLOCK, Set'Access, null); + pragma Assert (Result = 0); + end Disable_Signals; + + -------------------- + -- Enable_Signals -- + -------------------- + + procedure Enable_Signals + is + Result : Interfaces.C.int; + begin + if not Default_Signal_Mask_Initialized then + return; + end if; + Result := pthread_sigmask + (SIG_SETMASK, Default_Signal_Mask'Access, null); + pragma Assert (Result = 0); + end Enable_Signals; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index f8ae997..338be46 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -485,7 +485,8 @@ package body Ch4 is -- Attribute Unsigned_Base_Range temporarily disabled if not Is_Attribute_Name (Attr_Name) - or else Attr_Name = Name_Unsigned_Base_Range + or else (Attr_Name = Name_Unsigned_Base_Range + and then not Debug_Flag_Dot_U) then if Apostrophe_Should_Be_Semicolon then Expr_Form := EF_Name; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 032bcf0..3575ad5 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -2888,8 +2888,7 @@ package body Par_SCO is end; end loop; - -- Clear the pending decisions list - Pending_Decisions.Set_Last (0); + Pending_Decisions.Clear; end Process_Pending_Decisions; ----------------------------- diff --git a/gcc/ada/rtinit.c b/gcc/ada/rtinit.c index 6a13552..598550c 100644 --- a/gcc/ada/rtinit.c +++ b/gcc/ada/rtinit.c @@ -419,6 +419,7 @@ __gnat_runtime_initialize (int install_handler) int last; int argc_expanded = 0; TCHAR result [MAX_PATH]; + int arglen; int quoted; __gnat_get_argw (GetCommandLineW (), &wargv, &wargc); @@ -436,7 +437,10 @@ __gnat_runtime_initialize (int install_handler) for (k=1; k<wargc; k++) { - quoted = (wargv[k][0] == _T('\'')); + arglen = _tcslen (wargv[k]); + quoted = wargv[k][0] == _T('\'') + && arglen > 1 + && wargv[k][arglen - 1] == _T('\''); /* Check for wildcard expansion if the argument is not quoted. */ if (!quoted && __gnat_do_argv_expansion diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 6b21905..8391f1f 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1882,6 +1882,7 @@ CND(IF_NAMESIZE, "Max size of interface name with 0 terminator"); #endif #elif defined(_WIN32) +#undef POLLPRI #define POLLPRI 0 /* If the POLLPRI flag is set on a socket for the Microsoft Winsock provider, * the WSAPoll function will fail. */ diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3575b04..b5c276a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -480,14 +480,16 @@ package body Sem_Ch12 is -- Create a new access type with the given designated type function Analyze_Associations - (N : Node_Id; - Formals : List_Id; - F_Copy : List_Id) return List_Id; + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id; + Parent_Installed : Boolean) return List_Id; -- At instantiation time, build the list of associations between formals -- and actuals. Each association becomes a renaming declaration for the -- formal entity. N is the instantiation node. Formals is the list of - -- unanalyzed formals. F_Copy is the analyzed list of formals in the - -- generic copy. + -- unanalyzed formals. F_Copy is the list of analyzed formals in the + -- generic copy. Parent_Installed is True if the parent has been installed + -- during the instantiation. procedure Analyze_Subprogram_Instantiation (N : Node_Id; @@ -838,9 +840,12 @@ package body Sem_Ch12 is -- the same list it is passing to Actual_Decls. function Instantiate_Formal_Subprogram - (Formal : Node_Id; - Actual : Node_Id; - Analyzed_Formal : Node_Id) return Node_Id; + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Parent_Installed : Boolean) return Node_Id; + -- Parent_Installed is True if the parent has been installed during the + -- instantiation. function Instantiate_Formal_Package (Formal : Node_Id; @@ -1283,12 +1288,14 @@ package body Sem_Ch12 is procedure Analyze_One_Association (N : Node_Id; Assoc : Associations.Assoc_Rec; + Parent_Installed : Boolean; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id); - -- Called by Analyze_Associations for each association. The renamings - -- are appended onto Result_Renamings. Defaulted actuals are appended - -- onto Default_Actuals, and actuals that require freezing are + -- Called by Analyze_Associations for each association. Parent_Installed + -- is True if the parent has been installed during the instantiation. The + -- renamings are appended onto Result_Renamings. The defaulted actuals are + -- appended onto Default_Actuals, and actuals that require freezing are -- appended onto Actuals_To_Freeze. procedure Analyze_Structural_Associations @@ -2362,9 +2369,10 @@ package body Sem_Ch12 is -------------------------- function Analyze_Associations - (N : Node_Id; - Formals : List_Id; - F_Copy : List_Id) return List_Id + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id; + Parent_Installed : Boolean) return List_Id is use Associations; @@ -2412,6 +2420,7 @@ package body Sem_Ch12 is Analyze_One_Association (N, Assoc, + Parent_Installed, Result_Renamings, Default_Actuals, Actuals_To_Freeze); @@ -2470,6 +2479,7 @@ package body Sem_Ch12 is procedure Analyze_One_Association (N : Node_Id; Assoc : Associations.Assoc_Rec; + Parent_Installed : Boolean; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id) @@ -2736,7 +2746,10 @@ package body Sem_Ch12 is else Append_To (Result_Renamings, Instantiate_Formal_Subprogram - (Assoc.Un_Formal, Match, Assoc.An_Formal)); + (Assoc.Un_Formal, + Match, + Assoc.An_Formal, + Parent_Installed)); -- If formal subprogram has contracts, create wrappers -- for it. This is an expansion activity that cannot @@ -3557,7 +3570,7 @@ package body Sem_Ch12 is -- List of primitives made temporarily visible in the instantiation -- to match the visibility of the formal type. - function Build_Local_Package return Node_Id; + function Build_Local_Package (Parent_Installed : Boolean) return Node_Id; -- The formal package is rewritten so that its parameters are replaced -- with corresponding declarations. For parameters with bona fide -- associations these declarations are created by Analyze_Associations @@ -3569,7 +3582,8 @@ package body Sem_Ch12 is -- Build_Local_Package -- ------------------------- - function Build_Local_Package return Node_Id is + function Build_Local_Package (Parent_Installed : Boolean) return Node_Id + is Decls : List_Id; Pack_Decl : Node_Id; @@ -3639,15 +3653,16 @@ package body Sem_Ch12 is Instantiating => True); begin - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; Instantiation_Node := N; Decls := Analyze_Associations - (N => Original_Node (N), - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => Original_Node (N), + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); Vis_Prims_List := Check_Hidden_Primitives (Decls); end; @@ -3782,7 +3797,7 @@ package body Sem_Ch12 is -- internal declarations. begin - New_N := Build_Local_Package; + New_N := Build_Local_Package (Parent_Installed); -- If there are errors in the parameter list, Analyze_Associations -- raises Instantiation_Error. Patch the declaration to prevent further @@ -3868,6 +3883,7 @@ package body Sem_Ch12 is Renaming_In_Par := Make_Defining_Identifier (Loc, Chars (Gen_Unit)); Mutate_Ekind (Renaming_In_Par, E_Package); + Set_Is_Internal (Renaming_In_Par); Set_Is_Not_Self_Hidden (Renaming_In_Par); Set_Etype (Renaming_In_Par, Standard_Void_Type); Set_Scope (Renaming_In_Par, Parent_Instance); @@ -4998,7 +5014,7 @@ package body Sem_Ch12 is -- inherited from formal packages of parent units, and these are -- constructed when the parents are installed. - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; -- Except for an abbreviated instance created to check a formal package, @@ -5159,9 +5175,10 @@ package body Sem_Ch12 is Renamings := Analyze_Associations - (N => N, - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); -- Bail out if the instantiation has been turned into something else @@ -6962,7 +6979,7 @@ package body Sem_Ch12 is -- Initialize renamings map, for error checking - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); @@ -6981,9 +6998,10 @@ package body Sem_Ch12 is Renamings := Analyze_Associations - (N => N, - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); -- Bail out if the instantiation has been turned into something else @@ -7236,7 +7254,7 @@ package body Sem_Ch12 is Restore_Hidden_Primitives (Vis_Prims_List); Restore_Env; Env_Installed := False; - Generic_Renamings.Set_Last (0); + Generic_Renamings.Clear; Generic_Renamings_HTable.Reset; end if; @@ -12538,9 +12556,10 @@ package body Sem_Ch12 is ----------------------------------- function Instantiate_Formal_Subprogram - (Formal : Node_Id; - Actual : Node_Id; - Analyzed_Formal : Node_Id) return Node_Id + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Parent_Installed : Boolean) return Node_Id is Analyzed_S : constant Entity_Id := Defining_Unit_Name (Specification (Analyzed_Formal)); @@ -12548,13 +12567,7 @@ package body Sem_Ch12 is Defining_Unit_Name (Specification (Formal)); function From_Parent_Scope (Subp : Entity_Id) return Boolean; - -- If the generic is a child unit, the parent has been installed on the - -- scope stack, but a default subprogram cannot resolve to something - -- on the parent because that parent is not really part of the visible - -- context (it is there to resolve explicit local entities). If the - -- default has resolved in this way, we remove the entity from immediate - -- visibility and analyze the node again to emit an error message or - -- find another visible candidate. + -- Return true if Subp is declared in a parent scope of Analyzed_S procedure Valid_Actual_Subprogram (Act : Node_Id); -- Perform legality check and raise exception on failure @@ -12812,21 +12825,31 @@ package body Sem_Ch12 is end if; -- Gather possible interpretations for the actual before analyzing the - -- instance. If overloaded, it will be resolved when analyzing the - -- renaming declaration. + -- instance. If the actual is overloaded, then it will be resolved when + -- the renaming declaration is analyzed. if Box_Present (Formal) and then No (Actual) then Analyze (Nam); - if Is_Child_Unit (Scope (Analyzed_S)) - and then Present (Entity (Nam)) + -- If the generic is a child unit and the parent has been installed + -- during this instantiation (as opposed to having been installed in + -- the context of the instantiation at some earlier point), a default + -- subprogram cannot resolve to something in the parent because the + -- parent is not really part of the visible context (it is there to + -- resolve explicit local entities). If the default subprogram has + -- been resolved in this way, we remove the entity from immediate + -- visibility and analyze the node again to emit an error message + -- or find another visible candidate. + + if Present (Entity (Nam)) + and then Is_Child_Unit (Scope (Analyzed_S)) + and then Parent_Installed then if not Is_Overloaded (Nam) then if From_Parent_Scope (Entity (Nam)) then Set_Is_Immediately_Visible (Entity (Nam), False); Set_Entity (Nam, Empty); Set_Etype (Nam, Empty); - Analyze (Nam); Set_Is_Immediately_Visible (Entity (Nam)); end if; @@ -17639,6 +17662,8 @@ package body Sem_Ch12 is Set_Etype (N2, E); end if; + -- If the entity is global, save its type in the generic node + if Is_Global (E) then Set_Global_Type (N, N2); @@ -17659,12 +17684,24 @@ package body Sem_Ch12 is Set_Etype (N, Empty); end if; + -- If default actuals have been added to a generic instantiation + -- and they are global, save them in the generic node. + if Nkind (Parent (N)) in N_Generic_Instantiation and then N = Name (Parent (N)) then Save_Global_Defaults (Parent (N), Parent (N2)); end if; + if Nkind (Parent (N)) = N_Selected_Component + and then N = Selector_Name (Parent (N)) + and then Nkind (Parent (Parent (N))) in N_Generic_Instantiation + and then Parent (N) = Name (Parent (Parent (N))) + then + Save_Global_Defaults + (Parent (Parent (N)), Parent (Parent (N2))); + end if; + elsif Nkind (Parent (N)) = N_Selected_Component and then Nkind (Parent (N2)) = N_Expanded_Name then @@ -18488,12 +18525,13 @@ package body Sem_Ch12 is elsif Nkind (N) = N_Pragma then Save_References_In_Pragma (N); + -- Aspects + elsif Nkind (N) = N_Aspect_Specification then declare P : constant Node_Id := Parent (N); - Expr : Node_Id; - begin + begin if Permits_Aspect_Specifications (P) then -- The capture of global references within aspects @@ -18505,15 +18543,11 @@ package body Sem_Ch12 is if Requires_Delayed_Save (Original_Node (P)) then null; - -- Otherwise save all global references within the - -- aspects - - else - Expr := Expression (N); + -- Otherwise save all global references within the + -- expression of the aspect. - if Present (Expr) then - Save_Global_References (Expr); - end if; + elsif Present (Expression (N)) then + Save_Global_References (Expression (N)); end if; end if; end; @@ -18523,10 +18557,11 @@ package body Sem_Ch12 is elsif Nkind (N) = N_Implicit_Label_Declaration then null; + -- Other nodes + else Save_References_In_Descendants (N); end if; - end Save_References; --------------------- @@ -18686,9 +18721,8 @@ package body Sem_Ch12 is procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is begin - Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); + Generic_Renamings.Append ((A, B, Assoc_Null)); Generic_Renamings_HTable.Set (Generic_Renamings.Last); - Generic_Renamings.Increment_Last; end Set_Instance_Of; -------------------- @@ -19321,39 +19355,22 @@ package body Sem_Ch12 is -------------------- function Save_And_Reset return Context is + First : constant Integer := Integer (Generic_Renamings.First); + Last : constant Integer := Integer (Generic_Renamings.Last); begin - return Result : Context (0 .. Integer (Generic_Renamings.Last)) do + return Result : Context (First .. Last) do for Index in Result'Range loop declare Indexed_Assoc : Assoc renames Generic_Renamings.Table (Assoc_Ptr (Index)); Result_Pair : Binding_Pair renames Result (Index); begin - -- If we have called Increment_Last but have not yet - -- initialized the new last element of the table, then - -- that last element might be invalid. Saving and - -- restoring (especially restoring, it turns out) invalid - -- values can result in exceptions if predicate checking - -- is enabled, so replace invalid values with Empty. - - if Indexed_Assoc.Gen_Id'Valid then - Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id; - else - pragma Assert (Index = Result'Last); - Result_Pair.Formal_Id := Empty; - end if; - - if Indexed_Assoc.Act_Id'Valid then - Result_Pair.Actual_Id := Indexed_Assoc.Act_Id; - else - pragma Assert (Index = Result'Last); - Result_Pair.Actual_Id := Empty; - end if; + Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id; + Result_Pair.Actual_Id := Indexed_Assoc.Act_Id; end; end loop; Generic_Renamings.Init; - Generic_Renamings.Set_Last (-1); Generic_Renamings_HTable.Reset; end return; end Save_And_Reset; @@ -19365,13 +19382,10 @@ package body Sem_Ch12 is procedure Restore (Saved : Context) is begin Generic_Renamings.Init; - Generic_Renamings.Set_Last (0); Generic_Renamings_HTable.Reset; - Generic_Renamings.Increment_Last; for Pair of Saved loop Set_Instance_Of (Pair.Formal_Id, Pair.Actual_Id); end loop; - Generic_Renamings.Decrement_Last; end Restore; end Instance_Context; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 22fea0d..f7be890 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1406,7 +1406,7 @@ package body Sem_Ch13 is Error_Msg_N ("nonoverridable aspect % of type % requires % " & Operation_Kind & "# to be a primitive operation", - Original); + Expr); end; end if; end Check_Nonoverridable_Aspect_Subprograms; @@ -2372,7 +2372,13 @@ package body Sem_Ch13 is then if A_Id = Aspect_Import then Set_Has_Completion (E); - Set_Is_Imported (E); + + -- Do not set Is_Imported on Exceptions, similarly + -- to Sem_Prag.Process_Import_Or_Interface. + + if Ekind (E) /= E_Exception then + Set_Is_Imported (E); + end if; -- An imported object cannot be explicitly initialized @@ -3590,6 +3596,7 @@ package body Sem_Ch13 is | Aspect_Effective_Reads | Aspect_Effective_Writes | Aspect_Preelaborable_Initialization + | Aspect_Unsigned_Base_Range then Error_Msg_Name_1 := Nam; @@ -3703,6 +3710,13 @@ package body Sem_Ch13 is then Delay_Required := False; + -- For Unsigned_Base_Range aspect, do not delay becase we + -- need to process it before any type or subtype derivation + -- is analyzed. + + elsif A_Id in Aspect_Unsigned_Base_Range then + Delay_Required := False; + -- All other cases are delayed else diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9ca7708..aa15166 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11287,7 +11287,13 @@ package body Sem_Ch3 is -- not. It is OK for the new bound we are creating, but not for -- the old one??? Still if it never happens, no problem. - Analyze_And_Resolve (Bound, Base_Type (Par_T)); + -- This must be disabled on unsigned base range types because their + -- base type is a modular type, and their type is a signed integer + -- type. + + if not Has_Unsigned_Base_Range_Aspect (Base_Type (Par_T)) then + Analyze_And_Resolve (Bound, Base_Type (Par_T)); + end if; if Nkind (Bound) in N_Integer_Literal | N_Real_Literal then New_Bound := New_Copy (Bound); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 2002cc7..989e6bf 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2266,7 +2266,32 @@ package body Sem_Ch7 is Next_Elmt (Op_Elmt_2); end loop; - -- Case 2: We have not found any explicit overriding and + -- Case 2: For a formal type, we need to explicitly check + -- whether a local subprogram hides from all visibility + -- the implicitly declared primitive, because subprograms + -- declared in a generic package specification are never + -- primitive for a formal type, even if they happen to + -- override an operation of the type (RM 3.2.3(7.d/2)). + + if Is_Generic_Type (E) then + declare + S : Entity_Id; + + begin + S := E; + while Present (S) loop + if Chars (S) = Chars (Parent_Subp) + and then Type_Conformant (Prim_Op, S) + then + goto Next_Primitive; + end if; + + Next_Entity (S); + end loop; + end; + end if; + + -- Case 3: We have not found any explicit overriding and -- hence we need to declare the operation (i.e., make it -- visible). diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 0ce2b35..4d57a86 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -17469,7 +17469,7 @@ package body Sem_Elab is -- Stuff that happens only at the outer level if No (Outer_Scope) then - Elab_Visited.Set_Last (0); + Elab_Visited.Clear; -- Nothing to do if current scope is Standard (this is a bit odd, but -- it happens in the case of generic instantiations). diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 28c5f17..0dc2e4f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10699,6 +10699,9 @@ package body Sem_Prag is -- the External_Name). For exceptions, the External_Name is the -- name of the RTTI structure. + -- Do not call Set_Is_Imported as that would disable the output + -- of the needed exception data structures. + -- ??? Emit an error if pragma Import/Export_Exception is present elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then @@ -12690,7 +12693,8 @@ package body Sem_Prag is -- Pragma Unsigned_Base_Range temporarily disabled if not Is_Pragma_Name (Pname) - or else Pname = Name_Unsigned_Base_Range + or else (Pname = Name_Unsigned_Base_Range + and then not Debug_Flag_Dot_U) then declare Msg_Issued : Boolean := False; @@ -21867,8 +21871,17 @@ package body Sem_Prag is if Rep_Item_Too_Late (Def_Id, N) then return; - else - Set_Has_Gigi_Rep_Item (Def_Id); + end if; + + Set_Has_Gigi_Rep_Item (Def_Id); + + -- The pragma is processed directly by the back end when Def_Id is + -- translated. If the argument is not a string literal, it may be + -- declared after Def_Id and before the pragma, which requires the + -- processing of Def_Id to be delayed for the back end. + + if Nkind (Get_Pragma_Arg (Arg2)) /= N_String_Literal then + Set_Has_Delayed_Freeze (Def_Id); end if; end Machine_Attribute; @@ -28145,12 +28158,23 @@ package body Sem_Prag is then Error_Pragma_Arg ("cannot apply pragma %", - "\& is not a signed integer type", - Arg1); + "\& is not a signed integer type", Arg1); elsif Is_Derived_Type (E) then Error_Pragma_Arg ("pragma % cannot apply to derived type", Arg1); + + elsif Is_Generic_Type (E) then + Error_Pragma_Arg + ("pragma % cannot apply to formal type", Arg1); + + elsif Present (Expr) + and then Is_False (Expr_Value (Expr)) + and then Ekind (Base_Type (E)) = E_Modular_Integer_Type + and then Has_Unsigned_Base_Range_Aspect (Base_Type (E)) + then + Error_Pragma_Arg + ("pragma % can only confirm previous True value", Arg1); end if; Check_First_Subtype (Arg1); @@ -28158,17 +28182,19 @@ package body Sem_Prag is -- Create the new unsigned integer base type entity, and apply -- the constraint to create the first subtype of E. - Unsigned_Base_Range_Type_Declaration (E, - Def => Type_Definition (Parent (E))); + if No (Expr) or else Is_True (Expr_Value (Expr)) then + Unsigned_Base_Range_Type_Declaration (E, + Def => Type_Definition (Parent (E))); - Set_Direct_Primitive_Operations (Base_Type (E), New_Elmt_List); - Set_Direct_Primitive_Operations (E, - Direct_Primitive_Operations (Base_Type (E))); - Ensure_Freeze_Node (Base_Type (E)); - Set_First_Subtype_Link (Freeze_Node (Base_Type (E)), E); - Set_Has_Delayed_Freeze (E); + Set_Direct_Primitive_Operations (Base_Type (E), New_Elmt_List); + Set_Direct_Primitive_Operations (E, + Direct_Primitive_Operations (Base_Type (E))); + Ensure_Freeze_Node (Base_Type (E)); + Set_First_Subtype_Link (Freeze_Node (Base_Type (E)), E); + Set_Has_Delayed_Freeze (E); - Set_Has_Unsigned_Base_Range_Aspect (Base_Type (E)); + Set_Has_Unsigned_Base_Range_Aspect (Base_Type (E)); + end if; end Unsigned_Base_Range; ---------------- @@ -28761,6 +28787,17 @@ package body Sem_Prag is OK : Boolean; Chr : Character; + function Enclose_Ending_Space + (Raw_Str : String) return String + is (if Raw_Str (Raw_Str'Last) = ' ' + then '"' & Raw_Str & '"' + else Raw_Str); + function Enclose_Ending_Space + (Raw_Chr : Character) return String + is (Enclose_Ending_Space ((1 => Raw_Chr))); + -- This function ensures that no error message ends + -- with a space, in case we enclose it within quotes. + begin J := 1; while J <= Len loop @@ -28792,7 +28829,8 @@ package body Sem_Prag is if not Set_Warning_Switch ('.', Chr) then Error_Pragma_Arg ("invalid warning switch character " - & '.' & Chr, Arg1); + & Enclose_Ending_Space ('.' & Chr), + Arg1); end if; -- Non-Dot case @@ -28803,7 +28841,8 @@ package body Sem_Prag is if not OK then Error_Pragma_Arg - ("invalid warning switch character " & Chr, + ("invalid warning switch character " + & Enclose_Ending_Space (Chr), Arg1); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7f864d6..a8984c8 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5881,18 +5881,20 @@ package body Sem_Util is -- Test whether the result type or any of the parameter types of -- each subprogram following the type match that type when the - -- type is declared in a package spec, is a derived type, or the - -- subprogram is marked as primitive. (The Is_Primitive test is - -- needed to find primitives of nonderived types in declarative - -- parts that happen to override the predefined "=" operator.) - - -- Note that generic formal subprograms are not considered to be - -- primitive operations and thus are never inherited. + -- type is declared in a package spec, the subprogram is marked as + -- primitive, or the subprogram is inherited. Note that the + -- Is_Primitive test is needed to find primitives of nonderived + -- types in declarative parts that happen to override the + -- predefined "=" operator. if Is_Overloadable (Id) and then (Is_Type_In_Pkg - or else Is_Derived_Type (B_Type) - or else Is_Primitive (Id)) + or else Is_Primitive (Id) + or else not Comes_From_Source (Id)) + + -- Generic formal subprograms are not considered to be primitive + -- operations and thus are never inherited. + and then Parent_Kind (Parent (Id)) not in N_Formal_Subprogram_Declaration and then not Is_Child_Unit (Id) diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index 20945fb..46499ff 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -330,7 +330,7 @@ package body Styleg is -- Do we need to worry about UTF_32 line terminators here ??? S := Scan_Ptr + 3; - while Source (S) not in Line_Terminator loop + while Source (S) not in EOF | Line_Terminator loop S := S + 1; end loop; diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 31891de..f803fc8 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -130,7 +130,7 @@ package body Table is begin Locked := False; - Last_Val := Min - 1; + Clear; Max := Min + (Table_Initial * Table_Factor) - 1; Length := Max - Min + 1; @@ -372,6 +372,24 @@ package body Table is end if; end Set_Item; + ----------- + -- Clear -- + ----------- + + procedure Clear is + begin + Last_Val := Min - 1; + end Clear; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty return Boolean is + begin + return Last_Val = Min - 1; + end Is_Empty; + -------------- -- Set_Last -- -------------- diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index 623ce14..94bb828 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -204,6 +204,13 @@ package Table is -- to Index. Item will replace any value already present in the table -- at this position. + procedure Clear; + -- Resets Last to its initial value, making the table have no elements. + -- No memory deallocation is performed. + + function Is_Empty return Boolean; + -- Returns whether the table is empty + type Saved_Table is private; -- Type used for Save/Restore subprograms diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 89f8875..85a5c0d 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -724,13 +724,16 @@ __gnat_setup_child_communication if (bRet == FALSE) { cpid = -1; } - - dwRet = buf[0] | (buf[1] << 8) | (buf[2] << 16) | (buf[3] << 24); - if (dwRet != 0) { - cpid = -1; + else { + dwRet = buf[0] | (buf[1] << 8) | (buf[2] << 16) | (buf[3] << 24); + if (dwRet != 0) { + cpid = -1; + } + else { + cpid = buf[4] | (buf[5] << 8) | (buf[6] << 16) | (buf[7] << 24); + } } - cpid = buf[4] | (buf[5] << 8) | (buf[6] << 16) | (buf[7] << 24); process->pid = cpid; } |