} : Specify the + configuration project file name + + @item @option{--autoconf=} + + This specifies a configuration project file name that already exists or will + be created automatically. Option @option{--autoconf=} + cannot be specified more than once. If the configuration project file + specified with @option{--autoconf=} exists, then it is used. Otherwise, + @value{gprconfig} is invoked to create it automatically. + + @item @option{-c} : Only delete compiler-generated files. Do not delete + executables and libraries. + + @item @option{-f} : Force deletions of unwritable files + + @item @option{-F} : Display full project path name in brief error messages + + @item @option{-h} : Display this message + + @item @option{-n} : Do not delete files, only list files to delete + + @item @option{-P} : Use Project File @emph{}. + + @item @option{-q} : Be quiet/terse. There is no output, except to report + problems. + + @item @option{-r} : (recursive) Clean all projects referenced by the main + project directly or indirectly. Without this switch, GPRclean only + cleans the main project. + + @item @option{-v} : Verbose mode + + @item @option{-vPx} : Specify verbosity when parsing Project Files. + x = 0 (default), 1 or 2. + + @item @option{-Xnm=val} : Specify an external reference for Project Files. + + @end itemize + + + diff -Nrcpad gcc-4.5.2/gcc/ada/put_scos.adb gcc-4.6.0/gcc/ada/put_scos.adb *** gcc-4.5.2/gcc/ada/put_scos.adb Tue Jan 26 13:49:56 2010 --- gcc-4.6.0/gcc/ada/put_scos.adb Thu Jun 17 07:42:04 2010 *************** *** 26,31 **** --- 26,63 ---- with SCOs; use SCOs; procedure Put_SCOs is + Ctr : Nat; + + procedure Output_Range (T : SCO_Table_Entry); + -- Outputs T.From and T.To in line:col-line:col format + + procedure Output_Source_Location (Loc : Source_Location); + -- Output source location in line:col format + + ------------------ + -- Output_Range -- + ------------------ + + procedure Output_Range (T : SCO_Table_Entry) is + begin + Output_Source_Location (T.From); + Write_Info_Char ('-'); + Output_Source_Location (T.To); + end Output_Range; + + ---------------------------- + -- Output_Source_Location -- + ---------------------------- + + procedure Output_Source_Location (Loc : Source_Location) is + begin + Write_Info_Nat (Nat (Loc.Line)); + Write_Info_Char (':'); + Write_Info_Nat (Nat (Loc.Col)); + end Output_Source_Location; + + -- Start of processing for Put_SCOs + begin -- Loop through entries in SCO_Unit_Table *************** begin *** 64,98 **** Output_SCO_Line : declare T : SCO_Table_Entry renames SCO_Table.Table (Start); - procedure Output_Range (T : SCO_Table_Entry); - -- Outputs T.From and T.To in line:col-line:col format - - ------------------ - -- Output_Range -- - ------------------ - - procedure Output_Range (T : SCO_Table_Entry) is - begin - Write_Info_Nat (Nat (T.From.Line)); - Write_Info_Char (':'); - Write_Info_Nat (Nat (T.From.Col)); - Write_Info_Char ('-'); - Write_Info_Nat (Nat (T.To.Line)); - Write_Info_Char (':'); - Write_Info_Nat (Nat (T.To.Col)); - end Output_Range; - - -- Start of processing for Output_SCO_Line - begin - Write_Info_Initiate ('C'); - Write_Info_Char (T.C1); - case T.C1 is -- Statements when 'S' => loop Write_Info_Char (' '); --- 96,111 ---- Output_SCO_Line : declare T : SCO_Table_Entry renames SCO_Table.Table (Start); begin case T.C1 is -- Statements when 'S' => + Write_Info_Initiate ('C'); + Write_Info_Char ('S'); + + Ctr := 0; loop Write_Info_Char (' '); *************** begin *** 105,112 **** --- 118,139 ---- Start := Start + 1; pragma Assert (SCO_Table.Table (Start).C1 = 's'); + + Ctr := Ctr + 1; + + -- Up to 6 items on a line, if more than 6 items, + -- continuation lines are marked Cs. + + if Ctr = 6 then + Write_Info_Terminate; + Write_Info_Initiate ('C'); + Write_Info_Char ('s'); + Ctr := 0; + end if; end loop; + Write_Info_Terminate; + -- Statement continuations should not occur since they -- are supposed to have been handled in the loop above. *************** begin *** 116,156 **** -- Decision when 'I' | 'E' | 'P' | 'W' | 'X' => ! if T.C2 = ' ' then ! Start := Start + 1; ! end if; ! -- Loop through table entries for this decision ! loop ! declare ! T : SCO_Table_Entry renames SCO_Table.Table (Start); ! begin Write_Info_Char (' '); ! if T.C1 = '!' or else ! T.C1 = '^' or else ! T.C1 = '&' or else ! T.C1 = '|' ! then ! Write_Info_Char (T.C1); ! else ! Write_Info_Char (T.C2); ! Output_Range (T); ! end if; ! exit when T.Last; ! Start := Start + 1; ! end; ! end loop; when others => raise Program_Error; end case; - - Write_Info_Terminate; end Output_SCO_Line; Start := Start + 1; --- 143,201 ---- -- Decision when 'I' | 'E' | 'P' | 'W' | 'X' => ! Start := Start + 1; ! -- For disabled pragma, skip decision output ! if T.C1 = 'P' and then T.C2 = 'd' then ! while not SCO_Table.Table (Start).Last loop ! Start := Start + 1; ! end loop; ! -- For all other cases output decision line ! ! else ! Write_Info_Initiate ('C'); ! Write_Info_Char (T.C1); ! ! if T.C1 /= 'X' then Write_Info_Char (' '); + Output_Source_Location (T.From); + end if; ! -- Loop through table entries for this decision ! loop ! declare ! T : SCO_Table_Entry ! renames SCO_Table.Table (Start); ! begin ! Write_Info_Char (' '); ! ! if T.C1 = '!' or else ! T.C1 = '&' or else ! T.C1 = '|' ! then ! Write_Info_Char (T.C1); ! Output_Source_Location (T.From); ! ! else ! Write_Info_Char (T.C2); ! Output_Range (T); ! end if; ! ! exit when T.Last; ! Start := Start + 1; ! end; ! end loop; ! ! Write_Info_Terminate; ! end if; when others => raise Program_Error; end case; end Output_SCO_Line; Start := Start + 1; diff -Nrcpad gcc-4.5.2/gcc/ada/raise-gcc.c gcc-4.6.0/gcc/ada/raise-gcc.c *** gcc-4.5.2/gcc/ada/raise-gcc.c Tue Oct 27 19:41:13 2009 --- gcc-4.6.0/gcc/ada/raise-gcc.c Tue Oct 26 10:52:27 2010 *************** *** 6,12 **** * * * C Implementation File * * * ! * 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- * --- 6,12 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2010, 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- * *************** db_phases (int phases) *** 407,413 **** =================================== The major point of this unit is to provide an exception propagation ! personality routine for Ada. This is __gnat_eh_personality. It is provided with a pointer to the propagated exception, an unwind context describing a location the propagation is going through, and a --- 407,413 ---- =================================== The major point of this unit is to provide an exception propagation ! personality routine for Ada. This is __gnat_personality_v0. It is provided with a pointer to the propagated exception, an unwind context describing a location the propagation is going through, and a *************** db_phases (int phases) *** 440,446 **** | | (Ada frame) | ! +--> __gnat_eh_personality (context, exception) | +--> get_region_descriptor_for (context) | --- 440,446 ---- | | (Ada frame) | ! +--> __gnat_personality_v0 (context, exception) | +--> get_region_descriptor_for (context) | *************** extern void __gnat_notify_unhandled_exce *** 1028,1036 **** GNU-Ada exceptions are met. */ #ifdef __USING_SJLJ_EXCEPTIONS__ ! #define PERSONALITY_FUNCTION __gnat_eh_personality_sj #else ! #define PERSONALITY_FUNCTION __gnat_eh_personality #endif /* Major tweak for ia64-vms : the CHF propagation phase calls this personality --- 1028,1036 ---- GNU-Ada exceptions are met. */ #ifdef __USING_SJLJ_EXCEPTIONS__ ! #define PERSONALITY_FUNCTION __gnat_personality_sj0 #else ! #define PERSONALITY_FUNCTION __gnat_personality_v0 #endif /* Major tweak for ia64-vms : the CHF propagation phase calls this personality diff -Nrcpad gcc-4.5.2/gcc/ada/raise.h gcc-4.6.0/gcc/ada/raise.h *** gcc-4.5.2/gcc/ada/raise.h Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/raise.h Mon Jun 14 13:32:14 2010 *************** *** 29,35 **** * * ****************************************************************************/ - /* C counterparts of what System.Standard_Library defines. */ typedef unsigned Exception_Code; --- 29,34 ---- *************** struct Exception_Data *** 46,61 **** typedef struct Exception_Data *Exception_Id; - struct Exception_Occurrence - { - int Max_Length; - Exception_Id Id; - int Msg_Length; - char Msg[0]; - }; - - typedef struct Exception_Occurrence *Exception_Occurrence_Access; - extern void _gnat_builtin_longjmp (void *, int); extern void __gnat_unhandled_terminate (void); extern void *__gnat_malloc (__SIZE_TYPE__); --- 45,50 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/repinfo.adb gcc-4.6.0/gcc/ada/repinfo.adb *** gcc-4.5.2/gcc/ada/repinfo.adb Wed Jul 22 10:25:32 2009 --- gcc-4.6.0/gcc/ada/repinfo.adb Fri Sep 10 11:01:37 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2010, 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- -- *************** package body Repinfo is *** 403,409 **** if List_Representation_Info >= 2 then List_Object_Info (E); end if; - end if; -- Recurse into nested package, but not if they are package --- 403,408 ---- *************** package body Repinfo is *** 1055,1060 **** --- 1054,1092 ---- Write_Str ("'Alignment use "); Write_Val (Alignment (Ent)); Write_Line (";"); + + -- Special stuff for fixed-point + + if Is_Fixed_Point_Type (Ent) then + + -- Write small (always a static constant) + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Small use "); + UR_Write (Small_Value (Ent)); + Write_Line (";"); + + -- Write range if static + + declare + R : constant Node_Id := Scalar_Range (Ent); + + begin + if Nkind (Low_Bound (R)) = N_Real_Literal + and then + Nkind (High_Bound (R)) = N_Real_Literal + then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Range use "); + UR_Write (Realval (Low_Bound (R))); + Write_Str (" .. "); + UR_Write (Realval (High_Bound (R))); + Write_Line (";"); + end if; + end; + end if; end List_Type_Info; ---------------------- *************** package body Repinfo is *** 1088,1095 **** -- Internal recursive routine to evaluate tree function W (Val : Uint) return Word; ! -- Convert Val to Word, assuming Val is always in the Int range. This is ! -- a helper function for the evaluation of bitwise expressions like -- Bit_And_Expr, for which there is no direct support in uintp. Uint -- values out of the Int range are expected to be seen in such -- expressions only with overflowing byte sizes around, introducing --- 1120,1127 ---- -- Internal recursive routine to evaluate tree function W (Val : Uint) return Word; ! -- Convert Val to Word, assuming Val is always in the Int range. This ! -- is a helper function for the evaluation of bitwise expressions like -- Bit_And_Expr, for which there is no direct support in uintp. Uint -- values out of the Int range are expected to be seen in such -- expressions only with overflowing byte sizes around, introducing diff -Nrcpad gcc-4.5.2/gcc/ada/restrict.adb gcc-4.6.0/gcc/ada/restrict.adb *** gcc-4.5.2/gcc/ada/restrict.adb Fri Apr 17 09:57:27 2009 --- gcc-4.6.0/gcc/ada/restrict.adb Thu Oct 7 12:59:00 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 25,30 **** --- 25,31 ---- with Atree; use Atree; with Casing; use Casing; + with Einfo; use Einfo; with Errout; use Errout; with Debug; use Debug; with Fname; use Fname; *************** with Opt; use Opt; *** 34,39 **** --- 35,41 ---- with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; + with Stand; use Stand; with Uname; use Uname; package body Restrict is *************** package body Restrict is *** 121,126 **** --- 123,168 ---- Check_Restriction (No_Implicit_Heap_Allocations, N); end Check_No_Implicit_Heap_Alloc; + ----------------------------------- + -- Check_Obsolescent_2005_Entity -- + ----------------------------------- + + procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is + function Chars_Is (E : Entity_Id; S : String) return Boolean; + -- Return True iff Chars (E) matches S (given in lower case) + + function Chars_Is (E : Entity_Id; S : String) return Boolean is + Nam : constant Name_Id := Chars (E); + begin + if Length_Of_Name (Nam) /= S'Length then + return False; + else + return Get_Name_String (Nam) = S; + end if; + end Chars_Is; + + -- Start of processing for Check_Obsolescent_2005_Entity + + begin + if Restriction_Check_Required (No_Obsolescent_Features) + and then Ada_Version >= Ada_2005 + and then Chars_Is (Scope (E), "handling") + and then Chars_Is (Scope (Scope (E)), "characters") + and then Chars_Is (Scope (Scope (Scope (E))), "ada") + and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard + then + if Chars_Is (E, "is_character") or else + Chars_Is (E, "is_string") or else + Chars_Is (E, "to_character") or else + Chars_Is (E, "to_string") or else + Chars_Is (E, "to_wide_character") or else + Chars_Is (E, "to_wide_string") + then + Check_Restriction (No_Obsolescent_Features, N); + end if; + end if; + end Check_Obsolescent_2005_Entity; + --------------------------- -- Check_Restricted_Unit -- --------------------------- *************** package body Restrict is *** 256,261 **** --- 298,311 ---- -- Start of processing for Check_Restriction begin + -- In CodePeer mode, we do not want to check for any restriction, or set + -- additional restrictions other than those already set in gnat1drv.adb + -- so that we have consistency between each compilation. + + if CodePeer_Mode then + return; + end if; + if UI_Is_In_Int_Range (V) then VV := Integer (UI_To_Int (V)); else *************** package body Restrict is *** 347,352 **** --- 397,425 ---- end loop; end Check_Restriction_No_Dependence; + -------------------------------------- + -- Check_Wide_Character_Restriction -- + -------------------------------------- + + procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is + begin + if Restriction_Check_Required (No_Wide_Characters) + and then Comes_From_Source (N) + then + declare + T : constant Entity_Id := Root_Type (E); + begin + if T = Standard_Wide_Character or else + T = Standard_Wide_String or else + T = Standard_Wide_Wide_Character or else + T = Standard_Wide_Wide_String + then + Check_Restriction (No_Wide_Characters, N); + end if; + end; + end if; + end Check_Wide_Character_Restriction; + ---------------------------------------- -- Cunit_Boolean_Restrictions_Restore -- ---------------------------------------- *************** package body Restrict is *** 513,518 **** --- 586,600 ---- return Restrictions.Set (R) and then not Restriction_Warnings (R); end Restriction_Active; + -------------------------------- + -- Restriction_Check_Required -- + -------------------------------- + + function Restriction_Check_Required (R : All_Restrictions) return Boolean is + begin + return Restrictions.Set (R); + end Restriction_Check_Required; + --------------------- -- Restriction_Msg -- --------------------- *************** package body Restrict is *** 603,609 **** Error_Msg_Sloc := No_Location; end if; ! -- Case of parametrized restriction if R in All_Parameter_Restrictions then Add_Char ('`'); --- 685,691 ---- Error_Msg_Sloc := No_Location; end if; ! -- Case of parameterized restriction if R in All_Parameter_Restrictions then Add_Char ('`'); diff -Nrcpad gcc-4.5.2/gcc/ada/restrict.ads gcc-4.6.0/gcc/ada/restrict.ads *** gcc-4.5.2/gcc/ada/restrict.ads Mon Aug 4 08:37:31 2008 --- gcc-4.6.0/gcc/ada/restrict.ads Thu Sep 9 09:57:00 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Restrict is *** 230,235 **** --- 230,250 ---- -- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N). -- Provided for easy use by back end, which has to check this restriction. + procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id); + -- This routine checks if the entity E is one of the obsolescent entries + -- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features + -- restriction is active. If so an appropriate message is given. N is + -- the node on which the message is to be placed. It's a bit kludgy to + -- have this highly specialized routine rather than some wonderful general + -- mechanism (e.g. a special pragma) to handle this case, but there are + -- only six cases, and it is not worth the effort to do something general. + + procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id); + -- This procedure checks if the No_Wide_Character restriction is active, + -- and if so, if N Comes_From_Source, and the root type of E is one of + -- [Wide_]Wide_Character or [Wide_]Wide_String, then the restriction + -- violation is recorded, and an appropriate message given. + function Cunit_Boolean_Restrictions_Save return Save_Cunit_Boolean_Restrictions; -- This function saves the compilation unit restriction settings, and *************** package Restrict is *** 277,283 **** -- used where the compiled code depends on whether the restriction is -- active. Always use Check_Restriction to record a violation. Note that -- this returns False if we only have a Restriction_Warnings set, since ! -- restriction warnings should never affect generated code. function Restricted_Profile return Boolean; -- Tests if set of restrictions corresponding to Profile (Restricted) is --- 292,310 ---- -- used where the compiled code depends on whether the restriction is -- active. Always use Check_Restriction to record a violation. Note that -- this returns False if we only have a Restriction_Warnings set, since ! -- restriction warnings should never affect generated code. If you want ! -- to know if a call to Check_Restriction is needed then use the function ! -- Restriction_Check_Required instead. ! ! function Restriction_Check_Required (R : All_Restrictions) return Boolean; ! pragma Inline (Restriction_Check_Required); ! -- Determines if either a Restriction_Warnings or Restrictions pragma has ! -- been given for the specified restriction. If true, then a subsequent ! -- call to Check_Restriction is required if the restriction is violated. ! -- This must not be used to guard code generation that depends on whether ! -- a restriction is active (see Restriction_Active above). Typically it ! -- is used to avoid complex code to determine if a restriction is violated, ! -- executing this code only if needed. function Restricted_Profile return Boolean; -- Tests if set of restrictions corresponding to Profile (Restricted) is diff -Nrcpad gcc-4.5.2/gcc/ada/rtsfind.adb gcc-4.6.0/gcc/ada/rtsfind.adb *** gcc-4.5.2/gcc/ada/rtsfind.adb Mon Jul 13 12:45:02 2009 --- gcc-4.6.0/gcc/ada/rtsfind.adb Fri Jun 18 09:53:00 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Rtsfind is *** 1333,1340 **** -- The RT_Unit_Table entry that may need updating begin ! -- If entry is not set, set it now, and indicate that it ! -- was loaded through an explicit context clause.. if No (U.Entity) then U := (Entity => E, --- 1333,1340 ---- -- The RT_Unit_Table entry that may need updating begin ! -- If entry is not set, set it now, and indicate that it was ! -- loaded through an explicit context clause. if No (U.Entity) then U := (Entity => E, diff -Nrcpad gcc-4.5.2/gcc/ada/rtsfind.ads gcc-4.6.0/gcc/ada/rtsfind.ads *** gcc-4.5.2/gcc/ada/rtsfind.ads Mon Jul 13 09:28:05 2009 --- gcc-4.6.0/gcc/ada/rtsfind.ads Mon Oct 18 10:27:48 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Rtsfind is *** 265,270 **** --- 265,271 ---- System_Machine_Code, System_Mantissa, System_Memcop, + System_Multiprocessors, System_Pack_03, System_Pack_05, System_Pack_06, *************** package Rtsfind is *** 536,542 **** RO_RT_Delay_Until, -- Ada.Real_Time.Delays RO_RT_To_Duration, -- Ada.Real_Time.Delays ! RE_Timing_Event, -- Ada_Real_Time_Timing_Events RE_Root_Stream_Type, -- Ada.Streams RE_Stream_Element, -- Ada.Streams --- 537,544 ---- RO_RT_Delay_Until, -- Ada.Real_Time.Delays RO_RT_To_Duration, -- Ada.Real_Time.Delays ! RE_Set_Handler, -- Ada_Real_Time.Timing_Events ! RE_Timing_Event, -- Ada_Real_Time.Timing_Events RE_Root_Stream_Type, -- Ada.Streams RE_Stream_Element, -- Ada.Streams *************** package Rtsfind is *** 600,605 **** --- 602,608 ---- RE_Signature, -- Ada.Tags RE_SSD, -- Ada.Tags RE_TSD, -- Ada.Tags + RE_Type_Is_Abstract, -- Ada.Tags RE_Type_Specific_Data, -- Ada.Tags RE_Register_Interface_Offset, -- Ada.Tags RE_Register_Tag, -- Ada.Tags *************** package Rtsfind is *** 798,803 **** --- 801,807 ---- RE_Image_Boolean, -- System.Img_Bool RE_Image_Character, -- System.Img_Char + RE_Image_Character_05, -- System.Img_Char RE_Image_Decimal, -- System.Img_Dec *************** package Rtsfind is *** 836,841 **** --- 840,847 ---- RE_Mantissa_Value, -- System_Mantissa + RE_CPU_Range, -- System.Multiprocessors + RE_Bits_03, -- System.Pack_03 RE_Get_03, -- System.Pack_03 RE_Set_03, -- System.Pack_03 *************** package Rtsfind is *** 1132,1137 **** --- 1138,1144 ---- RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface RE_Register_Passive_Package, -- System.Partition_Interface RE_Register_Receiving_Stub, -- System.Partition_Interface + RE_Request, -- System.Partition_Interface RE_Request_Access, -- System.Partition_Interface RE_RCI_Locator, -- System.Partition_Interface RE_RCI_Subp_Info, -- System.Partition_Interface *************** package Rtsfind is *** 1171,1182 **** RE_NVList_Ref, -- System.Partition_Interface RE_NVList_Create, -- System.Partition_Interface RE_NVList_Add_Item, -- System.Partition_Interface - RE_Request_Create, -- System.Partition_Interface - RE_Request_Invoke, -- System.Partition_Interface RE_Request_Arguments, -- System.Partition_Interface ! RE_Request_Set_Out, -- System.Partition_Interface RE_Request_Raise_Occurrence, -- System.Partition_Interface ! RE_Request_Destroy, -- System.Partition_Interface RE_Nil_Exc_List, -- System.Partition_Interface RE_Servant, -- System.Partition_Interface RE_Move_Any_Value, -- System.Partition_Interface --- 1178,1188 ---- RE_NVList_Ref, -- System.Partition_Interface RE_NVList_Create, -- System.Partition_Interface RE_NVList_Add_Item, -- System.Partition_Interface RE_Request_Arguments, -- System.Partition_Interface ! RE_Request_Invoke, -- System.Partition_Interface RE_Request_Raise_Occurrence, -- System.Partition_Interface ! RE_Request_Set_Out, -- System.Partition_Interface ! RE_Request_Setup, -- System.Partition_Interface RE_Nil_Exc_List, -- System.Partition_Interface RE_Servant, -- System.Partition_Interface RE_Move_Any_Value, -- System.Partition_Interface *************** package Rtsfind is *** 1396,1401 **** --- 1402,1412 ---- RE_Conditional_Call, -- System.Tasking RE_Asynchronous_Call, -- System.Tasking + RE_Foreign_Task_Level, -- System.Tasking + RE_Environment_Task_Level, -- System.Tasking + RE_Independent_Task_Level, -- System.Tasking + RE_Library_Task_Level, -- System.Tasking + RE_Ada_Task_Control_Block, -- System.Tasking RE_Task_List, -- System.Tasking *************** package Rtsfind is *** 1418,1423 **** --- 1429,1436 ---- RE_Activation_Chain_Access, -- System.Tasking RE_Storage_Size, -- System.Tasking + RE_Unspecified_CPU, -- System.Tasking + RE_Abort_Defer, -- System.Soft_Links RE_Abort_Undefer, -- System.Soft_Links RE_Complete_Master, -- System.Soft_Links *************** package Rtsfind is *** 1701,1706 **** --- 1714,1720 ---- RO_RT_Delay_Until => Ada_Real_Time_Delays, RO_RT_To_Duration => Ada_Real_Time_Delays, + RE_Set_Handler => Ada_Real_Time_Timing_Events, RE_Timing_Event => Ada_Real_Time_Timing_Events, RE_Root_Stream_Type => Ada_Streams, *************** package Rtsfind is *** 1765,1770 **** --- 1779,1785 ---- RE_Signature => Ada_Tags, RE_SSD => Ada_Tags, RE_TSD => Ada_Tags, + RE_Type_Is_Abstract => Ada_Tags, RE_Type_Specific_Data => Ada_Tags, RE_Register_Interface_Offset => Ada_Tags, RE_Register_Tag => Ada_Tags, *************** package Rtsfind is *** 1963,1968 **** --- 1978,1984 ---- RE_Image_Boolean => System_Img_Bool, RE_Image_Character => System_Img_Char, + RE_Image_Character_05 => System_Img_Char, RE_Image_Decimal => System_Img_Dec, *************** package Rtsfind is *** 2001,2006 **** --- 2017,2024 ---- RE_Mantissa_Value => System_Mantissa, + RE_CPU_Range => System_Multiprocessors, + RE_Bits_03 => System_Pack_03, RE_Get_03 => System_Pack_03, RE_Set_03 => System_Pack_03, *************** package Rtsfind is *** 2297,2302 **** --- 2315,2321 ---- RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface, RE_Register_Passive_Package => System_Partition_Interface, RE_Register_Receiving_Stub => System_Partition_Interface, + RE_Request => System_Partition_Interface, RE_Request_Access => System_Partition_Interface, RE_RCI_Locator => System_Partition_Interface, RE_RCI_Subp_Info => System_Partition_Interface, *************** package Rtsfind is *** 2327,2338 **** RE_NVList_Ref => System_Partition_Interface, RE_NVList_Create => System_Partition_Interface, RE_NVList_Add_Item => System_Partition_Interface, - RE_Request_Create => System_Partition_Interface, - RE_Request_Invoke => System_Partition_Interface, RE_Request_Arguments => System_Partition_Interface, ! RE_Request_Set_Out => System_Partition_Interface, RE_Request_Raise_Occurrence => System_Partition_Interface, ! RE_Request_Destroy => System_Partition_Interface, RE_Nil_Exc_List => System_Partition_Interface, RE_Servant => System_Partition_Interface, RE_Move_Any_Value => System_Partition_Interface, --- 2346,2356 ---- RE_NVList_Ref => System_Partition_Interface, RE_NVList_Create => System_Partition_Interface, RE_NVList_Add_Item => System_Partition_Interface, RE_Request_Arguments => System_Partition_Interface, ! RE_Request_Invoke => System_Partition_Interface, RE_Request_Raise_Occurrence => System_Partition_Interface, ! RE_Request_Set_Out => System_Partition_Interface, ! RE_Request_Setup => System_Partition_Interface, RE_Nil_Exc_List => System_Partition_Interface, RE_Servant => System_Partition_Interface, RE_Move_Any_Value => System_Partition_Interface, *************** package Rtsfind is *** 2561,2566 **** --- 2579,2589 ---- RE_Conditional_Call => System_Tasking, RE_Asynchronous_Call => System_Tasking, + RE_Foreign_Task_Level => System_Tasking, + RE_Environment_Task_Level => System_Tasking, + RE_Independent_Task_Level => System_Tasking, + RE_Library_Task_Level => System_Tasking, + RE_Ada_Task_Control_Block => System_Tasking, RE_Task_List => System_Tasking, *************** package Rtsfind is *** 2583,2588 **** --- 2606,2613 ---- RE_Activation_Chain_Access => System_Tasking, RE_Storage_Size => System_Tasking, + RE_Unspecified_CPU => System_Tasking, + RE_Abort_Defer => System_Soft_Links, RE_Abort_Undefer => System_Soft_Links, RE_Complete_Master => System_Soft_Links, diff -Nrcpad gcc-4.5.2/gcc/ada/s-asthan-vms-alpha.adb gcc-4.6.0/gcc/ada/s-asthan-vms-alpha.adb *** gcc-4.5.2/gcc/ada/s-asthan-vms-alpha.adb Thu Apr 16 08:33:28 2009 --- gcc-4.6.0/gcc/ada/s-asthan-vms-alpha.adb Tue Oct 5 09:37:44 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2010, 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- -- *************** with System.Task_Primitives; *** 48,61 **** with System.Task_Primitives.Operations; with System.Task_Primitives.Operations.DEC; ! -- with Ada.Finalization; ! -- removed, because of problem with controlled attribute ??? ! with Ada.Task_Attributes; with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; package body System.AST_Handling is --- 48,60 ---- with System.Task_Primitives.Operations; with System.Task_Primitives.Operations.DEC; ! with Ada.Finalization; with Ada.Task_Attributes; with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; + with Ada.Unchecked_Deallocation; package body System.AST_Handling is *************** package body System.AST_Handling is *** 190,204 **** type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; type AST_Handler_Vector_Ref is access all AST_Handler_Vector; ! -- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record ! -- removed due to problem with controlled attribute, consequence is that ! -- we have a memory leak if a task that has AST attribute entries is ! -- terminated. ??? ! ! type AST_Vector_Ptr is record Vector : AST_Handler_Vector_Ref; end record; AST_Vector_Init : AST_Vector_Ptr; -- Initial value, treated as constant, Vector will be null --- 189,210 ---- type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; type AST_Handler_Vector_Ref is access all AST_Handler_Vector; ! type AST_Vector_Ptr is new Ada.Finalization.Controlled with record Vector : AST_Handler_Vector_Ref; end record; + procedure Finalize (Obj : in out AST_Vector_Ptr); + -- Override Finalize so that the AST Vector gets freed. + + procedure Finalize (Obj : in out AST_Vector_Ptr) is + procedure Free is new + Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref); + begin + if Obj.Vector /= null then + Free (Obj.Vector); + end if; + end Finalize; + AST_Vector_Init : AST_Vector_Ptr; -- Initial value, treated as constant, Vector will be null diff -Nrcpad gcc-4.5.2/gcc/ada/s-auxdec-vms-alpha.adb gcc-4.6.0/gcc/ada/s-auxdec-vms-alpha.adb *** gcc-4.5.2/gcc/ada/s-auxdec-vms-alpha.adb Thu Jan 1 00:00:00 1970 --- gcc-4.6.0/gcc/ada/s-auxdec-vms-alpha.adb Mon Dec 20 07:26:57 2010 *************** *** 0 **** --- 1,809 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . A U X _ D E C -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1992-2010, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This is the Alpha/VMS version. + + pragma Style_Checks (All_Checks); + -- Turn off alpha ordering check on subprograms, this unit is laid + -- out to correspond to the declarations in the DEC 83 System unit. + + with System.Machine_Code; use System.Machine_Code; + package body System.Aux_DEC is + + ------------------------ + -- Fetch_From_Address -- + ------------------------ + + function Fetch_From_Address (A : Address) return Target is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + return Ptr.all; + end Fetch_From_Address; + + ----------------------- + -- Assign_To_Address -- + ----------------------- + + procedure Assign_To_Address (A : Address; T : Target) is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + Ptr.all := T; + end Assign_To_Address; + + ----------------------- + -- Clear_Interlocked -- + ----------------------- + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Old_Bit : Boolean; + + begin + -- All these ASM sequences should be commented. I suggest defining + -- a constant called E which is LF & HT and then you have more space + -- for line by line comments ??? + + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bic $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Clr_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + end Clear_Interlocked; + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bic %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Clr_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Clear_Interlocked; + + --------------------- + -- Set_Interlocked -- + --------------------- + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Old_Bit : Boolean; + + begin + -- Don't we need comments on these long asm sequences??? + + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "mb" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bis $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Set_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + end Set_Interlocked; + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bis %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Set_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Set_Interlocked; + + --------------------- + -- Add_Interlocked -- + --------------------- + + procedure Add_Interlocked + (Addend : Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer) + is + use ASCII; + Overflowed : Boolean := False; + + begin + System.Machine_Code.Asm + ( + "lda $18, %0" & LF & HT & + "bic $18, 6, $21" & LF & HT & + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $0, 0($21)" & LF & HT & + "extwl $0, $18, $19" & LF & HT & + "mskwl $0, $18, $0" & LF & HT & + "addq $19, %3, $20" & LF & HT & + "inswl $20, $18, $17" & LF & HT & + "xor $19, %3, $19" & LF & HT & + "bis $17, $0, $0" & LF & HT & + "stq_c $0, 0($21)" & LF & HT & + "beq $0, 1b" & LF & HT & + "srl $20, 16, $0" & LF & HT & + "mb" & LF & HT & + "srl $20, 12, $21" & LF & HT & + "zapnot $20, 3, $20" & LF & HT & + "and $0, 1, $0" & LF & HT & + "and $21, 8, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "cmpeq $20, 0, $21" & LF & HT & + "xor $20, 2, $20" & LF & HT & + "sll $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "bic $20, $19, $21" & LF & HT & + "srl $21, 14, $21" & LF & HT & + "and $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "and $0, 2, %2" & LF & HT & + "bne %2, 2f" & LF & HT & + "and $0, 4, %1" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "and $0, 8, $0" & LF & HT & + "lda $16, -1" & LF & HT & + "cmovne $0, $16, %1" & LF & HT & + "2:", + Outputs => (Aligned_Word'Asm_Output ("=m", Augend), + Integer'Asm_Output ("=r", Sign), + Boolean'Asm_Output ("=r", Overflowed)), + Inputs => (Short_Integer'Asm_Input ("r", Addend), + Aligned_Word'Asm_Input ("m", Augend)), + Clobber => "$0, $1, $16, $17, $18, $19, $20, $21", + Volatile => True); + + if Overflowed then + raise Constraint_Error; + end if; + end Add_Interlocked; + + ---------------- + -- Add_Atomic -- + ---------------- + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + ---------------- + -- And_Atomic -- + ---------------- + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + --------------- + -- Or_Atomic -- + --------------- + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + ------------ + -- Insqhi -- + ------------ + + procedure Insqhi + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x87" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqhi; + + ------------ + -- Remqhi -- + ------------ + + procedure Remqhi + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x93" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqhi; + + ------------ + -- Insqti -- + ------------ + + procedure Insqti + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x88" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqti; + + ------------ + -- Remqti -- + ------------ + + procedure Remqti + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x94" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqti; + + end System.Aux_DEC; diff -Nrcpad gcc-4.5.2/gcc/ada/s-auxdec-vms_64.ads gcc-4.6.0/gcc/ada/s-auxdec-vms_64.ads *** gcc-4.5.2/gcc/ada/s-auxdec-vms_64.ads Mon Apr 20 08:55:51 2009 --- gcc-4.6.0/gcc/ada/s-auxdec-vms_64.ads Mon Dec 20 07:26:57 2010 *************** package System.Aux_DEC is *** 112,117 **** --- 112,120 ---- function "-" (Left : Address; Right : Address) return Integer; function "-" (Left : Address; Right : Integer) return Address; + pragma Import (Intrinsic, "+"); + pragma Import (Intrinsic, "-"); + generic type Target is private; function Fetch_From_Address (A : Address) return Target; *************** package System.Aux_DEC is *** 227,242 **** type Unsigned_Quadword_Array is array (Integer range <>) of Unsigned_Quadword; ! function To_Address (X : Integer) return Address; pragma Pure_Function (To_Address); ! function To_Address_Long (X : Unsigned_Longword) return Address; pragma Pure_Function (To_Address_Long); ! function To_Integer (X : Address) return Integer; ! function To_Unsigned_Longword (X : Address) return Unsigned_Longword; ! function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; -- Conventional names for static subtypes of type UNSIGNED_LONGWORD --- 230,245 ---- type Unsigned_Quadword_Array is array (Integer range <>) of Unsigned_Quadword; ! function To_Address (X : Integer) return Short_Address; pragma Pure_Function (To_Address); ! function To_Address_Long (X : Unsigned_Longword) return Short_Address; pragma Pure_Function (To_Address_Long); ! function To_Integer (X : Short_Address) return Integer; ! function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword; ! function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; -- Conventional names for static subtypes of type UNSIGNED_LONGWORD *************** private *** 461,472 **** -- them intrinsic, since the backend can handle them, but the front -- end is not prepared to deal with them, so at least inline them. ! pragma Inline_Always ("+"); ! pragma Inline_Always ("-"); ! pragma Inline_Always ("not"); ! pragma Inline_Always ("and"); ! pragma Inline_Always ("or"); ! pragma Inline_Always ("xor"); -- Other inlined subprograms --- 464,473 ---- -- them intrinsic, since the backend can handle them, but the front -- end is not prepared to deal with them, so at least inline them. ! pragma Import (Intrinsic, "not"); ! pragma Import (Intrinsic, "and"); ! pragma Import (Intrinsic, "or"); ! pragma Import (Intrinsic, "xor"); -- Other inlined subprograms *************** private *** 578,583 **** --- 579,591 ---- Mechanism => (Reference, Value, Value, Reference, Reference)); pragma Inline_Always (Or_Atomic); + -- Inline the VAX Queue Functions + + pragma Inline_Always (Insqhi); + pragma Inline_Always (Remqhi); + pragma Inline_Always (Insqti); + pragma Inline_Always (Remqti); + -- Provide proper unchecked conversion definitions for transfer -- functions. Note that we need this level of indirection because -- the formal parameter name is X and not Source (and this is indeed *************** private *** 649,679 **** -- want warnings when we compile on such systems. function To_Address_A is new ! Ada.Unchecked_Conversion (Integer, Address); pragma Pure_Function (To_Address_A); ! function To_Address (X : Integer) return Address renames To_Address_A; pragma Pure_Function (To_Address); function To_Address_Long_A is new ! Ada.Unchecked_Conversion (Unsigned_Longword, Address); pragma Pure_Function (To_Address_Long_A); ! function To_Address_Long (X : Unsigned_Longword) return Address renames To_Address_Long_A; pragma Pure_Function (To_Address_Long); function To_Integer_A is new ! Ada.Unchecked_Conversion (Address, Integer); ! function To_Integer (X : Address) return Integer renames To_Integer_A; function To_Unsigned_Longword_A is new ! Ada.Unchecked_Conversion (Address, Unsigned_Longword); ! function To_Unsigned_Longword (X : Address) return Unsigned_Longword renames To_Unsigned_Longword_A; function To_Unsigned_Longword_A is new --- 657,687 ---- -- want warnings when we compile on such systems. function To_Address_A is new ! Ada.Unchecked_Conversion (Integer, Short_Address); pragma Pure_Function (To_Address_A); ! function To_Address (X : Integer) return Short_Address renames To_Address_A; pragma Pure_Function (To_Address); function To_Address_Long_A is new ! Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address); pragma Pure_Function (To_Address_Long_A); ! function To_Address_Long (X : Unsigned_Longword) return Short_Address renames To_Address_Long_A; pragma Pure_Function (To_Address_Long); function To_Integer_A is new ! Ada.Unchecked_Conversion (Short_Address, Integer); ! function To_Integer (X : Short_Address) return Integer renames To_Integer_A; function To_Unsigned_Longword_A is new ! Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); ! function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword renames To_Unsigned_Longword_A; function To_Unsigned_Longword_A is new diff -Nrcpad gcc-4.5.2/gcc/ada/s-bitops.adb gcc-4.6.0/gcc/ada/s-bitops.adb *** gcc-4.5.2/gcc/ada/s-bitops.adb Mon Nov 30 11:08:56 2009 --- gcc-4.6.0/gcc/ada/s-bitops.adb Thu Sep 9 09:44:34 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2010, 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- -- *************** pragma Compiler_Unit; *** 34,39 **** --- 34,40 ---- with System; use System; with System.Unsigned_Types; use System.Unsigned_Types; + with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; package body System.Bit_Ops is *************** package body System.Bit_Ops is *** 72,77 **** --- 73,79 ---- ----------------------- procedure Raise_Error; + pragma No_Return (Raise_Error); -- Raise Constraint_Error, complaining about unequal lengths ------------- *************** package body System.Bit_Ops is *** 211,217 **** procedure Raise_Error is begin ! raise Constraint_Error; end Raise_Error; end System.Bit_Ops; --- 213,220 ---- procedure Raise_Error is begin ! Raise_Exception ! (Constraint_Error'Identity, "operand lengths are unequal"); end Raise_Error; end System.Bit_Ops; diff -Nrcpad gcc-4.5.2/gcc/ada/s-crc32.adb gcc-4.6.0/gcc/ada/s-crc32.adb *** gcc-4.5.2/gcc/ada/s-crc32.adb Fri Apr 17 13:15:47 2009 --- gcc-4.6.0/gcc/ada/s-crc32.adb Thu Oct 7 12:37:10 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2010, 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- -- *************** package body System.CRC32 is *** 130,136 **** procedure Update (C : in out CRC32; Value : Character) is V : constant CRC32 := CRC32 (Character'Pos (Value)); - begin C := Shift_Right (C, 8) xor Table (V xor (C and 16#0000_00FF#)); end Update; --- 130,135 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/s-crtl.ads gcc-4.6.0/gcc/ada/s-crtl.ads *** gcc-4.5.2/gcc/ada/s-crtl.ads Mon Nov 30 10:20:47 2009 --- gcc-4.6.0/gcc/ada/s-crtl.ads Thu Jun 17 12:26:10 2010 *************** package System.CRTL is *** 59,64 **** --- 59,67 ---- type size_t is mod 2 ** Standard'Address_Size; + type ssize_t is range -(2 ** (Standard'Address_Size - 1)) + .. +(2 ** (Standard'Address_Size - 1)) - 1; + type Filename_Encoding is (UTF8, ASCII_8bits, Unspecified); for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1, Unspecified => 2); pragma Convention (C, Filename_Encoding); *************** package System.CRTL is *** 187,196 **** function close (fd : int) return int; pragma Import (C, close, "close"); ! function read (fd : int; buffer : chars; nbytes : int) return int; pragma Import (C, read, "read"); ! function write (fd : int; buffer : chars; nbytes : int) return int; pragma Import (C, write, "write"); end System.CRTL; --- 190,199 ---- function close (fd : int) return int; pragma Import (C, close, "close"); ! function read (fd : int; buffer : chars; count : size_t) return ssize_t; pragma Import (C, read, "read"); ! function write (fd : int; buffer : chars; count : size_t) return ssize_t; pragma Import (C, write, "write"); end System.CRTL; diff -Nrcpad gcc-4.5.2/gcc/ada/s-direio.adb gcc-4.6.0/gcc/ada/s-direio.adb *** gcc-4.5.2/gcc/ada/s-direio.adb Mon Jul 13 08:39:28 2009 --- gcc-4.6.0/gcc/ada/s-direio.adb Thu Sep 9 10:39:19 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body System.Direct_IO is *** 127,133 **** function End_Of_File (File : File_Type) return Boolean is begin FIO.Check_Read_Status (AP (File)); ! return Count (File.Index) > Size (File); end End_Of_File; ----------- --- 127,133 ---- function End_Of_File (File : File_Type) return Boolean is begin FIO.Check_Read_Status (AP (File)); ! return File.Index > Size (File); end End_Of_File; ----------- *************** package body System.Direct_IO is *** 137,143 **** function Index (File : File_Type) return Positive_Count is begin FIO.Check_File_Open (AP (File)); ! return Count (File.Index); end Index; ---------- --- 137,143 ---- function Index (File : File_Type) return Positive_Count is begin FIO.Check_File_Open (AP (File)); ! return File.Index; end Index; ---------- diff -Nrcpad gcc-4.5.2/gcc/ada/s-fatgen.adb gcc-4.6.0/gcc/ada/s-fatgen.adb *** gcc-4.5.2/gcc/ada/s-fatgen.adb Mon Nov 30 10:28:23 2009 --- gcc-4.6.0/gcc/ada/s-fatgen.adb Thu Sep 9 08:57:08 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body System.Fat_Gen is *** 162,174 **** begin if X = 0.0 then Frac := X; Expo := 0; - -- More useful would be defining Expo to be T'Machine_Emin - 1 or - -- T'Machine_Emin - T'Machine_Mantissa, which would preserve - -- monotonicity of the exponent function ??? - -- Check for infinities, transfinites, whatnot elsif X > T'Safe_Last then --- 162,173 ---- begin if X = 0.0 then + + -- The normalized exponent of zero is zero, see RM A.5.2(15) + Frac := X; Expo := 0; -- Check for infinities, transfinites, whatnot elsif X > T'Safe_Last then *************** package body System.Fat_Gen is *** 205,210 **** --- 204,210 ---- end if; -- Ax < R_Power (N) + end loop; -- 1 <= Ax < Rad *************** package body System.Fat_Gen is *** 229,234 **** --- 229,235 ---- end if; -- R_Neg_Power (N) <= Ax < 1 + end loop; end if; *************** package body System.Fat_Gen is *** 553,560 **** -- Scaling -- ------------- ! -- Return x * rad ** adjustment quickly, ! -- or quietly underflow to zero, or overflow naturally. function Scaling (X : T; Adjustment : UI) return T is begin --- 554,561 ---- -- Scaling -- ------------- ! -- Return x * rad ** adjustment quickly, or quietly underflow to zero, ! -- or overflow naturally. function Scaling (X : T; Adjustment : UI) return T is begin *************** package body System.Fat_Gen is *** 586,591 **** --- 587,593 ---- end if; -- -Log_Power (N) < Ex <= 0 + end loop; -- Ex = 0 *************** package body System.Fat_Gen is *** 611,616 **** --- 613,619 ---- end loop; -- Ex = 0 + end if; return Y; *************** package body System.Fat_Gen is *** 648,660 **** else Decompose (X, X_Frac, X_Exp); ! -- A special case, if the number we had was a negative power of ! -- two, then we want to add half of what we would otherwise add, ! -- since the exponent is going to be reduced. -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, ! -- then we know that we have a negative number (and hence a ! -- negative power of 2). if X_Frac = -0.5 then return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); --- 651,663 ---- else Decompose (X, X_Frac, X_Exp); ! -- A special case, if the number we had was a negative power of two, ! -- then we want to add half of what we would otherwise add, since the ! -- exponent is going to be reduced. -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, ! -- then we know that we have a negative number (and hence a negative ! -- power of 2). if X_Frac = -0.5 then return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); *************** package body System.Fat_Gen is *** 779,786 **** -- one read, but small enough so that all floating point object sizes -- are a multiple of the Float_Word'Size. ! -- The following conditions must be met for all possible ! -- instantiations of the attributes package: -- - T'Size is an integral multiple of Float_Word'Size --- 782,789 ---- -- one read, but small enough so that all floating point object sizes -- are a multiple of the Float_Word'Size. ! -- The following conditions must be met for all possible instantiations ! -- of the attributes package: -- - T'Size is an integral multiple of Float_Word'Size *************** package body System.Fat_Gen is *** 795,803 **** type Rep_Index is range 0 .. 7; Rep_Words : constant Positive := ! (T'Size + Float_Word'Size - 1) / Float_Word'Size; ! Rep_Last : constant Rep_Index := Rep_Index'Min ! (Rep_Index (Rep_Words - 1), (T'Mantissa + 16) / Float_Word'Size); -- Determine the number of Float_Words needed for representing the -- entire floating-point value. Do not take into account excessive -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 --- 798,808 ---- type Rep_Index is range 0 .. 7; Rep_Words : constant Positive := ! (T'Size + Float_Word'Size - 1) / Float_Word'Size; ! Rep_Last : constant Rep_Index := ! Rep_Index'Min ! (Rep_Index (Rep_Words - 1), ! (T'Mantissa + 16) / Float_Word'Size); -- Determine the number of Float_Words needed for representing the -- entire floating-point value. Do not take into account excessive -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 diff -Nrcpad gcc-4.5.2/gcc/ada/s-ficobl.ads gcc-4.6.0/gcc/ada/s-ficobl.ads *** gcc-4.5.2/gcc/ada/s-ficobl.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-ficobl.ads Thu Sep 9 10:32:50 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package System.File_Control_Block is *** 60,65 **** --- 60,66 ---- -- Used to hold name and form strings type File_Mode is (In_File, Inout_File, Out_File, Append_File); + subtype Read_File_Mode is File_Mode range In_File .. Inout_File; -- File mode (union of file modes permitted by individual packages, -- the types File_Mode in the individual packages are declared to -- allow easy conversion to and from this general type. diff -Nrcpad gcc-4.5.2/gcc/ada/s-fileio.adb gcc-4.6.0/gcc/ada/s-fileio.adb *** gcc-4.5.2/gcc/ada/s-fileio.adb Mon Nov 30 10:28:23 2009 --- gcc-4.6.0/gcc/ada/s-fileio.adb Fri Sep 10 09:54:24 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body System.File_IO is *** 104,110 **** File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case ! -- sensitive (e.g., in OS/2, set False). ----------------------- -- Local Subprograms -- --- 104,110 ---- File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case ! -- sensitive (e.g., in Windows, set False). ----------------------- -- Local Subprograms -- *************** package body System.File_IO is *** 205,211 **** begin if File = null then raise Status_Error with "file not open"; ! elsif File.Mode > Inout_File then raise Mode_Error with "file not readable"; end if; end Check_Read_Status; --- 205,211 ---- begin if File = null then raise Status_Error with "file not open"; ! elsif File.Mode not in Read_File_Mode then raise Mode_Error with "file not readable"; end if; end Check_Read_Status; *************** package body System.File_IO is *** 385,391 **** end Errno_Message; function Errno_Message ! (Name : String; Errno : Integer := OS_Lib.Errno) return String is begin --- 385,391 ---- end Errno_Message; function Errno_Message ! (Name : String; Errno : Integer := OS_Lib.Errno) return String is begin *************** package body System.File_IO is *** 1183,1189 **** -- reopen. if Mode = File.Mode ! and then Mode <= Inout_File then rewind (File.Stream); --- 1183,1189 ---- -- reopen. if Mode = File.Mode ! and then Mode in Read_File_Mode then rewind (File.Stream); diff -Nrcpad gcc-4.5.2/gcc/ada/s-filofl.ads gcc-4.6.0/gcc/ada/s-filofl.ads *** gcc-4.5.2/gcc/ada/s-filofl.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-filofl.ads Fri Jun 18 12:32:53 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2005,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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- 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- -- diff -Nrcpad gcc-4.5.2/gcc/ada/s-finimp.adb gcc-4.6.0/gcc/ada/s-finimp.adb *** gcc-4.5.2/gcc/ada/s-finimp.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-finimp.adb Mon Jun 14 12:46:56 2010 *************** package body System.Finalization_Impleme *** 332,341 **** P : Finalizable_Ptr := L; Q : Finalizable_Ptr; ! type Fake_Exception_Occurence is record Id : Exception_Id; end record; ! type Ptr is access all Fake_Exception_Occurence; function To_Ptr is new Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr); --- 332,341 ---- P : Finalizable_Ptr := L; Q : Finalizable_Ptr; ! type Fake_Exception_Occurrence is record Id : Exception_Id; end record; ! type Ptr is access all Fake_Exception_Occurrence; function To_Ptr is new Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr); diff -Nrcpad gcc-4.5.2/gcc/ada/s-htable.adb gcc-4.6.0/gcc/ada/s-htable.adb *** gcc-4.5.2/gcc/ada/s-htable.adb Mon Jun 22 12:24:57 2009 --- gcc-4.6.0/gcc/ada/s-htable.adb Mon Oct 11 10:43:04 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2009, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1995-2010, AdaCore -- -- -- -- 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- -- *************** package body System.HTable is *** 110,116 **** function Get_Non_Null return Elmt_Ptr is begin ! while Iterator_Ptr = Null_Ptr loop if Iterator_Index = Table'Last then Iterator_Started := False; return Null_Ptr; --- 110,116 ---- function Get_Non_Null return Elmt_Ptr is begin ! while Iterator_Ptr = Null_Ptr loop if Iterator_Index = Table'Last then Iterator_Started := False; return Null_Ptr; *************** package body System.HTable is *** 246,251 **** --- 246,262 ---- end if; end Get_First; + procedure Get_First (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_First; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_First; + ------------- -- Get_Key -- ------------- *************** package body System.HTable is *** 269,274 **** --- 280,296 ---- end if; end Get_Next; + procedure Get_Next (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_Next; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_Next; + ---------- -- Next -- ---------- diff -Nrcpad gcc-4.5.2/gcc/ada/s-htable.ads gcc-4.6.0/gcc/ada/s-htable.ads *** gcc-4.5.2/gcc/ada/s-htable.ads Wed Jul 15 09:42:04 2009 --- gcc-4.6.0/gcc/ada/s-htable.ads Mon Oct 11 10:43:04 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2009, AdaCore -- -- -- -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2010, AdaCore -- -- -- -- 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- -- *************** package System.HTable is *** 80,86 **** function Get (K : Key) return Element; -- Returns the Element associated with a key or No_Element if the ! -- given key has not associated element procedure Remove (K : Key); -- Removes the latest inserted element pointer associated with the --- 80,86 ---- function Get (K : Key) return Element; -- Returns the Element associated with a key or No_Element if the ! -- given key has no associated element. procedure Remove (K : Key); -- Removes the latest inserted element pointer associated with the *************** package System.HTable is *** 94,101 **** function Get_Next return Element; -- Returns a non-specified element that has not been returned by the -- same function since the last call to Get_First or No_Element if ! -- there is no such element. If there is no call to 'Set' in between -- Get_Next calls, all the elements of the HTable will be traversed. end Simple_HTable; ------------------- --- 94,117 ---- function Get_Next return Element; -- Returns a non-specified element that has not been returned by the -- same function since the last call to Get_First or No_Element if ! -- there is no such element. If there is no call to Set in between ! -- Get_Next calls, all the elements of the HTable will be traversed. ! ! procedure Get_First (K : in out Key; E : out Element); ! -- This version of the iterator returns a key/element pair. A non- ! -- specified entry is returned, and there is no guarantee that two ! -- calls to this procedure will return the same element. If the table ! -- is empty, E is set to No_Element, and K is unchanged, otherwise ! -- K and E are set to the first returned entry. ! ! procedure Get_Next (K : in out Key; E : out Element); ! -- This version of the iterator returns a key/element pair. It returns ! -- a non-specified element that has not been returned since the last ! -- call to Get_First. If there is no remaining element, then E is set ! -- to No_Element, and the value in K is unchanged, otherwise K and E ! -- are set to the next entry. If there is no call to Set in between -- Get_Next calls, all the elements of the HTable will be traversed. + end Simple_HTable; ------------------- diff -Nrcpad gcc-4.5.2/gcc/ada/s-imgcha.adb gcc-4.6.0/gcc/ada/s-imgcha.adb *** gcc-4.5.2/gcc/ada/s-imgcha.adb Mon Nov 30 10:28:23 2009 --- gcc-4.6.0/gcc/ada/s-imgcha.adb Fri Oct 8 12:34:08 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body System.Img_Char is *** 158,161 **** --- 158,180 ---- end if; end Image_Character; + ------------------------ + -- Image_Character_05 -- + ------------------------ + + procedure Image_Character_05 + (V : Character; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + begin + if V = Character'Val (16#00AD#) then + P := 11; + S (1 .. P) := "SOFT_HYPHEN"; + else + Image_Character (V, S, P); + end if; + end Image_Character_05; + end System.Img_Char; diff -Nrcpad gcc-4.5.2/gcc/ada/s-imgcha.ads gcc-4.6.0/gcc/ada/s-imgcha.ads *** gcc-4.5.2/gcc/ada/s-imgcha.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-imgcha.ads Fri Oct 8 12:34:08 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package System.Img_Char is *** 42,45 **** --- 42,55 ---- -- setting the resulting value of P. The caller guarantees that S is -- long enough to hold the result, and that S'First is 1. + procedure Image_Character_05 + (V : Character; + S : in out String; + P : out Natural); + -- Computes Character'Image (V) and stores the result in S (1 .. P) + -- setting the resulting value of P. The caller guarantees that S is + -- long enough to hold the result, and that S'First is 1. This version + -- is for use in Ada 2005 and beyond, where soft hyphen is a non-graphic + -- and results in "SOFT_HYPHEN" as the output. + end System.Img_Char; diff -Nrcpad gcc-4.5.2/gcc/ada/s-imgwch.adb gcc-4.6.0/gcc/ada/s-imgwch.adb *** gcc-4.5.2/gcc/ada/s-imgwch.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-imgwch.adb Fri Oct 8 12:34:08 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body System.Img_WChar is *** 61,66 **** --- 61,76 ---- P := 4; + -- Deal with annoying Ada 95 incompatibility with soft hyphen + + elsif V = Wide_Character'Val (16#00AD#) + and then not Ada_2005 + then + P := 3; + S (1) := '''; + S (2) := Character'Val (16#00AD#); + S (3) := '''; + -- Normal case, same as Wide_Wide_Character else *************** package body System.Img_WChar is *** 83,92 **** Val : Unsigned_32 := Wide_Wide_Character'Pos (V); begin ! -- If in range of standard Character, use Character routine if Val <= 16#FF# then ! Image_Character (Character'Val (Wide_Wide_Character'Pos (V)), S, P); -- Otherwise value returned is Hex_hhhhhhhh --- 93,106 ---- Val : Unsigned_32 := Wide_Wide_Character'Pos (V); begin ! -- If in range of standard Character, use Character routine. Use the ! -- Ada 2005 version, since either we are called directly in Ada 2005 ! -- mode for Wide_Wide_Character, or this is the Wide_Character case ! -- which already took care of the Soft_Hyphen glitch. if Val <= 16#FF# then ! Image_Character_05 ! (Character'Val (Wide_Wide_Character'Pos (V)), S, P); -- Otherwise value returned is Hex_hhhhhhhh diff -Nrcpad gcc-4.5.2/gcc/ada/s-interr.adb gcc-4.6.0/gcc/ada/s-interr.adb *** gcc-4.5.2/gcc/ada/s-interr.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-interr.adb Thu Jun 17 13:14:44 2010 *************** package body System.Interrupts is *** 367,377 **** -------------- procedure Finalize (Object : in out Static_Interrupt_Protection) is begin -- ??? loop to be executed only when we're not doing library level -- finalization, since in this case all interrupt tasks are gone. ! if not Interrupt_Manager'Terminated then for N in reverse Object.Previous_Handlers'Range loop Interrupt_Manager.Attach_Handler (New_Handler => Object.Previous_Handlers (N).Handler, --- 367,393 ---- -------------- procedure Finalize (Object : in out Static_Interrupt_Protection) is + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state for interrupt number Int. Defined in init.c + + Default : constant Character := 's'; + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + begin -- ??? loop to be executed only when we're not doing library level -- finalization, since in this case all interrupt tasks are gone. ! -- If the Abort_Task signal is set to system, it means that we cannot ! -- reset interrupt handlers since this would require sending the abort ! -- signal to the Server_Task ! ! if not Interrupt_Manager'Terminated ! and then State (System.Interrupt_Management.Abort_Task_Interrupt) ! /= Default ! then for N in reverse Object.Previous_Handlers'Range loop Interrupt_Manager.Attach_Handler (New_Handler => Object.Previous_Handlers (N).Handler, diff -Nrcpad gcc-4.5.2/gcc/ada/s-intman-vxworks.ads gcc-4.6.0/gcc/ada/s-intman-vxworks.ads *** gcc-4.5.2/gcc/ada/s-intman-vxworks.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-intman-vxworks.ads Tue Jun 22 08:49:11 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.Interrupt_Management is *** 59,66 **** type Interrupt_Set is array (Interrupt_ID) of Boolean; ! subtype Signal_ID is Interrupt_ID ! range 0 .. Interfaces.C."-" (System.OS_Interface.NSIG, 1); type Signal_Set is array (Signal_ID) of Boolean; --- 59,65 ---- type Interrupt_Set is array (Interrupt_ID) of Boolean; ! subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1; type Signal_Set is array (Signal_ID) of Boolean; *************** package System.Interrupt_Management is *** 74,80 **** -- convention that ID zero is not used for any "real" signals, and SIGRARE -- = 0 when SIGRARE is not one of the locally supported signals, we can -- write: ! -- Reserved (SIGRARE) := true; -- and the initialization code will be portable. Abort_Task_Interrupt : Signal_ID; --- 73,79 ---- -- convention that ID zero is not used for any "real" signals, and SIGRARE -- = 0 when SIGRARE is not one of the locally supported signals, we can -- write: ! -- Reserved (SIGRARE) := True; -- and the initialization code will be portable. Abort_Task_Interrupt : Signal_ID; diff -Nrcpad gcc-4.5.2/gcc/ada/s-multip.adb gcc-4.6.0/gcc/ada/s-multip.adb *** gcc-4.5.2/gcc/ada/s-multip.adb Thu Jan 1 00:00:00 1970 --- gcc-4.6.0/gcc/ada/s-multip.adb Mon Oct 11 07:30:09 2010 *************** *** 0 **** --- 1,45 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . M U L T I P R O C E S S O R S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2010, Free Software Foundation, Inc. -- + -- -- + -- GNARL 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + ------------------------------------------------------------------------------ + + with Interfaces.C; use Interfaces.C; + + package body System.Multiprocessors is + + function Gnat_Number_Of_CPUs return int; + pragma Import (C, Gnat_Number_Of_CPUs, "__gnat_number_of_cpus"); + + -------------------- + -- Number_Of_CPUs -- + -------------------- + + function Number_Of_CPUs return CPU is + begin + return CPU (Gnat_Number_Of_CPUs); + end Number_Of_CPUs; + + end System.Multiprocessors; diff -Nrcpad gcc-4.5.2/gcc/ada/s-multip.ads gcc-4.6.0/gcc/ada/s-multip.ads *** gcc-4.5.2/gcc/ada/s-multip.ads Thu Jan 1 00:00:00 1970 --- gcc-4.6.0/gcc/ada/s-multip.ads Mon Oct 11 07:30:09 2010 *************** *** 0 **** --- 1,28 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S Y S T E M . M U L T I P R O C E S S O R S -- + -- -- + -- S p e c -- + -- -- + -- This specification is derived from the Ada Reference Manual for use with -- + -- GNAT. In accordance with the copyright of that document, you can freely -- + -- copy and modify this specification, provided that if you redistribute a -- + -- modified version, any changes that you have made are clearly indicated. -- + -- -- + ------------------------------------------------------------------------------ + + package System.Multiprocessors is + pragma Preelaborate (Multiprocessors); + + type CPU_Range is range 0 .. 2 ** 16 - 1; + + subtype CPU is CPU_Range range 1 .. CPU_Range'Last; + + Not_A_Specific_CPU : constant CPU_Range := 0; + + function Number_Of_CPUs return CPU; + -- Number of available CPUs + + end System.Multiprocessors; diff -Nrcpad gcc-4.5.2/gcc/ada/s-os_lib.adb gcc-4.6.0/gcc/ada/s-os_lib.adb *** gcc-4.5.2/gcc/ada/s-os_lib.adb Tue Oct 27 13:51:46 2009 --- gcc-4.6.0/gcc/ada/s-os_lib.adb Thu Jun 17 12:26:10 2010 *************** package body System.OS_Lib is *** 2309,2316 **** N : Integer) return Integer is begin ! return Integer (System.CRTL.read ! (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); end Read; ----------------- --- 2309,2319 ---- N : Integer) return Integer is begin ! return ! Integer (System.CRTL.read ! (System.CRTL.int (FD), ! System.CRTL.chars (A), ! System.CRTL.size_t (N))); end Read; ----------------- *************** package body System.OS_Lib is *** 2718,2725 **** N : Integer) return Integer is begin ! return Integer (System.CRTL.write ! (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); end Write; end System.OS_Lib; --- 2721,2731 ---- N : Integer) return Integer is begin ! return ! Integer (System.CRTL.write ! (System.CRTL.int (FD), ! System.CRTL.chars (A), ! System.CRTL.size_t (N))); end Write; end System.OS_Lib; diff -Nrcpad gcc-4.5.2/gcc/ada/s-os_lib.ads gcc-4.6.0/gcc/ada/s-os_lib.ads *** gcc-4.5.2/gcc/ada/s-os_lib.ads Tue Oct 27 13:51:46 2009 --- gcc-4.6.0/gcc/ada/s-os_lib.ads Fri Sep 10 15:14:10 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1995-2010, 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- -- *************** package System.OS_Lib is *** 203,210 **** (Name : String; Fmode : Mode) return File_Descriptor; -- Creates new file with given name for writing, returning file descriptor ! -- for subsequent use in Write calls. File descriptor returned is ! -- Invalid_FD if file cannot be successfully created. function Create_Output_Text_File (Name : String) return File_Descriptor; -- Creates new text file with given name suitable to redirect standard --- 203,211 ---- (Name : String; Fmode : Mode) return File_Descriptor; -- Creates new file with given name for writing, returning file descriptor ! -- for subsequent use in Write calls. If the file already exists, it is ! -- overwritten. File descriptor returned is Invalid_FD if file cannot be ! -- successfully created. function Create_Output_Text_File (Name : String) return File_Descriptor; -- Creates new text file with given name suitable to redirect standard *************** package System.OS_Lib is *** 687,695 **** -- (notably Unix systems) a simple file name may also work (if the -- executable can be located in the path). -- ! -- "Spawn" should be avoided in tasking applications, since there are ! -- subtle interactions between creating a process and signals/locks ! -- that can cause troubles. -- -- Note: Arguments in Args that contain spaces and/or quotes such as -- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all --- 688,695 ---- -- (notably Unix systems) a simple file name may also work (if the -- executable can be located in the path). -- ! -- Spawning processes from tasking programs is not recommended. See ! -- "NOTE: Spawn in tasking programs" below. -- -- Note: Arguments in Args that contain spaces and/or quotes such as -- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all *************** package System.OS_Lib is *** 716,722 **** -- by the operating system, or -1 under VxWorks and any other similar -- operating systems which have no notion of separately spawnable programs. -- ! -- "Spawn" should not be used in tasking applications. procedure Spawn (Program_Name : String; --- 716,723 ---- -- by the operating system, or -1 under VxWorks and any other similar -- operating systems which have no notion of separately spawnable programs. -- ! -- Spawning processes from tasking programs is not recommended. See ! -- "NOTE: Spawn in tasking programs" below. procedure Spawn (Program_Name : String; *************** package System.OS_Lib is *** 729,735 **** -- Standard Error output is also redirected. -- Return_Code is set to the status code returned by the operating system -- ! -- "Spawn" should not be used in tasking applications. procedure Spawn (Program_Name : String; --- 730,737 ---- -- Standard Error output is also redirected. -- Return_Code is set to the status code returned by the operating system -- ! -- Spawning processes from tasking programs is not recommended. See ! -- "NOTE: Spawn in tasking programs" below. procedure Spawn (Program_Name : String; *************** package System.OS_Lib is *** 746,752 **** -- will be set to the status code returned by the operating system. -- Otherwise, Return_Code is undefined. -- ! -- "Spawn" should not be used in tasking applications. type Process_Id is private; -- A private type used to identify a process activated by the following --- 748,755 ---- -- will be set to the status code returned by the operating system. -- Otherwise, Return_Code is undefined. -- ! -- Spawning processes from tasking programs is not recommended. See ! -- "NOTE: Spawn in tasking programs" below. type Process_Id is private; -- A private type used to identify a process activated by the following *************** package System.OS_Lib is *** 767,773 **** -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is -- returned the program could not be spawned. -- ! -- "Non_Blocking_Spawn" should not be used in tasking applications. -- -- This function will always return Invalid_Pid under VxWorks, since there -- is no notion of executables under this OS. --- 770,777 ---- -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is -- returned the program could not be spawned. -- ! -- Spawning processes from tasking programs is not recommended. See ! -- "NOTE: Spawn in tasking programs" below. -- -- This function will always return Invalid_Pid under VxWorks, since there -- is no notion of executables under this OS. *************** package System.OS_Lib is *** 782,788 **** -- Standard Error output is also redirected. Invalid_Pid is returned -- if the program could not be spawned successfully. -- ! -- "Non_Blocking_Spawn" should not be used in tasking applications. -- -- This function will always return Invalid_Pid under VxWorks, since there -- is no notion of executables under this OS. --- 786,793 ---- -- Standard Error output is also redirected. Invalid_Pid is returned -- if the program could not be spawned successfully. -- ! -- Spawning processes from tasking programs is not recommended. See ! -- "NOTE: Spawn in tasking programs" below. -- -- This function will always return Invalid_Pid under VxWorks, since there -- is no notion of executables under this OS. *************** package System.OS_Lib is *** 800,806 **** -- file could not be created or if the program could not be spawned -- successfully. -- ! -- "Non_Blocking_Spawn" should not be used in tasking applications. -- -- This function will always return Invalid_Pid under VxWorks, since there -- is no notion of executables under this OS. --- 805,812 ---- -- file could not be created or if the program could not be spawned -- successfully. -- ! -- Spawning processes from tasking programs is not recommended. See ! -- "NOTE: Spawn in tasking programs" below. -- -- This function will always return Invalid_Pid under VxWorks, since there -- is no notion of executables under this OS. *************** package System.OS_Lib is *** 826,831 **** --- 832,901 ---- -- be freed by the programmer (when it is no longer needed) to avoid -- memory leaks. + ------------------------------------- + -- NOTE: Spawn in Tasking Programs -- + ------------------------------------- + + -- Spawning processes in tasking programs using the above Spawn and + -- Non_Blocking_Spawn subprograms is not recommended, because there are + -- subtle interactions between creating a process and signals/locks that + -- can cause trouble. These issues are not specific to Ada; they depend + -- primarily on the operating system. + + -- If you need to spawn processes in a tasking program, you will need to + -- understand the semantics of your operating system, and you are likely to + -- write non-portable code, because operating systems differ in this area. + + -- The Spawn and Non_Blocking_Spawn subprograms call the following + -- operating system functions: + + -- On Windows: spawnvp (blocking) or CreateProcess (non-blocking) + + -- On Solaris: fork1, followed in the child process by execv + + -- On other Unix-like systems, and on VMS: fork, followed in the child + -- process by execv. + + -- On vxworks, nucleus, and RTX, spawning of processes is not supported + + -- For details, look at the functions __gnat_portable_spawn and + -- __gnat_portable_no_block_spawn in adaint.c. + + -- You should read the operating-system-specific documentation for the + -- above functions, paying special attention to subtle interactions with + -- threading, signals, locks, and file descriptors. Most of the issues are + -- related to the fact that on Unix, there is a window of time between fork + -- and execv; Windows does not have this problem, because spawning is done + -- in a single operation. + + -- On Posix-compliant systems, such as Linux, fork duplicates just the + -- calling thread. (On Solaris, fork1 is the Posix-compliant version of + -- fork.) + + -- You should avoid using signals while spawning. This includes signals + -- used internally by the Ada run-time system, such as timer signals used + -- to implement delay statements. + + -- It is best to spawn any subprocesses very early, before the parent + -- process creates tasks, locks, or installs signal handlers. Certainly + -- avoid doing simultaneous spawns from multiple threads of the same + -- process. + + -- There is no problem spawning a subprocess that uses tasking: the + -- problems are caused only by tasking in the parent. + + -- If the parent is using tasking, and needs to spawn subprocesses at + -- arbitrary times, one technique is for the parent to spawn (very early) + -- a particular spawn-manager subprocess whose job is to spawn other + -- processes. The spawn-manager avoids tasking. The parent sends messages + -- to the spawn-manager requesting it to spawn processes, using whatever + -- inter-process communication mechanism you like, such as sockets. + + -- In short, mixing spawning of subprocesses with tasking is a tricky + -- business, and should be avoided if possible, but if it is necessary, + -- the above guidelines should be followed, and you should beware of + -- portability problems. + ------------------- -- Miscellaneous -- ------------------- diff -Nrcpad gcc-4.5.2/gcc/ada/s-oscons-tmplt.c gcc-4.6.0/gcc/ada/s-oscons-tmplt.c *** gcc-4.5.2/gcc/ada/s-oscons-tmplt.c Mon Nov 30 21:12:13 2009 --- gcc-4.6.0/gcc/ada/s-oscons-tmplt.c Mon Dec 20 07:26:57 2010 *************** pragma Style_Checks ("M32766"); *** 98,103 **** --- 98,119 ---- #include #include + #if defined (__alpha__) && defined (__osf__) + /** Tru64 is unable to do vector IO operations with default value of IOV_MAX, + ** so its value is redefined to a small one which is known to work properly. + **/ + #undef IOV_MAX + #define IOV_MAX 16 + #endif + + #if defined (__VMS) + /** VMS is unable to do vector IO operations with default value of IOV_MAX, + ** so its value is redefined to a small one which is known to work properly. + **/ + #undef IOV_MAX + #define IOV_MAX 16 + #endif + #if ! (defined (__vxworks) || defined (__VMS) || defined (__MINGW32__) || \ defined (__nucleus__)) # define HAVE_TERMIOS *************** CND(AF_INET, "IPv4 address family") *** 932,938 **** #endif /** ! ** Tru64 UNIX V4.0F defines AF_INET6 without IPv6 support, specificially ** without struct sockaddr_in6. We use _SS_MAXSIZE (used for the definition ** of struct sockaddr_storage on Tru64 UNIX V5.1) to detect this. **/ --- 948,954 ---- #endif /** ! ** Tru64 UNIX V4.0F defines AF_INET6 without IPv6 support, specifically ** without struct sockaddr_in6. We use _SS_MAXSIZE (used for the definition ** of struct sockaddr_storage on Tru64 UNIX V5.1) to detect this. **/ *************** CND(SIZEOF_sockaddr_in6, "struct sockadd *** 1215,1240 **** #define SIZEOF_fd_set (sizeof (fd_set)) CND(SIZEOF_fd_set, "fd_set"); #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent"); /* - -- Fields of struct hostent - */ - - #ifdef __MINGW32__ - # define h_addrtype_t "short" - # define h_length_t "short" - #else - # define h_addrtype_t "int" - # define h_length_t "int" - #endif - - TXT(" subtype H_Addrtype_T is Interfaces.C." h_addrtype_t ";") - TXT(" subtype H_Length_T is Interfaces.C." h_length_t ";") - - /* - -- Fields of struct msghdr */ --- 1231,1243 ---- #define SIZEOF_fd_set (sizeof (fd_set)) CND(SIZEOF_fd_set, "fd_set"); + #define SIZEOF_struct_hostent (sizeof (struct hostent)) + CND(SIZEOF_struct_hostent, "struct hostent"); + #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent"); /* -- Fields of struct msghdr */ *************** TXT(" subtype Msg_Iovlen_T is Interfac *** 1255,1260 **** --- 1258,1264 ---- */ CND(Need_Netdb_Buffer, "Need buffer for Netdb ops") + CND(Need_Netdb_Lock, "Need lock for Netdb ops") CND(Has_Sockaddr_Len, "Sockaddr has sa_len field") /** diff -Nrcpad gcc-4.5.2/gcc/ada/s-osinte-hpux-dce.ads gcc-4.6.0/gcc/ada/s-osinte-hpux-dce.ads *** gcc-4.5.2/gcc/ada/s-osinte-hpux-dce.ads Mon Nov 23 14:56:58 2009 --- gcc-4.6.0/gcc/ada/s-osinte-hpux-dce.ads Fri Jun 18 12:32:53 2010 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- diff -Nrcpad gcc-4.5.2/gcc/ada/s-osinte-linux.ads gcc-4.6.0/gcc/ada/s-osinte-linux.ads *** gcc-4.5.2/gcc/ada/s-osinte-linux.ads Mon Nov 23 14:56:58 2009 --- gcc-4.6.0/gcc/ada/s-osinte-linux.ads Sat Nov 27 18:34:52 2010 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.OS_Interface is *** 490,500 **** (thread : pthread_t; cpusetsize : size_t; cpuset : access cpu_set_t) return int; ! pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np"); private ! type sigset_t is array (0 .. 127) of Interfaces.C.unsigned_char; pragma Convention (C, sigset_t); for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; --- 490,513 ---- (thread : pthread_t; cpusetsize : size_t; cpuset : access cpu_set_t) return int; ! pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np"); ! pragma Weak_External (pthread_setaffinity_np); ! -- Use a weak symbol because this function may be available or not, ! -- depending on the version of the system. ! ! function pthread_attr_setaffinity_np ! (attr : access pthread_attr_t; ! cpusetsize : size_t; ! cpuset : access cpu_set_t) return int; ! pragma Import (C, pthread_attr_setaffinity_np, ! "pthread_attr_setaffinity_np"); ! pragma Weak_External (pthread_attr_setaffinity_np); ! -- Use a weak symbol because this function may be available or not, ! -- depending on the version of the system. private ! type sigset_t is array (0 .. 127) of unsigned_char; pragma Convention (C, sigset_t); for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; *************** private *** 543,550 **** --- 556,567 ---- type pthread_mutex_t is new System.Linux.pthread_mutex_t; + type unsigned_long_long_t is mod 2 ** 64; + -- Interfaces.C.Extensions isn't preelaborated so cannot be with-ed + type pthread_cond_t is array (0 .. 47) of unsigned_char; pragma Convention (C, pthread_cond_t); + for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment; type pthread_key_t is new unsigned; diff -Nrcpad gcc-4.5.2/gcc/ada/s-osinte-vxworks.adb gcc-4.6.0/gcc/ada/s-osinte-vxworks.adb *** gcc-4.5.2/gcc/ada/s-osinte-vxworks.adb Wed Apr 15 12:43:58 2009 --- gcc-4.6.0/gcc/ada/s-osinte-vxworks.adb Tue Oct 5 09:37:44 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.OS_Interface is *** 229,234 **** --- 229,243 ---- Parameter); end Interrupt_Connect; + ----------------------- + -- Interrupt_Context -- + ----------------------- + + function Interrupt_Context return int is + begin + return System.VxWorks.Ext.Interrupt_Context; + end Interrupt_Context; + -------------------------------- -- Interrupt_Number_To_Vector -- -------------------------------- diff -Nrcpad gcc-4.5.2/gcc/ada/s-osinte-vxworks.ads gcc-4.6.0/gcc/ada/s-osinte-vxworks.ads *** gcc-4.5.2/gcc/ada/s-osinte-vxworks.ads Wed Jun 24 09:41:39 2009 --- gcc-4.6.0/gcc/ada/s-osinte-vxworks.ads Mon Dec 20 07:26:57 2010 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.OS_Interface is *** 471,480 **** Handler : Interrupt_Handler; Parameter : System.Address := System.Null_Address) return int; pragma Inline (Interrupt_Connect); ! -- Use this to set up an user handler. The routine installs a a user -- handler which is invoked after the OS has saved enough context for a -- high-level language routine to be safely invoked. function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Inline (Interrupt_Number_To_Vector); -- Convert a logical interrupt number to the hardware interrupt vector --- 471,485 ---- Handler : Interrupt_Handler; Parameter : System.Address := System.Null_Address) return int; pragma Inline (Interrupt_Connect); ! -- Use this to set up an user handler. The routine installs a user -- handler which is invoked after the OS has saved enough context for a -- high-level language routine to be safely invoked. + function Interrupt_Context return int; + pragma Inline (Interrupt_Context); + -- Return 1 if executing in an interrupt context; return 0 if executing in + -- a task context. + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Inline (Interrupt_Number_To_Vector); -- Convert a logical interrupt number to the hardware interrupt vector *************** package System.OS_Interface is *** 490,497 **** -- For uniprocessor systems return ERROR status. private - type sigset_t is new unsigned_long_long; - type pid_t is new int; ERROR_PID : constant pid_t := -1; --- 495,500 ---- *************** private *** 499,502 **** --- 502,506 ---- type clockid_t is new int; CLOCK_REALTIME : constant clockid_t := 0; + type sigset_t is new System.VxWorks.Ext.sigset_t; end System.OS_Interface; diff -Nrcpad gcc-4.5.2/gcc/ada/s-osprim-mingw.adb gcc-4.6.0/gcc/ada/s-osprim-mingw.adb *** gcc-4.5.2/gcc/ada/s-osprim-mingw.adb Tue Jan 26 09:42:04 2010 --- gcc-4.6.0/gcc/ada/s-osprim-mingw.adb Mon Dec 20 07:26:57 2010 *************** package body System.OS_Primitives is *** 193,201 **** GetSystemTimeAsFileTime (Ctrl_Time'Access); ! -- Scan for clock tick, will take upto 16ms/1ms depending on PC. -- This cannot be an infinite loop or the system hardware is badly ! -- dammaged. loop GetSystemTimeAsFileTime (Loc_Time'Access); --- 193,201 ---- GetSystemTimeAsFileTime (Ctrl_Time'Access); ! -- Scan for clock tick, will take up to 16ms/1ms depending on PC. -- This cannot be an infinite loop or the system hardware is badly ! -- damaged. loop GetSystemTimeAsFileTime (Loc_Time'Access); diff -Nrcpad gcc-4.5.2/gcc/ada/s-pooglo.ads gcc-4.6.0/gcc/ada/s-pooglo.ads *** gcc-4.5.2/gcc/ada/s-pooglo.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-pooglo.ads Fri Sep 10 13:56:18 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package System.Pool_Global is *** 57,69 **** (Pool : Unbounded_No_Reclaim_Pool) return System.Storage_Elements.Storage_Count; ! procedure Allocate (Pool : in out Unbounded_No_Reclaim_Pool; Address : out System.Address; Storage_Size : System.Storage_Elements.Storage_Count; Alignment : System.Storage_Elements.Storage_Count); ! procedure Deallocate (Pool : in out Unbounded_No_Reclaim_Pool; Address : System.Address; Storage_Size : System.Storage_Elements.Storage_Count; --- 57,69 ---- (Pool : Unbounded_No_Reclaim_Pool) return System.Storage_Elements.Storage_Count; ! overriding procedure Allocate (Pool : in out Unbounded_No_Reclaim_Pool; Address : out System.Address; Storage_Size : System.Storage_Elements.Storage_Count; Alignment : System.Storage_Elements.Storage_Count); ! overriding procedure Deallocate (Pool : in out Unbounded_No_Reclaim_Pool; Address : System.Address; Storage_Size : System.Storage_Elements.Storage_Count; diff -Nrcpad gcc-4.5.2/gcc/ada/s-rannum.adb gcc-4.6.0/gcc/ada/s-rannum.adb *** gcc-4.5.2/gcc/ada/s-rannum.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-rannum.adb Wed Jun 23 06:21:26 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007,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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2007-2010, 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- -- *************** *** 86,129 **** -- -- ------------------------------------------------------------------------------ ! with Ada.Calendar; use Ada.Calendar; with Ada.Unchecked_Conversion; ! with Interfaces; use Interfaces; use Ada; package body System.Random_Numbers is ! ------------------------- ! -- Implementation Note -- ! ------------------------- ! -- The design of this spec is very awkward, as a result of Ada 95 not ! -- permitting in-out parameters for function formals (most naturally, ! -- Generator values would be passed this way). In pure Ada 95, the only ! -- solution is to use the heap and pointers, and, to avoid memory leaks, ! -- controlled types. ! -- This is awfully heavy, so what we do is to use Unrestricted_Access to ! -- get a pointer to the state in the passed Generator. This works because ! -- Generator is a limited type and will thus always be passed by reference. ! Low31_Mask : constant := 2**31-1; ! Bit31_Mask : constant := 2**31; ! Matrix_A_X : constant array (State_Val range 0 .. 1) of State_Val := ! (0, 16#9908b0df#); ! Y2K : constant Calendar.Time := ! Calendar.Time_Of ! (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); ! -- First Year 2000 day ! subtype Image_String is String (1 .. Max_Image_Width); ! -- Utility functions ! procedure Init (Gen : out Generator; Initiator : Unsigned_32); -- Perform a default initialization of the state of Gen. The resulting -- state is identical for identical values of Initiator. --- 86,159 ---- -- -- ------------------------------------------------------------------------------ ! with Ada.Calendar; use Ada.Calendar; with Ada.Unchecked_Conversion; ! ! with Interfaces; use Interfaces; use Ada; package body System.Random_Numbers is ! Y2K : constant Calendar.Time := ! Calendar.Time_Of ! (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); ! -- First day of Year 2000 (what is this for???) ! Image_Numeral_Length : constant := Max_Image_Width / N; ! subtype Image_String is String (1 .. Max_Image_Width); ! ---------------------------- ! -- Algorithmic Parameters -- ! ---------------------------- ! Lower_Mask : constant := 2**31-1; ! Upper_Mask : constant := 2**31; ! Matrix_A : constant array (State_Val range 0 .. 1) of State_Val ! := (0, 16#9908b0df#); ! -- The twist transformation is represented by a matrix of the form ! -- ! -- [ 0 I(31) ] ! -- [ _a ] ! -- ! -- where 0 is a 31x31 block of 0s, I(31) is the 31x31 identity matrix and ! -- _a is a particular bit row-vector, represented here by a 32-bit integer. ! -- If integer x represents a row vector of bits (with x(0), the units bit, ! -- last), then ! -- x * A = [0 x(31..1)] xor Matrix_A(x(0)). ! U : constant := 11; ! S : constant := 7; ! B_Mask : constant := 16#9d2c5680#; ! T : constant := 15; ! C_Mask : constant := 16#efc60000#; ! L : constant := 18; ! -- The tempering shifts and bit masks, in the order applied ! Seed0 : constant := 5489; ! -- Default seed, used to initialize the state vector when Reset not called ! Seed1 : constant := 19650218; ! -- Seed used to initialize the state vector when calling Reset with an ! -- initialization vector. ! Mult0 : constant := 1812433253; ! -- Multiplier for a modified linear congruential generator used to ! -- initialize the state vector when calling Reset with a single integer ! -- seed. ! ! Mult1 : constant := 1664525; ! Mult2 : constant := 1566083941; ! -- Multipliers for two modified linear congruential generators used to ! -- initialize the state vector when calling Reset with an initialization ! -- vector. ! ! ----------------------- ! -- Local Subprograms -- ! ----------------------- ! ! procedure Init (Gen : Generator; Initiator : Unsigned_32); -- Perform a default initialization of the state of Gen. The resulting -- state is identical for identical values of Initiator. *************** package body System.Random_Numbers is *** 147,221 **** ------------ function Random (Gen : Generator) return Unsigned_32 is ! G : Generator renames Gen'Unrestricted_Access.all; Y : State_Val; ! I : Integer; begin I := G.I; if I < N - M then ! Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask); ! Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1); I := I + 1; elsif I < N - 1 then ! Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask); Y := G.S (I + (M - N)) xor Shift_Right (Y, 1) ! xor Matrix_A_X (Y and 1); I := I + 1; elsif I = N - 1 then ! Y := (G.S (I) and Bit31_Mask) or (G.S (0) and Low31_Mask); ! Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1); I := 0; else ! Init (G, 5489); return Random (Gen); end if; G.S (G.I) := Y; G.I := I; ! Y := Y xor Shift_Right (Y, 11); ! Y := Y xor (Shift_Left (Y, 7) and 16#9d2c5680#); ! Y := Y xor (Shift_Left (Y, 15) and 16#efc60000#); ! Y := Y xor Shift_Right (Y, 18); return Y; end Random; ! function Random (Gen : Generator) return Float is ! -- Note: The application of Float'Machine (...) is necessary to avoid ! -- returning extra significand bits. Without it, the function's value ! -- will change if it is spilled, for example, causing ! -- gratuitous nondeterminism. - Result : constant Float := - Float'Machine - (Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-32)); begin ! if Result < 1.0 then ! return Result; else ! return Float'Adjacent (1.0, 0.0); end if; end Random; function Random (Gen : Generator) return Long_Float is ! Result : constant Long_Float := ! Long_Float'Machine ((Long_Float (Unsigned_32'(Random (Gen))) ! * 2.0 ** (-32)) ! + (Long_Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-64))); begin ! if Result < 1.0 then ! return Result; ! else ! return Long_Float'Adjacent (1.0, 0.0); ! end if; end Random; function Random (Gen : Generator) return Unsigned_64 is --- 177,384 ---- ------------ function Random (Gen : Generator) return Unsigned_32 is ! G : Generator renames Gen.Writable.Self.all; Y : State_Val; ! I : Integer; -- should avoid use of identifier I ??? begin I := G.I; if I < N - M then ! Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); ! Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); I := I + 1; elsif I < N - 1 then ! Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); Y := G.S (I + (M - N)) xor Shift_Right (Y, 1) ! xor Matrix_A (Y and 1); I := I + 1; elsif I = N - 1 then ! Y := (G.S (I) and Upper_Mask) or (G.S (0) and Lower_Mask); ! Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); I := 0; else ! Init (G, Seed0); return Random (Gen); end if; G.S (G.I) := Y; G.I := I; ! Y := Y xor Shift_Right (Y, U); ! Y := Y xor (Shift_Left (Y, S) and B_Mask); ! Y := Y xor (Shift_Left (Y, T) and C_Mask); ! Y := Y xor Shift_Right (Y, L); return Y; end Random; ! generic ! type Unsigned is mod <>; ! type Real is digits <>; ! with function Random (G : Generator) return Unsigned is <>; ! function Random_Float_Template (Gen : Generator) return Real; ! pragma Inline (Random_Float_Template); ! -- Template for a random-number generator implementation that delivers ! -- values of type Real in the range [0 .. 1], using values from Gen, ! -- assuming that Unsigned is large enough to hold the bits of a mantissa ! -- for type Real. ! --------------------------- ! -- Random_Float_Template -- ! --------------------------- ! ! function Random_Float_Template (Gen : Generator) return Real is ! ! pragma Compile_Time_Error ! (Unsigned'Last <= 2**(Real'Machine_Mantissa - 1), ! "insufficiently large modular type used to hold mantissa"); begin ! -- This code generates random floating-point numbers from unsigned ! -- integers. Assuming that Real'Machine_Radix = 2, it can deliver all ! -- machine values of type Real (as implied by Real'Machine_Mantissa and ! -- Real'Machine_Emin), which is not true of the standard method (to ! -- which we fall back for non-binary radix): computing Real() / (+1). To do so, we first extract an ! -- (M-1)-bit significand (where M is Real'Machine_Mantissa), and then ! -- decide on a normalized exponent by repeated coin flips, decrementing ! -- from 0 as long as we flip heads (1 bits). This process yields the ! -- proper geometric distribution for the exponent: in a uniformly ! -- distributed set of floating-point numbers, 1/2 of them will be in ! -- (0.5, 1], 1/4 will be in (0.25, 0.5], and so forth. It makes a ! -- further adjustment at binade boundaries (see comments below) to give ! -- the effect of selecting a uniformly distributed real deviate in ! -- [0..1] and then rounding to the nearest representable floating-point ! -- number. The algorithm attempts to be stingy with random integers. In ! -- the worst case, it can consume roughly -Real'Machine_Emin/32 32-bit ! -- integers, but this case occurs with probability around ! -- 2**Machine_Emin, and the expected number of calls to integer-valued ! -- Random is 1. For another discussion of the issues addressed by this ! -- process, see Allen Downey's unpublished paper at ! -- http://allendowney.com/research/rand/downey07randfloat.pdf. ! ! if Real'Machine_Radix /= 2 then ! return Real'Machine ! (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); ! else ! declare ! type Bit_Count is range 0 .. 4; ! ! subtype T is Real'Base; ! ! Trailing_Ones : constant array (Unsigned_32 range 0 .. 15) ! of Bit_Count := ! (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, ! 2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3, ! 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, ! 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4); ! ! Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real ! := (0 => 2.0**(0 - T'Machine_Mantissa), ! 1 => 2.0**(-1 - T'Machine_Mantissa), ! 2 => 2.0**(-2 - T'Machine_Mantissa), ! 3 => 2.0**(-3 - T'Machine_Mantissa)); ! ! Extra_Bits : constant Natural := ! (Unsigned'Size - T'Machine_Mantissa + 1); ! -- Random bits left over after selecting mantissa ! ! Mantissa : Unsigned; ! ! X : Real; -- Scaled mantissa ! R : Unsigned_32; -- Supply of random bits ! R_Bits : Natural; -- Number of bits left in R ! K : Bit_Count; -- Next decrement to exponent ! ! begin ! Mantissa := Random (Gen) / 2**Extra_Bits; ! R := Unsigned_32 (Mantissa mod 2**Extra_Bits); ! R_Bits := Extra_Bits; ! X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact ! ! if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then ! ! -- We got lucky and got a zero in our few extra bits ! ! K := Trailing_Ones (R); ! ! else ! Find_Zero : loop ! ! -- R has R_Bits unprocessed random bits, a multiple of 4. ! -- X needs to be halved for each trailing one bit. The ! -- process stops as soon as a 0 bit is found. If R_Bits ! -- becomes zero, reload R. ! ! -- Process 4 bits at a time for speed: the two iterations ! -- on average with three tests each was still too slow, ! -- probably because the branches are not predictable. ! -- This loop now will only execute once 94% of the cases, ! -- doing more bits at a time will not help. ! ! while R_Bits >= 4 loop ! K := Trailing_Ones (R mod 16); ! ! exit Find_Zero when K < 4; -- Exits 94% of the time ! ! R_Bits := R_Bits - 4; ! X := X / 16.0; ! R := R / 16; ! end loop; ! ! -- Do not allow us to loop endlessly even in the (very ! -- unlikely) case that Random (Gen) keeps yielding all ones. ! ! exit Find_Zero when X = 0.0; ! R := Random (Gen); ! R_Bits := 32; ! end loop Find_Zero; ! end if; ! ! -- K has the count of trailing ones not reflected yet in X. The ! -- following multiplication takes care of that, as well as the ! -- correction to move the radix point to the left of the mantissa. ! -- Doing it at the end avoids repeated rounding errors in the ! -- exceedingly unlikely case of ever having a subnormal result. ! ! X := X * Pow_Tab (K); ! ! -- The smallest value in each binade is rounded to by 0.75 of ! -- the span of real numbers as its next larger neighbor, and ! -- 1.0 is rounded to by half of the span of real numbers as its ! -- next smaller neighbor. To account for this, when we encounter ! -- the smallest number in a binade, we substitute the smallest ! -- value in the next larger binade with probability 1/2. ! ! if Mantissa = 0 and then Unsigned_32'(Random (Gen)) mod 2 = 0 then ! X := 2.0 * X; ! end if; ! ! return X; ! end; end if; + end Random_Float_Template; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Float is + function F is new Random_Float_Template (Unsigned_32, Float); + begin + return F (Gen); end Random; function Random (Gen : Generator) return Long_Float is ! function F is new Random_Float_Template (Unsigned_64, Long_Float); begin ! return F (Gen); end Random; function Random (Gen : Generator) return Unsigned_64 is *************** package body System.Random_Numbers is *** 244,253 **** declare -- In the 64-bit case, we have to be careful, since not all 64-bit -- unsigned values are representable in GNAT's root_integer type. ! -- Ignore different-size warnings here; since GNAT's handling -- is correct. ! pragma Warnings ("Z"); function Conv_To_Unsigned is new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64); function Conv_To_Result is --- 407,416 ---- declare -- In the 64-bit case, we have to be careful, since not all 64-bit -- unsigned values are representable in GNAT's root_integer type. ! -- Ignore different-size warnings here since GNAT's handling -- is correct. ! pragma Warnings ("Z"); -- better to use msg string! ??? function Conv_To_Unsigned is new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64); function Conv_To_Result is *************** package body System.Random_Numbers is *** 320,344 **** -- Reset -- ----------- ! procedure Reset (Gen : out Generator) is ! X : constant Unsigned_32 := Unsigned_32 ((Calendar.Clock - Y2K) * 64.0); begin Init (Gen, X); end Reset; ! procedure Reset (Gen : out Generator; Initiator : Integer_32) is begin Init (Gen, To_Unsigned (Initiator)); end Reset; ! procedure Reset (Gen : out Generator; Initiator : Unsigned_32) is begin Init (Gen, Initiator); end Reset; ! procedure Reset (Gen : out Generator; Initiator : Integer) is begin ! pragma Warnings ("C"); -- This is probably an unnecessary precaution against future change, but -- since the test is a static expression, no extra code is involved. --- 483,512 ---- -- Reset -- ----------- ! procedure Reset (Gen : Generator) is ! Clock : constant Time := Calendar.Clock; ! Duration_Since_Y2K : constant Duration := Clock - Y2K; ! ! X : constant Unsigned_32 := ! Unsigned_32'Mod (Unsigned_64 (Duration_Since_Y2K) * 64); ! begin Init (Gen, X); end Reset; ! procedure Reset (Gen : Generator; Initiator : Integer_32) is begin Init (Gen, To_Unsigned (Initiator)); end Reset; ! procedure Reset (Gen : Generator; Initiator : Unsigned_32) is begin Init (Gen, Initiator); end Reset; ! procedure Reset (Gen : Generator; Initiator : Integer) is begin ! pragma Warnings (Off, "condition is always *"); -- This is probably an unnecessary precaution against future change, but -- since the test is a static expression, no extra code is involved. *************** package body System.Random_Numbers is *** 358,387 **** end; end if; ! pragma Warnings ("c"); end Reset; ! procedure Reset (Gen : out Generator; Initiator : Initialization_Vector) is I, J : Integer; begin ! Init (Gen, 19650218); I := 1; J := 0; if Initiator'Length > 0 then for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop ! Gen.S (I) := ! (Gen.S (I) ! xor ((Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) ! * 1664525)) + Initiator (J + Initiator'First) + Unsigned_32 (J); I := I + 1; J := J + 1; if I >= N then ! Gen.S (0) := Gen.S (N - 1); I := 1; end if; --- 526,555 ---- end; end if; ! pragma Warnings (On, "condition is always *"); end Reset; ! procedure Reset (Gen : Generator; Initiator : Initialization_Vector) is ! G : Generator renames Gen.Writable.Self.all; I, J : Integer; begin ! Init (G, Seed1); I := 1; J := 0; if Initiator'Length > 0 then for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop ! G.S (I) := ! (G.S (I) xor ((G.S (I - 1) ! xor Shift_Right (G.S (I - 1), 30)) * Mult1)) + Initiator (J + Initiator'First) + Unsigned_32 (J); I := I + 1; J := J + 1; if I >= N then ! G.S (0) := G.S (N - 1); I := 1; end if; *************** package body System.Random_Numbers is *** 392,430 **** end if; for K in reverse 1 .. N - 1 loop ! Gen.S (I) := ! (Gen.S (I) xor ((Gen.S (I - 1) ! xor Shift_Right (Gen.S (I - 1), 30)) * 1566083941)) - Unsigned_32 (I); I := I + 1; if I >= N then ! Gen.S (0) := Gen.S (N - 1); I := 1; end if; end loop; ! Gen.S (0) := Bit31_Mask; end Reset; ! procedure Reset (Gen : out Generator; From_State : Generator) is begin ! Gen.S := From_State.S; ! Gen.I := From_State.I; end Reset; ! procedure Reset (Gen : out Generator; From_State : State) is begin ! Gen.I := 0; ! Gen.S := From_State; end Reset; ! procedure Reset (Gen : out Generator; From_Image : String) is begin ! Gen.I := 0; for J in 0 .. N - 1 loop ! Gen.S (J) := Extract_Value (From_Image, J); end loop; end Reset; --- 560,601 ---- end if; for K in reverse 1 .. N - 1 loop ! G.S (I) := ! (G.S (I) xor ((G.S (I - 1) ! xor Shift_Right (G.S (I - 1), 30)) * Mult2)) - Unsigned_32 (I); I := I + 1; if I >= N then ! G.S (0) := G.S (N - 1); I := 1; end if; end loop; ! G.S (0) := Upper_Mask; end Reset; ! procedure Reset (Gen : Generator; From_State : Generator) is ! G : Generator renames Gen.Writable.Self.all; begin ! G.S := From_State.S; ! G.I := From_State.I; end Reset; ! procedure Reset (Gen : Generator; From_State : State) is ! G : Generator renames Gen.Writable.Self.all; begin ! G.I := 0; ! G.S := From_State; end Reset; ! procedure Reset (Gen : Generator; From_Image : String) is ! G : Generator renames Gen.Writable.Self.all; begin ! G.I := 0; for J in 0 .. N - 1 loop ! G.S (J) := Extract_Value (From_Image, J); end loop; end Reset; *************** package body System.Random_Numbers is *** 468,474 **** begin Result := (others => ' '); - for J in 0 .. N - 1 loop Insert_Image (Result, J, Gen.S ((J + Gen.I) mod N)); end loop; --- 639,644 ---- *************** package body System.Random_Numbers is *** 493,510 **** -- Init -- ---------- ! procedure Init (Gen : out Generator; Initiator : Unsigned_32) is begin ! Gen.S (0) := Initiator; for I in 1 .. N - 1 loop ! Gen.S (I) := ! 1812433253 ! * (Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) + Unsigned_32 (I); end loop; ! Gen.I := 0; end Init; ------------------ --- 663,680 ---- -- Init -- ---------- ! procedure Init (Gen : Generator; Initiator : Unsigned_32) is ! G : Generator renames Gen.Writable.Self.all; begin ! G.S (0) := Initiator; for I in 1 .. N - 1 loop ! G.S (I) := ! (G.S (I - 1) xor Shift_Right (G.S (I - 1), 30)) * Mult0 + Unsigned_32 (I); end loop; ! G.I := 0; end Init; ------------------ *************** package body System.Random_Numbers is *** 526,534 **** ------------------- function Extract_Value (S : String; Index : Integer) return State_Val is begin ! return State_Val'Value (S (S'First + Index * 11 .. ! S'First + Index * 11 + 11)); end Extract_Value; - end System.Random_Numbers; --- 696,703 ---- ------------------- function Extract_Value (S : String; Index : Integer) return State_Val is + Start : constant Integer := S'First + Index * Image_Numeral_Length; begin ! return State_Val'Value (S (Start .. Start + Image_Numeral_Length - 1)); end Extract_Value; end System.Random_Numbers; diff -Nrcpad gcc-4.5.2/gcc/ada/s-rannum.ads gcc-4.6.0/gcc/ada/s-rannum.ads *** gcc-4.5.2/gcc/ada/s-rannum.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-rannum.ads Wed Jun 23 05:40:52 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007,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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2007-2010, 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- -- *************** package System.Random_Numbers is *** 88,114 **** -- in Reset). In general, there is little point in providing more than -- a certain number of values (currently 624). ! procedure Reset (Gen : out Generator); -- Re-initialize the state of Gen from the time of day ! procedure Reset (Gen : out Generator; Initiator : Initialization_Vector); ! procedure Reset (Gen : out Generator; Initiator : Interfaces.Integer_32); ! procedure Reset (Gen : out Generator; Initiator : Interfaces.Unsigned_32); ! procedure Reset (Gen : out Generator; Initiator : Integer); -- Re-initialize Gen based on the Initiator in various ways. Identical -- values of Initiator cause identical sequences of values. ! procedure Reset (Gen : out Generator; From_State : Generator); -- Causes the state of Gen to be identical to that of From_State; Gen -- and From_State will produce identical sequences of values subsequently. ! procedure Reset (Gen : out Generator; From_State : State); procedure Save (Gen : Generator; To_State : out State); -- The sequence -- Save (Gen2, S); Reset (Gen1, S) -- has the same effect as Reset (Gen2, Gen1). ! procedure Reset (Gen : out Generator; From_Image : String); function Image (Gen : Generator) return String; -- The call -- Reset (Gen2, Image (Gen1)) --- 88,114 ---- -- in Reset). In general, there is little point in providing more than -- a certain number of values (currently 624). ! procedure Reset (Gen : Generator); -- Re-initialize the state of Gen from the time of day ! procedure Reset (Gen : Generator; Initiator : Initialization_Vector); ! procedure Reset (Gen : Generator; Initiator : Interfaces.Integer_32); ! procedure Reset (Gen : Generator; Initiator : Interfaces.Unsigned_32); ! procedure Reset (Gen : Generator; Initiator : Integer); -- Re-initialize Gen based on the Initiator in various ways. Identical -- values of Initiator cause identical sequences of values. ! procedure Reset (Gen : Generator; From_State : Generator); -- Causes the state of Gen to be identical to that of From_State; Gen -- and From_State will produce identical sequences of values subsequently. ! procedure Reset (Gen : Generator; From_State : State); procedure Save (Gen : Generator; To_State : out State); -- The sequence -- Save (Gen2, S); Reset (Gen1, S) -- has the same effect as Reset (Gen2, Gen1). ! procedure Reset (Gen : Generator; From_Image : String); function Image (Gen : Generator) return String; -- The call -- Reset (Gen2, Image (Gen1)) *************** private *** 135,146 **** subtype State_Val is Interfaces.Unsigned_32; type State is array (0 .. N - 1) of State_Val; type Generator is limited record S : State := (others => 0); -- The shift register, a circular buffer I : Integer := N; ! -- Current starting position in shift register S end record; end System.Random_Numbers; --- 135,153 ---- subtype State_Val is Interfaces.Unsigned_32; type State is array (0 .. N - 1) of State_Val; + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + S : State := (others => 0); -- The shift register, a circular buffer I : Integer := N; ! -- Current starting position in shift register S (N means uninitialized) ! -- We should avoid using the identifier I here ??? end record; end System.Random_Numbers; diff -Nrcpad gcc-4.5.2/gcc/ada/s-regexp.adb gcc-4.6.0/gcc/ada/s-regexp.adb *** gcc-4.5.2/gcc/ada/s-regexp.adb Thu Jul 23 12:32:41 2009 --- gcc-4.6.0/gcc/ada/s-regexp.adb Mon Dec 20 07:26:57 2010 *************** package body System.Regexp is *** 196,213 **** Past_Elmt : Boolean := False; -- Set to True everywhere an elmt has been parsed, if Glob=False, ! -- meaning there can be now an occurence of '*', '+' and '?'. Past_Term : Boolean := False; -- Set to True everywhere a term has been parsed, if Glob=False, ! -- meaning there can be now an occurence of '|'. Parenthesis_Level : Integer := 0; Curly_Level : Integer := 0; Last_Open : Integer := S'First - 1; ! -- The last occurence of an opening parenthesis, if Glob=False, ! -- or the last occurence of an opening curly brace, if Glob=True. procedure Raise_Exception_If_No_More_Chars (K : Integer := 0); -- If no more characters are raised, call Raise_Exception --- 196,213 ---- Past_Elmt : Boolean := False; -- Set to True everywhere an elmt has been parsed, if Glob=False, ! -- meaning there can be now an occurrence of '*', '+' and '?'. Past_Term : Boolean := False; -- Set to True everywhere a term has been parsed, if Glob=False, ! -- meaning there can be now an occurrence of '|'. Parenthesis_Level : Integer := 0; Curly_Level : Integer := 0; Last_Open : Integer := S'First - 1; ! -- The last occurrence of an opening parenthesis, if Glob=False, ! -- or the last occurrence of an opening curly brace, if Glob=True. procedure Raise_Exception_If_No_More_Chars (K : Integer := 0); -- If no more characters are raised, call Raise_Exception diff -Nrcpad gcc-4.5.2/gcc/ada/s-regpat.adb gcc-4.6.0/gcc/ada/s-regpat.adb *** gcc-4.5.2/gcc/ada/s-regpat.adb Wed Jul 22 10:25:32 2009 --- gcc-4.6.0/gcc/ada/s-regpat.adb Mon Jun 21 14:23:35 2010 *************** *** 7,13 **** -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1999-2009, AdaCore -- -- -- -- 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- -- --- 7,13 ---- -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- ! -- Copyright (C) 1999-2010, AdaCore -- -- -- -- 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- -- *************** with Ada.Unchecked_Conversion; *** 47,58 **** package body System.Regpat is ! MAGIC : constant Character := Character'Val (10#0234#); ! -- The first byte of the regexp internal "program" is actually ! -- this magic number; the start node begins in the second byte. ! -- ! -- This is used to make sure that a regular expression was correctly ! -- compiled. ---------------------------- -- Implementation details -- --- 47,56 ---- package body System.Regpat is ! Debug : constant Boolean := False; ! -- Set to True to activate debug traces. This is normally set to constant ! -- False to simply delete all the trace code. It is to be edited to True ! -- for internal debugging of the package. ---------------------------- -- Implementation details -- *************** package body System.Regpat is *** 76,96 **** -- You can see the exact byte-compiled version by using the Dump -- subprogram. However, here are a few examples: ! -- (a|b): 1 : MAGIC ! -- 2 : BRANCH (next at 10) ! -- 5 : EXACT (next at 18) operand=a ! -- 10 : BRANCH (next at 18) ! -- 13 : EXACT (next at 18) operand=b ! -- 18 : EOP (next at 0) -- ! -- (ab)*: 1 : MAGIC ! -- 2 : CURLYX (next at 26) { 0, 32767} ! -- 9 : OPEN 1 (next at 13) ! -- 13 : EXACT (next at 19) operand=ab ! -- 19 : CLOSE 1 (next at 23) ! -- 23 : WHILEM (next at 0) ! -- 26 : NOTHING (next at 29) ! -- 29 : EOP (next at 0) -- The opcodes are: --- 74,92 ---- -- You can see the exact byte-compiled version by using the Dump -- subprogram. However, here are a few examples: ! -- (a|b): 1 : BRANCH (next at 9) ! -- 4 : EXACT (next at 17) operand=a ! -- 9 : BRANCH (next at 17) ! -- 12 : EXACT (next at 17) operand=b ! -- 17 : EOP (next at 0) -- ! -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767} ! -- 8 : OPEN 1 (next at 12) ! -- 12 : EXACT (next at 18) operand=ab ! -- 18 : CLOSE 1 (next at 22) ! -- 22 : WHILEM (next at 0) ! -- 25 : NOTHING (next at 28) ! -- 28 : EOP (next at 0) -- The opcodes are: *************** package body System.Regpat is *** 186,191 **** --- 182,193 ---- -- Using two bytes for the "next" pointer is vast overkill for most -- things, but allows patterns to get big without disasters. + Next_Pointer_Bytes : constant := 3; + -- Points after the "next pointer" data. An instruction is therefore: + -- 1 byte: instruction opcode + -- 2 bytes: pointer to next instruction + -- * bytes: optional data for the instruction + ----------------------- -- Character classes -- ----------------------- *************** package body System.Regpat is *** 279,289 **** Op : out Character_Class); -- Return a pointer to the string argument of the node at P - function Get_Next_Offset - (Program : Program_Data; - IP : Pointer) return Pointer; - -- Get the offset field of a node. Used by Get_Next - function Get_Next (Program : Program_Data; IP : Pointer) return Pointer; --- 281,286 ---- *************** package body System.Regpat is *** 303,309 **** pragma Inline (Is_Alnum); pragma Inline (Is_White_Space); pragma Inline (Get_Next); - pragma Inline (Get_Next_Offset); pragma Inline (Operand); pragma Inline (Read_Natural); pragma Inline (String_Length); --- 300,305 ---- *************** package body System.Regpat is *** 318,323 **** --- 314,336 ---- Worst_Expression : constant Expression_Flags := (others => False); -- Worst case + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True); + -- Dump the program until the node Till (not included) is met. Every line + -- is indented with Index spaces at the beginning Dumps till the end if + -- Till is 0. + + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural); + -- Same as above, but only dumps a single operation, and compute its + -- indentation from the program. + --------- -- "=" -- --------- *************** package body System.Regpat is *** 340,346 **** (Program_Data, Character_Class); begin ! Op (0 .. 31) := Convert (Program (P + 3 .. P + 34)); end Bitmap_Operand; ------------- --- 353,359 ---- (Program_Data, Character_Class); begin ! Op (0 .. 31) := Convert (Program (P + Next_Pointer_Bytes .. P + 34)); end Bitmap_Operand; ------------- *************** package body System.Regpat is *** 369,375 **** PM : Pattern_Matcher renames Matcher; Program : Program_Data renames PM.Program; - Emit_Code : constant Boolean := PM.Size > 0; Emit_Ptr : Pointer := Program_First; Parse_Pos : Natural := Expression'First; -- Input-scan pointer --- 382,387 ---- *************** package body System.Regpat is *** 421,441 **** (Expr_Flags : out Expression_Flags; IP : out Pointer); -- Parse_Atom is the lowest level parse procedure. ! -- Optimization: gobbles an entire sequence of ordinary characters ! -- so that it can turn them into a single node, which is smaller to ! -- store and faster to run. Backslashed characters are exceptions, ! -- each becoming a separate node; the code is simpler that way and ! -- it's not worth fixing. procedure Insert_Operator (Op : Opcode; Operand : Pointer; Greedy : Boolean := True); ! -- Insert_Operator inserts an operator in front of an ! -- already-emitted operand and relocates the operand. ! -- This applies to PLUS and STAR. -- If Minmod is True, then the operator is non-greedy. procedure Insert_Curly_Operator (Op : Opcode; Min : Natural; --- 433,463 ---- (Expr_Flags : out Expression_Flags; IP : out Pointer); -- Parse_Atom is the lowest level parse procedure. ! -- ! -- Optimization: Gobbles an entire sequence of ordinary characters so ! -- that it can turn them into a single node, which is smaller to store ! -- and faster to run. Backslashed characters are exceptions, each ! -- becoming a separate node; the code is simpler that way and it's ! -- not worth fixing. procedure Insert_Operator (Op : Opcode; Operand : Pointer; Greedy : Boolean := True); ! -- Insert_Operator inserts an operator in front of an already-emitted ! -- operand and relocates the operand. This applies to PLUS and STAR. -- If Minmod is True, then the operator is non-greedy. + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer; + -- Insert an operator before Operand (and move the latter forward in the + -- program). Opsize is the size needed to represent the operator. This + -- returns the position at which the operator was inserted, and moves + -- Emit_Ptr after the new position of the operand. + procedure Insert_Curly_Operator (Op : Opcode; Min : Natural; *************** package body System.Regpat is *** 451,459 **** procedure Link_Operand_Tail (P, Val : Pointer); -- Link_Tail on operand of first argument; noop if operand-less - function Next_Instruction (P : Pointer) return Pointer; - -- Dig the "next" pointer out of a node - procedure Fail (M : String); pragma No_Return (Fail); -- Fail with a diagnostic message, if possible --- 473,478 ---- *************** package body System.Regpat is *** 513,519 **** procedure Emit (B : Character) is begin ! if Emit_Code then Program (Emit_Ptr) := B; end if; --- 532,538 ---- procedure Emit (B : Character) is begin ! if Emit_Ptr <= PM.Size then Program (Emit_Ptr) := B; end if; *************** package body System.Regpat is *** 531,537 **** (Character_Class, Program31); begin ! if Emit_Code then Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); end if; --- 550,561 ---- (Character_Class, Program31); begin ! -- What is the mysterious constant 31 here??? Can't it be expressed ! -- symbolically (size of integer - 1 or some such???). In any case ! -- it should be declared as a constant (and referenced presumably ! -- as this constant + 1 below. ! ! if Emit_Ptr + 31 <= PM.Size then Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); end if; *************** package body System.Regpat is *** 544,550 **** procedure Emit_Natural (IP : Pointer; N : Natural) is begin ! if Emit_Code then Program (IP + 1) := Character'Val (N / 256); Program (IP) := Character'Val (N mod 256); end if; --- 568,574 ---- procedure Emit_Natural (IP : Pointer; N : Natural) is begin ! if IP + 1 <= PM.Size then Program (IP + 1) := Character'Val (N / 256); Program (IP) := Character'Val (N mod 256); end if; *************** package body System.Regpat is *** 558,570 **** Result : constant Pointer := Emit_Ptr; begin ! if Emit_Code then Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); Program (Emit_Ptr + 1) := ASCII.NUL; Program (Emit_Ptr + 2) := ASCII.NUL; end if; ! Emit_Ptr := Emit_Ptr + 3; return Result; end Emit_Node; --- 582,594 ---- Result : constant Pointer := Emit_Ptr; begin ! if Emit_Ptr + 2 <= PM.Size then Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); Program (Emit_Ptr + 1) := ASCII.NUL; Program (Emit_Ptr + 2) := ASCII.NUL; end if; ! Emit_Ptr := Emit_Ptr + Next_Pointer_Bytes; return Result; end Emit_Node; *************** package body System.Regpat is *** 639,659 **** Operand : Pointer; Greedy : Boolean := True) is - Dest : constant Pointer := Emit_Ptr; Old : Pointer; ! Size : Pointer := 7; begin ! -- If the operand is not greedy, insert an extra operand before it if not Greedy then ! Size := Size + 3; end if; -- Move the operand in the byte-compilation, so that we can insert -- the operator before it. ! if Emit_Code then Program (Operand + Size .. Emit_Ptr + Size) := Program (Operand .. Emit_Ptr); end if; --- 663,700 ---- Operand : Pointer; Greedy : Boolean := True) is Old : Pointer; ! begin ! Old := Insert_Operator_Before (Op, Operand, Greedy, Opsize => 7); ! Emit_Natural (Old + Next_Pointer_Bytes, Min); ! Emit_Natural (Old + Next_Pointer_Bytes + 2, Max); ! end Insert_Curly_Operator; ! ! ---------------------------- ! -- Insert_Operator_Before -- ! ---------------------------- ! ! function Insert_Operator_Before ! (Op : Opcode; ! Operand : Pointer; ! Greedy : Boolean; ! Opsize : Pointer) return Pointer ! is ! Dest : constant Pointer := Emit_Ptr; ! Old : Pointer; ! Size : Pointer := Opsize; begin ! -- If not greedy, we have to emit another opcode first if not Greedy then ! Size := Size + Next_Pointer_Bytes; end if; -- Move the operand in the byte-compilation, so that we can insert -- the operator before it. ! if Emit_Ptr + Size <= PM.Size then Program (Operand + Size .. Emit_Ptr + Size) := Program (Operand .. Emit_Ptr); end if; *************** package body System.Regpat is *** 665,679 **** if not Greedy then Old := Emit_Node (MINMOD); ! Link_Tail (Old, Old + 3); end if; Old := Emit_Node (Op); - Emit_Natural (Old + 3, Min); - Emit_Natural (Old + 5, Max); - Emit_Ptr := Dest + Size; ! end Insert_Curly_Operator; --------------------- -- Insert_Operator -- --- 706,718 ---- if not Greedy then Old := Emit_Node (MINMOD); ! Link_Tail (Old, Old + Next_Pointer_Bytes); end if; Old := Emit_Node (Op); Emit_Ptr := Dest + Size; ! return Old; ! end Insert_Operator_Before; --------------------- -- Insert_Operator -- *************** package body System.Regpat is *** 684,723 **** Operand : Pointer; Greedy : Boolean := True) is - Dest : constant Pointer := Emit_Ptr; - Old : Pointer; - Size : Pointer := 3; - Discard : Pointer; pragma Warnings (Off, Discard); - begin ! -- If not greedy, we have to emit another opcode first ! ! if not Greedy then ! Size := Size + 3; ! end if; ! ! -- Move the operand in the byte-compilation, so that we can insert ! -- the operator before it. ! ! if Emit_Code then ! Program (Operand + Size .. Emit_Ptr + Size) := ! Program (Operand .. Emit_Ptr); ! end if; ! ! -- Insert the operator at the position previously occupied by the ! -- operand. ! ! Emit_Ptr := Operand; ! ! if not Greedy then ! Old := Emit_Node (MINMOD); ! Link_Tail (Old, Old + 3); ! end if; ! ! Discard := Emit_Node (Op); ! Emit_Ptr := Dest + Size; end Insert_Operator; ----------------------- --- 723,733 ---- Operand : Pointer; Greedy : Boolean := True) is Discard : Pointer; pragma Warnings (Off, Discard); begin ! Discard := Insert_Operator_Before ! (Op, Operand, Greedy, Opsize => Next_Pointer_Bytes); end Insert_Operator; ----------------------- *************** package body System.Regpat is *** 784,790 **** procedure Link_Operand_Tail (P, Val : Pointer) is begin ! if Emit_Code and then Program (P) = BRANCH then Link_Tail (Operand (P), Val); end if; end Link_Operand_Tail; --- 794,800 ---- procedure Link_Operand_Tail (P, Val : Pointer) is begin ! if P <= PM.Size and then Program (P) = BRANCH then Link_Tail (Operand (P), Val); end if; end Link_Operand_Tail; *************** package body System.Regpat is *** 799,814 **** Offset : Pointer; begin ! if not Emit_Code then ! return; ! end if; ! ! -- Find last node Scan := P; ! loop ! Temp := Next_Instruction (Scan); ! exit when Temp = 0; Scan := Temp; end loop; --- 809,821 ---- Offset : Pointer; begin ! -- Find last node (the size of the pattern matcher might be too ! -- small, so don't try to read past its end). Scan := P; ! while Scan + Next_Pointer_Bytes <= PM.Size loop ! Temp := Get_Next (Program, Scan); ! exit when Temp = Scan; Scan := Temp; end loop; *************** package body System.Regpat is *** 817,863 **** Emit_Natural (Scan + 1, Natural (Offset)); end Link_Tail; - ---------------------- - -- Next_Instruction -- - ---------------------- - - function Next_Instruction (P : Pointer) return Pointer is - Offset : Pointer; - - begin - if not Emit_Code then - return 0; - end if; - - Offset := Get_Next_Offset (Program, P); - - if Offset = 0 then - return 0; - end if; - - return P + Offset; - end Next_Instruction; - ----------- -- Parse -- ----------- ! -- Combining parenthesis handling with the base level ! -- of regular expression is a trifle forced, but the ! -- need to tie the tails of the branches to what follows ! -- makes it hard to avoid. procedure Parse ! (Parenthesized : Boolean; ! Flags : out Expression_Flags; ! IP : out Pointer) is ! E : String renames Expression; ! Br : Pointer; ! Ender : Pointer; ! Par_No : Natural; ! New_Flags : Expression_Flags; ! Have_Branch : Boolean := False; begin Flags := (Has_Width => True, others => False); -- Tentatively --- 824,848 ---- Emit_Natural (Scan + 1, Natural (Offset)); end Link_Tail; ----------- -- Parse -- ----------- ! -- Combining parenthesis handling with the base level of regular ! -- expression is a trifle forced, but the need to tie the tails of the ! -- the branches to what follows makes it hard to avoid. procedure Parse ! (Parenthesized : Boolean; ! Flags : out Expression_Flags; ! IP : out Pointer) is ! E : String renames Expression; ! Br, Br2 : Pointer; ! Ender : Pointer; ! Par_No : Natural; ! New_Flags : Expression_Flags; ! Have_Branch : Boolean := False; begin Flags := (Has_Width => True, others => False); -- Tentatively *************** package body System.Regpat is *** 938,952 **** Link_Tail (IP, Ender); ! if Have_Branch then -- Hook the tails of the branches to the closing node Br := IP; loop - exit when Br = 0; Link_Operand_Tail (Br, Ender); ! Br := Next_Instruction (Br); end loop; end if; --- 923,938 ---- Link_Tail (IP, Ender); ! if Have_Branch and then Emit_Ptr <= PM.Size then -- Hook the tails of the branches to the closing node Br := IP; loop Link_Operand_Tail (Br, Ender); ! Br2 := Get_Next (Program, Br); ! exit when Br2 = Br; ! Br := Br2; end loop; end if; *************** package body System.Regpat is *** 1639,1651 **** -- is an initial string to emit, do it now. if Has_Special_Operator ! and then Emit_Ptr >= Length_Ptr + 3 then Emit_Ptr := Emit_Ptr - 1; Parse_Pos := Start_Pos; end if; ! if Emit_Code then Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); end if; --- 1625,1637 ---- -- is an initial string to emit, do it now. if Has_Special_Operator ! and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes then Emit_Ptr := Emit_Ptr - 1; Parse_Pos := Start_Pos; end if; ! if Length_Ptr <= PM.Size then Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); end if; *************** package body System.Regpat is *** 1987,1993 **** -- Start of processing for Compile begin - Emit (MAGIC); Parse (False, Expr_Flags, Result); if Result = 0 then --- 1973,1978 ---- *************** package body System.Regpat is *** 1999,2005 **** -- Do we want to actually compile the expression, or simply get the -- code size ??? ! if Emit_Code then Optimize (PM); end if; --- 1984,1990 ---- -- Do we want to actually compile the expression, or simply get the -- code size ??? ! if Emit_Ptr <= PM.Size then Optimize (PM); end if; *************** package body System.Regpat is *** 2010,2028 **** (Expression : String; Flags : Regexp_Flags := No_Flags) return Pattern_Matcher is Size : Program_Size; - Dummy : Pattern_Matcher (0); - pragma Unreferenced (Dummy); begin Compile (Dummy, Expression, Size, Flags); ! declare ! Result : Pattern_Matcher (Size); ! begin ! Compile (Result, Expression, Size, Flags); ! return Result; ! end; end Compile; procedure Compile --- 1995,2032 ---- (Expression : String; Flags : Regexp_Flags := No_Flags) return Pattern_Matcher is + -- Assume the compiled regexp will fit in 1000 chars. If it does not we + -- will have to compile a second time once the correct size is known. If + -- it fits, we save a significant amount of time by avoiding the second + -- compilation. + + Dummy : Pattern_Matcher (1000); Size : Program_Size; begin Compile (Dummy, Expression, Size, Flags); ! if Size <= Dummy.Size then ! return Pattern_Matcher' ! (Size => Size, ! First => Dummy.First, ! Anchored => Dummy.Anchored, ! Must_Have => Dummy.Must_Have, ! Must_Have_Length => Dummy.Must_Have_Length, ! Paren_Count => Dummy.Paren_Count, ! Flags => Dummy.Flags, ! Program => Dummy.Program ! (Dummy.Program'First .. Dummy.Program'First + Size - 1)); ! else ! -- We have to recompile now that we know the size ! -- ??? Can we use Ada05's return construct ? ! declare ! Result : Pattern_Matcher (Size); ! begin ! Compile (Result, Expression, Size, Flags); ! return Result; ! end; ! end if; end Compile; procedure Compile *************** package body System.Regpat is *** 2031,2123 **** Flags : Regexp_Flags := No_Flags) is Size : Program_Size; ! pragma Unreferenced (Size); begin Compile (Matcher, Expression, Size, Flags); end Compile; ! ---------- ! -- Dump -- ! ---------- ! procedure Dump (Self : Pattern_Matcher) is ! Op : Opcode; ! Program : Program_Data renames Self.Program; ! procedure Dump_Until ! (Start : Pointer; ! Till : Pointer; ! Indent : Natural := 0); ! -- Dump the program until the node Till (not included) is met. ! -- Every line is indented with Index spaces at the beginning ! -- Dumps till the end if Till is 0. ! ---------------- ! -- Dump_Until -- ! ---------------- ! procedure Dump_Until ! (Start : Pointer; ! Till : Pointer; ! Indent : Natural := 0) ! is ! Next : Pointer; ! Index : Pointer; ! Local_Indent : Natural := Indent; ! Length : Pointer; begin ! Index := Start; ! while Index < Till loop ! Op := Opcode'Val (Character'Pos ((Self.Program (Index)))); ! if Op = CLOSE then ! Local_Indent := Local_Indent - 3; ! end if; ! declare ! Point : constant String := Pointer'Image (Index); ! begin ! for J in 1 .. 6 - Point'Length loop ! Put (' '); ! end loop; ! Put (Point ! & " : " ! & (1 .. Local_Indent => ' ') ! & Opcode'Image (Op)); end; -- Print the parenthesis number if Op = OPEN or else Op = CLOSE or else Op = REFF then ! Put (Natural'Image (Character'Pos (Program (Index + 3)))); end if; - Next := Index + Get_Next_Offset (Program, Index); - if Next = Index then ! Put (" (next at 0)"); else ! Put (" (next at " & Pointer'Image (Next) & ")"); end if; ! case Op is ! ! -- Character class operand ! ! when ANYOF => null; ! declare ! Bitmap : Character_Class; ! Last : Character := ASCII.NUL; ! Current : Natural := 0; ! Current_Char : Character; ! begin ! Bitmap_Operand (Program, Index, Bitmap); ! Put (" operand="); while Current <= 255 loop Current_Char := Character'Val (Current); --- 2035,2141 ---- Flags : Regexp_Flags := No_Flags) is Size : Program_Size; ! begin Compile (Matcher, Expression, Size, Flags); + + if Size > Matcher.Size then + raise Expression_Error with "Pattern_Matcher is too small"; + end if; end Compile; ! -------------------- ! -- Dump_Operation -- ! -------------------- ! procedure Dump_Operation ! (Program : Program_Data; ! Index : Pointer; ! Indent : Natural) ! is ! Current : Pointer := Index; ! begin ! Dump_Until (Program, Current, Current + 1, Indent); ! end Dump_Operation; ! ---------------- ! -- Dump_Until -- ! ---------------- ! procedure Dump_Until ! (Program : Program_Data; ! Index : in out Pointer; ! Till : Pointer; ! Indent : Natural; ! Do_Print : Boolean := True) ! is ! function Image (S : String) return String; ! -- Remove leading space ! ----------- ! -- Image -- ! ----------- + function Image (S : String) return String is begin ! if S (S'First) = ' ' then ! return S (S'First + 1 .. S'Last); ! else ! return S; ! end if; ! end Image; ! -- Local variables ! Op : Opcode; ! Next : Pointer; ! Length : Pointer; ! Local_Indent : Natural := Indent; ! -- Start of processing for Dump_Until ! begin ! while Index < Till loop ! Op := Opcode'Val (Character'Pos ((Program (Index)))); ! Next := Get_Next (Program, Index); ! ! if Do_Print then ! declare ! Point : constant String := Pointer'Image (Index); ! begin ! Put ((1 .. 4 - Point'Length => ' ') ! & Point & ":" ! & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op)); end; -- Print the parenthesis number if Op = OPEN or else Op = CLOSE or else Op = REFF then ! Put (Image (Natural'Image ! (Character'Pos ! (Program (Index + Next_Pointer_Bytes))))); end if; if Next = Index then ! Put (" (-)"); else ! Put (" (" & Image (Pointer'Image (Next)) & ")"); end if; + end if; ! case Op is ! when ANYOF => ! declare ! Bitmap : Character_Class; ! Last : Character := ASCII.NUL; ! Current : Natural := 0; ! Current_Char : Character; ! begin ! Bitmap_Operand (Program, Index, Bitmap); ! if Do_Print then ! Put ("["); while Current <= 255 loop Current_Char := Character'Val (Current); *************** package body System.Regpat is *** 2135,2151 **** Current_Char := Character'Val (Current); exit when not Get_From_Class (Bitmap, Current_Char); - end loop; ! if Last <= ' ' then Put (Last'Img); else Put (Last); end if; if Character'Succ (Last) /= Current_Char then ! Put ("-" & Character'Pred (Current_Char)); end if; else --- 2153,2168 ---- Current_Char := Character'Val (Current); exit when not Get_From_Class (Bitmap, Current_Char); end loop; ! if not Is_Graphic (Last) then Put (Last'Img); else Put (Last); end if; if Character'Succ (Last) /= Current_Char then ! Put ("\-" & Character'Pred (Current_Char)); end if; else *************** package body System.Regpat is *** 2153,2228 **** end if; end loop; ! New_Line; ! Index := Index + 3 + Bitmap'Length; ! end; ! -- string operand ! when EXACT | EXACTF => ! Length := String_Length (Program, Index); ! Put (" operand (length:" & Program_Size'Image (Length + 1) ! & ") =" ! & String (Program (String_Operand (Index) ! .. String_Operand (Index) ! + Length))); ! Index := String_Operand (Index) + Length + 1; ! New_Line; -- Node operand ! when BRANCH => New_Line; ! Dump_Until (Index + 3, Next, Local_Indent + 3); ! Index := Next; ! when STAR | PLUS => ! New_Line; ! -- Only one instruction ! Dump_Until (Index + 3, Index + 4, Local_Indent + 3); ! Index := Next; ! when CURLY | CURLYX => ! Put (" {" ! & Natural'Image (Read_Natural (Program, Index + 3)) ! & "," ! & Natural'Image (Read_Natural (Program, Index + 5)) ! & "}"); New_Line; ! Dump_Until (Index + 7, Next, Local_Indent + 3); ! Index := Next; ! when OPEN => ! New_Line; ! Index := Index + 4; ! Local_Indent := Local_Indent + 3; ! when CLOSE | REFF => New_Line; ! Index := Index + 4; ! when EOP => ! Index := Index + 3; ! New_Line; ! exit; ! -- No operand ! when others => ! Index := Index + 3; New_Line; ! end case; ! end loop; ! end Dump_Until; -- Start of processing for Dump begin - pragma Assert (Self.Program (Program_First) = MAGIC, - "Corrupted Pattern_Matcher"); - Put_Line ("Must start with (Self.First) = " & Character'Image (Self.First)); --- 2170,2262 ---- end if; end loop; ! Put_Line ("]"); ! end if; ! Index := Index + Next_Pointer_Bytes + Bitmap'Length; ! end; ! when EXACT | EXACTF => ! Length := String_Length (Program, Index); ! if Do_Print then ! Put (" (" & Image (Program_Size'Image (Length + 1)) ! & " chars) <" ! & String (Program (String_Operand (Index) ! .. String_Operand (Index) ! + Length))); ! Put_Line (">"); ! end if; ! ! Index := String_Operand (Index) + Length + 1; -- Node operand ! when BRANCH | STAR | PLUS => ! if Do_Print then New_Line; ! end if; ! Index := Index + Next_Pointer_Bytes; ! Dump_Until (Program, Index, Pointer'Min (Next, Till), ! Local_Indent + 1, Do_Print); ! when CURLY | CURLYX => ! if Do_Print then ! Put_Line ! (" {" ! & Image (Natural'Image ! (Read_Natural (Program, Index + Next_Pointer_Bytes))) ! & "," ! & Image (Natural'Image (Read_Natural (Program, Index + 5))) ! & "}"); ! end if; ! Index := Index + 7; ! Dump_Until (Program, Index, Pointer'Min (Next, Till), ! Local_Indent + 1, Do_Print); ! when OPEN => ! if Do_Print then New_Line; ! end if; ! Index := Index + 4; ! Local_Indent := Local_Indent + 1; ! when CLOSE | REFF => ! if Do_Print then New_Line; ! end if; ! Index := Index + 4; ! if Op = CLOSE then ! Local_Indent := Local_Indent - 1; ! end if; ! when others => ! Index := Index + Next_Pointer_Bytes; ! ! if Do_Print then New_Line; ! end if; ! ! exit when Op = EOP; ! end case; ! end loop; ! end Dump_Until; ! ! ---------- ! -- Dump -- ! ---------- ! ! procedure Dump (Self : Pattern_Matcher) is ! Program : Program_Data renames Self.Program; ! Index : Pointer := Program'First; -- Start of processing for Dump begin Put_Line ("Must start with (Self.First) = " & Character'Image (Self.First)); *************** package body System.Regpat is *** 2238,2245 **** Put_Line (" Multiple_Lines mode"); end if; ! Put_Line (" 1 : MAGIC"); ! Dump_Until (Program_First + 1, Self.Program'Last + 1); end Dump; -------------------- --- 2272,2278 ---- Put_Line (" Multiple_Lines mode"); end if; ! Dump_Until (Program, Index, Self.Program'Last + 1, 0); end Dump; -------------------- *************** package body System.Regpat is *** 2261,2287 **** -------------- function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is - Offset : constant Pointer := Get_Next_Offset (Program, IP); begin ! if Offset = 0 then ! return 0; ! else ! return IP + Offset; ! end if; end Get_Next; - --------------------- - -- Get_Next_Offset -- - --------------------- - - function Get_Next_Offset - (Program : Program_Data; - IP : Pointer) return Pointer - is - begin - return Pointer (Read_Natural (Program, IP + 1)); - end Get_Next_Offset; - -------------- -- Is_Alnum -- -------------- --- 2294,2303 ---- -------------- function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is begin ! return IP + Pointer (Read_Natural (Program, IP + 1)); end Get_Next; -------------- -- Is_Alnum -- -------------- *************** package body System.Regpat is *** 2401,2409 **** -- using a loop instead of recursion. -- Why is the above comment part of the spec rather than body ??? ! function Match_Whilem (IP : Pointer) return Boolean; ! -- Return True if a WHILEM matches ! -- How come IP is unreferenced in the body ??? function Recurse_Match (IP : Pointer; From : Natural) return Boolean; pragma Inline (Recurse_Match); --- 2417,2424 ---- -- using a loop instead of recursion. -- Why is the above comment part of the spec rather than body ??? ! function Match_Whilem return Boolean; ! -- Return True if a WHILEM matches the Current_Curly function Recurse_Match (IP : Pointer; From : Natural) return Boolean; pragma Inline (Recurse_Match); *************** package body System.Regpat is *** 2418,2423 **** --- 2433,2443 ---- Greedy : Boolean) return Boolean; -- Return True it the simple operator (possibly non-greedy) matches + Dump_Indent : Integer := -1; + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True); + procedure Dump_Error (Msg : String); + -- Debug: print the current context + pragma Inline (Index); pragma Inline (Repeat); *************** package body System.Regpat is *** 2446,2460 **** ------------------- function Recurse_Match (IP : Pointer; From : Natural) return Boolean is ! L : constant Natural := Last_Paren; ! Tmp_F : constant Match_Array := Matches_Full (From + 1 .. Matches_Full'Last); - Start : constant Natural_Array := Matches_Tmp (From + 1 .. Matches_Tmp'Last); Input : constant Natural := Input_Pos; begin if Match (IP) then return True; --- 2466,2480 ---- ------------------- function Recurse_Match (IP : Pointer; From : Natural) return Boolean is ! L : constant Natural := Last_Paren; Tmp_F : constant Match_Array := Matches_Full (From + 1 .. Matches_Full'Last); Start : constant Natural_Array := Matches_Tmp (From + 1 .. Matches_Tmp'Last); Input : constant Natural := Input_Pos; + Dump_Indent_Save : constant Integer := Dump_Indent; + begin if Match (IP) then return True; *************** package body System.Regpat is *** 2464,2472 **** --- 2484,2528 ---- Matches_Full (Tmp_F'Range) := Tmp_F; Matches_Tmp (Start'Range) := Start; Input_Pos := Input; + Dump_Indent := Dump_Indent_Save; return False; end Recurse_Match; + ------------------ + -- Dump_Current -- + ------------------ + + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is + Length : constant := 10; + Pos : constant String := Integer'Image (Input_Pos); + + begin + if Prefix then + Put ((1 .. 5 - Pos'Length => ' ')); + Put (Pos & " <" + & Data (Input_Pos + .. Integer'Min (Last_In_Data, Input_Pos + Length - 1))); + Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' ')); + Put ("> |"); + + else + Put (" "); + end if; + + Dump_Operation (Program, Scan, Indent => Dump_Indent); + end Dump_Current; + + ---------------- + -- Dump_Error -- + ---------------- + + procedure Dump_Error (Msg : String) is + begin + Put (" | "); + Put ((1 .. Dump_Indent * 2 => ' ')); + Put_Line (Msg); + end Dump_Error; + ----------- -- Match -- ----------- *************** package body System.Regpat is *** 2475,2482 **** --- 2531,2541 ---- Scan : Pointer := IP; Next : Pointer; Op : Opcode; + Result : Boolean; begin + Dump_Indent := Dump_Indent + 1; + State_Machine : loop pragma Assert (Scan /= 0); *************** package body System.Regpat is *** 2485,2497 **** Op := Opcode'Val (Character'Pos (Program (Scan))); ! -- Calculate offset of next instruction. ! -- Second character is most significant in Program_Data. Next := Get_Next (Program, Scan); case Op is when EOP => return True; -- Success ! when BRANCH => --- 2544,2561 ---- Op := Opcode'Val (Character'Pos (Program (Scan))); ! -- Calculate offset of next instruction. Second character is most ! -- significant in Program_Data. Next := Get_Next (Program, Scan); + if Debug then + Dump_Current (Scan); + end if; + case Op is when EOP => + Dump_Indent := Dump_Indent - 1; return True; -- Success ! when BRANCH => *************** package body System.Regpat is *** 2501,2506 **** --- 2565,2571 ---- else loop if Recurse_Match (Operand (Scan), 0) then + Dump_Indent := Dump_Indent - 1; return True; end if; *************** package body System.Regpat is *** 2517,2523 **** when BOL => exit State_Machine when Input_Pos /= BOL_Pos and then ((Self.Flags and Multiple_Lines) = 0 ! or else Data (Input_Pos - 1) /= ASCII.LF); when MBOL => exit State_Machine when Input_Pos /= BOL_Pos --- 2582,2588 ---- when BOL => exit State_Machine when Input_Pos /= BOL_Pos and then ((Self.Flags and Multiple_Lines) = 0 ! or else Data (Input_Pos - 1) /= ASCII.LF); when MBOL => exit State_Machine when Input_Pos /= BOL_Pos *************** package body System.Regpat is *** 2529,2535 **** when EOL => exit State_Machine when Input_Pos <= Data'Last and then ((Self.Flags and Multiple_Lines) = 0 ! or else Data (Input_Pos) /= ASCII.LF); when MEOL => exit State_Machine when Input_Pos <= Data'Last --- 2594,2600 ---- when EOL => exit State_Machine when Input_Pos <= Data'Last and then ((Self.Flags and Multiple_Lines) = 0 ! or else Data (Input_Pos) /= ASCII.LF); when MEOL => exit State_Machine when Input_Pos <= Data'Last *************** package body System.Regpat is *** 2610,2616 **** declare Opnd : Pointer := String_Operand (Scan); Current : Positive := Input_Pos; - Last : constant Pointer := Opnd + String_Length (Program, Scan); --- 2675,2680 ---- *************** package body System.Regpat is *** 2686,2691 **** --- 2750,2761 ---- -- If we haven't seen that parenthesis yet if Last_Paren < No then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + return False; end if; *************** package body System.Regpat is *** 2695,2700 **** --- 2765,2776 ---- if Input_Pos > Last_In_Data or else Data (Input_Pos) /= Data (Data_Pos) then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + return False; end if; *************** package body System.Regpat is *** 2711,2717 **** Greed : constant Boolean := Greedy; begin Greedy := True; ! return Match_Simple_Operator (Op, Scan, Next, Greed); end; when CURLYX => --- 2787,2795 ---- Greed : constant Boolean := Greedy; begin Greedy := True; ! Result := Match_Simple_Operator (Op, Scan, Next, Greed); ! Dump_Indent := Dump_Indent - 1; ! return Result; end; when CURLYX => *************** package body System.Regpat is *** 2725,2733 **** declare Min : constant Natural := ! Read_Natural (Program, Scan + 3); Max : constant Natural := ! Read_Natural (Program, Scan + 5); Cc : aliased Current_Curly_Record; Has_Match : Boolean; --- 2803,2812 ---- declare Min : constant Natural := ! Read_Natural (Program, Scan + Next_Pointer_Bytes); Max : constant Natural := ! Read_Natural ! (Program, Scan + Next_Pointer_Bytes + 2); Cc : aliased Current_Curly_Record; Has_Match : Boolean; *************** package body System.Regpat is *** 2742,2766 **** Next => Next, Lastloc => 0, Old_Cc => Current_Curly); Current_Curly := Cc'Unchecked_Access; ! Has_Match := Match (Next - 3); -- Start on the WHILEM Current_Curly := Cc.Old_Cc; return Has_Match; end; when WHILEM => ! return Match_Whilem (IP); end case; Scan := Next; end loop State_Machine; ! -- If we get here, there is no match. ! -- For successful matches when EOP is the terminating point. return False; end Match; --- 2821,2866 ---- Next => Next, Lastloc => 0, Old_Cc => Current_Curly); + Greedy := True; Current_Curly := Cc'Unchecked_Access; ! Has_Match := Match (Next - Next_Pointer_Bytes); -- Start on the WHILEM Current_Curly := Cc.Old_Cc; + Dump_Indent := Dump_Indent - 1; + + if not Has_Match then + if Debug then + Dump_Error ("CURLYX failed..."); + end if; + end if; + return Has_Match; end; when WHILEM => ! Result := Match_Whilem; ! Dump_Indent := Dump_Indent - 1; ! ! if Debug and then not Result then ! Dump_Error ("WHILEM: no match, backtracking"); ! end if; ! ! return Result; end case; Scan := Next; end loop State_Machine; ! if Debug then ! Dump_Error ("failed..."); ! Dump_Indent := Dump_Indent - 1; ! end if; ! ! -- If we get here, there is no match. For successful matches when EOP ! -- is the terminating point. return False; end Match; *************** package body System.Regpat is *** 2786,2793 **** Save : constant Natural := Input_Pos; begin ! -- Lookahead to avoid useless match attempts ! -- when we know what character comes next. if Program (Next) = EXACT then Next_Char := Program (String_Operand (Next)); --- 2886,2893 ---- Save : constant Natural := Input_Pos; begin ! -- Lookahead to avoid useless match attempts when we know what ! -- character comes next. if Program (Next) = EXACT then Next_Char := Program (String_Operand (Next)); *************** package body System.Regpat is *** 2806,2826 **** Operand_Code := Operand (Scan); when others => ! Min := Read_Natural (Program, Scan + 3); ! Max := Read_Natural (Program, Scan + 5); Operand_Code := Scan + 7; end case; -- Non greedy operators if not Greedy then ! -- Test the minimal repetitions ! if Min /= 0 ! and then Repeat (Operand_Code, Min) < Min ! then ! return False; end if; Old := Input_Pos; --- 2906,2936 ---- Operand_Code := Operand (Scan); when others => ! Min := Read_Natural (Program, Scan + Next_Pointer_Bytes); ! Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2); Operand_Code := Scan + 7; end case; + if Debug then + Dump_Current (Operand_Code, Prefix => False); + end if; + -- Non greedy operators if not Greedy then ! -- Test we can repeat at least Min times ! if Min /= 0 then ! No := Repeat (Operand_Code, Min); ! ! if No < Min then ! if Debug then ! Dump_Error ("failed... matched" & No'Img & " times"); ! end if; ! ! return False; ! end if; end if; Old := Input_Pos; *************** package body System.Regpat is *** 2828,2833 **** --- 2938,2944 ---- -- Find the place where 'next' could work if Next_Char_Known then + -- Last position to check if Max = Natural'Last then *************** package body System.Regpat is *** 2842,2847 **** --- 2953,2962 ---- -- Look for the first possible opportunity + if Debug then + Dump_Error ("Next_Char must be " & Next_Char); + end if; + loop -- Find the next possible position *************** package body System.Regpat is *** 2855,2862 **** return False; end if; ! -- Check that we still match if we stop ! -- at the position we just found. declare Num : constant Natural := Input_Pos - Old; --- 2970,2977 ---- return False; end if; ! -- Check that we still match if we stop at the position we ! -- just found. declare Num : constant Natural := Input_Pos - Old; *************** package body System.Regpat is *** 2864,2869 **** --- 2979,2988 ---- begin Input_Pos := Old; + if Debug then + Dump_Error ("Would we still match at that position?"); + end if; + if Repeat (Operand_Code, Num) < Num then return False; end if; *************** package body System.Regpat is *** 2879,2892 **** Input_Pos := Input_Pos + 1; end loop; ! -- We know what the next character is else while Max >= Min loop -- If the next character matches ! if Match (Next) then return True; end if; --- 2998,3015 ---- Input_Pos := Input_Pos + 1; end loop; ! -- We do not know what the next character is else while Max >= Min loop + if Debug then + Dump_Error ("Non-greedy repeat, N=" & Min'Img); + Dump_Error ("Do we still match Next if we stop here?"); + end if; -- If the next character matches ! if Recurse_Match (Next, 1) then return True; end if; *************** package body System.Regpat is *** 2897,2902 **** --- 3020,3029 ---- if Repeat (Operand_Code, 1) /= 0 then Min := Min + 1; else + if Debug then + Dump_Error ("Non-greedy repeat failed..."); + end if; + return False; end if; end loop; *************** package body System.Regpat is *** 2909,2920 **** else No := Repeat (Operand_Code, Max); ! -- ??? Perl has some special code here in case the ! -- next instruction is of type EOL, since $ and \Z ! -- can match before *and* after newline at the end. ! -- ??? Perl has some special code here in case (paren) ! -- is True. -- Else, if we don't have any parenthesis --- 3036,3050 ---- else No := Repeat (Operand_Code, Max); ! if Debug and then No < Min then ! Dump_Error ("failed... matched" & No'Img & " times"); ! end if; ! -- ??? Perl has some special code here in case the next ! -- instruction is of type EOL, since $ and \Z can match before ! -- *and* after newline at the end. ! ! -- ??? Perl has some special code here in case (paren) is True -- Else, if we don't have any parenthesis *************** package body System.Regpat is *** 2948,2957 **** -- tree by recursing ever deeper. And if it fails, we have to reset -- our parent's current state that we can try again after backing off. ! function Match_Whilem (IP : Pointer) return Boolean is ! pragma Unreferenced (IP); ! Cc : constant Current_Curly_Access := Current_Curly; N : constant Natural := Cc.Cur + 1; Ln : Natural := 0; --- 3078,3086 ---- -- tree by recursing ever deeper. And if it fails, we have to reset -- our parent's current state that we can try again after backing off. ! function Match_Whilem return Boolean is Cc : constant Current_Curly_Access := Current_Curly; + N : constant Natural := Cc.Cur + 1; Ln : Natural := 0; *************** package body System.Regpat is *** 2991,3002 **** --- 3120,3141 ---- Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error + ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img); + end if; + if Match (Cc.Scan) then return True; end if; Cc.Cur := N - 1; Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + return False; end if; *************** package body System.Regpat is *** 3022,3027 **** --- 3161,3169 ---- -- Maximum greed exceeded ? if N >= Cc.Max then + if Debug then + Dump_Error ("failed..."); + end if; return False; end if; *************** package body System.Regpat is *** 3029,3034 **** --- 3171,3180 ---- Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error ("Next failed, what about Current?"); + end if; + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then return True; end if; *************** package body System.Regpat is *** 3044,3049 **** --- 3190,3199 ---- Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error ("Recurse at current position"); + end if; + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then return True; end if; *************** package body System.Regpat is *** 3057,3062 **** --- 3207,3216 ---- Ln := Current_Curly.Cur; end if; + if Debug then + Dump_Error ("Failed matching for later positions"); + end if; + if Match (Cc.Next) then return True; end if; *************** package body System.Regpat is *** 3068,3073 **** --- 3222,3232 ---- Current_Curly := Cc; Cc.Cur := N - 1; Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + return False; end Match_Whilem; *************** package body System.Regpat is *** 3200,3206 **** Last_Paren := 0; Matches_Full := (others => No_Match); ! if Match (Program_First + 1) then Matches_Full (0) := (Pos, Input_Pos - 1); return True; end if; --- 3359,3365 ---- Last_Paren := 0; Matches_Full := (others => No_Match); ! if Match (Program_First) then Matches_Full (0) := (Pos, Input_Pos - 1); return True; end if; *************** package body System.Regpat is *** 3218,3229 **** return; end if; - -- Check validity of program - - pragma Assert - (Program (Program_First) = MAGIC, - "Corrupted Pattern_Matcher"); - -- If there is a "must appear" string, look for it if Self.Must_Have_Length > 0 then --- 3377,3382 ---- *************** package body System.Regpat is *** 3430,3436 **** function Operand (P : Pointer) return Pointer is begin ! return P + 3; end Operand; -------------- --- 3583,3589 ---- function Operand (P : Pointer) return Pointer is begin ! return P + Next_Pointer_Bytes; end Operand; -------------- *************** package body System.Regpat is *** 3452,3458 **** Self.Must_Have := Program'Last + 1; Self.Must_Have_Length := 0; ! Scan := Program_First + 1; -- First instruction (can be anything) if Program (Scan) = EXACT then Self.First := Program (String_Operand (Scan)); --- 3605,3611 ---- Self.Must_Have := Program'Last + 1; Self.Must_Have_Length := 0; ! Scan := Program_First; -- First instruction (can be anything) if Program (Scan) = EXACT then Self.First := Program (String_Operand (Scan)); *************** package body System.Regpat is *** 3547,3553 **** is begin pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); ! return Character'Pos (Program (P + 3)); end String_Length; -------------------- --- 3700,3706 ---- is begin pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); ! return Character'Pos (Program (P + Next_Pointer_Bytes)); end String_Length; -------------------- diff -Nrcpad gcc-4.5.2/gcc/ada/s-rident.ads gcc-4.6.0/gcc/ada/s-rident.ads *** gcc-4.5.2/gcc/ada/s-rident.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-rident.ads Mon Oct 18 10:34:56 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package System.Rident is *** 62,69 **** --- 62,72 ---- No_Abort_Statements, -- (RM D.7(5), H.4(3)) No_Access_Subprograms, -- (RM H.4(17)) No_Allocators, -- (RM H.4(7)) + No_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2)) + No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1)) No_Asynchronous_Control, -- (RM D.7(10)) No_Calendar, -- GNAT + No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2)) No_Delay, -- (RM H.4(21)) No_Direct_Boolean_Operators, -- GNAT No_Dispatch, -- (RM H.4(19)) *************** package System.Rident is *** 327,333 **** -- value of the parameter permitted by the profile. end record; ! Profile_Info : array (Profile_Name_Actual) of Profile_Data := -- Restricted Profile --- 330,336 ---- -- value of the parameter permitted by the profile. end record; ! Profile_Info : constant array (Profile_Name_Actual) of Profile_Data := -- Restricted Profile diff -Nrcpad gcc-4.5.2/gcc/ada/s-shasto.adb gcc-4.6.0/gcc/ada/s-shasto.adb *** gcc-4.5.2/gcc/ada/s-shasto.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-shasto.adb Fri Jun 18 09:53:00 2010 *************** *** 6,13 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- --- 6,13 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2010, 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- *************** package body System.Shared_Storage is *** 88,95 **** Item : AS.Stream_Element_Array); subtype Hash_Header is Natural range 0 .. 30; ! -- Number of hash headers, related (for efficiency purposes only) ! -- to the maximum number of lock files.. type Shared_Var_File_Entry; type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; --- 88,95 ---- Item : AS.Stream_Element_Array); subtype Hash_Header is Natural range 0 .. 30; ! -- Number of hash headers, related (for efficiency purposes only) to the ! -- maximum number of lock files. type Shared_Var_File_Entry; type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; diff -Nrcpad gcc-4.5.2/gcc/ada/s-stalib.ads gcc-4.6.0/gcc/ada/s-stalib.ads *** gcc-4.5.2/gcc/ada/s-stalib.ads Wed Apr 22 09:57:03 2009 --- gcc-4.6.0/gcc/ada/s-stalib.ads Thu Oct 21 10:25:12 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 33,43 **** -- are required to be part of every Ada program. A special mechanism is -- required to ensure that these are loaded, since it may be the case in -- some programs that the only references to these required packages are ! -- from C code or from code generated directly by Gigi, an in both cases -- the binder is not aware of such references. -- System.Standard_Library also includes data that must be present in every ! -- program, in particular the definitions of all the standard and also some -- subprograms that must be present in every program. -- The binder unconditionally includes s-stalib.ali, which ensures that this --- 33,43 ---- -- are required to be part of every Ada program. A special mechanism is -- required to ensure that these are loaded, since it may be the case in -- some programs that the only references to these required packages are ! -- from C code or from code generated directly by Gigi, and in both cases -- the binder is not aware of such references. -- System.Standard_Library also includes data that must be present in every ! -- program, in particular data for all the standard exceptions, and also some -- subprograms that must be present in every program. -- The binder unconditionally includes s-stalib.ali, which ensures that this diff -Nrcpad gcc-4.5.2/gcc/ada/s-stausa.adb gcc-4.6.0/gcc/ada/s-stausa.adb *** gcc-4.5.2/gcc/ada/s-stausa.adb Mon Nov 30 10:45:39 2009 --- gcc-4.6.0/gcc/ada/s-stausa.adb Mon Oct 18 10:34:56 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Stack_Usage is *** 232,238 **** "ENVIRONMENT TASK", My_Stack_Size, My_Stack_Size, ! System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address)); Fill_Stack (Environment_Task_Analyzer); --- 232,239 ---- "ENVIRONMENT TASK", My_Stack_Size, My_Stack_Size, ! System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address), ! 0); Fill_Stack (Environment_Task_Analyzer); *************** package body System.Stack_Usage is *** 259,314 **** Stack_Used_When_Filling : Integer; Current_Stack_Level : aliased Integer; begin ! -- Readjust the pattern size. When we arrive in this function, there is ! -- already a given amount of stack used, that we won't analyze. ! Stack_Used_When_Filling := ! Stack_Size ! (Analyzer.Bottom_Of_Stack, ! To_Stack_Address (Current_Stack_Level'Address)) ! + Natural (Current_Stack_Level'Size); ! if Stack_Used_When_Filling > Analyzer.Pattern_Size then ! -- In this case, the known size of the stack is too small, we've ! -- already taken more than expected, so there's no possible ! -- computation - Analyzer.Pattern_Size := 0; else ! Analyzer.Pattern_Size := ! Analyzer.Pattern_Size - Stack_Used_When_Filling; ! end if; ! declare ! Stack : aliased Stack_Slots ! (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); ! begin ! Stack := (others => Analyzer.Pattern); ! Analyzer.Stack_Overlay_Address := Stack'Address; ! if Analyzer.Pattern_Size /= 0 then ! Analyzer.Bottom_Pattern_Mark := ! To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address); ! Analyzer.Top_Pattern_Mark := ! To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address); else ! Analyzer.Bottom_Pattern_Mark := To_Stack_Address (Stack'Address); ! Analyzer.Top_Pattern_Mark := To_Stack_Address (Stack'Address); end if; ! -- If Arr has been packed, the following assertion must be true (we ! -- add the size of the element whose address is: ! -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)): ! pragma Assert ! (Analyzer.Pattern_Size = 0 or else ! Analyzer.Pattern_Size = ! Stack_Size ! (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)); ! end; end Fill_Stack; ------------------------- --- 260,355 ---- Stack_Used_When_Filling : Integer; Current_Stack_Level : aliased Integer; + Guard : constant Integer := 256; + -- Guard space between the Current_Stack_Level'Address and the last + -- allocated byte on the stack. + begin ! -- Easiest and most accurate method: the top of the stack is known. ! if Analyzer.Top_Pattern_Mark /= 0 then ! Analyzer.Pattern_Size := ! Stack_Size (Analyzer.Top_Pattern_Mark, ! To_Stack_Address (Current_Stack_Level'Address)) ! - Guard; ! if System.Parameters.Stack_Grows_Down then ! Analyzer.Stack_Overlay_Address := ! To_Address (Analyzer.Top_Pattern_Mark); ! else ! Analyzer.Stack_Overlay_Address := ! To_Address (Analyzer.Top_Pattern_Mark ! - Stack_Address (Analyzer.Pattern_Size)); ! end if; ! ! declare ! Pattern : aliased Stack_Slots ! (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); ! for Pattern'Address use Analyzer.Stack_Overlay_Address; ! ! begin ! if System.Parameters.Stack_Grows_Down then ! for J in reverse Pattern'Range loop ! Pattern (J) := Analyzer.Pattern; ! end loop; ! ! Analyzer.Bottom_Pattern_Mark := ! To_Stack_Address (Pattern (Pattern'Last)'Address); ! ! else ! for J in Pattern'Range loop ! Pattern (J) := Analyzer.Pattern; ! end loop; ! ! Analyzer.Bottom_Pattern_Mark := ! To_Stack_Address (Pattern (Pattern'First)'Address); ! end if; ! end; else ! -- Readjust the pattern size. When we arrive in this function, there ! -- is already a given amount of stack used, that we won't analyze. ! Stack_Used_When_Filling := ! Stack_Size (Analyzer.Bottom_Of_Stack, ! To_Stack_Address (Current_Stack_Level'Address)); ! if Stack_Used_When_Filling > Analyzer.Pattern_Size then ! -- In this case, the known size of the stack is too small, we've ! -- already taken more than expected, so there's no possible ! -- computation ! Analyzer.Pattern_Size := 0; else ! Analyzer.Pattern_Size := ! Analyzer.Pattern_Size - Stack_Used_When_Filling; end if; ! declare ! Stack : aliased Stack_Slots ! (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); ! begin ! Stack := (others => Analyzer.Pattern); ! ! Analyzer.Stack_Overlay_Address := Stack'Address; ! ! if Analyzer.Pattern_Size /= 0 then ! Analyzer.Bottom_Pattern_Mark := ! To_Stack_Address ! (Stack (Bottom_Slot_Index_In (Stack))'Address); ! Analyzer.Top_Pattern_Mark := ! To_Stack_Address ! (Stack (Top_Slot_Index_In (Stack))'Address); ! else ! Analyzer.Bottom_Pattern_Mark := ! To_Stack_Address (Stack'Address); ! Analyzer.Top_Pattern_Mark := ! To_Stack_Address (Stack'Address); ! end if; ! end; ! end if; end Fill_Stack; ------------------------- *************** package body System.Stack_Usage is *** 321,337 **** My_Stack_Size : Natural; Max_Pattern_Size : Natural; Bottom : Stack_Address; Pattern : Unsigned_32 := 16#DEAD_BEEF#) is begin -- Initialize the analyzer fields ! Analyzer.Bottom_Of_Stack := Bottom; ! Analyzer.Stack_Size := My_Stack_Size; ! Analyzer.Pattern_Size := Max_Pattern_Size; ! Analyzer.Pattern := Pattern; ! Analyzer.Result_Id := Next_Id; ! Analyzer.Task_Name := (others => ' '); -- Compute the task name, and truncate if bigger than Task_Name_Length --- 362,380 ---- My_Stack_Size : Natural; Max_Pattern_Size : Natural; Bottom : Stack_Address; + Top : Stack_Address; Pattern : Unsigned_32 := 16#DEAD_BEEF#) is begin -- Initialize the analyzer fields ! Analyzer.Bottom_Of_Stack := Bottom; ! Analyzer.Stack_Size := My_Stack_Size; ! Analyzer.Pattern_Size := Max_Pattern_Size; ! Analyzer.Pattern := Pattern; ! Analyzer.Result_Id := Next_Id; ! Analyzer.Task_Name := (others => ' '); ! Analyzer.Top_Pattern_Mark := Top; -- Compute the task name, and truncate if bigger than Task_Name_Length diff -Nrcpad gcc-4.5.2/gcc/ada/s-stausa.ads gcc-4.6.0/gcc/ada/s-stausa.ads *** gcc-4.5.2/gcc/ada/s-stausa.ads Wed Apr 29 10:30:53 2009 --- gcc-4.6.0/gcc/ada/s-stausa.ads Mon Oct 18 10:18:07 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.Stack_Usage is *** 218,227 **** -- | of Fill_Stack | | -- | (deallocated at | | -- | the end of the call) | | ! -- ^ | | ! -- Analyzer.Bottom_Of_Stack ^ | ! -- Analyzer.Bottom_Pattern_Mark ^ ! -- Analyzer.Top_Pattern_Mark procedure Initialize_Analyzer (Analyzer : in out Stack_Analyzer; --- 218,228 ---- -- | of Fill_Stack | | -- | (deallocated at | | -- | the end of the call) | | ! -- ^ | ^ ! -- Analyzer.Bottom_Of_Stack | Analyzer.Top_Pattern_Mark ! -- ^ ! -- Analyzer.Bottom_Pattern_Mark ! -- procedure Initialize_Analyzer (Analyzer : in out Stack_Analyzer; *************** package System.Stack_Usage is *** 229,234 **** --- 230,236 ---- My_Stack_Size : Natural; Max_Pattern_Size : Natural; Bottom : Stack_Address; + Top : Stack_Address; Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); -- Should be called before any use of a Stack_Analyzer, to initialize it. -- Max_Pattern_Size is the size of the pattern zone, might be smaller than diff -Nrcpad gcc-4.5.2/gcc/ada/s-stchop.adb gcc-4.6.0/gcc/ada/s-stchop.adb *** gcc-4.5.2/gcc/ada/s-stchop.adb Mon Nov 30 10:45:39 2009 --- gcc-4.6.0/gcc/ada/s-stchop.adb Tue Jun 22 17:04:37 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Stack_Checking.Opera *** 48,75 **** function Set_Stack_Info (Stack : not null access Stack_Access) return Stack_Access; - -- The function Set_Stack_Info is the actual function that updates the -- cache containing a pointer to the Stack_Info. It may also be used for -- detecting asynchronous abort in combination with Invalidate_Self_Cache. ! -- Set_Stack_Info should do the following things in order: -- 1) Get the Stack_Access value for the current task -- 2) Set Stack.all to the value obtained in 1) -- 3) Optionally Poll to check for asynchronous abort ! -- This order is important because if at any time a write to the stack -- cache is pending, that write should be followed by a Poll to prevent -- loosing signals. ! -- Note: This function must be compiled with Polling turned off ! ! -- Note: on systems like VxWorks and OS/2 with real thread-local storage, ! -- Set_Stack_Info should return an access value for such local ! -- storage. In those cases the cache will always be up-to-date. ! ! -- The following constants should be imported from some system-specific ! -- constants package. The constants must be static for performance reasons. ---------------------------- -- Invalidate_Stack_Cache -- --- 48,71 ---- function Set_Stack_Info (Stack : not null access Stack_Access) return Stack_Access; -- The function Set_Stack_Info is the actual function that updates the -- cache containing a pointer to the Stack_Info. It may also be used for -- detecting asynchronous abort in combination with Invalidate_Self_Cache. ! -- -- Set_Stack_Info should do the following things in order: -- 1) Get the Stack_Access value for the current task -- 2) Set Stack.all to the value obtained in 1) -- 3) Optionally Poll to check for asynchronous abort ! -- -- This order is important because if at any time a write to the stack -- cache is pending, that write should be followed by a Poll to prevent -- loosing signals. ! -- -- Note: This function must be compiled with Polling turned off ! -- ! -- Note: on systems with real thread-local storage, Set_Stack_Info should ! -- return an access value for such local storage. In those cases the cache ! -- will always be up-to-date. ---------------------------- -- Invalidate_Stack_Cache -- diff -Nrcpad gcc-4.5.2/gcc/ada/s-stoele.adb gcc-4.6.0/gcc/ada/s-stoele.adb *** gcc-4.5.2/gcc/ada/s-stoele.adb Fri Apr 17 13:07:12 2009 --- gcc-4.6.0/gcc/ada/s-stoele.adb Thu Jun 17 15:23:55 2010 *************** package body System.Storage_Elements is *** 37,42 **** --- 37,46 ---- pragma Suppress (All_Checks); + -- Conversion to/from address + + -- Note qualification below of To_Address to avoid ambiguities on VMS + function To_Address is new Ada.Unchecked_Conversion (Storage_Offset, Address); function To_Offset is *************** package body System.Storage_Elements is *** 47,84 **** -- These functions must be place first because they are inlined_always -- and are used and inlined in other subprograms defined in this unit. ! function To_Integer (Value : Address) return Integer_Address is ! begin ! return Integer_Address (Value); ! end To_Integer; function To_Address (Value : Integer_Address) return Address is begin return Address (Value); end To_Address; -- Address arithmetic function "+" (Left : Address; Right : Storage_Offset) return Address is begin ! return To_Address (To_Integer (Left) + To_Integer (To_Address (Right))); end "+"; function "+" (Left : Storage_Offset; Right : Address) return Address is begin ! return To_Address (To_Integer (To_Address (Left)) + To_Integer (Right)); end "+"; function "-" (Left : Address; Right : Storage_Offset) return Address is begin ! return To_Address (To_Integer (Left) - To_Integer (To_Address (Right))); end "-"; function "-" (Left, Right : Address) return Storage_Offset is begin ! return To_Offset (To_Address (To_Integer (Left) - To_Integer (Right))); end "-"; function "mod" (Left : Address; Right : Storage_Offset) return Storage_Offset --- 51,112 ---- -- These functions must be place first because they are inlined_always -- and are used and inlined in other subprograms defined in this unit. ! ---------------- ! -- To_Address -- ! ---------------- function To_Address (Value : Integer_Address) return Address is begin return Address (Value); end To_Address; + ---------------- + -- To_Integer -- + ---------------- + + function To_Integer (Value : Address) return Integer_Address is + begin + return Integer_Address (Value); + end To_Integer; + -- Address arithmetic + --------- + -- "+" -- + --------- + function "+" (Left : Address; Right : Storage_Offset) return Address is begin ! return Storage_Elements.To_Address ! (To_Integer (Left) + To_Integer (To_Address (Right))); end "+"; function "+" (Left : Storage_Offset; Right : Address) return Address is begin ! return Storage_Elements.To_Address ! (To_Integer (To_Address (Left)) + To_Integer (Right)); end "+"; + --------- + -- "-" -- + --------- + function "-" (Left : Address; Right : Storage_Offset) return Address is begin ! return Storage_Elements.To_Address ! (To_Integer (Left) - To_Integer (To_Address (Right))); end "-"; function "-" (Left, Right : Address) return Storage_Offset is begin ! return To_Offset (Storage_Elements.To_Address ! (To_Integer (Left) - To_Integer (Right))); end "-"; + ----------- + -- "mod" -- + ----------- + function "mod" (Left : Address; Right : Storage_Offset) return Storage_Offset *************** package body System.Storage_Elements is *** 98,101 **** --- 126,130 ---- raise Constraint_Error; end if; end "mod"; + end System.Storage_Elements; diff -Nrcpad gcc-4.5.2/gcc/ada/s-stratt-xdr.adb gcc-4.6.0/gcc/ada/s-stratt-xdr.adb *** gcc-4.5.2/gcc/ada/s-stratt-xdr.adb Thu Jan 1 00:00:00 1970 --- gcc-4.6.0/gcc/ada/s-stratt-xdr.adb Thu Sep 9 12:31:35 2010 *************** *** 0 **** --- 1,1891 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT RUN-TIME COMPONENTS -- + -- -- + -- S Y S T E M . S T R E A M _ A T T R I B U T E S -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- + -- -- + -- GARLIC 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This file is an alternate version of s-stratt.adb based on the XDR + -- standard. It is especially useful for exchanging streams between two + -- different systems with different basic type representations and endianness. + + with Ada.IO_Exceptions; + with Ada.Streams; use Ada.Streams; + with Ada.Unchecked_Conversion; + + package body System.Stream_Attributes is + + pragma Suppress (Range_Check); + pragma Suppress (Overflow_Check); + + use UST; + + Data_Error : exception renames Ada.IO_Exceptions.End_Error; + -- Exception raised if insufficient data read (End_Error is mandated by + -- AI95-00132). + + SU : constant := System.Storage_Unit; + -- The code in this body assumes that SU = 8 + + BB : constant := 2 ** SU; -- Byte base + BL : constant := 2 ** SU - 1; -- Byte last + BS : constant := 2 ** (SU - 1); -- Byte sign + + US : constant := Unsigned'Size; -- Unsigned size + UB : constant := (US - 1) / SU + 1; -- Unsigned byte + UL : constant := 2 ** US - 1; -- Unsigned last + + subtype SE is Ada.Streams.Stream_Element; + subtype SEA is Ada.Streams.Stream_Element_Array; + subtype SEO is Ada.Streams.Stream_Element_Offset; + + generic function UC renames Ada.Unchecked_Conversion; + + type Field_Type is + record + E_Size : Integer; -- Exponent bit size + E_Bias : Integer; -- Exponent bias + F_Size : Integer; -- Fraction bit size + E_Last : Integer; -- Max exponent value + F_Mask : SE; -- Mask to apply on first fraction byte + E_Bytes : SEO; -- N. of exponent bytes completely used + F_Bytes : SEO; -- N. of fraction bytes completely used + F_Bits : Integer; -- N. of bits used on first fraction word + end record; + + type Precision is (Single, Double, Quadruple); + + Fields : constant array (Precision) of Field_Type := ( + + -- Single precision + + (E_Size => 8, + E_Bias => 127, + F_Size => 23, + E_Last => 2 ** 8 - 1, + F_Mask => 16#7F#, -- 2 ** 7 - 1, + E_Bytes => 2, + F_Bytes => 3, + F_Bits => 23 mod US), + + -- Double precision + + (E_Size => 11, + E_Bias => 1023, + F_Size => 52, + E_Last => 2 ** 11 - 1, + F_Mask => 16#0F#, -- 2 ** 4 - 1, + E_Bytes => 2, + F_Bytes => 7, + F_Bits => 52 mod US), + + -- Quadruple precision + + (E_Size => 15, + E_Bias => 16383, + F_Size => 112, + E_Last => 2 ** 8 - 1, + F_Mask => 16#FF#, -- 2 ** 8 - 1, + E_Bytes => 2, + F_Bytes => 14, + F_Bits => 112 mod US)); + + -- The representation of all items requires a multiple of four bytes + -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes + -- are read or written to some byte stream such that byte m always + -- precedes byte m+1. If the n bytes needed to contain the data are not + -- a multiple of four, then the n bytes are followed by enough (0 to 3) + -- residual zero bytes, r, to make the total byte count a multiple of 4. + + -- An XDR signed integer is a 32-bit datum that encodes an integer + -- in the range [-2147483648,2147483647]. The integer is represented + -- in two's complement notation. The most and least significant bytes + -- are 0 and 3, respectively. Integers are declared as follows: + + -- (MSB) (LSB) + -- +-------+-------+-------+-------+ + -- |byte 0 |byte 1 |byte 2 |byte 3 | + -- +-------+-------+-------+-------+ + -- <------------32 bits------------> + + SSI_L : constant := 1; + SI_L : constant := 2; + I_L : constant := 4; + LI_L : constant := 8; + LLI_L : constant := 8; + + subtype XDR_S_SSI is SEA (1 .. SSI_L); + subtype XDR_S_SI is SEA (1 .. SI_L); + subtype XDR_S_I is SEA (1 .. I_L); + subtype XDR_S_LI is SEA (1 .. LI_L); + subtype XDR_S_LLI is SEA (1 .. LLI_L); + + function Short_Short_Integer_To_XDR_S_SSI is + new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI); + function XDR_S_SSI_To_Short_Short_Integer is + new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer); + + function Short_Integer_To_XDR_S_SI is + new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI); + function XDR_S_SI_To_Short_Integer is + new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer); + + function Integer_To_XDR_S_I is + new Ada.Unchecked_Conversion (Integer, XDR_S_I); + function XDR_S_I_To_Integer is + new Ada.Unchecked_Conversion (XDR_S_I, Integer); + + function Long_Long_Integer_To_XDR_S_LI is + new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI); + function XDR_S_LI_To_Long_Long_Integer is + new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer); + + function Long_Long_Integer_To_XDR_S_LLI is + new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI); + function XDR_S_LLI_To_Long_Long_Integer is + new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer); + + -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative + -- integer in the range [0,4294967295]. It is represented by an unsigned + -- binary number whose most and least significant bytes are 0 and 3, + -- respectively. An unsigned integer is declared as follows: + + -- (MSB) (LSB) + -- +-------+-------+-------+-------+ + -- |byte 0 |byte 1 |byte 2 |byte 3 | + -- +-------+-------+-------+-------+ + -- <------------32 bits------------> + + SSU_L : constant := 1; + SU_L : constant := 2; + U_L : constant := 4; + LU_L : constant := 8; + LLU_L : constant := 8; + + subtype XDR_S_SSU is SEA (1 .. SSU_L); + subtype XDR_S_SU is SEA (1 .. SU_L); + subtype XDR_S_U is SEA (1 .. U_L); + subtype XDR_S_LU is SEA (1 .. LU_L); + subtype XDR_S_LLU is SEA (1 .. LLU_L); + + type XDR_SSU is mod BB ** SSU_L; + type XDR_SU is mod BB ** SU_L; + type XDR_U is mod BB ** U_L; + + function Short_Unsigned_To_XDR_S_SU is + new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU); + function XDR_S_SU_To_Short_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned); + + function Unsigned_To_XDR_S_U is + new Ada.Unchecked_Conversion (Unsigned, XDR_S_U); + function XDR_S_U_To_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_U, Unsigned); + + function Long_Long_Unsigned_To_XDR_S_LU is + new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU); + function XDR_S_LU_To_Long_Long_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned); + + function Long_Long_Unsigned_To_XDR_S_LLU is + new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU); + function XDR_S_LLU_To_Long_Long_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned); + + -- The standard defines the floating-point data type "float" (32 bits + -- or 4 bytes). The encoding used is the IEEE standard for normalized + -- single-precision floating-point numbers. + + -- The standard defines the encoding used for the double-precision + -- floating-point data type "double" (64 bits or 8 bytes). The encoding + -- used is the IEEE standard for normalized double-precision floating-point + -- numbers. + + SF_L : constant := 4; -- Single precision + F_L : constant := 4; -- Single precision + LF_L : constant := 8; -- Double precision + LLF_L : constant := 16; -- Quadruple precision + + TM_L : constant := 8; + subtype XDR_S_TM is SEA (1 .. TM_L); + type XDR_TM is mod BB ** TM_L; + + type XDR_SA is mod 2 ** Standard'Address_Size; + function To_XDR_SA is new UC (System.Address, XDR_SA); + function To_XDR_SA is new UC (XDR_SA, System.Address); + + -- Enumerations have the same representation as signed integers. + -- Enumerations are handy for describing subsets of the integers. + + -- Booleans are important enough and occur frequently enough to warrant + -- their own explicit type in the standard. Booleans are declared as + -- an enumeration, with FALSE = 0 and TRUE = 1. + + -- The standard defines a string of n (numbered 0 through n-1) ASCII + -- bytes to be the number n encoded as an unsigned integer (as described + -- above), and followed by the n bytes of the string. Byte m of the string + -- always precedes byte m+1 of the string, and byte 0 of the string always + -- follows the string's length. If n is not a multiple of four, then the + -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make + -- the total byte count a multiple of four. + + -- To fit with XDR string, do not consider character as an enumeration + -- type. + + C_L : constant := 1; + subtype XDR_S_C is SEA (1 .. C_L); + + -- Consider Wide_Character as an enumeration type + + WC_L : constant := 4; + subtype XDR_S_WC is SEA (1 .. WC_L); + type XDR_WC is mod BB ** WC_L; + + -- Consider Wide_Wide_Character as an enumeration type + + WWC_L : constant := 8; + subtype XDR_S_WWC is SEA (1 .. WWC_L); + type XDR_WWC is mod BB ** WWC_L; + + -- Optimization: if we already have the correct Bit_Order, then some + -- computations can be avoided since the source and the target will be + -- identical anyway. They will be replaced by direct unchecked + -- conversions. + + Optimize_Integers : constant Boolean := + Default_Bit_Order = High_Order_First; + + ----------------- + -- Block_IO_OK -- + ----------------- + + function Block_IO_OK return Boolean is + begin + return False; + end Block_IO_OK; + + ---------- + -- I_AD -- + ---------- + + function I_AD (Stream : not null access RST) return Fat_Pointer is + FP : Fat_Pointer; + + begin + FP.P1 := I_AS (Stream).P1; + FP.P2 := I_AS (Stream).P1; + + return FP; + end I_AD; + + ---------- + -- I_AS -- + ---------- + + function I_AS (Stream : not null access RST) return Thin_Pointer is + S : XDR_S_TM; + L : SEO; + U : XDR_TM := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_TM (S (N)); + end loop; + + return (P1 => To_XDR_SA (XDR_SA (U))); + end if; + end I_AS; + + --------- + -- I_B -- + --------- + + function I_B (Stream : not null access RST) return Boolean is + begin + case I_SSU (Stream) is + when 0 => return False; + when 1 => return True; + when others => raise Data_Error; + end case; + end I_B; + + --------- + -- I_C -- + --------- + + function I_C (Stream : not null access RST) return Character is + S : XDR_S_C; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + -- Use Ada requirements on Character representation clause + + return Character'Val (S (1)); + end if; + end I_C; + + --------- + -- I_F -- + --------- + + function I_F (Stream : not null access RST) return Float is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Positive : Boolean; + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Result : Float; + S : SEA (1 .. F_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask); + for N in F_L + 2 - F_Bytes .. F_L loop + Fraction := Fraction * BB + Long_Unsigned (S (N)); + end loop; + Result := Float'Scaling (Float (Fraction), -F_Size); + + if BS <= S (1) then + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Positive then + Result := -Result; + end if; + + return Result; + end I_F; + + --------- + -- I_I -- + --------- + + function I_I (Stream : not null access RST) return Integer is + S : XDR_S_I; + L : SEO; + U : XDR_U := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_I_To_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_U (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Integer (U); + + else + return Integer (-((XDR_U'Last xor U) + 1)); + end if; + end if; + end I_I; + + ---------- + -- I_LF -- + ---------- + + function I_LF (Stream : not null access RST) return Long_Float is + I : constant Precision := Double; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Positive : Boolean; + Exponent : Long_Unsigned; + Fraction : Long_Long_Unsigned; + Result : Long_Float; + S : SEA (1 .. LF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask); + for N in LF_L + 2 - F_Bytes .. LF_L loop + Fraction := Fraction * BB + Long_Long_Unsigned (S (N)); + end loop; + + Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size); + + if BS <= S (1) then + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Long_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Long_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Positive then + Result := -Result; + end if; + + return Result; + end I_LF; + + ---------- + -- I_LI -- + ---------- + + function I_LI (Stream : not null access RST) return Long_Integer is + S : XDR_S_LI; + L : SEO; + U : Unsigned := 0; + X : Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S)); + + else + + -- Compute using machine unsigned + -- rather than long_long_unsigned + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Unsigned (U); + U := 0; + end if; + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Long_Integer (X); + else + return Long_Integer (-((Long_Unsigned'Last xor X) + 1)); + end if; + + end if; + end I_LI; + + ----------- + -- I_LLF -- + ----------- + + function I_LLF (Stream : not null access RST) return Long_Long_Float is + I : constant Precision := Quadruple; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Positive : Boolean; + Exponent : Long_Unsigned; + Fraction_1 : Long_Long_Unsigned := 0; + Fraction_2 : Long_Long_Unsigned := 0; + Result : Long_Long_Float; + HF : constant Natural := F_Size / 2; + S : SEA (1 .. LLF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop + Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I)); + end loop; + + for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop + Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I)); + end loop; + + Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF); + Result := Long_Long_Float (Fraction_1) + Result; + Result := Long_Long_Float'Scaling (Result, HF - F_Size); + + if BS <= S (1) then + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction_1 = 0 and then Fraction_2 = 0 then + null; + + -- Denormalized float + + else + Result := Long_Long_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Long_Long_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Positive then + Result := -Result; + end if; + + return Result; + end I_LLF; + + ----------- + -- I_LLI -- + ----------- + + function I_LLI (Stream : not null access RST) return Long_Long_Integer is + S : XDR_S_LLI; + L : SEO; + U : Unsigned := 0; + X : Long_Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_LLI_To_Long_Long_Integer (S); + + else + -- Compute using machine unsigned for computing + -- rather than long_long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Long_Unsigned (U); + U := 0; + end if; + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Long_Long_Integer (X); + else + return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1)); + end if; + end if; + end I_LLI; + + ----------- + -- I_LLU -- + ----------- + + function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is + S : XDR_S_LLU; + L : SEO; + U : Unsigned := 0; + X : Long_Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_LLU_To_Long_Long_Unsigned (S); + + else + -- Compute using machine unsigned + -- rather than long_long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Long_Unsigned (U); + U := 0; + end if; + end loop; + + return X; + end if; + end I_LLU; + + ---------- + -- I_LU -- + ---------- + + function I_LU (Stream : not null access RST) return Long_Unsigned is + S : XDR_S_LU; + L : SEO; + U : Unsigned := 0; + X : Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); + + else + -- Compute using machine unsigned + -- rather than long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Unsigned (U); + U := 0; + end if; + end loop; + + return X; + end if; + end I_LU; + + ---------- + -- I_SF -- + ---------- + + function I_SF (Stream : not null access RST) return Short_Float is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Positive : Boolean; + Result : Short_Float; + S : SEA (1 .. SF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask); + for N in SF_L + 2 - F_Bytes .. SF_L loop + Fraction := Fraction * BB + Long_Unsigned (S (N)); + end loop; + Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); + + if BS <= S (1) then + Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Short_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Short_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Positive then + Result := -Result; + end if; + + return Result; + end I_SF; + + ---------- + -- I_SI -- + ---------- + + function I_SI (Stream : not null access RST) return Short_Integer is + S : XDR_S_SI; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SI_To_Short_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Integer (U); + else + return Short_Integer (-((XDR_SU'Last xor U) + 1)); + end if; + end if; + end I_SI; + + ----------- + -- I_SSI -- + ----------- + + function I_SSI (Stream : not null access RST) return Short_Short_Integer is + S : XDR_S_SSI; + L : SEO; + U : XDR_SSU; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SSI_To_Short_Short_Integer (S); + + else + U := XDR_SSU (S (1)); + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Short_Integer (U); + else + return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); + end if; + end if; + end I_SSI; + + ----------- + -- I_SSU -- + ----------- + + function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is + S : XDR_S_SSU; + L : SEO; + U : XDR_SSU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + U := XDR_SSU (S (1)); + return Short_Short_Unsigned (U); + end if; + end I_SSU; + + ---------- + -- I_SU -- + ---------- + + function I_SU (Stream : not null access RST) return Short_Unsigned is + S : XDR_S_SU; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SU_To_Short_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + return Short_Unsigned (U); + end if; + end I_SU; + + --------- + -- I_U -- + --------- + + function I_U (Stream : not null access RST) return Unsigned is + S : XDR_S_U; + L : SEO; + U : XDR_U := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_U_To_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_U (S (N)); + end loop; + + return Unsigned (U); + end if; + end I_U; + + ---------- + -- I_WC -- + ---------- + + function I_WC (Stream : not null access RST) return Wide_Character is + S : XDR_S_WC; + L : SEO; + U : XDR_WC := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_WC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Character representation clause + + return Wide_Character'Val (U); + end if; + end I_WC; + + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + S : XDR_S_WWC; + L : SEO; + U : XDR_WWC := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_WWC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Wide_Character representation clause + + return Wide_Wide_Character'Val (U); + end if; + end I_WWC; + + ---------- + -- W_AD -- + ---------- + + procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is + S : XDR_S_TM; + U : XDR_TM; + + begin + U := XDR_TM (To_XDR_SA (Item.P1)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + U := XDR_TM (To_XDR_SA (Item.P2)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AD; + + ---------- + -- W_AS -- + ---------- + + procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is + S : XDR_S_TM; + U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); + + begin + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AS; + + --------- + -- W_B -- + --------- + + procedure W_B (Stream : not null access RST; Item : Boolean) is + begin + if Item then + W_SSU (Stream, 1); + else + W_SSU (Stream, 0); + end if; + end W_B; + + --------- + -- W_C -- + --------- + + procedure W_C (Stream : not null access RST; Item : Character) is + S : XDR_S_C; + + pragma Assert (C_L = 1); + + begin + -- Use Ada requirements on Character representation clause + + S (1) := SE (Character'Pos (Item)); + + Ada.Streams.Write (Stream.all, S); + end W_C; + + --------- + -- W_F -- + --------- + + procedure W_F (Stream : not null access RST; Item : Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Positive : Boolean; + E : Integer; + F : Float; + S : SEA (1 .. F_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Float'Scaling (F, F_Size + E_Bias - 1); + E := -E_Bias; + else + F := Float'Scaling (Float'Fraction (F), F_Size + 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse F_L - F_Bytes + 1 .. F_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_F; + + --------- + -- W_I -- + --------- + + procedure W_I (Stream : not null access RST; Item : Integer) is + S : XDR_S_I; + U : XDR_U; + + begin + if Optimize_Integers then + S := Integer_To_XDR_S_I (Item); + + else + -- Test sign and apply two complement notation + + U := (if Item < 0 + then XDR_U'Last xor XDR_U (-(Item + 1)) + else XDR_U (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_I; + + ---------- + -- W_LF -- + ---------- + + procedure W_LF (Stream : not null access RST; Item : Long_Float) is + I : constant Precision := Double; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Long_Unsigned; + Positive : Boolean; + E : Integer; + F : Long_Float; + S : SEA (1 .. LF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Long_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Long_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse LF_L - F_Bytes + 1 .. LF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LF; + + ---------- + -- W_LI -- + ---------- + + procedure W_LI (Stream : not null access RST; Item : Long_Integer) is + S : XDR_S_LI; + U : Unsigned; + X : Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); + else + X := Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LI; + + ----------- + -- W_LLF -- + ----------- + + procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is + I : constant Precision := Quadruple; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + HFS : constant Integer := F_Size / 2; + + Exponent : Long_Unsigned; + Fraction_1 : Long_Long_Unsigned; + Fraction_2 : Long_Long_Unsigned; + Positive : Boolean; + E : Integer; + F : Long_Long_Float := Item; + S : SEA (1 .. LLF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Positive := (0.0 <= Item); + if F < 0.0 then + F := -Item; + end if; + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction_1 := 0; + Fraction_2 := 0; + + else + E := Long_Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Long_Long_Float'Scaling (F, E_Bias - 1); + E := -E_Bias; + else + F := Long_Long_Float'Scaling + (Long_Long_Float'Fraction (F), 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + F := Long_Long_Float'Scaling (F, F_Size - HFS); + Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + F := F - Long_Long_Float (Fraction_1); + F := Long_Long_Float'Scaling (F, HFS); + Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + end if; + + -- Store Fraction_1 + + for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop + S (I) := SE (Fraction_1 mod BB); + Fraction_1 := Fraction_1 / BB; + end loop; + + -- Store Fraction_2 + + for I in reverse LLF_L - 6 .. LLF_L loop + S (SEO (I)) := SE (Fraction_2 mod BB); + Fraction_2 := Fraction_2 / BB; + end loop; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLF; + + ----------- + -- W_LLI -- + ----------- + + procedure W_LLI + (Stream : not null access RST; + Item : Long_Long_Integer) + is + S : XDR_S_LLI; + U : Unsigned; + X : Long_Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LLI (Item); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); + else + X := Long_Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLI; + + ----------- + -- W_LLU -- + ----------- + + procedure W_LLU + (Stream : not null access RST; + Item : Long_Long_Unsigned) + is + S : XDR_S_LLU; + U : Unsigned; + X : Long_Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LLU (Item); + + else + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLU; + + ---------- + -- W_LU -- + ---------- + + procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is + S : XDR_S_LU; + U : Unsigned; + X : Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); + + else + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LU; + + ---------- + -- W_SF -- + ---------- + + procedure W_SF (Stream : not null access RST; Item : Short_Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Positive : Boolean; + E : Integer; + F : Short_Float; + S : SEA (1 .. SF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Short_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Short_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Short_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse SF_L - F_Bytes + 1 .. SF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SF; + + ---------- + -- W_SI -- + ---------- + + procedure W_SI (Stream : not null access RST; Item : Short_Integer) is + S : XDR_S_SI; + U : XDR_SU; + + begin + if Optimize_Integers then + S := Short_Integer_To_XDR_S_SI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SU'Last xor XDR_SU (-(Item + 1)) + else XDR_SU (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SI; + + ----------- + -- W_SSI -- + ----------- + + procedure W_SSI + (Stream : not null access RST; + Item : Short_Short_Integer) + is + S : XDR_S_SSI; + U : XDR_SSU; + + begin + if Optimize_Integers then + S := Short_Short_Integer_To_XDR_S_SSI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) + else XDR_SSU (Item)); + + S (1) := SE (U); + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SSI; + + ----------- + -- W_SSU -- + ----------- + + procedure W_SSU + (Stream : not null access RST; + Item : Short_Short_Unsigned) + is + U : constant XDR_SSU := XDR_SSU (Item); + S : XDR_S_SSU; + + begin + S (1) := SE (U); + Ada.Streams.Write (Stream.all, S); + end W_SSU; + + ---------- + -- W_SU -- + ---------- + + procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is + S : XDR_S_SU; + U : XDR_SU := XDR_SU (Item); + + begin + if Optimize_Integers then + S := Short_Unsigned_To_XDR_S_SU (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SU; + + --------- + -- W_U -- + --------- + + procedure W_U (Stream : not null access RST; Item : Unsigned) is + S : XDR_S_U; + U : XDR_U := XDR_U (Item); + + begin + if Optimize_Integers then + S := Unsigned_To_XDR_S_U (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_U; + + ---------- + -- W_WC -- + ---------- + + procedure W_WC (Stream : not null access RST; Item : Wide_Character) is + S : XDR_S_WC; + U : XDR_WC; + + begin + -- Use Ada requirements on Wide_Character representation clause + + U := XDR_WC (Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WC; + + ----------- + -- W_WWC -- + ----------- + + procedure W_WWC + (Stream : not null access RST; Item : Wide_Wide_Character) + is + S : XDR_S_WWC; + U : XDR_WWC; + + begin + -- Use Ada requirements on Wide_Wide_Character representation clause + + U := XDR_WWC (Wide_Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WWC; + + end System.Stream_Attributes; diff -Nrcpad gcc-4.5.2/gcc/ada/s-stratt.ads gcc-4.6.0/gcc/ada/s-stratt.ads *** gcc-4.5.2/gcc/ada/s-stratt.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-stratt.ads Thu Sep 9 12:31:35 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package System.Stream_Attributes is *** 157,166 **** function Block_IO_OK return Boolean; -- Package System.Stream_Attributes has several bodies - the default one ! -- distributed with GNAT, s-strxdr.adb which is based on the XDR standard ! -- and s-stratt.adb for Garlic. All three bodies share the same spec. The ! -- role of this function is to determine whether the current version of ! -- System.Stream_Attributes is able to support block IO. private pragma Inline (I_AD); --- 157,166 ---- function Block_IO_OK return Boolean; -- Package System.Stream_Attributes has several bodies - the default one ! -- distributed with GNAT, and s-stratt-xdr.adb, which is based on the XDR ! -- standard. Both bodies share the same spec. The role of this function is ! -- to indicate whether the current version of System.Stream_Attributes ! -- supports block IO. private pragma Inline (I_AD); diff -Nrcpad gcc-4.5.2/gcc/ada/s-strxdr.adb gcc-4.6.0/gcc/ada/s-strxdr.adb *** gcc-4.5.2/gcc/ada/s-strxdr.adb Mon Nov 30 10:45:39 2009 --- gcc-4.6.0/gcc/ada/s-strxdr.adb Thu Jan 1 00:00:00 1970 *************** *** 1,1891 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT RUN-TIME COMPONENTS -- - -- -- - -- S Y S T E M . S T R E A M _ A T T R I B U T E S -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- - -- -- - -- GARLIC 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. -- - -- -- - -- As a special exception under Section 7 of GPL version 3, you are granted -- - -- additional permissions described in the GCC Runtime Library Exception, -- - -- version 3.1, as published by the Free Software Foundation. -- - -- -- - -- You should have received a copy of the GNU General Public License and -- - -- a copy of the GCC Runtime Library Exception along with this program; -- - -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- - -- . -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This file is an alternate version of s-stratt.adb based on the XDR - -- standard. It is especially useful for exchanging streams between two - -- different systems with different basic type representations and endianness. - - with Ada.IO_Exceptions; - with Ada.Streams; use Ada.Streams; - with Ada.Unchecked_Conversion; - - package body System.Stream_Attributes is - - pragma Suppress (Range_Check); - pragma Suppress (Overflow_Check); - - use UST; - - Data_Error : exception renames Ada.IO_Exceptions.End_Error; - -- Exception raised if insufficient data read (End_Error is mandated by - -- AI95-00132). - - SU : constant := System.Storage_Unit; - -- The code in this body assumes that SU = 8 - - BB : constant := 2 ** SU; -- Byte base - BL : constant := 2 ** SU - 1; -- Byte last - BS : constant := 2 ** (SU - 1); -- Byte sign - - US : constant := Unsigned'Size; -- Unsigned size - UB : constant := (US - 1) / SU + 1; -- Unsigned byte - UL : constant := 2 ** US - 1; -- Unsigned last - - subtype SE is Ada.Streams.Stream_Element; - subtype SEA is Ada.Streams.Stream_Element_Array; - subtype SEO is Ada.Streams.Stream_Element_Offset; - - generic function UC renames Ada.Unchecked_Conversion; - - type Field_Type is - record - E_Size : Integer; -- Exponent bit size - E_Bias : Integer; -- Exponent bias - F_Size : Integer; -- Fraction bit size - E_Last : Integer; -- Max exponent value - F_Mask : SE; -- Mask to apply on first fraction byte - E_Bytes : SEO; -- N. of exponent bytes completely used - F_Bytes : SEO; -- N. of fraction bytes completely used - F_Bits : Integer; -- N. of bits used on first fraction word - end record; - - type Precision is (Single, Double, Quadruple); - - Fields : constant array (Precision) of Field_Type := ( - - -- Single precision - - (E_Size => 8, - E_Bias => 127, - F_Size => 23, - E_Last => 2 ** 8 - 1, - F_Mask => 16#7F#, -- 2 ** 7 - 1, - E_Bytes => 2, - F_Bytes => 3, - F_Bits => 23 mod US), - - -- Double precision - - (E_Size => 11, - E_Bias => 1023, - F_Size => 52, - E_Last => 2 ** 11 - 1, - F_Mask => 16#0F#, -- 2 ** 4 - 1, - E_Bytes => 2, - F_Bytes => 7, - F_Bits => 52 mod US), - - -- Quadruple precision - - (E_Size => 15, - E_Bias => 16383, - F_Size => 112, - E_Last => 2 ** 8 - 1, - F_Mask => 16#FF#, -- 2 ** 8 - 1, - E_Bytes => 2, - F_Bytes => 14, - F_Bits => 112 mod US)); - - -- The representation of all items requires a multiple of four bytes - -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes - -- are read or written to some byte stream such that byte m always - -- precedes byte m+1. If the n bytes needed to contain the data are not - -- a multiple of four, then the n bytes are followed by enough (0 to 3) - -- residual zero bytes, r, to make the total byte count a multiple of 4. - - -- An XDR signed integer is a 32-bit datum that encodes an integer - -- in the range [-2147483648,2147483647]. The integer is represented - -- in two's complement notation. The most and least significant bytes - -- are 0 and 3, respectively. Integers are declared as follows: - - -- (MSB) (LSB) - -- +-------+-------+-------+-------+ - -- |byte 0 |byte 1 |byte 2 |byte 3 | - -- +-------+-------+-------+-------+ - -- <------------32 bits------------> - - SSI_L : constant := 1; - SI_L : constant := 2; - I_L : constant := 4; - LI_L : constant := 8; - LLI_L : constant := 8; - - subtype XDR_S_SSI is SEA (1 .. SSI_L); - subtype XDR_S_SI is SEA (1 .. SI_L); - subtype XDR_S_I is SEA (1 .. I_L); - subtype XDR_S_LI is SEA (1 .. LI_L); - subtype XDR_S_LLI is SEA (1 .. LLI_L); - - function Short_Short_Integer_To_XDR_S_SSI is - new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI); - function XDR_S_SSI_To_Short_Short_Integer is - new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer); - - function Short_Integer_To_XDR_S_SI is - new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI); - function XDR_S_SI_To_Short_Integer is - new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer); - - function Integer_To_XDR_S_I is - new Ada.Unchecked_Conversion (Integer, XDR_S_I); - function XDR_S_I_To_Integer is - new Ada.Unchecked_Conversion (XDR_S_I, Integer); - - function Long_Long_Integer_To_XDR_S_LI is - new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI); - function XDR_S_LI_To_Long_Long_Integer is - new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer); - - function Long_Long_Integer_To_XDR_S_LLI is - new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI); - function XDR_S_LLI_To_Long_Long_Integer is - new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer); - - -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative - -- integer in the range [0,4294967295]. It is represented by an unsigned - -- binary number whose most and least significant bytes are 0 and 3, - -- respectively. An unsigned integer is declared as follows: - - -- (MSB) (LSB) - -- +-------+-------+-------+-------+ - -- |byte 0 |byte 1 |byte 2 |byte 3 | - -- +-------+-------+-------+-------+ - -- <------------32 bits------------> - - SSU_L : constant := 1; - SU_L : constant := 2; - U_L : constant := 4; - LU_L : constant := 8; - LLU_L : constant := 8; - - subtype XDR_S_SSU is SEA (1 .. SSU_L); - subtype XDR_S_SU is SEA (1 .. SU_L); - subtype XDR_S_U is SEA (1 .. U_L); - subtype XDR_S_LU is SEA (1 .. LU_L); - subtype XDR_S_LLU is SEA (1 .. LLU_L); - - type XDR_SSU is mod BB ** SSU_L; - type XDR_SU is mod BB ** SU_L; - type XDR_U is mod BB ** U_L; - - function Short_Unsigned_To_XDR_S_SU is - new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU); - function XDR_S_SU_To_Short_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned); - - function Unsigned_To_XDR_S_U is - new Ada.Unchecked_Conversion (Unsigned, XDR_S_U); - function XDR_S_U_To_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_U, Unsigned); - - function Long_Long_Unsigned_To_XDR_S_LU is - new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU); - function XDR_S_LU_To_Long_Long_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned); - - function Long_Long_Unsigned_To_XDR_S_LLU is - new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU); - function XDR_S_LLU_To_Long_Long_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned); - - -- The standard defines the floating-point data type "float" (32 bits - -- or 4 bytes). The encoding used is the IEEE standard for normalized - -- single-precision floating-point numbers. - - -- The standard defines the encoding used for the double-precision - -- floating-point data type "double" (64 bits or 8 bytes). The encoding - -- used is the IEEE standard for normalized double-precision floating-point - -- numbers. - - SF_L : constant := 4; -- Single precision - F_L : constant := 4; -- Single precision - LF_L : constant := 8; -- Double precision - LLF_L : constant := 16; -- Quadruple precision - - TM_L : constant := 8; - subtype XDR_S_TM is SEA (1 .. TM_L); - type XDR_TM is mod BB ** TM_L; - - type XDR_SA is mod 2 ** Standard'Address_Size; - function To_XDR_SA is new UC (System.Address, XDR_SA); - function To_XDR_SA is new UC (XDR_SA, System.Address); - - -- Enumerations have the same representation as signed integers. - -- Enumerations are handy for describing subsets of the integers. - - -- Booleans are important enough and occur frequently enough to warrant - -- their own explicit type in the standard. Booleans are declared as - -- an enumeration, with FALSE = 0 and TRUE = 1. - - -- The standard defines a string of n (numbered 0 through n-1) ASCII - -- bytes to be the number n encoded as an unsigned integer (as described - -- above), and followed by the n bytes of the string. Byte m of the string - -- always precedes byte m+1 of the string, and byte 0 of the string always - -- follows the string's length. If n is not a multiple of four, then the - -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make - -- the total byte count a multiple of four. - - -- To fit with XDR string, do not consider character as an enumeration - -- type. - - C_L : constant := 1; - subtype XDR_S_C is SEA (1 .. C_L); - - -- Consider Wide_Character as an enumeration type - - WC_L : constant := 4; - subtype XDR_S_WC is SEA (1 .. WC_L); - type XDR_WC is mod BB ** WC_L; - - -- Consider Wide_Wide_Character as an enumeration type - - WWC_L : constant := 8; - subtype XDR_S_WWC is SEA (1 .. WWC_L); - type XDR_WWC is mod BB ** WWC_L; - - -- Optimization: if we already have the correct Bit_Order, then some - -- computations can be avoided since the source and the target will be - -- identical anyway. They will be replaced by direct unchecked - -- conversions. - - Optimize_Integers : constant Boolean := - Default_Bit_Order = High_Order_First; - - ----------------- - -- Block_IO_OK -- - ----------------- - - function Block_IO_OK return Boolean is - begin - return False; - end Block_IO_OK; - - ---------- - -- I_AD -- - ---------- - - function I_AD (Stream : not null access RST) return Fat_Pointer is - FP : Fat_Pointer; - - begin - FP.P1 := I_AS (Stream).P1; - FP.P2 := I_AS (Stream).P1; - - return FP; - end I_AD; - - ---------- - -- I_AS -- - ---------- - - function I_AS (Stream : not null access RST) return Thin_Pointer is - S : XDR_S_TM; - L : SEO; - U : XDR_TM := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_TM (S (N)); - end loop; - - return (P1 => To_XDR_SA (XDR_SA (U))); - end if; - end I_AS; - - --------- - -- I_B -- - --------- - - function I_B (Stream : not null access RST) return Boolean is - begin - case I_SSU (Stream) is - when 0 => return False; - when 1 => return True; - when others => raise Data_Error; - end case; - end I_B; - - --------- - -- I_C -- - --------- - - function I_C (Stream : not null access RST) return Character is - S : XDR_S_C; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - -- Use Ada requirements on Character representation clause - - return Character'Val (S (1)); - end if; - end I_C; - - --------- - -- I_F -- - --------- - - function I_F (Stream : not null access RST) return Float is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Positive : Boolean; - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Result : Float; - S : SEA (1 .. F_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask); - for N in F_L + 2 - F_Bytes .. F_L loop - Fraction := Fraction * BB + Long_Unsigned (S (N)); - end loop; - Result := Float'Scaling (Float (Fraction), -F_Size); - - if BS <= S (1) then - Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Positive then - Result := -Result; - end if; - - return Result; - end I_F; - - --------- - -- I_I -- - --------- - - function I_I (Stream : not null access RST) return Integer is - S : XDR_S_I; - L : SEO; - U : XDR_U := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_I_To_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_U (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Integer (U); - - else - return Integer (-((XDR_U'Last xor U) + 1)); - end if; - end if; - end I_I; - - ---------- - -- I_LF -- - ---------- - - function I_LF (Stream : not null access RST) return Long_Float is - I : constant Precision := Double; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Positive : Boolean; - Exponent : Long_Unsigned; - Fraction : Long_Long_Unsigned; - Result : Long_Float; - S : SEA (1 .. LF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask); - for N in LF_L + 2 - F_Bytes .. LF_L loop - Fraction := Fraction * BB + Long_Long_Unsigned (S (N)); - end loop; - - Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size); - - if BS <= S (1) then - Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Long_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Long_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Positive then - Result := -Result; - end if; - - return Result; - end I_LF; - - ---------- - -- I_LI -- - ---------- - - function I_LI (Stream : not null access RST) return Long_Integer is - S : XDR_S_LI; - L : SEO; - U : Unsigned := 0; - X : Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S)); - - else - - -- Compute using machine unsigned - -- rather than long_long_unsigned - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Unsigned (U); - U := 0; - end if; - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Long_Integer (X); - else - return Long_Integer (-((Long_Unsigned'Last xor X) + 1)); - end if; - - end if; - end I_LI; - - ----------- - -- I_LLF -- - ----------- - - function I_LLF (Stream : not null access RST) return Long_Long_Float is - I : constant Precision := Quadruple; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Positive : Boolean; - Exponent : Long_Unsigned; - Fraction_1 : Long_Long_Unsigned := 0; - Fraction_2 : Long_Long_Unsigned := 0; - Result : Long_Long_Float; - HF : constant Natural := F_Size / 2; - S : SEA (1 .. LLF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop - Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I)); - end loop; - - for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop - Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I)); - end loop; - - Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF); - Result := Long_Long_Float (Fraction_1) + Result; - Result := Long_Long_Float'Scaling (Result, HF - F_Size); - - if BS <= S (1) then - Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction_1 = 0 and then Fraction_2 = 0 then - null; - - -- Denormalized float - - else - Result := Long_Long_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Long_Long_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Positive then - Result := -Result; - end if; - - return Result; - end I_LLF; - - ----------- - -- I_LLI -- - ----------- - - function I_LLI (Stream : not null access RST) return Long_Long_Integer is - S : XDR_S_LLI; - L : SEO; - U : Unsigned := 0; - X : Long_Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_LLI_To_Long_Long_Integer (S); - - else - -- Compute using machine unsigned for computing - -- rather than long_long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Long_Unsigned (U); - U := 0; - end if; - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Long_Long_Integer (X); - else - return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1)); - end if; - end if; - end I_LLI; - - ----------- - -- I_LLU -- - ----------- - - function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is - S : XDR_S_LLU; - L : SEO; - U : Unsigned := 0; - X : Long_Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_LLU_To_Long_Long_Unsigned (S); - - else - -- Compute using machine unsigned - -- rather than long_long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Long_Unsigned (U); - U := 0; - end if; - end loop; - - return X; - end if; - end I_LLU; - - ---------- - -- I_LU -- - ---------- - - function I_LU (Stream : not null access RST) return Long_Unsigned is - S : XDR_S_LU; - L : SEO; - U : Unsigned := 0; - X : Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); - - else - -- Compute using machine unsigned - -- rather than long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Unsigned (U); - U := 0; - end if; - end loop; - - return X; - end if; - end I_LU; - - ---------- - -- I_SF -- - ---------- - - function I_SF (Stream : not null access RST) return Short_Float is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Positive : Boolean; - Result : Short_Float; - S : SEA (1 .. SF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask); - for N in SF_L + 2 - F_Bytes .. SF_L loop - Fraction := Fraction * BB + Long_Unsigned (S (N)); - end loop; - Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); - - if BS <= S (1) then - Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Short_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Short_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Positive then - Result := -Result; - end if; - - return Result; - end I_SF; - - ---------- - -- I_SI -- - ---------- - - function I_SI (Stream : not null access RST) return Short_Integer is - S : XDR_S_SI; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SI_To_Short_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Integer (U); - else - return Short_Integer (-((XDR_SU'Last xor U) + 1)); - end if; - end if; - end I_SI; - - ----------- - -- I_SSI -- - ----------- - - function I_SSI (Stream : not null access RST) return Short_Short_Integer is - S : XDR_S_SSI; - L : SEO; - U : XDR_SSU; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SSI_To_Short_Short_Integer (S); - - else - U := XDR_SSU (S (1)); - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Short_Integer (U); - else - return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); - end if; - end if; - end I_SSI; - - ----------- - -- I_SSU -- - ----------- - - function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is - S : XDR_S_SSU; - L : SEO; - U : XDR_SSU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - U := XDR_SSU (S (1)); - return Short_Short_Unsigned (U); - end if; - end I_SSU; - - ---------- - -- I_SU -- - ---------- - - function I_SU (Stream : not null access RST) return Short_Unsigned is - S : XDR_S_SU; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SU_To_Short_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - return Short_Unsigned (U); - end if; - end I_SU; - - --------- - -- I_U -- - --------- - - function I_U (Stream : not null access RST) return Unsigned is - S : XDR_S_U; - L : SEO; - U : XDR_U := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_U_To_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_U (S (N)); - end loop; - - return Unsigned (U); - end if; - end I_U; - - ---------- - -- I_WC -- - ---------- - - function I_WC (Stream : not null access RST) return Wide_Character is - S : XDR_S_WC; - L : SEO; - U : XDR_WC := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_WC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Character representation clause - - return Wide_Character'Val (U); - end if; - end I_WC; - - ----------- - -- I_WWC -- - ----------- - - function I_WWC (Stream : not null access RST) return Wide_Wide_Character is - S : XDR_S_WWC; - L : SEO; - U : XDR_WWC := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_WWC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Wide_Character representation clause - - return Wide_Wide_Character'Val (U); - end if; - end I_WWC; - - ---------- - -- W_AD -- - ---------- - - procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is - S : XDR_S_TM; - U : XDR_TM; - - begin - U := XDR_TM (To_XDR_SA (Item.P1)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - U := XDR_TM (To_XDR_SA (Item.P2)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AD; - - ---------- - -- W_AS -- - ---------- - - procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is - S : XDR_S_TM; - U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); - - begin - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AS; - - --------- - -- W_B -- - --------- - - procedure W_B (Stream : not null access RST; Item : Boolean) is - begin - if Item then - W_SSU (Stream, 1); - else - W_SSU (Stream, 0); - end if; - end W_B; - - --------- - -- W_C -- - --------- - - procedure W_C (Stream : not null access RST; Item : Character) is - S : XDR_S_C; - - pragma Assert (C_L = 1); - - begin - -- Use Ada requirements on Character representation clause - - S (1) := SE (Character'Pos (Item)); - - Ada.Streams.Write (Stream.all, S); - end W_C; - - --------- - -- W_F -- - --------- - - procedure W_F (Stream : not null access RST; Item : Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Positive : Boolean; - E : Integer; - F : Float; - S : SEA (1 .. F_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Float'Scaling (F, F_Size + E_Bias - 1); - E := -E_Bias; - else - F := Float'Scaling (Float'Fraction (F), F_Size + 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse F_L - F_Bytes + 1 .. F_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_F; - - --------- - -- W_I -- - --------- - - procedure W_I (Stream : not null access RST; Item : Integer) is - S : XDR_S_I; - U : XDR_U; - - begin - if Optimize_Integers then - S := Integer_To_XDR_S_I (Item); - - else - -- Test sign and apply two complement notation - - U := (if Item < 0 - then XDR_U'Last xor XDR_U (-(Item + 1)) - else XDR_U (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_I; - - ---------- - -- W_LF -- - ---------- - - procedure W_LF (Stream : not null access RST; Item : Long_Float) is - I : constant Precision := Double; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Long_Unsigned; - Positive : Boolean; - E : Integer; - F : Long_Float; - S : SEA (1 .. LF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Long_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Long_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse LF_L - F_Bytes + 1 .. LF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LF; - - ---------- - -- W_LI -- - ---------- - - procedure W_LI (Stream : not null access RST; Item : Long_Integer) is - S : XDR_S_LI; - U : Unsigned; - X : Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); - else - X := Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LI; - - ----------- - -- W_LLF -- - ----------- - - procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is - I : constant Precision := Quadruple; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - HFS : constant Integer := F_Size / 2; - - Exponent : Long_Unsigned; - Fraction_1 : Long_Long_Unsigned; - Fraction_2 : Long_Long_Unsigned; - Positive : Boolean; - E : Integer; - F : Long_Long_Float := Item; - S : SEA (1 .. LLF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Positive := (0.0 <= Item); - if F < 0.0 then - F := -Item; - end if; - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction_1 := 0; - Fraction_2 := 0; - - else - E := Long_Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Long_Long_Float'Scaling (F, E_Bias - 1); - E := -E_Bias; - else - F := Long_Long_Float'Scaling - (Long_Long_Float'Fraction (F), 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - F := Long_Long_Float'Scaling (F, F_Size - HFS); - Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - F := Long_Long_Float (F - Long_Long_Float (Fraction_1)); - F := Long_Long_Float'Scaling (F, HFS); - Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - end if; - - -- Store Fraction_1 - - for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop - S (I) := SE (Fraction_1 mod BB); - Fraction_1 := Fraction_1 / BB; - end loop; - - -- Store Fraction_2 - - for I in reverse LLF_L - 6 .. LLF_L loop - S (SEO (I)) := SE (Fraction_2 mod BB); - Fraction_2 := Fraction_2 / BB; - end loop; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLF; - - ----------- - -- W_LLI -- - ----------- - - procedure W_LLI - (Stream : not null access RST; - Item : Long_Long_Integer) - is - S : XDR_S_LLI; - U : Unsigned; - X : Long_Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LLI (Item); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); - else - X := Long_Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLI; - - ----------- - -- W_LLU -- - ----------- - - procedure W_LLU - (Stream : not null access RST; - Item : Long_Long_Unsigned) - is - S : XDR_S_LLU; - U : Unsigned; - X : Long_Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LLU (Item); - - else - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLU; - - ---------- - -- W_LU -- - ---------- - - procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is - S : XDR_S_LU; - U : Unsigned; - X : Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); - - else - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LU; - - ---------- - -- W_SF -- - ---------- - - procedure W_SF (Stream : not null access RST; Item : Short_Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Positive : Boolean; - E : Integer; - F : Short_Float; - S : SEA (1 .. SF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Short_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Short_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Short_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse SF_L - F_Bytes + 1 .. SF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SF; - - ---------- - -- W_SI -- - ---------- - - procedure W_SI (Stream : not null access RST; Item : Short_Integer) is - S : XDR_S_SI; - U : XDR_SU; - - begin - if Optimize_Integers then - S := Short_Integer_To_XDR_S_SI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SU'Last xor XDR_SU (-(Item + 1)) - else XDR_SU (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SI; - - ----------- - -- W_SSI -- - ----------- - - procedure W_SSI - (Stream : not null access RST; - Item : Short_Short_Integer) - is - S : XDR_S_SSI; - U : XDR_SSU; - - begin - if Optimize_Integers then - S := Short_Short_Integer_To_XDR_S_SSI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) - else XDR_SSU (Item)); - - S (1) := SE (U); - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SSI; - - ----------- - -- W_SSU -- - ----------- - - procedure W_SSU - (Stream : not null access RST; - Item : Short_Short_Unsigned) - is - U : constant XDR_SSU := XDR_SSU (Item); - S : XDR_S_SSU; - - begin - S (1) := SE (U); - Ada.Streams.Write (Stream.all, S); - end W_SSU; - - ---------- - -- W_SU -- - ---------- - - procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is - S : XDR_S_SU; - U : XDR_SU := XDR_SU (Item); - - begin - if Optimize_Integers then - S := Short_Unsigned_To_XDR_S_SU (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SU; - - --------- - -- W_U -- - --------- - - procedure W_U (Stream : not null access RST; Item : Unsigned) is - S : XDR_S_U; - U : XDR_U := XDR_U (Item); - - begin - if Optimize_Integers then - S := Unsigned_To_XDR_S_U (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_U; - - ---------- - -- W_WC -- - ---------- - - procedure W_WC (Stream : not null access RST; Item : Wide_Character) is - S : XDR_S_WC; - U : XDR_WC; - - begin - -- Use Ada requirements on Wide_Character representation clause - - U := XDR_WC (Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WC; - - ----------- - -- W_WWC -- - ----------- - - procedure W_WWC - (Stream : not null access RST; Item : Wide_Wide_Character) - is - S : XDR_S_WWC; - U : XDR_WWC; - - begin - -- Use Ada requirements on Wide_Wide_Character representation clause - - U := XDR_WWC (Wide_Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WWC; - - end System.Stream_Attributes; --- 0 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/s-ststop.adb gcc-4.6.0/gcc/ada/s-ststop.adb *** gcc-4.5.2/gcc/ada/s-ststop.adb Fri Apr 17 13:07:12 2009 --- gcc-4.6.0/gcc/ada/s-ststop.adb Thu Oct 21 10:14:06 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2008-2010, 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- -- *************** package body System.Strings.Stream_Ops i *** 216,222 **** Rem_Size : constant Natural := Block_Size mod Default_Block_Size; ! -- String indices Low : Positive := Item'First; High : Positive := Low + C_In_Default_Block - 1; --- 216,222 ---- Rem_Size : constant Natural := Block_Size mod Default_Block_Size; ! -- String indexes Low : Positive := Item'First; High : Positive := Low + C_In_Default_Block - 1; *************** package body System.Strings.Stream_Ops i *** 338,344 **** Rem_Size : constant Natural := Block_Size mod Default_Block_Size; ! -- String indices Low : Positive := Item'First; High : Positive := Low + C_In_Default_Block - 1; --- 338,344 ---- Rem_Size : constant Natural := Block_Size mod Default_Block_Size; ! -- String indexes Low : Positive := Item'First; High : Positive := Low + C_In_Default_Block - 1; diff -Nrcpad gcc-4.5.2/gcc/ada/s-stusta.adb gcc-4.6.0/gcc/ada/s-stusta.adb *** gcc-4.5.2/gcc/ada/s-stusta.adb Wed Apr 29 10:50:37 2009 --- gcc-4.6.0/gcc/ada/s-stusta.adb Mon Dec 20 07:26:57 2010 *************** package body System.Stack_Usage.Tasking *** 51,57 **** -- System.Stack_Usage.Result_Array procedure Compute_Current_Task; ! -- Compute the stack usage for a given task and saves it in the a precise -- slot in System.Stack_Usage.Result_Array; procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean); --- 51,57 ---- -- System.Stack_Usage.Result_Array procedure Compute_Current_Task; ! -- Compute the stack usage for a given task and saves it in the precise -- slot in System.Stack_Usage.Result_Array; procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean); diff -Nrcpad gcc-4.5.2/gcc/ada/s-taenca.adb gcc-4.6.0/gcc/ada/s-taenca.adb *** gcc-4.5.2/gcc/ada/s-taenca.adb Mon Nov 30 10:45:39 2009 --- gcc-4.6.0/gcc/ada/s-taenca.adb Thu Sep 9 13:53:19 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Tasking.Entry_Calls *** 590,595 **** --- 590,602 ---- Entry_Call.Cancellation_Attempted := True; + -- Reset Entry_Call.State so that the call is marked as cancelled + -- by Check_Pending_Actions_For_Entry_Call below. + + if Entry_Call.State < Was_Abortable then + Entry_Call.State := Now_Abortable; + end if; + if Self_Id.Pending_ATC_Level >= Entry_Call.Level then Self_Id.Pending_ATC_Level := Entry_Call.Level - 1; end if; diff -Nrcpad gcc-4.5.2/gcc/ada/s-taprop-linux.adb gcc-4.6.0/gcc/ada/s-taprop-linux.adb *** gcc-4.5.2/gcc/ada/s-taprop-linux.adb Mon Nov 30 10:45:39 2009 --- gcc-4.6.0/gcc/ada/s-taprop-linux.adb Mon Oct 18 13:54:23 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** with System.Tasking.Debug; *** 48,53 **** --- 48,54 ---- with System.Interrupt_Management; with System.OS_Primitives; with System.Stack_Checking.Operations; + with System.Multiprocessors; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization *************** package body System.Task_Primitives.Oper *** 717,723 **** Specific.Set (Self_ID); ! if Use_Alternate_Stack then declare Stack : aliased stack_t; Result : Interfaces.C.int; --- 718,726 ---- Specific.Set (Self_ID); ! if Use_Alternate_Stack ! and then Self_ID.Common.Task_Alternate_Stack /= Null_Address ! then declare Stack : aliased stack_t; Result : Interfaces.C.int; *************** package body System.Task_Primitives.Oper *** 817,822 **** --- 820,827 ---- Adjusted_Stack_Size : Interfaces.C.size_t; Result : Interfaces.C.int; + use type System.Multiprocessors.CPU_Range; + begin Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); *************** package body System.Task_Primitives.Oper *** 839,844 **** --- 844,889 ---- (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); + -- Set the required attributes for the creation of the thread + + -- Note: Previously, we called pthread_setaffinity_np (after thread + -- creation but before thread activation) to set the affinity but it was + -- not behaving as expected. Setting the required attributes for the + -- creation of the thread works correctly and it is more appropriate. + + -- Do nothing if required support not provided by the operating system + + if pthread_attr_setaffinity_np'Address = System.Null_Address then + null; + + -- Support is available + + elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then + declare + CPU_Set : aliased cpu_set_t := (bits => (others => False)); + begin + CPU_Set.bits (Integer (T.Common.Base_CPU)) := True; + Result := + pthread_attr_setaffinity_np + (Attributes'Access, + CPU_SETSIZE / 8, + CPU_Set'Access); + pragma Assert (Result = 0); + end; + + -- Handle Task_Info + + elsif T.Common.Task_Info /= null + and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU + then + Result := + pthread_attr_setaffinity_np + (Attributes'Access, + CPU_SETSIZE / 8, + T.Common.Task_Info.CPU_Affinity'Access); + pragma Assert (Result = 0); + end if; + -- Since the initial signal mask of a thread is inherited from the -- creator, and the Environment task has all its signals masked, we -- do not need to manipulate caller's signal mask at this point. *************** package body System.Task_Primitives.Oper *** 861,879 **** Succeeded := True; - -- Handle Task_Info - - if T.Common.Task_Info /= null then - if T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU then - Result := - pthread_setaffinity_np - (T.Common.LL.Thread, - CPU_SETSIZE / 8, - T.Common.Task_Info.CPU_Affinity'Access); - pragma Assert (Result = 0); - end if; - end if; - Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result = 0); --- 906,911 ---- *************** package body System.Task_Primitives.Oper *** 1236,1241 **** --- 1268,1275 ---- -- 's' Interrupt_State pragma set state to System (use "default" -- system handler) + use type System.Multiprocessors.CPU_Range; + begin Environment_Task_Id := Environment_Task; *************** package body System.Task_Primitives.Oper *** 1296,1301 **** --- 1330,1354 ---- pragma Assert (Result = 0); Abort_Handler_Installed := True; end if; + + -- pragma CPU for the environment task + + if pthread_setaffinity_np'Address /= System.Null_Address + and then Environment_Task.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + declare + CPU_Set : aliased cpu_set_t := (bits => (others => False)); + begin + CPU_Set.bits (Integer (Environment_Task.Common.Base_CPU)) := True; + Result := + pthread_setaffinity_np + (Environment_Task.Common.LL.Thread, + CPU_SETSIZE / 8, + CPU_Set'Access); + pragma Assert (Result = 0); + end; + end if; end Initialize; end System.Task_Primitives.Operations; diff -Nrcpad gcc-4.5.2/gcc/ada/s-taprop-mingw.adb gcc-4.6.0/gcc/ada/s-taprop-mingw.adb *** gcc-4.5.2/gcc/ada/s-taprop-mingw.adb Mon Nov 30 10:28:23 2009 --- gcc-4.6.0/gcc/ada/s-taprop-mingw.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** with Ada.Unchecked_Deallocation; *** 43,48 **** --- 43,49 ---- with Interfaces.C; with Interfaces.C.Strings; + with System.Multiprocessors; with System.Tasking.Debug; with System.OS_Primitives; with System.Task_Info; *************** package body System.Task_Primitives.Oper *** 794,799 **** --- 795,803 ---- pragma Import (C, Init_Float, "__gnat_init_float"); -- Properly initializes the FPU for x86 systems + procedure Get_Stack_Bounds (Base : Address; Limit : Address); + pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds"); + -- Get stack boundaries begin Specific.Set (Self_ID); Init_Float; *************** package body System.Task_Primitives.Oper *** 806,811 **** --- 810,819 ---- end if; Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; + + Get_Stack_Bounds + (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address, + Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address); end Enter_Task; -------------- *************** package body System.Task_Primitives.Oper *** 883,888 **** --- 891,898 ---- Result : DWORD; Entry_Point : PTHREAD_START_ROUTINE; + use type System.Multiprocessors.CPU_Range; + begin pTaskParameter := To_Address (T); *************** package body System.Task_Primitives.Oper *** 918,923 **** --- 928,942 ---- T.Common.LL.Thread := hTask; + -- Note: it would be useful to initialize Thread_Id right away to avoid + -- a race condition in gdb where Thread_ID may not have the right value + -- yet, but GetThreadId is a Vista specific API, not available under XP: + -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the + -- field to 0 to avoid having a random value. Thread_Id is initialized + -- in Enter_Task anyway. + + T.Common.LL.Thread_Id := 0; + -- Step 3: set its priority (child has inherited priority from parent) Set_Priority (T, Priority); *************** package body System.Task_Primitives.Oper *** 927,948 **** or else Get_Policy (Priority) = 'F' then -- Here we need Annex D semantics so we disable the NT priority ! -- boost. A priority boost is temporarily given by the system to a ! -- thread when it is taken out of a wait state. SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE); end if; ! -- Step 4: Handle Task_Info ! if T.Common.Task_Info /= null then if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then Result := SetThreadIdealProcessor (hTask, T.Common.Task_Info.CPU); pragma Assert (Result = 1); end if; end if; ! -- Step 5: Now, start it for good: Result := ResumeThread (hTask); pragma Assert (Result = 1); --- 946,976 ---- or else Get_Policy (Priority) = 'F' then -- Here we need Annex D semantics so we disable the NT priority ! -- boost. A priority boost is temporarily given by the system to ! -- a thread when it is taken out of a wait state. SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE); end if; ! -- Step 4: Handle pragma CPU and Task_Info ! if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then ! ! -- The CPU numbering in pragma CPU starts at 1 while the subprogram ! -- to set the affinity starts at 0, therefore we must subtract 1. ! ! Result := SetThreadIdealProcessor ! (hTask, ProcessorId (T.Common.Base_CPU) - 1); ! pragma Assert (Result = 1); ! ! elsif T.Common.Task_Info /= null then if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then Result := SetThreadIdealProcessor (hTask, T.Common.Task_Info.CPU); pragma Assert (Result = 1); end if; end if; ! -- Step 5: Now, start it for good Result := ResumeThread (hTask); pragma Assert (Result = 1); *************** package body System.Task_Primitives.Oper *** 1046,1051 **** --- 1074,1083 ---- Discard : BOOL; pragma Unreferenced (Discard); + Result : DWORD; + + use type System.Multiprocessors.CPU_Range; + begin Environment_Task_Id := Environment_Task; OS_Primitives.Initialize; *************** package body System.Task_Primitives.Oper *** 1076,1081 **** --- 1108,1128 ---- Environment_Task.Known_Tasks_Index := Known_Tasks'First; Enter_Task (Environment_Task); + + -- pragma CPU for the environment task + + if Environment_Task.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must subtract 1. + + Result := + SetThreadIdealProcessor + (Environment_Task.Common.LL.Thread, + ProcessorId (Environment_Task.Common.Base_CPU) - 1); + pragma Assert (Result = 1); + end if; end Initialize; --------------------- *************** package body System.Task_Primitives.Oper *** 1122,1127 **** --- 1169,1175 ---- procedure Finalize (S : in out Suspension_Object) is Result : BOOL; + begin -- Destroy internal mutex *************** package body System.Task_Primitives.Oper *** 1200,1205 **** --- 1248,1254 ---- procedure Suspend_Until_True (S : in out Suspension_Object) is Result : DWORD; Result_Bool : BOOL; + begin SSL.Abort_Defer.all; diff -Nrcpad gcc-4.5.2/gcc/ada/s-taprop-solaris.adb gcc-4.6.0/gcc/ada/s-taprop-solaris.adb *** gcc-4.5.2/gcc/ada/s-taprop-solaris.adb Mon Nov 30 10:45:39 2009 --- gcc-4.6.0/gcc/ada/s-taprop-solaris.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** with Ada.Unchecked_Deallocation; *** 42,47 **** --- 42,48 ---- with Interfaces.C; + with System.Multiprocessors; with System.Tasking.Debug; with System.Interrupt_Management; with System.OS_Primitives; *************** package body System.Task_Primitives.Oper *** 866,877 **** Last_Proc : processorid_t; -- Last processor # use System.Task_Info; begin Self_ID.Common.LL.Thread := thr_self; Self_ID.Common.LL.LWP := lwp_self; ! if Self_ID.Common.Task_Info /= null then if Self_ID.Common.Task_Info.New_LWP and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED then --- 867,896 ---- Last_Proc : processorid_t; -- Last processor # use System.Task_Info; + use type System.Multiprocessors.CPU_Range; + begin Self_ID.Common.LL.Thread := thr_self; Self_ID.Common.LL.LWP := lwp_self; ! -- pragma CPU ! ! if Self_ID.Common.Base_CPU /= ! System.Multiprocessors.Not_A_Specific_CPU ! then ! -- The CPU numbering in pragma CPU starts at 1 while the subprogram ! -- to set the affinity starts at 0, therefore we must subtract 1. ! ! Result := ! processor_bind ! (P_LWPID, P_MYID, processorid_t (Self_ID.Common.Base_CPU) - 1, ! null); ! pragma Assert (Result = 0); ! ! -- Task_Info ! ! elsif Self_ID.Common.Task_Info /= null then if Self_ID.Common.Task_Info.New_LWP and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED then diff -Nrcpad gcc-4.5.2/gcc/ada/s-taprop-vxworks.adb gcc-4.6.0/gcc/ada/s-taprop-vxworks.adb *** gcc-4.5.2/gcc/ada/s-taprop-vxworks.adb Mon Nov 30 10:45:39 2009 --- gcc-4.6.0/gcc/ada/s-taprop-vxworks.adb Mon Oct 18 10:27:48 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** with Ada.Unchecked_Deallocation; *** 43,48 **** --- 43,49 ---- with Interfaces.C; + with System.Multiprocessors; with System.Tasking.Debug; with System.Interrupt_Management; *************** package body System.Task_Primitives.Oper *** 99,108 **** Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - function Get_Policy (Prio : System.Any_Priority) return Character; - pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); - -- Get priority specific dispatching policy - Mutex_Protocol : Priority_Type; Foreign_Task_Elaborated : aliased Boolean := True; --- 100,105 ---- *************** package body System.Task_Primitives.Oper *** 167,172 **** --- 164,173 ---- procedure Install_Signal_Handlers; -- Install the default signal handlers for the current task + function Is_Task_Context return Boolean; + -- This function returns True if the current execution is in the context + -- of a task, and False if it is an interrupt context. + function To_Address is new Ada.Unchecked_Conversion (Task_Id, System.Address); *************** package body System.Task_Primitives.Oper *** 734,753 **** -- Set_Priority -- ------------------ - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for each - -- priority. Note that we assume that we are on a single processor with - -- run-till-blocked scheduling. - procedure Set_Priority (T : Task_Id; Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is ! Array_Item : Integer; Result : int; begin --- 735,747 ---- -- Set_Priority -- ------------------ procedure Set_Priority (T : Task_Id; Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is ! pragma Unreferenced (Loss_Of_Inheritance); ! Result : int; begin *************** package body System.Task_Primitives.Oper *** 756,788 **** (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); ! if (Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F') ! and then Loss_Of_Inheritance ! and then Prio < T.Common.Current_Priority ! then ! -- Annex D requirement (RM D.2.2(9)): ! ! -- If the task drops its priority due to the loss of inherited ! -- priority, it is added at the head of the ready queue for its ! -- new active priority. ! ! Array_Item := Prio_Array (T.Common.Base_Priority) + 1; ! Prio_Array (T.Common.Base_Priority) := Array_Item; ! ! loop ! -- Give some processes a chance to arrive ! ! taskDelay (0); ! ! -- Then wait for our turn to proceed ! ! exit when Array_Item = Prio_Array (T.Common.Base_Priority) ! or else Prio_Array (T.Common.Base_Priority) = 1; ! end loop; ! Prio_Array (T.Common.Base_Priority) := ! Prio_Array (T.Common.Base_Priority) - 1; ! end if; T.Common.Current_Priority := Prio; end Set_Priority; --- 750,765 ---- (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); ! -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of ! -- the priority queue instead of the head. This is not the behavior ! -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable ! -- variation (RM 1.1.3(6)), given this is the built-in behavior of the ! -- operating system. VxWorks versions starting from 6.7 implement the ! -- required Annex D semantics. ! -- In older versions we attempted to better approximate the Annex D ! -- required behavior, but this simulation was not entirely accurate, ! -- and it seems better to live with the standard VxWorks semantics. T.Common.Current_Priority := Prio; end Set_Priority; *************** package body System.Task_Primitives.Oper *** 892,900 **** Succeeded : out Boolean) is Adjusted_Stack_Size : size_t; ! Result : int; use System.Task_Info; begin -- Ask for four extra bytes of stack space so that the ATCB pointer can --- 869,878 ---- Succeeded : out Boolean) is Adjusted_Stack_Size : size_t; ! Result : int := 0; use System.Task_Info; + use type System.Multiprocessors.CPU_Range; begin -- Ask for four extra bytes of stack space so that the ATCB pointer can *************** package body System.Task_Primitives.Oper *** 960,973 **** -- Set processor affinity ! if T.Common.Task_Info /= Unspecified_Task_Info then Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); ! if Result = -1 then ! taskDelete (T.Common.LL.Thread); ! T.Common.LL.Thread := -1; ! end if; end if; if T.Common.LL.Thread = -1 then --- 938,955 ---- -- Set processor affinity ! if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then ! Result := ! taskCpuAffinitySet (T.Common.LL.Thread, int (T.Common.Base_CPU)); ! ! elsif T.Common.Task_Info /= Unspecified_Task_Info then Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); + end if; ! if Result = -1 then ! taskDelete (T.Common.LL.Thread); ! T.Common.LL.Thread := -1; end if; if T.Common.LL.Thread = -1 then *************** package body System.Task_Primitives.Oper *** 1123,1129 **** Result : STATUS; begin ! SSL.Abort_Defer.all; Result := semTake (S.L, WAIT_FOREVER); pragma Assert (Result = OK); --- 1105,1116 ---- Result : STATUS; begin ! -- Set_True can be called from an interrupt context, in which case ! -- Abort_Defer is undefined. ! ! if Is_Task_Context then ! SSL.Abort_Defer.all; ! end if; Result := semTake (S.L, WAIT_FOREVER); pragma Assert (Result = OK); *************** package body System.Task_Primitives.Oper *** 1146,1152 **** Result := semGive (S.L); pragma Assert (Result = OK); ! SSL.Abort_Undefer.all; end Set_True; ------------------------ --- 1133,1145 ---- Result := semGive (S.L); pragma Assert (Result = OK); ! -- Set_True can be called from an interrupt context, in which case ! -- Abort_Undefer is undefined. ! ! if Is_Task_Context then ! SSL.Abort_Undefer.all; ! end if; ! end Set_True; ------------------------ *************** package body System.Task_Primitives.Oper *** 1344,1349 **** --- 1337,1351 ---- end if; end Continue_Task; + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return System.OS_Interface.Interrupt_Context /= 1; + end Is_Task_Context; + ---------------- -- Initialize -- ---------------- *************** package body System.Task_Primitives.Oper *** 1351,1356 **** --- 1353,1360 ---- procedure Initialize (Environment_Task : Task_Id) is Result : int; + use type System.Multiprocessors.CPU_Range; + begin Environment_Task_Id := Environment_Task; *************** package body System.Task_Primitives.Oper *** 1397,1402 **** --- 1401,1418 ---- Environment_Task.Known_Tasks_Index := Known_Tasks'First; Enter_Task (Environment_Task); + + -- Set processor affinity + + if Environment_Task.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + Result := + taskCpuAffinitySet + (Environment_Task.Common.LL.Thread, + int (Environment_Task.Common.Base_CPU)); + pragma Assert (Result /= -1); + end if; end Initialize; end System.Task_Primitives.Operations; diff -Nrcpad gcc-4.5.2/gcc/ada/s-tarest.adb gcc-4.6.0/gcc/ada/s-tarest.adb *** gcc-4.5.2/gcc/ada/s-tarest.adb Mon Nov 30 10:28:23 2009 --- gcc-4.6.0/gcc/ada/s-tarest.adb Mon Oct 18 10:27:48 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Tasking.Restricted.S *** 458,463 **** --- 458,464 ---- Stack_Address : System.Address; Size : System.Parameters.Size_Type; Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; State : Task_Procedure_Access; Discriminants : System.Address; Elaborated : Access_Boolean; *************** package body System.Tasking.Restricted.S *** 467,472 **** --- 468,474 ---- is Self_ID : constant Task_Id := STPO.Self; Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; Success : Boolean; Len : Integer; *************** package body System.Tasking.Restricted.S *** 481,486 **** --- 483,503 ---- then Self_ID.Common.Base_Priority else System.Any_Priority (Priority)); + if CPU /= Unspecified_CPU + and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) + or else CPU > Integer (System.Multiprocessors.CPU_Range'Last) + or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) + then + raise Tasking_Error with "CPU not in range"; + + -- Normal CPU affinity + else + Base_CPU := + (if CPU = Unspecified_CPU + then Self_ID.Common.Base_CPU + else System.Multiprocessors.CPU_Range (CPU)); + end if; + if Single_Lock then Lock_RTS; end if; *************** package body System.Tasking.Restricted.S *** 492,498 **** Initialize_ATCB (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, ! Task_Info, Size, Created_Task, Success); -- If we do our job right then there should never be any failures, which -- was probably said about the Titanic; so just to be safe, let's retain --- 509,515 ---- Initialize_ATCB (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, ! Base_CPU, Task_Info, Size, Created_Task, Success); -- If we do our job right then there should never be any failures, which -- was probably said about the Titanic; so just to be safe, let's retain diff -Nrcpad gcc-4.5.2/gcc/ada/s-tarest.ads gcc-4.6.0/gcc/ada/s-tarest.ads *** gcc-4.5.2/gcc/ada/s-tarest.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-tarest.ads Mon Oct 18 10:27:48 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.Tasking.Restricted.Stages *** 87,95 **** -- system__tasking__ada_task_control_blockIP (_init._atcb, 0); -- _init._task_id := _init._atcb'unchecked_access; -- create_restricted_task (unspecified_priority, tZ, ! -- unspecified_task_info, task_procedure_access!(tB'address), ! -- _init'address, tE'unchecked_access, _chain, _task_name, _init. ! -- _task_id); -- return; -- end tVIP; --- 87,95 ---- -- system__tasking__ada_task_control_blockIP (_init._atcb, 0); -- _init._task_id := _init._atcb'unchecked_access; -- create_restricted_task (unspecified_priority, tZ, ! -- unspecified_task_info, unspecified_cpu, ! -- task_procedure_access!(tB'address), _init'address, ! -- tE'unchecked_access, _chain, _task_name, _init._task_id); -- return; -- end tVIP; *************** package System.Tasking.Restricted.Stages *** 127,132 **** --- 127,133 ---- Stack_Address : System.Address; Size : System.Parameters.Size_Type; Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; State : Task_Procedure_Access; Discriminants : System.Address; Elaborated : Access_Boolean; *************** package System.Tasking.Restricted.Stages *** 149,154 **** --- 150,160 ---- -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. -- + -- CPU is the task affinity. We pass it as an Integer to avoid an explicit + -- dependency from System.Multiprocessors when not needed. Static range + -- checks are performed when analyzing the pragma, and dynamic ones are + -- performed before setting the affinity at run time. + -- -- State is the compiler generated task's procedure body -- -- Discriminants is a pointer to a limited record whose discriminants are diff -Nrcpad gcc-4.5.2/gcc/ada/s-tasdeb.adb gcc-4.6.0/gcc/ada/s-tasdeb.adb *** gcc-4.5.2/gcc/ada/s-tasdeb.adb Thu Apr 16 09:34:40 2009 --- gcc-4.6.0/gcc/ada/s-tasdeb.adb Thu Jun 17 12:26:10 2010 *************** package body System.Tasking.Debug is *** 362,371 **** ----------- procedure Write (Fd : Integer; S : String; Count : Integer) is ! Discard : Integer; pragma Unreferenced (Discard); begin ! Discard := System.CRTL.write (Fd, S (S'First)'Address, Count); -- Is it really right to ignore write errors here ??? end Write; --- 362,372 ---- ----------- procedure Write (Fd : Integer; S : String; Count : Integer) is ! Discard : System.CRTL.ssize_t; pragma Unreferenced (Discard); begin ! Discard := System.CRTL.write (Fd, S (S'First)'Address, ! System.CRTL.size_t (Count)); -- Is it really right to ignore write errors here ??? end Write; diff -Nrcpad gcc-4.5.2/gcc/ada/s-taskin.adb gcc-4.6.0/gcc/ada/s-taskin.adb *** gcc-4.5.2/gcc/ada/s-taskin.adb Mon Jul 13 08:39:28 2009 --- gcc-4.6.0/gcc/ada/s-taskin.adb Mon Oct 18 10:27:48 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Tasking is *** 98,103 **** --- 98,104 ---- Parent : Task_Id; Elaborated : Access_Boolean; Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; T : Task_Id; *************** package body System.Tasking is *** 119,124 **** --- 120,126 ---- T.Common.Parent := Parent; T.Common.Base_Priority := Base_Priority; + T.Common.Base_CPU := Base_CPU; T.Common.Current_Priority := 0; T.Common.Protected_Action_Nesting := 0; T.Common.Call := null; *************** package body System.Tasking is *** 170,181 **** --- 172,190 ---- -- because we use the value -1 to indicate the default main priority, and -- that is of course not in Priority'range. + Main_CPU : Integer; + pragma Import (C, Main_CPU, "__gl_main_cpu"); + -- Affinity for main task. Note that this is of type Integer, not + -- CPU_Range, because we use the value -1 to indicate the unassigned + -- affinity, and that is of course not in CPU_Range'Range. + Initialized : Boolean := False; -- Used to prevent multiple calls to Initialize procedure Initialize is T : Task_Id; Base_Priority : Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; Success : Boolean; begin *************** package body System.Tasking is *** 192,200 **** then Default_Priority else Priority (Main_Priority)); T := STPO.New_ATCB (0); Initialize_ATCB ! (null, null, Null_Address, Null_Task, null, Base_Priority, Task_Info.Unspecified_Task_Info, 0, T, Success); pragma Assert (Success); --- 201,214 ---- then Default_Priority else Priority (Main_Priority)); + Base_CPU := + (if Main_CPU = Unspecified_CPU + then System.Multiprocessors.Not_A_Specific_CPU + else System.Multiprocessors.CPU_Range (Main_CPU)); + T := STPO.New_ATCB (0); Initialize_ATCB ! (null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU, Task_Info.Unspecified_Task_Info, 0, T, Success); pragma Assert (Success); diff -Nrcpad gcc-4.5.2/gcc/ada/s-taskin.ads gcc-4.6.0/gcc/ada/s-taskin.ads *** gcc-4.5.2/gcc/ada/s-taskin.ads Tue Jul 7 12:42:43 2009 --- gcc-4.6.0/gcc/ada/s-taskin.ads Thu Oct 21 10:14:06 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** with System.Task_Info; *** 42,47 **** --- 42,48 ---- with System.Soft_Links; with System.Task_Primitives; with System.Stack_Usage; + with System.Multiprocessors; package System.Tasking is pragma Preelaborate; *************** package System.Tasking is *** 282,313 **** Cancelled -- the call was asynchronous, and was cancelled ); ! -- Never_Abortable is used for calls that are made in a abort ! -- deferred region (see ARM 9.8(5-11), 9.8 (20)). ! -- Such a call is never abortable. ! -- The Was_ vs. Not_Yet_ distinction is needed to decide whether it ! -- is OK to advance into the abortable part of an async. select stmt. ! -- That is allowed iff the mode is Now_ or Was_. ! -- Done indicates the call has been completed, without cancellation, ! -- or no call has been made yet at this ATC nesting level, ! -- and so aborting the call is no longer an issue. ! -- Completion of the call does not necessarily indicate "success"; ! -- the call may be returning an exception if Exception_To_Raise is ! -- non-null. ! -- Cancelled indicates the call was cancelled, ! -- and so aborting the call is no longer an issue. ! -- The call is on an entry queue unless ! -- State >= Done, in which case it may or may not be still Onqueue. ! -- Please do not modify the order of the values, without checking ! -- all uses of this type. We rely on partial "monotonicity" of ! -- Entry_Call_Record.State to avoid locking when we access this ! -- value for certain tests. In particular: -- 1) Once State >= Done, we can rely that the call has been -- completed. If State >= Done, it will not --- 283,313 ---- Cancelled -- the call was asynchronous, and was cancelled ); + pragma Ordered (Entry_Call_State); ! -- Never_Abortable is used for calls that are made in a abort deferred ! -- region (see ARM 9.8(5-11), 9.8 (20)). Such a call is never abortable. ! -- The Was_ vs. Not_Yet_ distinction is needed to decide whether it is OK ! -- to advance into the abortable part of an async. select stmt. That is ! -- allowed iff the mode is Now_ or Was_. ! -- Done indicates the call has been completed, without cancellation, or no ! -- call has been made yet at this ATC nesting level, and so aborting the ! -- call is no longer an issue. Completion of the call does not necessarily ! -- indicate "success"; the call may be returning an exception if ! -- Exception_To_Raise is non-null. ! -- Cancelled indicates the call was cancelled, and so aborting the call is ! -- no longer an issue. ! -- The call is on an entry queue unless State >= Done, in which case it may ! -- or may not be still Onqueue. ! -- Please do not modify the order of the values, without checking all uses ! -- of this type. We rely on partial "monotonicity" of ! -- Entry_Call_Record.State to avoid locking when we access this value for ! -- certain tests. In particular: -- 1) Once State >= Done, we can rely that the call has been -- completed. If State >= Done, it will not *************** package System.Tasking is *** 465,470 **** --- 465,475 ---- -- -- Protection: Only written by Self, accessed by anyone + Base_CPU : System.Multiprocessors.CPU_Range; + -- Base CPU, only changed via dispatching domains package. + -- + -- Protection: Self.L + Current_Priority : System.Any_Priority; -- Active priority, except that the effects of protected object -- priority ceilings are not reflected. This only reflects explicit *************** package System.Tasking is *** 695,703 **** Independent_Task_Level : constant Master_Level := 2; Library_Task_Level : constant Master_Level := 3; ! ------------------------------ ! -- Task size, priority info -- ! ------------------------------ Unspecified_Priority : constant Integer := System.Priority'First - 1; --- 700,708 ---- Independent_Task_Level : constant Master_Level := 2; Library_Task_Level : constant Master_Level := 3; ! ------------------- ! -- Priority info -- ! ------------------- Unspecified_Priority : constant Integer := System.Priority'First - 1; *************** package System.Tasking is *** 707,712 **** --- 712,724 ---- subtype Rendezvous_Priority is Integer range Priority_Not_Boosted .. System.Any_Priority'Last; + ------------------- + -- Affinity info -- + ------------------- + + Unspecified_CPU : constant := -1; + -- No affinity specified + ------------------------------------ -- Rendezvous related definitions -- ------------------------------------ *************** package System.Tasking is *** 858,864 **** type Direct_Index is range 0 .. Parameters.Default_Attribute_Count; subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last; ! -- Attributes with indices in this range are stored directly in the task -- control block. Such attributes must be Address-sized. Other attributes -- will be held in dynamically allocated records chained off of the task -- control block. --- 870,876 ---- type Direct_Index is range 0 .. Parameters.Default_Attribute_Count; subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last; ! -- Attributes with indexes in this range are stored directly in the task -- control block. Such attributes must be Address-sized. Other attributes -- will be held in dynamically allocated records chained off of the task -- control block. *************** package System.Tasking is *** 1092,1097 **** --- 1104,1110 ---- Parent : Task_Id; Elaborated : Access_Boolean; Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; T : Task_Id; diff -Nrcpad gcc-4.5.2/gcc/ada/s-tasren.adb gcc-4.6.0/gcc/ada/s-tasren.adb *** gcc-4.5.2/gcc/ada/s-tasren.adb Mon Jul 13 08:39:28 2009 --- gcc-4.6.0/gcc/ada/s-tasren.adb Thu Sep 9 10:32:50 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Tasking.Rendezvous i *** 1268,1274 **** if Old_State /= Entry_Call.State and then Entry_Call.State = Now_Abortable ! and then Entry_Call.Mode > Simple_Call and then Entry_Call.Self /= Self_ID -- Asynchronous_Call or Conditional_Call --- 1268,1274 ---- if Old_State /= Entry_Call.State and then Entry_Call.State = Now_Abortable ! and then Entry_Call.Mode /= Simple_Call and then Entry_Call.Self /= Self_ID -- Asynchronous_Call or Conditional_Call diff -Nrcpad gcc-4.5.2/gcc/ada/s-tassta.adb gcc-4.6.0/gcc/ada/s-tassta.adb *** gcc-4.5.2/gcc/ada/s-tassta.adb Mon Nov 30 10:49:27 2009 --- gcc-4.6.0/gcc/ada/s-tassta.adb Mon Oct 18 10:27:48 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Tasking.Stages is *** 473,478 **** --- 473,479 ---- (Priority : Integer; Size : System.Parameters.Size_Type; Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; Relative_Deadline : Ada.Real_Time.Time_Span; Num_Entries : Task_Entry_Index; Master : Master_Level; *************** package body System.Tasking.Stages is *** 489,494 **** --- 490,496 ---- Success : Boolean; Base_Priority : System.Any_Priority; Len : Natural; + Base_CPU : System.Multiprocessors.CPU_Range; pragma Unreferenced (Relative_Deadline); -- EDF scheduling is not supported by any of the target platforms so *************** package body System.Tasking.Stages is *** 522,527 **** --- 524,544 ---- then Self_ID.Common.Base_Priority else System.Any_Priority (Priority)); + if CPU /= Unspecified_CPU + and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) + or else CPU > Integer (System.Multiprocessors.CPU_Range'Last) + or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) + then + raise Tasking_Error with "CPU not in range"; + + -- Normal CPU affinity + else + Base_CPU := + (if CPU = Unspecified_CPU + then Self_ID.Common.Base_CPU + else System.Multiprocessors.CPU_Range (CPU)); + end if; + -- Find parent P of new Task, via master level number P := Self_ID; *************** package body System.Tasking.Stages is *** 570,576 **** end if; Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, ! Base_Priority, Task_Info, Size, T, Success); if not Success then Free (T); --- 587,593 ---- end if; Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, ! Base_Priority, Base_CPU, Task_Info, Size, T, Success); if not Success then Free (T); *************** package body System.Tasking.Stages is *** 1093,1103 **** -- Assume a size of the stack taken at this stage - Overflow_Guard := - (if Size < Small_Stack_Limit - then Small_Overflow_Guard - else Big_Overflow_Guard); - if not Parameters.Sec_Stack_Dynamic then Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address; --- 1110,1115 ---- *************** package body System.Tasking.Stages is *** 1109,1117 **** Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; end if; ! Size := Size - Overflow_Guard; if System.Stack_Usage.Is_Enabled then STPO.Lock_RTS; Initialize_Analyzer (Self_ID.Common.Analyzer, --- 1121,1144 ---- Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; end if; ! -- Set the guard page at the bottom of the stack. The call to unprotect ! -- the page is done in Terminate_Task ! ! Stack_Guard (Self_ID, True); ! ! -- Initialize low-level TCB components, that cannot be initialized by ! -- the creator. Enter_Task sets Self_ID.LL.Thread ! ! Enter_Task (Self_ID); ! ! -- Initialize dynamic stack usage if System.Stack_Usage.Is_Enabled then + Overflow_Guard := + (if Size < Small_Stack_Limit + then Small_Overflow_Guard + else Big_Overflow_Guard); + STPO.Lock_RTS; Initialize_Analyzer (Self_ID.Common.Analyzer, *************** package body System.Tasking.Stages is *** 1119,1140 **** (1 .. Self_ID.Common.Task_Image_Len), Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), ! Size, ! SSE.To_Integer (Bottom_Of_Stack'Address)); STPO.Unlock_RTS; Fill_Stack (Self_ID.Common.Analyzer); end if; - -- Set the guard page at the bottom of the stack. The call to unprotect - -- the page is done in Terminate_Task - - Stack_Guard (Self_ID, True); - - -- Initialize low-level TCB components, that cannot be initialized by - -- the creator. Enter_Task sets Self_ID.LL.Thread - - Enter_Task (Self_ID); - -- We setup the SEH (Structured Exception Handling) handler if supported -- on the target. --- 1146,1159 ---- (1 .. Self_ID.Common.Task_Image_Len), Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), ! Size - Overflow_Guard, ! SSE.To_Integer (Bottom_Of_Stack'Address), ! SSE.To_Integer ! (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit)); STPO.Unlock_RTS; Fill_Stack (Self_ID.Common.Analyzer); end if; -- We setup the SEH (Structured Exception Handling) handler if supported -- on the target. diff -Nrcpad gcc-4.5.2/gcc/ada/s-tassta.ads gcc-4.6.0/gcc/ada/s-tassta.ads *** gcc-4.5.2/gcc/ada/s-tassta.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-tassta.ads Mon Oct 18 10:34:56 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.Tasking.Stages is *** 81,90 **** -- _init.discr := discr; -- _init._task_id := null; -- create_task (unspecified_priority, tZ, ! -- unspecified_task_info, ada__real_time__time_span_zero, 0, ! -- _master, task_procedure_access!(tB'address), ! -- _init'address, tE'unchecked_access, _chain, _task_id, _init. ! -- _task_id); -- return; -- end tVIP; -- ] --- 81,90 ---- -- _init.discr := discr; -- _init._task_id := null; -- create_task (unspecified_priority, tZ, ! -- unspecified_task_info, unspecified_cpu, ! -- ada__real_time__time_span_zero, 0, _master, ! -- task_procedure_access!(tB'address), _init'address, ! -- tE'unchecked_access, _chain, _task_id, _init._task_id); -- return; -- end tVIP; -- ] *************** package System.Tasking.Stages is *** 170,175 **** --- 170,176 ---- (Priority : Integer; Size : System.Parameters.Size_Type; Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; Relative_Deadline : Ada.Real_Time.Time_Span; Num_Entries : Task_Entry_Index; Master : Master_Level; *************** package System.Tasking.Stages is *** 183,193 **** -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task. -- ! -- Priority is the task's priority (assumed to be in the ! -- System.Any_Priority'Range) -- Size is the stack size of the task to create -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. -- Relative_Deadline is the relative deadline associated with the created -- task by means of a pragma Relative_Deadline, or 0.0 if none. -- State is the compiler generated task's procedure body --- 184,198 ---- -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task. -- ! -- Priority is the task's priority (assumed to be in range of type ! -- System.Any_Priority) -- Size is the stack size of the task to create -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. + -- CPU is the task affinity. Passed as an Integer because the undefined + -- value is not in the range of CPU_Range. Static range checks are + -- performed when analyzing the pragma, and dynamic ones are performed + -- before setting the affinity at run time. -- Relative_Deadline is the relative deadline associated with the created -- task by means of a pragma Relative_Deadline, or 0.0 if none. -- State is the compiler generated task's procedure body diff -Nrcpad gcc-4.5.2/gcc/ada/s-tataat.ads gcc-4.6.0/gcc/ada/s-tataat.ads *** gcc-4.5.2/gcc/ada/s-tataat.ads Wed Mar 26 07:35:19 2008 --- gcc-4.6.0/gcc/ada/s-tataat.ads Thu Oct 21 10:14:06 2010 *************** *** 7,13 **** -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2008, AdaCore -- -- -- -- GNARL 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- -- --- 7,13 ---- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- ! -- Copyright (C) 1995-2010, AdaCore -- -- -- -- GNARL 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- -- *************** package System.Tasking.Task_Attributes i *** 107,113 **** -- Ensure that the designated object is always strictly enough aligned. In_Use : Direct_Index_Vector := 0; ! -- Set True for direct indices that are already used (True??? type???) All_Attributes : Access_Instance; -- A linked list of all indirectly access attributes, which includes all --- 107,113 ---- -- Ensure that the designated object is always strictly enough aligned. In_Use : Direct_Index_Vector := 0; ! -- Set True for direct indexes that are already used (True??? type???) All_Attributes : Access_Instance; -- A linked list of all indirectly access attributes, which includes all diff -Nrcpad gcc-4.5.2/gcc/ada/s-tpoben.adb gcc-4.6.0/gcc/ada/s-tpoben.adb *** gcc-4.5.2/gcc/ada/s-tpoben.adb Tue Jan 26 10:02:11 2010 --- gcc-4.6.0/gcc/ada/s-tpoben.adb Fri Jun 18 19:48:43 2010 *************** package body System.Tasking.Protected_Ob *** 226,237 **** raise Program_Error; end if; - -- pragma Assert (Self_Id.Deferral_Level = 0); -- If a PO is created from a controlled operation, abort is already ! -- deferred at this point, so we need to use Defer_Abort_Nestable ! -- In some cases, the above assertion can be useful to spot ! -- inconsistencies, outside the above scenario involving controlled ! -- types. Initialization.Defer_Abort_Nestable (Self_ID); Initialize_Lock (Init_Priority, Object.L'Access); --- 226,237 ---- raise Program_Error; end if; -- If a PO is created from a controlled operation, abort is already ! -- deferred at this point, so we need to use Defer_Abort_Nestable. In ! -- some cases, the following assertion can help to spot inconsistencies, ! -- outside the above scenario involving controlled types. ! ! -- pragma Assert (Self_Id.Deferral_Level = 0); Initialization.Defer_Abort_Nestable (Self_ID); Initialize_Lock (Init_Priority, Object.L'Access); diff -Nrcpad gcc-4.5.2/gcc/ada/s-tpobop.adb gcc-4.6.0/gcc/ada/s-tpobop.adb *** gcc-4.5.2/gcc/ada/s-tpobop.adb Mon Jul 13 08:39:28 2009 --- gcc-4.6.0/gcc/ada/s-tpobop.adb Thu Sep 9 13:53:19 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package body System.Tasking.Protected_Ob *** 646,671 **** end if; end if; ! elsif Mode < Asynchronous_Call then ! ! -- Simple_Call or Conditional_Call ! ! if Single_Lock then ! STPO.Lock_RTS; ! Entry_Calls.Wait_For_Completion (Entry_Call); ! STPO.Unlock_RTS; ! else ! STPO.Write_Lock (Self_ID); ! Entry_Calls.Wait_For_Completion (Entry_Call); ! STPO.Unlock (Self_ID); ! end if; ! Block.Cancelled := Entry_Call.State = Cancelled; ! else ! pragma Assert (False); ! null; end if; Initialization.Undefer_Abort_Nestable (Self_ID); --- 646,671 ---- end if; end if; ! else ! case Mode is ! when Simple_Call | Conditional_Call => ! if Single_Lock then ! STPO.Lock_RTS; ! Entry_Calls.Wait_For_Completion (Entry_Call); ! STPO.Unlock_RTS; ! else ! STPO.Write_Lock (Self_ID); ! Entry_Calls.Wait_For_Completion (Entry_Call); ! STPO.Unlock (Self_ID); ! end if; ! Block.Cancelled := Entry_Call.State = Cancelled; ! when Asynchronous_Call | Timed_Call => ! pragma Assert (False); ! null; ! end case; end if; Initialization.Undefer_Abort_Nestable (Self_ID); *************** package body System.Tasking.Protected_Ob *** 958,964 **** Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); end if; ! Initialization.Defer_Abort (Self_Id); Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then --- 958,964 ---- Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); end if; ! Initialization.Defer_Abort_Nestable (Self_Id); Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then *************** package body System.Tasking.Protected_Ob *** 1009,1015 **** end if; Entry_Call_Successful := Entry_Call.State = Done; ! Initialization.Undefer_Abort (Self_Id); Entry_Calls.Check_Exception (Self_Id, Entry_Call); return; end if; --- 1009,1015 ---- end if; Entry_Call_Successful := Entry_Call.State = Done; ! Initialization.Undefer_Abort_Nestable (Self_Id); Entry_Calls.Check_Exception (Self_Id, Entry_Call); return; end if; *************** package body System.Tasking.Protected_Ob *** 1025,1031 **** -- ??? Do we need to yield in case Yielded is False ! Initialization.Undefer_Abort (Self_Id); Entry_Call_Successful := Entry_Call.State = Done; Entry_Calls.Check_Exception (Self_Id, Entry_Call); end Timed_Protected_Entry_Call; --- 1025,1031 ---- -- ??? Do we need to yield in case Yielded is False ! Initialization.Undefer_Abort_Nestable (Self_Id); Entry_Call_Successful := Entry_Call.State = Done; Entry_Calls.Check_Exception (Self_Id, Entry_Call); end Timed_Protected_Entry_Call; diff -Nrcpad gcc-4.5.2/gcc/ada/s-tporft.adb gcc-4.6.0/gcc/ada/s-tporft.adb *** gcc-4.5.2/gcc/ada/s-tporft.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-tporft.adb Mon Oct 18 10:27:48 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** with System.Task_Info; *** 35,40 **** --- 35,42 ---- with System.Soft_Links; -- used to initialize TSD for a C thread, in function Self + with System.Multiprocessors; + separate (System.Task_Primitives.Operations) function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is Local_ATCB : aliased Ada_Task_Control_Block (0); *************** begin *** 63,70 **** System.Tasking.Initialize_ATCB (Self_Id, null, Null_Address, Null_Task, Foreign_Task_Elaborated'Access, ! System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_Id, ! Succeeded); Unlock_RTS; pragma Assert (Succeeded); --- 65,72 ---- System.Tasking.Initialize_ATCB (Self_Id, null, Null_Address, Null_Task, Foreign_Task_Elaborated'Access, ! System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, ! Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded); Unlock_RTS; pragma Assert (Succeeded); *************** begin *** 86,101 **** Self_Id.Deferral_Level := 0; System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data); -- ??? ! -- The following call is commented out to avoid dependence on ! -- the System.Tasking.Initialization package. ! -- It seems that if we want Ada.Task_Attributes to work correctly ! -- for C threads we will need to raise the visibility of this soft ! -- link to System.Soft_Links. ! -- We are putting that off until this new functionality is otherwise ! -- stable. -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T); --- 88,105 ---- Self_Id.Deferral_Level := 0; + -- We do not provide an alternate stack for foreign threads + + Self_Id.Common.Task_Alternate_Stack := Null_Address; + System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data); -- ??? ! -- The following call is commented out to avoid dependence on the ! -- System.Tasking.Initialization package. It seems that if we want ! -- Ada.Task_Attributes to work correctly for C threads we will need to ! -- raise the visibility of this soft link to System.Soft_Links. We are ! -- putting that off until this new functionality is otherwise stable. -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T); diff -Nrcpad gcc-4.5.2/gcc/ada/s-utf_32.adb gcc-4.6.0/gcc/ada/s-utf_32.adb *** gcc-4.5.2/gcc/ada/s-utf_32.adb Fri Apr 17 13:07:12 2009 --- gcc-4.6.0/gcc/ada/s-utf_32.adb Thu Oct 7 09:16:06 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2005-2010, 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- -- *************** package body System.UTF_32 is *** 4232,4246 **** -- The following two tables define the mapping to upper case. The first -- table gives the ranges of lower case letters. The corresponding entry ! -- in Uppercase_Adjust shows the amount to be added (or subtracted) from ! -- the code value to get the corresponding upper case letter. ! ! -- Note that this folding is not reversible, for example lower case ! -- dotless i folds to normal upper case I, and that cannot be reversed. Lower_Case_Letters : constant UTF_32_Ranges := ( (16#00061#, 16#0007A#), -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z - (16#000B5#, 16#000B5#), -- MICRO SIGN .. MICRO SIGN (16#000E0#, 16#000F6#), -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS (16#000F8#, 16#000FE#), -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN (16#000FF#, 16#000FF#), -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS --- 4232,4247 ---- -- The following two tables define the mapping to upper case. The first -- table gives the ranges of lower case letters. The corresponding entry ! -- in Uppercase_Adjust shows the amount to be added to (or subtracted from ! -- if the value is negative) the code value to get the corresponding upper ! -- case letter. ! -- ! -- An entry is in this table if its 10646 has the string SMALL LETTER ! -- the name, and there is a corresponding entry which has the string ! -- CAPITAL LETTER in its name. Lower_Case_Letters : constant UTF_32_Ranges := ( (16#00061#, 16#0007A#), -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z (16#000E0#, 16#000F6#), -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS (16#000F8#, 16#000FE#), -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN (16#000FF#, 16#000FF#), -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS *************** package body System.UTF_32 is *** 4268,4275 **** (16#0012B#, 16#0012B#), -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON (16#0012D#, 16#0012D#), -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE (16#0012F#, 16#0012F#), -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK ! (16#00131#, 16#00131#), -- LATIN SMALL LETTER DOTLESS I .. LATIN SMALL LETTER DOTLESS I ! (16#00133#, 16#00133#), -- LATIN SMALL LIGATURE IJ .. LATIN SMALL LIGATURE IJ (16#00135#, 16#00135#), -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX (16#00137#, 16#00137#), -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA (16#0013A#, 16#0013A#), -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE --- 4269,4275 ---- (16#0012B#, 16#0012B#), -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON (16#0012D#, 16#0012D#), -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE (16#0012F#, 16#0012F#), -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK ! (16#00133#, 16#00133#), -- LATIN SMALL LETTER I J .. LATIN SMALL LETTER I J (16#00135#, 16#00135#), -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX (16#00137#, 16#00137#), -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA (16#0013A#, 16#0013A#), -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE *************** package body System.UTF_32 is *** 4284,4290 **** (16#0014D#, 16#0014D#), -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON (16#0014F#, 16#0014F#), -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE (16#00151#, 16#00151#), -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE ! (16#00153#, 16#00153#), -- LATIN SMALL LIGATURE OE .. LATIN SMALL LIGATURE OE (16#00155#, 16#00155#), -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE (16#00157#, 16#00157#), -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA (16#00159#, 16#00159#), -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON --- 4284,4290 ---- (16#0014D#, 16#0014D#), -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON (16#0014F#, 16#0014F#), -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE (16#00151#, 16#00151#), -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE ! (16#00153#, 16#00153#), -- LATIN SMALL LETTER O E .. LATIN SMALL LETTER O E (16#00155#, 16#00155#), -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE (16#00157#, 16#00157#), -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA (16#00159#, 16#00159#), -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON *************** package body System.UTF_32 is *** 4306,4318 **** (16#0017A#, 16#0017A#), -- LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE (16#0017C#, 16#0017C#), -- LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE (16#0017E#, 16#0017E#), -- LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER Z WITH CARON - (16#0017F#, 16#0017F#), -- LATIN SMALL LETTER LONG S .. LATIN SMALL LETTER LONG S (16#00183#, 16#00183#), -- LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR (16#00185#, 16#00185#), -- LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX (16#00188#, 16#00188#), -- LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK (16#0018C#, 16#0018C#), -- LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER D WITH TOPBAR (16#00192#, 16#00192#), -- LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK - (16#00195#, 16#00195#), -- LATIN SMALL LETTER HV .. LATIN SMALL LETTER HV (16#00199#, 16#00199#), -- LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER K WITH HOOK (16#0019E#, 16#0019E#), -- LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG (16#001A1#, 16#001A1#), -- LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN --- 4306,4316 ---- *************** package body System.UTF_32 is *** 4325,4336 **** (16#001B6#, 16#001B6#), -- LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE (16#001B9#, 16#001B9#), -- LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH REVERSED (16#001BD#, 16#001BD#), -- LATIN SMALL LETTER TONE FIVE .. LATIN SMALL LETTER TONE FIVE - (16#001BF#, 16#001BF#), -- LATIN LETTER WYNN .. LATIN LETTER WYNN - (16#001C5#, 16#001C5#), -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON (16#001C6#, 16#001C6#), -- LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON - (16#001C8#, 16#001C8#), -- LATIN CAPITAL LETTER L WITH SMALL LETTER J .. LATIN CAPITAL LETTER L WITH SMALL LETTER J (16#001C9#, 16#001C9#), -- LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ - (16#001CB#, 16#001CB#), -- LATIN CAPITAL LETTER N WITH SMALL LETTER J .. LATIN CAPITAL LETTER N WITH SMALL LETTER J (16#001CC#, 16#001CC#), -- LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ (16#001CE#, 16#001CE#), -- LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON (16#001D0#, 16#001D0#), -- LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON --- 4323,4330 ---- *************** package body System.UTF_32 is *** 4340,4346 **** (16#001D8#, 16#001D8#), -- LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE (16#001DA#, 16#001DA#), -- LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON (16#001DC#, 16#001DC#), -- LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE - (16#001DD#, 16#001DD#), -- LATIN SMALL LETTER TURNED E .. LATIN SMALL LETTER TURNED E (16#001DF#, 16#001DF#), -- LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON (16#001E1#, 16#001E1#), -- LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON (16#001E3#, 16#001E3#), -- LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON --- 4334,4339 ---- *************** package body System.UTF_32 is *** 4350,4356 **** (16#001EB#, 16#001EB#), -- LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK (16#001ED#, 16#001ED#), -- LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON (16#001EF#, 16#001EF#), -- LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER EZH WITH CARON - (16#001F2#, 16#001F2#), -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z (16#001F3#, 16#001F3#), -- LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ (16#001F5#, 16#001F5#), -- LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE (16#001F9#, 16#001F9#), -- LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE --- 4343,4348 ---- *************** package body System.UTF_32 is *** 4384,4391 **** (16#00233#, 16#00233#), -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON (16#00253#, 16#00253#), -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK (16#00254#, 16#00254#), -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O ! (16#00256#, 16#00257#), -- LATIN SMALL LETTER D WITH TAIL .. LATIN SMALL LETTER D WITH HOOK ! (16#00259#, 16#00259#), -- LATIN SMALL LETTER SCHWA .. LATIN SMALL LETTER SCHWA (16#0025B#, 16#0025B#), -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E (16#00260#, 16#00260#), -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK (16#00263#, 16#00263#), -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA --- 4376,4383 ---- (16#00233#, 16#00233#), -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON (16#00253#, 16#00253#), -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK (16#00254#, 16#00254#), -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O ! (16#00257#, 16#00257#), -- LATIN SMALL LETTER D WITH HOOK .. LATIN SMALL LETTER D WITH HOOK ! (16#00258#, 16#00259#), -- LATIN SMALL LETTER REVERSED E .. LATIN SMALL LETTER SCHWA (16#0025B#, 16#0025B#), -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E (16#00260#, 16#00260#), -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK (16#00263#, 16#00263#), -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA *************** package body System.UTF_32 is *** 4393,4400 **** (16#00269#, 16#00269#), -- LATIN SMALL LETTER IOTA .. LATIN SMALL LETTER IOTA (16#0026F#, 16#0026F#), -- LATIN SMALL LETTER TURNED M .. LATIN SMALL LETTER TURNED M (16#00272#, 16#00272#), -- LATIN SMALL LETTER N WITH LEFT HOOK .. LATIN SMALL LETTER N WITH LEFT HOOK - (16#00275#, 16#00275#), -- LATIN SMALL LETTER BARRED O .. LATIN SMALL LETTER BARRED O - (16#00280#, 16#00280#), -- LATIN LETTER SMALL CAPITAL R .. LATIN LETTER SMALL CAPITAL R (16#00283#, 16#00283#), -- LATIN SMALL LETTER ESH .. LATIN SMALL LETTER ESH (16#00288#, 16#00288#), -- LATIN SMALL LETTER T WITH RETROFLEX HOOK .. LATIN SMALL LETTER T WITH RETROFLEX HOOK (16#0028A#, 16#0028B#), -- LATIN SMALL LETTER UPSILON .. LATIN SMALL LETTER V WITH HOOK --- 4385,4390 ---- *************** package body System.UTF_32 is *** 4402,4416 **** (16#003AC#, 16#003AC#), -- GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER ALPHA WITH TONOS (16#003AD#, 16#003AF#), -- GREEK SMALL LETTER EPSILON WITH TONOS .. GREEK SMALL LETTER IOTA WITH TONOS (16#003B1#, 16#003C1#), -- GREEK SMALL LETTER ALPHA .. GREEK SMALL LETTER RHO - (16#003C2#, 16#003C2#), -- GREEK SMALL LETTER FINAL SIGMA .. GREEK SMALL LETTER FINAL SIGMA (16#003C3#, 16#003CB#), -- GREEK SMALL LETTER SIGMA .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA (16#003CC#, 16#003CC#), -- GREEK SMALL LETTER OMICRON WITH TONOS .. GREEK SMALL LETTER OMICRON WITH TONOS (16#003CD#, 16#003CE#), -- GREEK SMALL LETTER UPSILON WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS - (16#003D0#, 16#003D0#), -- GREEK BETA SYMBOL .. GREEK BETA SYMBOL - (16#003D1#, 16#003D1#), -- GREEK THETA SYMBOL .. GREEK THETA SYMBOL - (16#003D5#, 16#003D5#), -- GREEK PHI SYMBOL .. GREEK PHI SYMBOL - (16#003D6#, 16#003D6#), -- GREEK PI SYMBOL .. GREEK PI SYMBOL - (16#003D9#, 16#003D9#), -- GREEK SMALL LETTER ARCHAIC KOPPA .. GREEK SMALL LETTER ARCHAIC KOPPA (16#003DB#, 16#003DB#), -- GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA (16#003DD#, 16#003DD#), -- GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA (16#003DF#, 16#003DF#), -- GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA --- 4392,4400 ---- *************** package body System.UTF_32 is *** 4422,4431 **** (16#003EB#, 16#003EB#), -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA (16#003ED#, 16#003ED#), -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA (16#003EF#, 16#003EF#), -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI ! (16#003F0#, 16#003F0#), -- GREEK KAPPA SYMBOL .. GREEK KAPPA SYMBOL ! (16#003F1#, 16#003F1#), -- GREEK RHO SYMBOL .. GREEK RHO SYMBOL ! (16#003F2#, 16#003F2#), -- GREEK LUNATE SIGMA SYMBOL .. GREEK LUNATE SIGMA SYMBOL ! (16#003F5#, 16#003F5#), -- GREEK LUNATE EPSILON SYMBOL .. GREEK LUNATE EPSILON SYMBOL (16#00430#, 16#0044F#), -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA (16#00450#, 16#0045F#), -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE (16#00461#, 16#00461#), -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA --- 4406,4413 ---- (16#003EB#, 16#003EB#), -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA (16#003ED#, 16#003ED#), -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA (16#003EF#, 16#003EF#), -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI ! (16#003F8#, 16#003F8#), -- GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO ! (16#003FB#, 16#003FB#), -- GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN (16#00430#, 16#0044F#), -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA (16#00450#, 16#0045F#), -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE (16#00461#, 16#00461#), -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA *************** package body System.UTF_32 is *** 4458,4464 **** (16#0049F#, 16#0049F#), -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE (16#004A1#, 16#004A1#), -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA (16#004A3#, 16#004A3#), -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER ! (16#004A5#, 16#004A5#), -- CYRILLIC SMALL LIGATURE EN GHE .. CYRILLIC SMALL LIGATURE EN GHE (16#004A7#, 16#004A7#), -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK (16#004A9#, 16#004A9#), -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA (16#004AB#, 16#004AB#), -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER --- 4440,4446 ---- (16#0049F#, 16#0049F#), -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE (16#004A1#, 16#004A1#), -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA (16#004A3#, 16#004A3#), -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER ! (16#004A5#, 16#004A5#), -- CYRILLIC SMALL LETTER EN GE .. CYRILLIC SMALL LETTER EN GE (16#004A7#, 16#004A7#), -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK (16#004A9#, 16#004A9#), -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA (16#004AB#, 16#004AB#), -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER *************** package body System.UTF_32 is *** 4466,4472 **** (16#004AF#, 16#004AF#), -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U (16#004B1#, 16#004B1#), -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE (16#004B3#, 16#004B3#), -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER ! (16#004B5#, 16#004B5#), -- CYRILLIC SMALL LIGATURE TE TSE .. CYRILLIC SMALL LIGATURE TE TSE (16#004B7#, 16#004B7#), -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER (16#004B9#, 16#004B9#), -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE (16#004BB#, 16#004BB#), -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA --- 4448,4454 ---- (16#004AF#, 16#004AF#), -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U (16#004B1#, 16#004B1#), -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE (16#004B3#, 16#004B3#), -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER ! (16#004B5#, 16#004B5#), -- CYRILLIC SMALL LETTER TE TSE .. CYRILLIC SMALL LETTER TE TSE (16#004B7#, 16#004B7#), -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER (16#004B9#, 16#004B9#), -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE (16#004BB#, 16#004BB#), -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA *************** package body System.UTF_32 is *** 4481,4487 **** (16#004CE#, 16#004CE#), -- CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL (16#004D1#, 16#004D1#), -- CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE (16#004D3#, 16#004D3#), -- CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS - (16#004D5#, 16#004D5#), -- CYRILLIC SMALL LIGATURE A IE .. CYRILLIC SMALL LIGATURE A IE (16#004D7#, 16#004D7#), -- CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE (16#004D9#, 16#004D9#), -- CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA (16#004DB#, 16#004DB#), -- CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS --- 4463,4468 ---- *************** package body System.UTF_32 is *** 4508,4513 **** --- 4489,4495 ---- (16#0050D#, 16#0050D#), -- CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE (16#0050F#, 16#0050F#), -- CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE (16#00561#, 16#00586#), -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LETTER FEH + (16#010D0#, 16#010F5#), -- GEORGIAN SMALL LETTER AN .. GEORGIAN SMALL LETTER HOE (16#01E01#, 16#01E01#), -- LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW (16#01E03#, 16#01E03#), -- LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE (16#01E05#, 16#01E05#), -- LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW *************** package body System.UTF_32 is *** 4583,4589 **** (16#01E91#, 16#01E91#), -- LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX (16#01E93#, 16#01E93#), -- LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW (16#01E95#, 16#01E95#), -- LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER Z WITH LINE BELOW - (16#01E9B#, 16#01E9B#), -- LATIN SMALL LETTER LONG S WITH DOT ABOVE .. LATIN SMALL LETTER LONG S WITH DOT ABOVE (16#01EA1#, 16#01EA1#), -- LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW (16#01EA3#, 16#01EA3#), -- LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE (16#01EA5#, 16#01EA5#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE --- 4565,4570 ---- *************** package body System.UTF_32 is *** 4645,4668 **** (16#01F78#, 16#01F79#), -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA (16#01F7A#, 16#01F7B#), -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA (16#01F7C#, 16#01F7D#), -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA - (16#01F80#, 16#01F87#), -- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - (16#01F90#, 16#01F97#), -- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - (16#01FA0#, 16#01FA7#), -- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI (16#01FB0#, 16#01FB1#), -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON - (16#01FB3#, 16#01FB3#), -- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI - (16#01FBE#, 16#01FBE#), -- GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI - (16#01FC3#, 16#01FC3#), -- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI (16#01FD0#, 16#01FD1#), -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON (16#01FE0#, 16#01FE1#), -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON (16#01FE5#, 16#01FE5#), -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA ! (16#01FF3#, 16#01FF3#), -- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI (16#0FF41#, 16#0FF5A#), -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z ! (16#10428#, 16#1044D#)); -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER ENG ! Upper_Case_Adjust : constant array (Lower_Case_Letters'Range) of UTF_32'Base := ( -32, -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z - 743, -- MICRO SIGN .. MICRO SIGN -32, -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS -32, -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN 121, -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS --- 4626,4643 ---- (16#01F78#, 16#01F79#), -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA (16#01F7A#, 16#01F7B#), -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA (16#01F7C#, 16#01F7D#), -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA (16#01FB0#, 16#01FB1#), -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON (16#01FD0#, 16#01FD1#), -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON (16#01FE0#, 16#01FE1#), -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON (16#01FE5#, 16#01FE5#), -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA ! (16#024D0#, 16#024E9#), -- CIRCLED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z (16#0FF41#, 16#0FF5A#), -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z ! (16#10428#, 16#1044F#), -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW ! (16#E0061#, 16#E007A#)); -- TAG LATIN SMALL LETTER A .. TAG LATIN SMALL LETTER Z ! Lower_Case_Adjust : constant array (Lower_Case_Letters'Range) of UTF_32'Base := ( -32, -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z -32, -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS -32, -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN 121, -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS *************** package body System.UTF_32 is *** 4690,4697 **** -1, -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON -1, -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE -1, -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK ! -232, -- LATIN SMALL LETTER DOTLESS I .. LATIN SMALL LETTER DOTLESS I ! -1, -- LATIN SMALL LIGATURE IJ .. LATIN SMALL LIGATURE IJ -1, -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX -1, -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA -1, -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE --- 4665,4671 ---- -1, -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON -1, -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE -1, -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK ! -1, -- LATIN SMALL LETTER I J .. LATIN SMALL LETTER I J -1, -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX -1, -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA -1, -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE *************** package body System.UTF_32 is *** 4706,4712 **** -1, -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON -1, -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE -1, -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE ! -1, -- LATIN SMALL LIGATURE OE .. LATIN SMALL LIGATURE OE -1, -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE -1, -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA -1, -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON --- 4680,4686 ---- -1, -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON -1, -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE -1, -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE ! -1, -- LATIN SMALL LETTER O E .. LATIN SMALL LETTER O E -1, -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE -1, -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA -1, -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON *************** package body System.UTF_32 is *** 4728,4740 **** -1, -- LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE -1, -- LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE -1, -- LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER Z WITH CARON - -300, -- LATIN SMALL LETTER LONG S .. LATIN SMALL LETTER LONG S -1, -- LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR -1, -- LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX -1, -- LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK -1, -- LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER D WITH TOPBAR -1, -- LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK - 97, -- LATIN SMALL LETTER HV .. LATIN SMALL LETTER HV -1, -- LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER K WITH HOOK 130, -- LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG -1, -- LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN --- 4702,4712 ---- *************** package body System.UTF_32 is *** 4747,4758 **** -1, -- LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE -1, -- LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH REVERSED -1, -- LATIN SMALL LETTER TONE FIVE .. LATIN SMALL LETTER TONE FIVE - 56, -- LATIN LETTER WYNN .. LATIN LETTER WYNN - -1, -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON -2, -- LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON - -1, -- LATIN CAPITAL LETTER L WITH SMALL LETTER J .. LATIN CAPITAL LETTER L WITH SMALL LETTER J -2, -- LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ - -1, -- LATIN CAPITAL LETTER N WITH SMALL LETTER J .. LATIN CAPITAL LETTER N WITH SMALL LETTER J -2, -- LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ -1, -- LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON -1, -- LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON --- 4719,4726 ---- *************** package body System.UTF_32 is *** 4762,4768 **** -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE - -79, -- LATIN SMALL LETTER TURNED E .. LATIN SMALL LETTER TURNED E -1, -- LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON -1, -- LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON -1, -- LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON --- 4730,4735 ---- *************** package body System.UTF_32 is *** 4772,4778 **** -1, -- LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK -1, -- LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON -1, -- LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER EZH WITH CARON - -1, -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z -2, -- LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ -1, -- LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE -1, -- LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE --- 4739,4744 ---- *************** package body System.UTF_32 is *** 4806,4813 **** -1, -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON -210, -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK -206, -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O ! -205, -- LATIN SMALL LETTER D WITH TAIL .. LATIN SMALL LETTER D WITH HOOK ! -202, -- LATIN SMALL LETTER SCHWA .. LATIN SMALL LETTER SCHWA -203, -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E -205, -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK -207, -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA --- 4772,4779 ---- -1, -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON -210, -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK -206, -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O ! -205, -- LATIN SMALL LETTER D WITH HOOK .. LATIN SMALL LETTER D WITH HOOK ! -202, -- LATIN SMALL LETTER REVERSED E .. LATIN SMALL LETTER SCHWA -203, -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E -205, -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK -207, -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA *************** package body System.UTF_32 is *** 4815,4822 **** -211, -- LATIN SMALL LETTER IOTA .. LATIN SMALL LETTER IOTA -211, -- LATIN SMALL LETTER TURNED M .. LATIN SMALL LETTER TURNED M -213, -- LATIN SMALL LETTER N WITH LEFT HOOK .. LATIN SMALL LETTER N WITH LEFT HOOK - -214, -- LATIN SMALL LETTER BARRED O .. LATIN SMALL LETTER BARRED O - -218, -- LATIN LETTER SMALL CAPITAL R .. LATIN LETTER SMALL CAPITAL R -218, -- LATIN SMALL LETTER ESH .. LATIN SMALL LETTER ESH -218, -- LATIN SMALL LETTER T WITH RETROFLEX HOOK .. LATIN SMALL LETTER T WITH RETROFLEX HOOK -217, -- LATIN SMALL LETTER UPSILON .. LATIN SMALL LETTER V WITH HOOK --- 4781,4786 ---- *************** package body System.UTF_32 is *** 4824,4838 **** -38, -- GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER ALPHA WITH TONOS -37, -- GREEK SMALL LETTER EPSILON WITH TONOS .. GREEK SMALL LETTER IOTA WITH TONOS -32, -- GREEK SMALL LETTER ALPHA .. GREEK SMALL LETTER RHO - -31, -- GREEK SMALL LETTER FINAL SIGMA .. GREEK SMALL LETTER FINAL SIGMA -32, -- GREEK SMALL LETTER SIGMA .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA -64, -- GREEK SMALL LETTER OMICRON WITH TONOS .. GREEK SMALL LETTER OMICRON WITH TONOS -63, -- GREEK SMALL LETTER UPSILON WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS - -62, -- GREEK BETA SYMBOL .. GREEK BETA SYMBOL - -57, -- GREEK THETA SYMBOL .. GREEK THETA SYMBOL - -47, -- GREEK PHI SYMBOL .. GREEK PHI SYMBOL - -54, -- GREEK PI SYMBOL .. GREEK PI SYMBOL - -1, -- GREEK SMALL LETTER ARCHAIC KOPPA .. GREEK SMALL LETTER ARCHAIC KOPPA -1, -- GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA -1, -- GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA -1, -- GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA --- 4788,4796 ---- *************** package body System.UTF_32 is *** 4844,4853 **** -1, -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA -1, -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA -1, -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI ! -86, -- GREEK KAPPA SYMBOL .. GREEK KAPPA SYMBOL ! -80, -- GREEK RHO SYMBOL .. GREEK RHO SYMBOL ! -79, -- GREEK LUNATE SIGMA SYMBOL .. GREEK LUNATE SIGMA SYMBOL ! -96, -- GREEK LUNATE EPSILON SYMBOL .. GREEK LUNATE EPSILON SYMBOL -32, -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA -80, -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE -1, -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA --- 4802,4809 ---- -1, -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA -1, -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA -1, -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI ! -1, -- GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO ! -1, -- GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN -32, -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA -80, -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE -1, -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA *************** package body System.UTF_32 is *** 4880,4886 **** -1, -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE -1, -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA -1, -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER ! -1, -- CYRILLIC SMALL LIGATURE EN GHE .. CYRILLIC SMALL LIGATURE EN GHE -1, -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK -1, -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA -1, -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER --- 4836,4842 ---- -1, -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE -1, -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA -1, -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER ! -1, -- CYRILLIC SMALL LETTER EN GE .. CYRILLIC SMALL LETTER EN GE -1, -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK -1, -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA -1, -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER *************** package body System.UTF_32 is *** 4888,4894 **** -1, -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U -1, -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE -1, -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER ! -1, -- CYRILLIC SMALL LIGATURE TE TSE .. CYRILLIC SMALL LIGATURE TE TSE -1, -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER -1, -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE -1, -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA --- 4844,4850 ---- -1, -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U -1, -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE -1, -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER ! -1, -- CYRILLIC SMALL LETTER TE TSE .. CYRILLIC SMALL LETTER TE TSE -1, -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER -1, -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE -1, -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA *************** package body System.UTF_32 is *** 4903,4909 **** -1, -- CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL -1, -- CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE -1, -- CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS - -1, -- CYRILLIC SMALL LIGATURE A IE .. CYRILLIC SMALL LIGATURE A IE -1, -- CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE -1, -- CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA -1, -- CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS --- 4859,4864 ---- *************** package body System.UTF_32 is *** 4930,4935 **** --- 4885,4891 ---- -1, -- CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE -1, -- CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE -48, -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LETTER FEH + -48, -- GEORGIAN SMALL LETTER AN .. GEORGIAN SMALL LETTER HOE -1, -- LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW -1, -- LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE -1, -- LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW *************** package body System.UTF_32 is *** 5005,5011 **** -1, -- LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX -1, -- LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW -1, -- LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER Z WITH LINE BELOW - -59, -- LATIN SMALL LETTER LONG S WITH DOT ABOVE .. LATIN SMALL LETTER LONG S WITH DOT ABOVE -1, -- LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW -1, -- LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE --- 4961,4966 ---- *************** package body System.UTF_32 is *** 5067,5086 **** 128, -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA 112, -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA 126, -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA - 8, -- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - 8, -- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - 8, -- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI 8, -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON - 9, -- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI - -7205, -- GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI - 9, -- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI 8, -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON 8, -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON 7, -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA ! 9, -- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI -32, -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z ! -40); -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER ENG ----------------------- -- Local Subprograms -- --- 5022,6107 ---- 128, -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA 112, -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA 126, -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA 8, -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON 8, -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON 8, -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON 7, -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA ! -26, -- CIRCLED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z -32, -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z ! -40, -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW ! -32); -- TAG LATIN SMALL LETTER A .. TAG LATIN SMALL LETTER Z ! ! -- The following is a list of the 10646 names for SMALL LETTER entries ! -- that have no matching CAPITAL LETTER entry and are thus not folded ! ! -- LATIN SMALL LETTER SHARP S ! -- LATIN SMALL LETTER DOTLESS I ! -- LATIN SMALL LETTER KRA ! -- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE ! -- LATIN SMALL LETTER LONG S ! -- LATIN SMALL LETTER B WITH STROKE ! -- LATIN SMALL LETTER TURNED DELTA ! -- LATIN SMALL LETTER HV ! -- LATIN SMALL LETTER L WITH BAR ! -- LATIN SMALL LETTER LAMBDA WITH STROKE ! -- LATIN SMALL LETTER T WITH PALATAL HOOK ! -- LATIN SMALL LETTER EZH WITH TAIL ! -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON ! -- LATIN CAPITAL LETTER L WITH SMALL LETTER J ! -- LATIN CAPITAL LETTER N WITH SMALL LETTER J ! -- LATIN SMALL LETTER TURNED E ! -- LATIN SMALL LETTER J WITH CARON ! -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z ! -- LATIN SMALL LETTER D WITH CURL ! -- LATIN SMALL LETTER L WITH CURL ! -- LATIN SMALL LETTER N WITH CURL ! -- LATIN SMALL LETTER T WITH CURL ! -- LATIN SMALL LETTER TURNED A ! -- LATIN SMALL LETTER ALPHA ! -- LATIN SMALL LETTER TURNED ALPHA ! -- LATIN SMALL LETTER C WITH CURL ! -- LATIN SMALL LETTER D WITH TAIL ! -- LATIN SMALL LETTER SCHWA WITH HOOK ! -- LATIN SMALL LETTER REVERSED OPEN E ! -- LATIN SMALL LETTER REVERSED OPEN E WITH HOOK ! -- LATIN SMALL LETTER CLOSED REVERSED OPEN E ! -- LATIN SMALL LETTER DOTLESS J WITH STROKE ! -- LATIN SMALL LETTER SCRIPT G ! -- LATIN SMALL LETTER RAMS HORN ! -- LATIN SMALL LETTER TURNED H ! -- LATIN SMALL LETTER H WITH HOOK ! -- LATIN SMALL LETTER HENG WITH HOOK ! -- LATIN SMALL LETTER L WITH MIDDLE TILDE ! -- LATIN SMALL LETTER L WITH BELT ! -- LATIN SMALL LETTER L WITH RETROFLEX HOOK ! -- LATIN SMALL LETTER LEZH ! -- LATIN SMALL LETTER TURNED M WITH LONG LEG ! -- LATIN SMALL LETTER M WITH HOOK ! -- LATIN SMALL LETTER N WITH RETROFLEX HOOK ! -- LATIN SMALL LETTER BARRED O ! -- LATIN SMALL LETTER CLOSED OMEGA ! -- LATIN SMALL LETTER PHI ! -- LATIN SMALL LETTER TURNED R ! -- LATIN SMALL LETTER TURNED R WITH LONG LEG ! -- LATIN SMALL LETTER TURNED R WITH HOOK ! -- LATIN SMALL LETTER R WITH LONG LEG ! -- LATIN SMALL LETTER R WITH TAIL ! -- LATIN SMALL LETTER R WITH FISHHOOK ! -- LATIN SMALL LETTER REVERSED R WITH FISHHOOK ! -- LATIN SMALL LETTER S WITH HOOK ! -- LATIN SMALL LETTER DOTLESS J WITH STROKE AND HOOK ! -- LATIN SMALL LETTER SQUAT REVERSED ESH ! -- LATIN SMALL LETTER ESH WITH CURL ! -- LATIN SMALL LETTER TURNED T ! -- LATIN SMALL LETTER U BAR ! -- LATIN SMALL LETTER TURNED V ! -- LATIN SMALL LETTER TURNED W ! -- LATIN SMALL LETTER TURNED Y ! -- LATIN SMALL LETTER Z WITH RETROFLEX HOOK ! -- LATIN SMALL LETTER Z WITH CURL ! -- LATIN SMALL LETTER EZH WITH CURL ! -- LATIN SMALL LETTER CLOSED OPEN E ! -- LATIN SMALL LETTER J WITH CROSSED-TAIL ! -- LATIN SMALL LETTER TURNED K ! -- LATIN SMALL LETTER Q WITH HOOK ! -- LATIN SMALL LETTER DZ DIGRAPH ! -- LATIN SMALL LETTER DEZH DIGRAPH ! -- LATIN SMALL LETTER DZ DIGRAPH WITH CURL ! -- LATIN SMALL LETTER TS DIGRAPH ! -- LATIN SMALL LETTER TESH DIGRAPH ! -- LATIN SMALL LETTER TC DIGRAPH WITH CURL ! -- LATIN SMALL LETTER FENG DIGRAPH ! -- LATIN SMALL LETTER LS DIGRAPH ! -- LATIN SMALL LETTER LZ DIGRAPH ! -- LATIN SMALL LETTER TURNED H WITH FISHHOOK ! -- LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL ! -- COMBINING LATIN SMALL LETTER A ! -- COMBINING LATIN SMALL LETTER E ! -- COMBINING LATIN SMALL LETTER I ! -- COMBINING LATIN SMALL LETTER O ! -- COMBINING LATIN SMALL LETTER U ! -- COMBINING LATIN SMALL LETTER C ! -- COMBINING LATIN SMALL LETTER D ! -- COMBINING LATIN SMALL LETTER H ! -- COMBINING LATIN SMALL LETTER M ! -- COMBINING LATIN SMALL LETTER R ! -- COMBINING LATIN SMALL LETTER T ! -- COMBINING LATIN SMALL LETTER V ! -- COMBINING LATIN SMALL LETTER X ! -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS ! -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS ! -- GREEK SMALL LETTER FINAL SIGMA ! -- GREEK SMALL LETTER CURLED BETA ! -- GREEK SMALL LETTER SCRIPT THETA ! -- GREEK SMALL LETTER SCRIPT PHI ! -- GREEK SMALL LETTER OMEGA PI ! -- GREEK SMALL LETTER ARCHAIC KOPPA ! -- GREEK SMALL LETTER SCRIPT KAPPA ! -- GREEK SMALL LETTER TAILED RHO ! -- GREEK SMALL LETTER LUNATE SIGMA ! -- GEORGIAN SMALL LETTER FI ! -- LIMBU SMALL LETTER KA ! -- LIMBU SMALL LETTER NGA ! -- LIMBU SMALL LETTER ANUSVARA ! -- LIMBU SMALL LETTER TA ! -- LIMBU SMALL LETTER NA ! -- LIMBU SMALL LETTER PA ! -- LIMBU SMALL LETTER MA ! -- LIMBU SMALL LETTER RA ! -- LIMBU SMALL LETTER LA ! -- LATIN SMALL LETTER TURNED AE ! -- LATIN SMALL LETTER TURNED OPEN E ! -- LATIN SMALL LETTER TURNED I ! -- LATIN SMALL LETTER SIDEWAYS O ! -- LATIN SMALL LETTER SIDEWAYS OPEN O ! -- LATIN SMALL LETTER SIDEWAYS O WITH STROKE ! -- LATIN SMALL LETTER TURNED OE ! -- LATIN SMALL LETTER TOP HALF O ! -- LATIN SMALL LETTER BOTTOM HALF O ! -- LATIN SMALL LETTER SIDEWAYS U ! -- LATIN SMALL LETTER SIDEWAYS DIAERESIZED U ! -- LATIN SMALL LETTER SIDEWAYS TURNED M ! -- LATIN SUBSCRIPT SMALL LETTER I ! -- LATIN SUBSCRIPT SMALL LETTER R ! -- LATIN SUBSCRIPT SMALL LETTER U ! -- LATIN SUBSCRIPT SMALL LETTER V ! -- GREEK SUBSCRIPT SMALL LETTER BETA ! -- GREEK SUBSCRIPT SMALL LETTER GAMMA ! -- GREEK SUBSCRIPT SMALL LETTER RHO ! -- GREEK SUBSCRIPT SMALL LETTER PHI ! -- GREEK SUBSCRIPT SMALL LETTER CHI ! -- LATIN SMALL LETTER UE ! -- LATIN SMALL LETTER H WITH LINE BELOW ! -- LATIN SMALL LETTER T WITH DIAERESIS ! -- LATIN SMALL LETTER W WITH RING ABOVE ! -- LATIN SMALL LETTER Y WITH RING ABOVE ! -- LATIN SMALL LETTER A WITH RIGHT HALF RING ! -- LATIN SMALL LETTER LONG S WITH DOT ABOVE ! -- GREEK SMALL LETTER UPSILON WITH PSILI ! -- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA ! -- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA ! -- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI ! -- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI ! -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER ETA WITH PERISPOMENI ! -- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA ! -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA ! -- GREEK SMALL LETTER IOTA WITH PERISPOMENI ! -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI ! -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA ! -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA ! -- GREEK SMALL LETTER RHO WITH PSILI ! -- GREEK SMALL LETTER UPSILON WITH PERISPOMENI ! -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI ! -- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI ! -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI ! -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI ! -- SUPERSCRIPT LATIN SMALL LETTER I ! -- SUPERSCRIPT LATIN SMALL LETTER N ! -- TURNED GREEK SMALL LETTER IOTA ! -- PARENTHESIZED LATIN SMALL LETTER A ! -- PARENTHESIZED LATIN SMALL LETTER B ! -- PARENTHESIZED LATIN SMALL LETTER C ! -- PARENTHESIZED LATIN SMALL LETTER D ! -- PARENTHESIZED LATIN SMALL LETTER E ! -- PARENTHESIZED LATIN SMALL LETTER F ! -- PARENTHESIZED LATIN SMALL LETTER G ! -- PARENTHESIZED LATIN SMALL LETTER H ! -- PARENTHESIZED LATIN SMALL LETTER I ! -- PARENTHESIZED LATIN SMALL LETTER J ! -- PARENTHESIZED LATIN SMALL LETTER K ! -- PARENTHESIZED LATIN SMALL LETTER L ! -- PARENTHESIZED LATIN SMALL LETTER M ! -- PARENTHESIZED LATIN SMALL LETTER N ! -- PARENTHESIZED LATIN SMALL LETTER O ! -- PARENTHESIZED LATIN SMALL LETTER P ! -- PARENTHESIZED LATIN SMALL LETTER Q ! -- PARENTHESIZED LATIN SMALL LETTER R ! -- PARENTHESIZED LATIN SMALL LETTER S ! -- PARENTHESIZED LATIN SMALL LETTER T ! -- PARENTHESIZED LATIN SMALL LETTER U ! -- PARENTHESIZED LATIN SMALL LETTER V ! -- PARENTHESIZED LATIN SMALL LETTER W ! -- PARENTHESIZED LATIN SMALL LETTER X ! -- PARENTHESIZED LATIN SMALL LETTER Y ! -- PARENTHESIZED LATIN SMALL LETTER Z + -- The following two tables define the mapping to lower case. The first + -- table gives the ranges of upper case letters. The corresponding entry + -- in Lower_Case_Adjust shows the amount to be added to (or subtracted from + -- if the value is negative) the code value to get the corresponding lower + -- case letter. + + -- An entry is in this table if its 10646 has the string CAPITAL LETTER + -- the name, and there is a corresponding entry which has the string + -- SMALL LETTER in its name. + + Upper_Case_Letters : constant UTF_32_Ranges := ( + (16#00041#, 16#0005A#), -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z + (16#000C0#, 16#000D6#), -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS + (16#000D8#, 16#000DE#), -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN + (16#00100#, 16#00100#), -- LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON + (16#00102#, 16#00102#), -- LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE + (16#00104#, 16#00104#), -- LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK + (16#00106#, 16#00106#), -- LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE + (16#00108#, 16#00108#), -- LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX + (16#0010A#, 16#0010A#), -- LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE + (16#0010C#, 16#0010C#), -- LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON + (16#0010E#, 16#0010E#), -- LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON + (16#00110#, 16#00110#), -- LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE + (16#00112#, 16#00112#), -- LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON + (16#00114#, 16#00114#), -- LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE + (16#00116#, 16#00116#), -- LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE + (16#00118#, 16#00118#), -- LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK + (16#0011A#, 16#0011A#), -- LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON + (16#0011C#, 16#0011C#), -- LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX + (16#0011E#, 16#0011E#), -- LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE + (16#00120#, 16#00120#), -- LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE + (16#00122#, 16#00122#), -- LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA + (16#00124#, 16#00124#), -- LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX + (16#00126#, 16#00126#), -- LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE + (16#00128#, 16#00128#), -- LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE + (16#0012A#, 16#0012A#), -- LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON + (16#0012C#, 16#0012C#), -- LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE + (16#0012E#, 16#0012E#), -- LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK + (16#00132#, 16#00132#), -- LATIN CAPITAL LETTER I J .. LATIN CAPITAL LETTER I J + (16#00134#, 16#00134#), -- LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX + (16#00136#, 16#00136#), -- LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA + (16#00139#, 16#00139#), -- LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE + (16#0013B#, 16#0013B#), -- LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA + (16#0013D#, 16#0013D#), -- LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON + (16#0013F#, 16#0013F#), -- LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT + (16#00141#, 16#00141#), -- LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE + (16#00143#, 16#00143#), -- LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE + (16#00145#, 16#00145#), -- LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA + (16#00147#, 16#00147#), -- LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON + (16#0014A#, 16#0014A#), -- LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG + (16#0014C#, 16#0014C#), -- LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON + (16#0014E#, 16#0014E#), -- LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE + (16#00150#, 16#00150#), -- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE + (16#00152#, 16#00152#), -- LATIN CAPITAL LETTER O E .. LATIN CAPITAL LETTER O E + (16#00154#, 16#00154#), -- LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE + (16#00156#, 16#00156#), -- LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA + (16#00158#, 16#00158#), -- LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON + (16#0015A#, 16#0015A#), -- LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE + (16#0015C#, 16#0015C#), -- LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX + (16#0015E#, 16#0015E#), -- LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA + (16#00160#, 16#00160#), -- LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON + (16#00162#, 16#00162#), -- LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA + (16#00164#, 16#00164#), -- LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON + (16#00166#, 16#00166#), -- LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE + (16#00168#, 16#00168#), -- LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE + (16#0016A#, 16#0016A#), -- LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON + (16#0016C#, 16#0016C#), -- LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE + (16#0016E#, 16#0016E#), -- LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE + (16#00170#, 16#00170#), -- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE + (16#00172#, 16#00172#), -- LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK + (16#00174#, 16#00174#), -- LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX + (16#00176#, 16#00176#), -- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX + (16#00178#, 16#00178#), -- LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Y WITH DIAERESIS + (16#00179#, 16#00179#), -- LATIN CAPITAL LETTER Z WITH ACUTE .. LATIN CAPITAL LETTER Z WITH ACUTE + (16#0017B#, 16#0017B#), -- LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE + (16#0017D#, 16#0017D#), -- LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON + (16#00181#, 16#00181#), -- LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH HOOK + (16#00182#, 16#00182#), -- LATIN CAPITAL LETTER B WITH TOPBAR .. LATIN CAPITAL LETTER B WITH TOPBAR + (16#00184#, 16#00184#), -- LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX + (16#00186#, 16#00186#), -- LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER OPEN O + (16#00187#, 16#00187#), -- LATIN CAPITAL LETTER C WITH HOOK .. LATIN CAPITAL LETTER C WITH HOOK + (16#0018A#, 16#0018A#), -- LATIN CAPITAL LETTER D WITH HOOK .. LATIN CAPITAL LETTER D WITH HOOK + (16#0018B#, 16#0018B#), -- LATIN CAPITAL LETTER D WITH TOPBAR .. LATIN CAPITAL LETTER D WITH TOPBAR + (16#0018E#, 16#0018F#), -- LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER SCHWA + (16#00190#, 16#00190#), -- LATIN CAPITAL LETTER OPEN E .. LATIN CAPITAL LETTER OPEN E + (16#00191#, 16#00191#), -- LATIN CAPITAL LETTER F WITH HOOK .. LATIN CAPITAL LETTER F WITH HOOK + (16#00193#, 16#00193#), -- LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER G WITH HOOK + (16#00194#, 16#00194#), -- LATIN CAPITAL LETTER GAMMA .. LATIN CAPITAL LETTER GAMMA + (16#00196#, 16#00196#), -- LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER IOTA + (16#00197#, 16#00197#), -- LATIN CAPITAL LETTER I WITH STROKE .. LATIN CAPITAL LETTER I WITH STROKE + (16#00198#, 16#00198#), -- LATIN CAPITAL LETTER K WITH HOOK .. LATIN CAPITAL LETTER K WITH HOOK + (16#0019C#, 16#0019C#), -- LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER TURNED M + (16#0019D#, 16#0019D#), -- LATIN CAPITAL LETTER N WITH LEFT HOOK .. LATIN CAPITAL LETTER N WITH LEFT HOOK + (16#001A0#, 16#001A0#), -- LATIN CAPITAL LETTER O WITH HORN .. LATIN CAPITAL LETTER O WITH HORN + (16#001A2#, 16#001A2#), -- LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI + (16#001A4#, 16#001A4#), -- LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK + (16#001A7#, 16#001A7#), -- LATIN CAPITAL LETTER TONE TWO .. LATIN CAPITAL LETTER TONE TWO + (16#001A9#, 16#001A9#), -- LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH + (16#001AC#, 16#001AC#), -- LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK + (16#001AE#, 16#001AE#), -- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER T WITH RETROFLEX HOOK + (16#001AF#, 16#001AF#), -- LATIN CAPITAL LETTER U WITH HORN .. LATIN CAPITAL LETTER U WITH HORN + (16#001B1#, 16#001B2#), -- LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER V WITH HOOK + (16#001B3#, 16#001B3#), -- LATIN CAPITAL LETTER Y WITH HOOK .. LATIN CAPITAL LETTER Y WITH HOOK + (16#001B5#, 16#001B5#), -- LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE + (16#001B7#, 16#001B7#), -- LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH + (16#001B8#, 16#001B8#), -- LATIN CAPITAL LETTER EZH REVERSED .. LATIN CAPITAL LETTER EZH REVERSED + (16#001BC#, 16#001BC#), -- LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE + (16#001C4#, 16#001C4#), -- LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON + (16#001C7#, 16#001C7#), -- LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ + (16#001CA#, 16#001CA#), -- LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ + (16#001CD#, 16#001CD#), -- LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON + (16#001CF#, 16#001CF#), -- LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON + (16#001D1#, 16#001D1#), -- LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON + (16#001D3#, 16#001D3#), -- LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON + (16#001D5#, 16#001D5#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON + (16#001D7#, 16#001D7#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE + (16#001D9#, 16#001D9#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON + (16#001DB#, 16#001DB#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE + (16#001DE#, 16#001DE#), -- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON + (16#001E0#, 16#001E0#), -- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON + (16#001E2#, 16#001E2#), -- LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON + (16#001E4#, 16#001E4#), -- LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE + (16#001E6#, 16#001E6#), -- LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON + (16#001E8#, 16#001E8#), -- LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON + (16#001EA#, 16#001EA#), -- LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK + (16#001EC#, 16#001EC#), -- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON + (16#001EE#, 16#001EE#), -- LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON + (16#001F1#, 16#001F1#), -- LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ + (16#001F4#, 16#001F4#), -- LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE + (16#001F8#, 16#001F8#), -- LATIN CAPITAL LETTER N WITH GRAVE .. LATIN CAPITAL LETTER N WITH GRAVE + (16#001FA#, 16#001FA#), -- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE + (16#001FC#, 16#001FC#), -- LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE + (16#001FE#, 16#001FE#), -- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE + (16#00200#, 16#00200#), -- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE + (16#00202#, 16#00202#), -- LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE + (16#00204#, 16#00204#), -- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE + (16#00206#, 16#00206#), -- LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE + (16#00208#, 16#00208#), -- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE + (16#0020A#, 16#0020A#), -- LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE + (16#0020C#, 16#0020C#), -- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE + (16#0020E#, 16#0020E#), -- LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE + (16#00210#, 16#00210#), -- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE + (16#00212#, 16#00212#), -- LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE + (16#00214#, 16#00214#), -- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE + (16#00216#, 16#00216#), -- LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE + (16#00218#, 16#00218#), -- LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW + (16#0021A#, 16#0021A#), -- LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW + (16#0021C#, 16#0021C#), -- LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH + (16#0021E#, 16#0021E#), -- LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON + (16#00220#, 16#00220#), -- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG + (16#00222#, 16#00222#), -- LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU + (16#00224#, 16#00224#), -- LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK + (16#00226#, 16#00226#), -- LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE + (16#00228#, 16#00228#), -- LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA + (16#0022A#, 16#0022A#), -- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON + (16#0022C#, 16#0022C#), -- LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON + (16#0022E#, 16#0022E#), -- LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE + (16#00230#, 16#00230#), -- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON + (16#00232#, 16#00232#), -- LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON + (16#00386#, 16#00386#), -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS + (16#00388#, 16#0038A#), -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS + (16#0038C#, 16#0038C#), -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS + (16#0038E#, 16#0038F#), -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS + (16#00391#, 16#003A1#), -- GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO + (16#003A3#, 16#003AB#), -- GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA + (16#003DA#, 16#003DA#), -- GREEK CAPITAL LETTER STIGMA .. GREEK CAPITAL LETTER STIGMA + (16#003DC#, 16#003DC#), -- GREEK CAPITAL LETTER DIGAMMA .. GREEK CAPITAL LETTER DIGAMMA + (16#003DE#, 16#003DE#), -- GREEK CAPITAL LETTER KOPPA .. GREEK CAPITAL LETTER KOPPA + (16#003E0#, 16#003E0#), -- GREEK CAPITAL LETTER SAMPI .. GREEK CAPITAL LETTER SAMPI + (16#003E2#, 16#003E2#), -- COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI + (16#003E4#, 16#003E4#), -- COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI + (16#003E6#, 16#003E6#), -- COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI + (16#003E8#, 16#003E8#), -- COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI + (16#003EA#, 16#003EA#), -- COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA + (16#003EC#, 16#003EC#), -- COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA + (16#003EE#, 16#003EE#), -- COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI + (16#003F7#, 16#003F7#), -- GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO + (16#003FA#, 16#003FA#), -- GREEK CAPITAL LETTER SAN .. GREEK CAPITAL LETTER SAN + (16#00400#, 16#0040F#), -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER DZHE + (16#00410#, 16#0042F#), -- CYRILLIC CAPITAL LETTER A .. CYRILLIC CAPITAL LETTER YA + (16#00460#, 16#00460#), -- CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA + (16#00462#, 16#00462#), -- CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT + (16#00464#, 16#00464#), -- CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E + (16#00466#, 16#00466#), -- CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS + (16#00468#, 16#00468#), -- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS + (16#0046A#, 16#0046A#), -- CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS + (16#0046C#, 16#0046C#), -- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS + (16#0046E#, 16#0046E#), -- CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI + (16#00470#, 16#00470#), -- CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI + (16#00472#, 16#00472#), -- CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA + (16#00474#, 16#00474#), -- CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA + (16#00476#, 16#00476#), -- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + (16#00478#, 16#00478#), -- CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK + (16#0047A#, 16#0047A#), -- CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA + (16#0047C#, 16#0047C#), -- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO + (16#0047E#, 16#0047E#), -- CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT + (16#00480#, 16#00480#), -- CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA + (16#0048A#, 16#0048A#), -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL + (16#0048C#, 16#0048C#), -- CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN + (16#0048E#, 16#0048E#), -- CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK + (16#00490#, 16#00490#), -- CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN + (16#00492#, 16#00492#), -- CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE + (16#00494#, 16#00494#), -- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK + (16#00496#, 16#00496#), -- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER + (16#00498#, 16#00498#), -- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER + (16#0049A#, 16#0049A#), -- CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER + (16#0049C#, 16#0049C#), -- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE + (16#0049E#, 16#0049E#), -- CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE + (16#004A0#, 16#004A0#), -- CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA + (16#004A2#, 16#004A2#), -- CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER + (16#004A4#, 16#004A4#), -- CYRILLIC CAPITAL LETTER EN GE .. CYRILLIC CAPITAL LETTER EN GE + (16#004A6#, 16#004A6#), -- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK + (16#004A8#, 16#004A8#), -- CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA + (16#004AA#, 16#004AA#), -- CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER + (16#004AC#, 16#004AC#), -- CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER + (16#004AE#, 16#004AE#), -- CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U + (16#004B0#, 16#004B0#), -- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE + (16#004B2#, 16#004B2#), -- CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER + (16#004B4#, 16#004B4#), -- CYRILLIC CAPITAL LETTER TE TSE .. CYRILLIC CAPITAL LETTER TE TSE + (16#004B6#, 16#004B6#), -- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER + (16#004B8#, 16#004B8#), -- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE + (16#004BA#, 16#004BA#), -- CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA + (16#004BC#, 16#004BC#), -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE + (16#004BE#, 16#004BE#), -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER + (16#004C1#, 16#004C1#), -- CYRILLIC CAPITAL LETTER ZHE WITH BREVE .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE + (16#004C3#, 16#004C3#), -- CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK + (16#004C5#, 16#004C5#), -- CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL + (16#004C7#, 16#004C7#), -- CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK + (16#004C9#, 16#004C9#), -- CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL + (16#004CB#, 16#004CB#), -- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE + (16#004CD#, 16#004CD#), -- CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL + (16#004D0#, 16#004D0#), -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE + (16#004D2#, 16#004D2#), -- CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS + (16#004D6#, 16#004D6#), -- CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE + (16#004D8#, 16#004D8#), -- CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA + (16#004DA#, 16#004DA#), -- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS + (16#004DC#, 16#004DC#), -- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS + (16#004DE#, 16#004DE#), -- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS + (16#004E0#, 16#004E0#), -- CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE + (16#004E2#, 16#004E2#), -- CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON + (16#004E4#, 16#004E4#), -- CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS + (16#004E6#, 16#004E6#), -- CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS + (16#004E8#, 16#004E8#), -- CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O + (16#004EA#, 16#004EA#), -- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS + (16#004EC#, 16#004EC#), -- CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS + (16#004EE#, 16#004EE#), -- CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON + (16#004F0#, 16#004F0#), -- CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS + (16#004F2#, 16#004F2#), -- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE + (16#004F4#, 16#004F4#), -- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS + (16#004F8#, 16#004F8#), -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS + (16#00500#, 16#00500#), -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE + (16#00502#, 16#00502#), -- CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE + (16#00504#, 16#00504#), -- CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE + (16#00506#, 16#00506#), -- CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE + (16#00508#, 16#00508#), -- CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE + (16#0050A#, 16#0050A#), -- CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE + (16#0050C#, 16#0050C#), -- CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE + (16#0050E#, 16#0050E#), -- CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE + (16#00531#, 16#00556#), -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH + (16#010A0#, 16#010C5#), -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE + (16#01E00#, 16#01E00#), -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW + (16#01E02#, 16#01E02#), -- LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE + (16#01E04#, 16#01E04#), -- LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW + (16#01E06#, 16#01E06#), -- LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW + (16#01E08#, 16#01E08#), -- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE + (16#01E0A#, 16#01E0A#), -- LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE + (16#01E0C#, 16#01E0C#), -- LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW + (16#01E0E#, 16#01E0E#), -- LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW + (16#01E10#, 16#01E10#), -- LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA + (16#01E12#, 16#01E12#), -- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW + (16#01E14#, 16#01E14#), -- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE + (16#01E16#, 16#01E16#), -- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE + (16#01E18#, 16#01E18#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW + (16#01E1A#, 16#01E1A#), -- LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW + (16#01E1C#, 16#01E1C#), -- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE + (16#01E1E#, 16#01E1E#), -- LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE + (16#01E20#, 16#01E20#), -- LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON + (16#01E22#, 16#01E22#), -- LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE + (16#01E24#, 16#01E24#), -- LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW + (16#01E26#, 16#01E26#), -- LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS + (16#01E28#, 16#01E28#), -- LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA + (16#01E2A#, 16#01E2A#), -- LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW + (16#01E2C#, 16#01E2C#), -- LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW + (16#01E2E#, 16#01E2E#), -- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE + (16#01E30#, 16#01E30#), -- LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE + (16#01E32#, 16#01E32#), -- LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW + (16#01E34#, 16#01E34#), -- LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW + (16#01E36#, 16#01E36#), -- LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW + (16#01E38#, 16#01E38#), -- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON + (16#01E3A#, 16#01E3A#), -- LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW + (16#01E3C#, 16#01E3C#), -- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW + (16#01E3E#, 16#01E3E#), -- LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE + (16#01E40#, 16#01E40#), -- LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE + (16#01E42#, 16#01E42#), -- LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW + (16#01E44#, 16#01E44#), -- LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE + (16#01E46#, 16#01E46#), -- LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW + (16#01E48#, 16#01E48#), -- LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW + (16#01E4A#, 16#01E4A#), -- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW + (16#01E4C#, 16#01E4C#), -- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE + (16#01E4E#, 16#01E4E#), -- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS + (16#01E50#, 16#01E50#), -- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE + (16#01E52#, 16#01E52#), -- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE + (16#01E54#, 16#01E54#), -- LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE + (16#01E56#, 16#01E56#), -- LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE + (16#01E58#, 16#01E58#), -- LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE + (16#01E5A#, 16#01E5A#), -- LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW + (16#01E5C#, 16#01E5C#), -- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON + (16#01E5E#, 16#01E5E#), -- LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW + (16#01E60#, 16#01E60#), -- LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE + (16#01E62#, 16#01E62#), -- LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW + (16#01E64#, 16#01E64#), -- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE + (16#01E66#, 16#01E66#), -- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE + (16#01E68#, 16#01E68#), -- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE + (16#01E6A#, 16#01E6A#), -- LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE + (16#01E6C#, 16#01E6C#), -- LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW + (16#01E6E#, 16#01E6E#), -- LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW + (16#01E70#, 16#01E70#), -- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW + (16#01E72#, 16#01E72#), -- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW + (16#01E74#, 16#01E74#), -- LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW + (16#01E76#, 16#01E76#), -- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW + (16#01E78#, 16#01E78#), -- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE + (16#01E7A#, 16#01E7A#), -- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS + (16#01E7C#, 16#01E7C#), -- LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE + (16#01E7E#, 16#01E7E#), -- LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW + (16#01E80#, 16#01E80#), -- LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE + (16#01E82#, 16#01E82#), -- LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE + (16#01E84#, 16#01E84#), -- LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS + (16#01E86#, 16#01E86#), -- LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE + (16#01E88#, 16#01E88#), -- LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW + (16#01E8A#, 16#01E8A#), -- LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE + (16#01E8C#, 16#01E8C#), -- LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS + (16#01E8E#, 16#01E8E#), -- LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE + (16#01E90#, 16#01E90#), -- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX + (16#01E92#, 16#01E92#), -- LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW + (16#01E94#, 16#01E94#), -- LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW + (16#01EA0#, 16#01EA0#), -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW + (16#01EA2#, 16#01EA2#), -- LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE + (16#01EA4#, 16#01EA4#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE + (16#01EA6#, 16#01EA6#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE + (16#01EA8#, 16#01EA8#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EAA#, 16#01EAA#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE + (16#01EAC#, 16#01EAC#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW + (16#01EAE#, 16#01EAE#), -- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE + (16#01EB0#, 16#01EB0#), -- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE + (16#01EB2#, 16#01EB2#), -- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE + (16#01EB4#, 16#01EB4#), -- LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE + (16#01EB6#, 16#01EB6#), -- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW + (16#01EB8#, 16#01EB8#), -- LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW + (16#01EBA#, 16#01EBA#), -- LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE + (16#01EBC#, 16#01EBC#), -- LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE + (16#01EBE#, 16#01EBE#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE + (16#01EC0#, 16#01EC0#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE + (16#01EC2#, 16#01EC2#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EC4#, 16#01EC4#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE + (16#01EC6#, 16#01EC6#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW + (16#01EC8#, 16#01EC8#), -- LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE + (16#01ECA#, 16#01ECA#), -- LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW + (16#01ECC#, 16#01ECC#), -- LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW + (16#01ECE#, 16#01ECE#), -- LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE + (16#01ED0#, 16#01ED0#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE + (16#01ED2#, 16#01ED2#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE + (16#01ED4#, 16#01ED4#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + (16#01ED6#, 16#01ED6#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE + (16#01ED8#, 16#01ED8#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW + (16#01EDA#, 16#01EDA#), -- LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE + (16#01EDC#, 16#01EDC#), -- LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE + (16#01EDE#, 16#01EDE#), -- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE + (16#01EE0#, 16#01EE0#), -- LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE + (16#01EE2#, 16#01EE2#), -- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW + (16#01EE4#, 16#01EE4#), -- LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW + (16#01EE6#, 16#01EE6#), -- LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE + (16#01EE8#, 16#01EE8#), -- LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE + (16#01EEA#, 16#01EEA#), -- LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE + (16#01EEC#, 16#01EEC#), -- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE + (16#01EEE#, 16#01EEE#), -- LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE + (16#01EF0#, 16#01EF0#), -- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW + (16#01EF2#, 16#01EF2#), -- LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE + (16#01EF4#, 16#01EF4#), -- LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW + (16#01EF6#, 16#01EF6#), -- LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE + (16#01EF8#, 16#01EF8#), -- LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE + (16#01F08#, 16#01F0F#), -- GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI + (16#01F18#, 16#01F1D#), -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA + (16#01F28#, 16#01F2F#), -- GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI + (16#01F38#, 16#01F3F#), -- GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI + (16#01F48#, 16#01F4D#), -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA + (16#01F59#, 16#01F59#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA + (16#01F5B#, 16#01F5B#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA + (16#01F5D#, 16#01F5D#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA + (16#01F5F#, 16#01F5F#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI + (16#01F68#, 16#01F6F#), -- GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI + (16#01FB8#, 16#01FB9#), -- GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH MACRON + (16#01FBA#, 16#01FBB#), -- GREEK CAPITAL LETTER ALPHA WITH VARIA .. GREEK CAPITAL LETTER ALPHA WITH OXIA + (16#01FC8#, 16#01FCB#), -- GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA + (16#01FD8#, 16#01FD9#), -- GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH MACRON + (16#01FDA#, 16#01FDB#), -- GREEK CAPITAL LETTER IOTA WITH VARIA .. GREEK CAPITAL LETTER IOTA WITH OXIA + (16#01FE8#, 16#01FE9#), -- GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER UPSILON WITH MACRON + (16#01FEA#, 16#01FEB#), -- GREEK CAPITAL LETTER UPSILON WITH VARIA .. GREEK CAPITAL LETTER UPSILON WITH OXIA + (16#01FEC#, 16#01FEC#), -- GREEK CAPITAL LETTER RHO WITH DASIA .. GREEK CAPITAL LETTER RHO WITH DASIA + (16#01FF8#, 16#01FF9#), -- GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMICRON WITH OXIA + (16#01FFA#, 16#01FFB#), -- GREEK CAPITAL LETTER OMEGA WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA + (16#024B6#, 16#024CF#), -- CIRCLED LATIN CAPITAL LETTER A .. CIRCLED LATIN CAPITAL LETTER Z + (16#0FF21#, 16#0FF3A#), -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z + (16#10400#, 16#10427#), -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW + (16#E0041#, 16#E005A#)); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z + + Upper_Case_Adjust : constant array (Lower_Case_Letters'Range) + of UTF_32'Base := ( + 32, -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z + 32, -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS + 32, -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN + 1, -- LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON + 1, -- LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE + 1, -- LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK + 1, -- LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE + 1, -- LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON + 1, -- LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON + 1, -- LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE + 1, -- LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON + 1, -- LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE + 1, -- LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK + 1, -- LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON + 1, -- LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE + 1, -- LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA + 1, -- LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE + 1, -- LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE + 1, -- LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON + 1, -- LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE + 1, -- LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK + 1, -- LATIN CAPITAL LETTER I J .. LATIN CAPITAL LETTER I J + 1, -- LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA + 1, -- LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE + 1, -- LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA + 1, -- LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON + 1, -- LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT + 1, -- LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE + 1, -- LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE + 1, -- LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA + 1, -- LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON + 1, -- LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG + 1, -- LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON + 1, -- LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE + 1, -- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE + 1, -- LATIN CAPITAL LETTER O E .. LATIN CAPITAL LETTER O E + 1, -- LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE + 1, -- LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA + 1, -- LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON + 1, -- LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE + 1, -- LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA + 1, -- LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON + 1, -- LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA + 1, -- LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON + 1, -- LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE + 1, -- LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE + 1, -- LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON + 1, -- LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE + 1, -- LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE + 1, -- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE + 1, -- LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK + 1, -- LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX + -121, -- LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Y WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER Z WITH ACUTE .. LATIN CAPITAL LETTER Z WITH ACUTE + 1, -- LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON + 210, -- LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH HOOK + 1, -- LATIN CAPITAL LETTER B WITH TOPBAR .. LATIN CAPITAL LETTER B WITH TOPBAR + 1, -- LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX + 206, -- LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER OPEN O + 1, -- LATIN CAPITAL LETTER C WITH HOOK .. LATIN CAPITAL LETTER C WITH HOOK + 205, -- LATIN CAPITAL LETTER D WITH HOOK .. LATIN CAPITAL LETTER D WITH HOOK + 1, -- LATIN CAPITAL LETTER D WITH TOPBAR .. LATIN CAPITAL LETTER D WITH TOPBAR + 202, -- LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER SCHWA + 203, -- LATIN CAPITAL LETTER OPEN E .. LATIN CAPITAL LETTER OPEN E + 1, -- LATIN CAPITAL LETTER F WITH HOOK .. LATIN CAPITAL LETTER F WITH HOOK + 205, -- LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER G WITH HOOK + 207, -- LATIN CAPITAL LETTER GAMMA .. LATIN CAPITAL LETTER GAMMA + 211, -- LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER IOTA + 209, -- LATIN CAPITAL LETTER I WITH STROKE .. LATIN CAPITAL LETTER I WITH STROKE + 1, -- LATIN CAPITAL LETTER K WITH HOOK .. LATIN CAPITAL LETTER K WITH HOOK + 211, -- LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER TURNED M + 213, -- LATIN CAPITAL LETTER N WITH LEFT HOOK .. LATIN CAPITAL LETTER N WITH LEFT HOOK + 1, -- LATIN CAPITAL LETTER O WITH HORN .. LATIN CAPITAL LETTER O WITH HORN + 1, -- LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI + 1, -- LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK + 1, -- LATIN CAPITAL LETTER TONE TWO .. LATIN CAPITAL LETTER TONE TWO + 218, -- LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH + 1, -- LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK + 218, -- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER T WITH RETROFLEX HOOK + 1, -- LATIN CAPITAL LETTER U WITH HORN .. LATIN CAPITAL LETTER U WITH HORN + 217, -- LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER V WITH HOOK + 1, -- LATIN CAPITAL LETTER Y WITH HOOK .. LATIN CAPITAL LETTER Y WITH HOOK + 1, -- LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE + 219, -- LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH + 1, -- LATIN CAPITAL LETTER EZH REVERSED .. LATIN CAPITAL LETTER EZH REVERSED + 1, -- LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE + 2, -- LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON + 2, -- LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ + 2, -- LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ + 1, -- LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON + 1, -- LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON + 1, -- LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON + 1, -- LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE + 1, -- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON + 1, -- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON + 1, -- LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON + 1, -- LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE + 1, -- LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON + 1, -- LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON + 1, -- LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK + 1, -- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON + 1, -- LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON + 2, -- LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ + 1, -- LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE + 1, -- LATIN CAPITAL LETTER N WITH GRAVE .. LATIN CAPITAL LETTER N WITH GRAVE + 1, -- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE + 1, -- LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE + 1, -- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE + 1, -- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW + 1, -- LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW + 1, -- LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH + 1, -- LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON + -130, -- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG + 1, -- LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU + 1, -- LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK + 1, -- LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA + 1, -- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON + 1, -- LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON + 1, -- LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON + 1, -- LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON + 38, -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS + 37, -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS + 64, -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS + 63, -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS + 32, -- GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO + 32, -- GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA + 1, -- GREEK CAPITAL LETTER STIGMA .. GREEK CAPITAL LETTER STIGMA + 1, -- GREEK CAPITAL LETTER DIGAMMA .. GREEK CAPITAL LETTER DIGAMMA + 1, -- GREEK CAPITAL LETTER KOPPA .. GREEK CAPITAL LETTER KOPPA + 1, -- GREEK CAPITAL LETTER SAMPI .. GREEK CAPITAL LETTER SAMPI + 1, -- COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI + 1, -- COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI + 1, -- COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI + 1, -- COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI + 1, -- COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA + 1, -- COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA + 1, -- COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI + 1, -- GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO + 1, -- GREEK CAPITAL LETTER SAN .. GREEK CAPITAL LETTER SAN + 80, -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER DZHE + 32, -- CYRILLIC CAPITAL LETTER A .. CYRILLIC CAPITAL LETTER YA + 1, -- CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA + 1, -- CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT + 1, -- CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E + 1, -- CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS + 1, -- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS + 1, -- CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS + 1, -- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS + 1, -- CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI + 1, -- CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI + 1, -- CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA + 1, -- CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA + 1, -- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + 1, -- CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK + 1, -- CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA + 1, -- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO + 1, -- CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT + 1, -- CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA + 1, -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN + 1, -- CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK + 1, -- CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN + 1, -- CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE + 1, -- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK + 1, -- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE + 1, -- CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE + 1, -- CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA + 1, -- CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER EN GE .. CYRILLIC CAPITAL LETTER EN GE + 1, -- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA + 1, -- CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U + 1, -- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE + 1, -- CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER TE TSE .. CYRILLIC CAPITAL LETTER TE TSE + 1, -- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE + 1, -- CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER ZHE WITH BREVE .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE + 1, -- CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK + 1, -- CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK + 1, -- CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE + 1, -- CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE + 1, -- CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE + 1, -- CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA + 1, -- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE + 1, -- CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON + 1, -- CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O + 1, -- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON + 1, -- CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE + 1, -- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE + 1, -- CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE + 1, -- CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE + 1, -- CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE + 1, -- CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE + 1, -- CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE + 1, -- CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE + 1, -- CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE + 48, -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH + 48, -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE + 1, -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW + 1, -- LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE + 1, -- LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA + 1, -- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE + 1, -- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW + 1, -- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE + 1, -- LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON + 1, -- LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA + 1, -- LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW + 1, -- LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW + 1, -- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE + 1, -- LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE + 1, -- LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON + 1, -- LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE + 1, -- LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE + 1, -- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS + 1, -- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE + 1, -- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE + 1, -- LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE + 1, -- LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON + 1, -- LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE + 1, -- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE + 1, -- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE + 1, -- LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW + 1, -- LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW + 1, -- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE + 1, -- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS + 1, -- LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE + 1, -- LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE + 1, -- LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE + 1, -- LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW + 1, -- LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW + 1, -- LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW + 1, -- LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW + 1, -- LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW + 1, -- LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE + 1, -- LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE + -8, -- GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA + -8, -- GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH MACRON + -74, -- GREEK CAPITAL LETTER ALPHA WITH VARIA .. GREEK CAPITAL LETTER ALPHA WITH OXIA + -86, -- GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA + -8, -- GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH MACRON + -100, -- GREEK CAPITAL LETTER IOTA WITH VARIA .. GREEK CAPITAL LETTER IOTA WITH OXIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER UPSILON WITH MACRON + -112, -- GREEK CAPITAL LETTER UPSILON WITH VARIA .. GREEK CAPITAL LETTER UPSILON WITH OXIA + -7, -- GREEK CAPITAL LETTER RHO WITH DASIA .. GREEK CAPITAL LETTER RHO WITH DASIA + -128, -- GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMICRON WITH OXIA + -126, -- GREEK CAPITAL LETTER OMEGA WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA + 26, -- CIRCLED LATIN CAPITAL LETTER A .. CIRCLED LATIN CAPITAL LETTER Z + 32, -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z + 40, -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW + 32); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z + + -- The following is a list of the 10646 names for CAPITAL LETTER entries + -- that have no matching SMALL LETTER entry and are thus not folded + + -- LATIN CAPITAL LETTER I WITH DOT ABOVE + -- LATIN CAPITAL LETTER AFRICAN D + -- LATIN CAPITAL LETTER O WITH MIDDLE TILDE + -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON + -- LATIN CAPITAL LETTER L WITH SMALL LETTER J + -- LATIN CAPITAL LETTER N WITH SMALL LETTER J + -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z + -- LATIN CAPITAL LETTER HWAIR + -- LATIN CAPITAL LETTER WYNN + -- GREEK CAPITAL LETTER UPSILON HOOK + -- GREEK CAPITAL LETTER UPSILON HOOK TONOS + -- GREEK CAPITAL LETTER UPSILON HOOK DIAERESIS + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI ----------------------- -- Local Subprograms -- *************** package body System.UTF_32 is *** 5290,5295 **** --- 6311,6330 ---- end Range_Search; -------------------------- + -- UTF_32_To_Lower_Case -- + -------------------------- + + function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32 is + Index : constant Integer := Range_Search (U, Upper_Case_Letters); + begin + if Index = 0 then + return U; + else + return U + Upper_Case_Adjust (Index); + end if; + end UTF_32_To_Lower_Case; + + -------------------------- -- UTF_32_To_Upper_Case -- -------------------------- *************** package body System.UTF_32 is *** 5299,5305 **** if Index = 0 then return U; else ! return U + Upper_Case_Adjust (Index); end if; end UTF_32_To_Upper_Case; --- 6334,6340 ---- if Index = 0 then return U; else ! return U + Lower_Case_Adjust (Index); end if; end UTF_32_To_Upper_Case; diff -Nrcpad gcc-4.5.2/gcc/ada/s-utf_32.ads gcc-4.6.0/gcc/ada/s-utf_32.ads *** gcc-4.5.2/gcc/ada/s-utf_32.ads Fri Apr 17 13:07:12 2009 --- gcc-4.6.0/gcc/ada/s-utf_32.ads Thu Oct 7 09:16:06 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2005-2010, 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- -- *************** package System.UTF_32 is *** 185,197 **** -- The following function is used to fold to upper case, as required by -- the Ada 2005 standard rules for identifier case folding. Two -- identifiers are equivalent if they are identical after folding all ! -- letters to upper case using this routine. function UTF_32_To_Upper_Case (U : UTF_32) return UTF_32; pragma Inline (UTF_32_To_Upper_Case); ! -- If U represents a lower case letter, returns the corresponding upper ! -- case letter, otherwise U is returned unchanged. The folding is locale ! -- independent as defined by documents referenced in the note in section ! -- 1 of ISO/IEC 10646:2003 end System.UTF_32; --- 185,211 ---- -- The following function is used to fold to upper case, as required by -- the Ada 2005 standard rules for identifier case folding. Two -- identifiers are equivalent if they are identical after folding all ! -- letters to upper case using this routine. A corresponding routine to ! -- fold to lower case is also provided. ! ! function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32; ! pragma Inline (UTF_32_To_Lower_Case); ! -- If U represents an upper case letter, returns the corresponding lower ! -- case letter, otherwise U is returned unchanged. The folding rule is ! -- simply that if the code corresponds to a 10646 entry whose name contains ! -- the string CAPITAL LETTER, and there is a corresponding entry whose name ! -- is the same but with CAPITAL LETTER replaced by SMALL LETTER, then the ! -- code is folded to this SMALL LETTER code. Otherwise the input code is ! -- returned unchanged. function UTF_32_To_Upper_Case (U : UTF_32) return UTF_32; pragma Inline (UTF_32_To_Upper_Case); ! -- If U represents a lower case letter, returns the corresponding lower ! -- case letter, otherwise U is returned unchanged. The folding rule is ! -- simply that if the code corresponds to a 10646 entry whose name contains ! -- the string SMALL LETTER, and there is a corresponding entry whose name ! -- is the same but with SMALL LETTER replaced by CAPITAL LETTER, then the ! -- code is folded to this CAPITAL LETTER code. Otherwise the input code is ! -- returned unchanged. end System.UTF_32; diff -Nrcpad gcc-4.5.2/gcc/ada/s-valcha.adb gcc-4.6.0/gcc/ada/s-valcha.adb *** gcc-4.5.2/gcc/ada/s-valcha.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/s-valcha.adb Fri Oct 8 12:34:08 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body System.Val_Char is *** 65,70 **** --- 65,74 ---- end if; end loop; + if S (F .. L) = "SOFT_HYPHEN" then + return Character'Val (16#AD#); + end if; + raise Constraint_Error; end if; end Value_Character; diff -Nrcpad gcc-4.5.2/gcc/ada/s-vxwext-kernel.ads gcc-4.6.0/gcc/ada/s-vxwext-kernel.ads *** gcc-4.5.2/gcc/ada/s-vxwext-kernel.ads Wed Jul 22 15:13:23 2009 --- gcc-4.6.0/gcc/ada/s-vxwext-kernel.ads Tue Oct 5 09:37:44 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.VxWorks.Ext is *** 39,44 **** --- 39,46 ---- subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Long_Long_Integer'Size; + type t_id is new Long_Integer; subtype int is Interfaces.C.int; *************** package System.VxWorks.Ext is *** 59,64 **** --- 61,69 ---- Parameter : System.Address := System.Null_Address) return int; pragma Import (C, Interrupt_Connect, "intConnect"); + function Interrupt_Context return int; + pragma Import (C, Interrupt_Context, "intContext"); + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec"); diff -Nrcpad gcc-4.5.2/gcc/ada/s-vxwext-rtp.adb gcc-4.6.0/gcc/ada/s-vxwext-rtp.adb *** gcc-4.5.2/gcc/ada/s-vxwext-rtp.adb Wed Jun 24 09:41:39 2009 --- gcc-4.6.0/gcc/ada/s-vxwext-rtp.adb Mon Oct 18 09:37:14 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** *** 26,32 **** -- -- ------------------------------------------------------------------------------ ! -- This package provides vxworks specific support functions needed -- by System.OS_Interface. -- This is the VxWorks 6 RTP version of this package --- 26,32 ---- -- -- ------------------------------------------------------------------------------ ! -- This package provides VxWorks specific support functions needed -- by System.OS_Interface. -- This is the VxWorks 6 RTP version of this package *************** package body System.VxWorks.Ext is *** 53,84 **** return ERROR; end Int_Unlock; ! -------------------- ! -- Set_Time_Slice -- ! -------------------- ! ! function Set_Time_Slice (ticks : int) return int is ! pragma Unreferenced (ticks); ! begin ! return ERROR; ! end Set_Time_Slice; function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; ! Parameter : System.Address := System.Null_Address) return int is pragma Unreferenced (Vector, Handler, Parameter); begin return ERROR; end Interrupt_Connect; function Interrupt_Number_To_Vector ! (intNum : int) return Interrupt_Vector is pragma Unreferenced (intNum); begin return 0; end Interrupt_Number_To_Vector; ------------------------ -- taskCpuAffinitySet -- ------------------------ --- 53,116 ---- return ERROR; end Int_Unlock; ! ----------------------- ! -- Interrupt_Connect -- ! ----------------------- function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; ! Parameter : System.Address := System.Null_Address) return int ! is pragma Unreferenced (Vector, Handler, Parameter); begin return ERROR; end Interrupt_Connect; + ----------------------- + -- Interrupt_Context -- + ----------------------- + + function Interrupt_Context return int is + begin + -- For RTPs, never in an interrupt context + + return 0; + end Interrupt_Context; + + -------------------------------- + -- Interrupt_Number_To_Vector -- + -------------------------------- + function Interrupt_Number_To_Vector ! (intNum : int) return Interrupt_Vector ! is pragma Unreferenced (intNum); begin return 0; end Interrupt_Number_To_Vector; + --------------- + -- semDelete -- + --------------- + + function semDelete (Sem : SEM_ID) return int is + function OS_semDelete (Sem : SEM_ID) return int; + pragma Import (C, OS_semDelete, "semDelete"); + begin + return OS_semDelete (Sem); + end semDelete; + + -------------------- + -- Set_Time_Slice -- + -------------------- + + function Set_Time_Slice (ticks : int) return int is + pragma Unreferenced (ticks); + begin + return ERROR; + end Set_Time_Slice; + ------------------------ -- taskCpuAffinitySet -- ------------------------ diff -Nrcpad gcc-4.5.2/gcc/ada/s-vxwext-rtp.ads gcc-4.6.0/gcc/ada/s-vxwext-rtp.ads *** gcc-4.5.2/gcc/ada/s-vxwext-rtp.ads Thu Jun 25 08:24:34 2009 --- gcc-4.6.0/gcc/ada/s-vxwext-rtp.ads Mon Oct 18 09:37:14 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.VxWorks.Ext is *** 39,44 **** --- 39,46 ---- subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Long_Long_Integer'Size; + type t_id is new Long_Integer; subtype int is Interfaces.C.int; *************** package System.VxWorks.Ext is *** 59,70 **** Parameter : System.Address := System.Null_Address) return int; pragma Convention (C, Interrupt_Connect); function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Convention (C, Interrupt_Number_To_Vector); function semDelete (Sem : SEM_ID) return int; ! pragma Import (C, semDelete, "semDelete"); function Task_Cont (tid : t_id) return int; pragma Import (C, Task_Cont, "taskResume"); --- 61,75 ---- Parameter : System.Address := System.Null_Address) return int; pragma Convention (C, Interrupt_Connect); + function Interrupt_Context return int; + pragma Convention (C, Interrupt_Context); + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Convention (C, Interrupt_Number_To_Vector); function semDelete (Sem : SEM_ID) return int; ! pragma Convention (C, semDelete); function Task_Cont (tid : t_id) return int; pragma Import (C, Task_Cont, "taskResume"); diff -Nrcpad gcc-4.5.2/gcc/ada/s-vxwext.ads gcc-4.6.0/gcc/ada/s-vxwext.ads *** gcc-4.5.2/gcc/ada/s-vxwext.ads Mon Nov 30 16:21:19 2009 --- gcc-4.6.0/gcc/ada/s-vxwext.ads Tue Oct 5 09:37:44 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- *************** package System.VxWorks.Ext is *** 39,45 **** --- 39,48 ---- subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Interfaces.C.long'Size; + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; type Interrupt_Handler is access procedure (parameter : System.Address); *************** package System.VxWorks.Ext is *** 59,64 **** --- 62,70 ---- Parameter : System.Address := System.Null_Address) return int; pragma Import (C, Interrupt_Connect, "intConnect"); + function Interrupt_Context return int; + pragma Import (C, Interrupt_Context, "intContext"); + function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec"); diff -Nrcpad gcc-4.5.2/gcc/ada/scans.adb gcc-4.6.0/gcc/ada/scans.adb *** gcc-4.5.2/gcc/ada/scans.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/scans.adb Tue Oct 19 12:29:25 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Scans is *** 118,123 **** --- 118,130 ---- Set_Reserved (Name_Reverse, Tok_Reverse); Set_Reserved (Name_Select, Tok_Select); Set_Reserved (Name_Separate, Tok_Separate); + + -- We choose to make Some into a non-reserved word, so it is handled + -- like a regular identifier in most contexts. Uncomment the following + -- line if a pedantic Ada2012 mode is required. + + -- Set_Reserved (Name_Some, Tok_Some); + Set_Reserved (Name_Subtype, Tok_Subtype); Set_Reserved (Name_Tagged, Tok_Tagged); Set_Reserved (Name_Task, Tok_Task); diff -Nrcpad gcc-4.5.2/gcc/ada/scans.ads gcc-4.6.0/gcc/ada/scans.ads *** gcc-4.5.2/gcc/ada/scans.ads Mon Nov 30 14:09:30 2009 --- gcc-4.6.0/gcc/ada/scans.ads Tue Oct 19 12:29:25 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Scans is *** 130,135 **** --- 130,136 ---- Tok_Record, -- RECORD Eterm, Sterm Tok_Renames, -- RENAMES Eterm, Sterm Tok_Reverse, -- REVERSE Eterm, Sterm + Tok_Some, -- SOME Eterm, Sterm Tok_Tagged, -- TAGGED Eterm, Sterm Tok_Then, -- THEN Eterm, Sterm *************** package Scans is *** 192,198 **** Tok_Project, Tok_Extends, Tok_External, ! -- These three entries represent keywords for the project file language -- and can be returned only in the case of scanning project files. Tok_Comment, --- 193,200 ---- Tok_Project, Tok_Extends, Tok_External, ! Tok_External_As_List, ! -- These four entries represent keywords for the project file language -- and can be returned only in the case of scanning project files. Tok_Comment, *************** package Scans is *** 415,441 **** -- We do things this way to minimize the impact on comment scanning. Character_Code : Char_Code; ! -- Valid only when Token is Tok_Char_Literal Real_Literal_Value : Ureal; ! -- Valid only when Token is Tok_Real_Literal Int_Literal_Value : Uint; ! -- Valid only when Token = Tok_Integer_Literal; String_Literal_Id : String_Id; - -- Id for currently scanned string value. -- Valid only when Token = Tok_String_Literal or Tok_Operator_Symbol. Wide_Character_Found : Boolean := False; ! -- Set True if wide character found (i.e. a character that does not fit ! -- in Character, but fits in Wide_Wide_Character). ! -- Valid only when Token = Tok_String_Literal. Wide_Wide_Character_Found : Boolean := False; ! -- Set True if wide wide character found (i.e. a character that does ! -- not fit in Character or Wide_Character). ! -- Valid only when Token = Tok_String_Literal. Special_Character : Character; -- Valid only when Token = Tok_Special. Returns one of the characters --- 417,450 ---- -- We do things this way to minimize the impact on comment scanning. Character_Code : Char_Code; ! -- Valid only when Token is Tok_Char_Literal. Contains the value of the ! -- scanned literal. Real_Literal_Value : Ureal; ! -- Valid only when Token is Tok_Real_Literal, contains the value of the ! -- scanned literal. Int_Literal_Value : Uint; ! -- Valid only when Token = Tok_Integer_Literal, contains the value of the ! -- scanned literal. ! ! Based_Literal_Uses_Colon : Boolean; ! -- Valid only when Token = Tok_Integer_Literal or Tok_Real_Literal. Set ! -- True only for the case of a based literal using ':' instead of '#'. String_Literal_Id : String_Id; -- Valid only when Token = Tok_String_Literal or Tok_Operator_Symbol. + -- Contains the Id for currently scanned string value. Wide_Character_Found : Boolean := False; ! -- Valid only when Token = Tok_String_Literal. Set True if wide character ! -- found (i.e. a character that does not fit in Character, but fits in ! -- Wide_Wide_Character). Wide_Wide_Character_Found : Boolean := False; ! -- Valid only when Token = Tok_String_Literal. Set True if wide wide ! -- character found (i.e. a character that does not fit in Character or ! -- Wide_Character). Special_Character : Character; -- Valid only when Token = Tok_Special. Returns one of the characters diff -Nrcpad gcc-4.5.2/gcc/ada/scil_ll.adb gcc-4.6.0/gcc/ada/scil_ll.adb *** gcc-4.5.2/gcc/ada/scil_ll.adb Thu Jan 1 00:00:00 1970 --- gcc-4.6.0/gcc/ada/scil_ll.adb Wed Jun 23 06:50:13 2010 *************** *** 0 **** --- 1,144 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S C I L _ L L -- + -- -- + -- B o d y -- + -- -- + -- Copyright (C) 2010, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + with Alloc; use Alloc; + with Atree; use Atree; + with Opt; use Opt; + with Sinfo; use Sinfo; + with Table; + + package body SCIL_LL is + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id); + -- Copy the SCIL field from Source to Target (it is used as the argument + -- for a call to Set_Reporting_Proc in package atree). + + function SCIL_Nodes_Table_Size return Pos; + -- Used to initialize the table of SCIL nodes because we do not want + -- to consume memory for this table if it is not required. + + ---------------------------- + -- SCIL_Nodes_Table_Size -- + ---------------------------- + + function SCIL_Nodes_Table_Size return Pos is + begin + if Generate_SCIL then + return Alloc.Orig_Nodes_Initial; + else + return 1; + end if; + end SCIL_Nodes_Table_Size; + + package SCIL_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => SCIL_Nodes_Table_Size, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "SCIL_Nodes"); + -- This table records the value of attribute SCIL_Node of all the + -- tree nodes. + + -------------------- + -- Copy_SCIL_Node -- + -------------------- + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is + begin + Set_SCIL_Node (Target, Get_SCIL_Node (Source)); + end Copy_SCIL_Node; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SCIL_Nodes.Init; + Set_Reporting_Proc (Copy_SCIL_Node'Access); + end Initialize; + + ------------------- + -- Get_SCIL_Node -- + ------------------- + + function Get_SCIL_Node (N : Node_Id) return Node_Id is + begin + if Generate_SCIL + and then Present (N) + then + return SCIL_Nodes.Table (N); + else + return Empty; + end if; + end Get_SCIL_Node; + + ------------------- + -- Set_SCIL_Node -- + ------------------- + + procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is + begin + pragma Assert (Generate_SCIL); + + if Present (Value) then + case Nkind (Value) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; + + when N_SCIL_Dispatching_Call => + pragma Assert (Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement)); + null; + + when N_SCIL_Membership_Test => + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions)); + null; + + when others => + pragma Assert (False); + raise Program_Error; + end case; + end if; + + if Atree.Last_Node_Id > SCIL_Nodes.Last then + SCIL_Nodes.Set_Last (Atree.Last_Node_Id); + end if; + + SCIL_Nodes.Set_Item (N, Value); + end Set_SCIL_Node; + + end SCIL_LL; diff -Nrcpad gcc-4.5.2/gcc/ada/scil_ll.ads gcc-4.6.0/gcc/ada/scil_ll.ads *** gcc-4.5.2/gcc/ada/scil_ll.ads Thu Jan 1 00:00:00 1970 --- gcc-4.6.0/gcc/ada/scil_ll.ads Wed Jun 23 06:11:20 2010 *************** *** 0 **** --- 1,48 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- S C I L _ L L -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2010, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. -- + -- -- + -- As a special exception under Section 7 of GPL version 3, you are granted -- + -- additional permissions described in the GCC Runtime Library Exception, -- + -- version 3.1, as published by the Free Software Foundation. -- + -- -- + -- You should have received a copy of the GNU General Public License and -- + -- a copy of the GCC Runtime Library Exception along with this program; -- + -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- + -- . -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package extends the tree nodes with a field that is used to reference + -- the SCIL node. + + with Types; use Types; + + package SCIL_LL is + + function Get_SCIL_Node (N : Node_Id) return Node_Id; + -- Read the value of attribute SCIL node + + procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id); + -- Set the value of attribute SCIL node + + procedure Initialize; + -- Initialize the table of SCIL nodes + + end SCIL_LL; diff -Nrcpad gcc-4.5.2/gcc/ada/scn.adb gcc-4.6.0/gcc/ada/scn.adb *** gcc-4.5.2/gcc/ada/scn.adb Mon Nov 30 14:09:30 2009 --- gcc-4.6.0/gcc/ada/scn.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Scn is *** 44,53 **** use ASCII; - Obsolescent_Check_Flag : Boolean := True; - -- Obsolescent check activation. Set to False during integrated - -- preprocessing. - Used_As_Identifier : array (Token_Type) of Boolean; -- Flags set True if a given keyword is used as an identifier (used to -- make sure that we only post an error message for incorrect use of a --- 44,49 ---- *************** package body Scn is *** 340,367 **** end loop; end Initialize_Scanner; - ----------------------- - -- Obsolescent_Check -- - ----------------------- - - procedure Obsolescent_Check (S : Source_Ptr) is - begin - if Obsolescent_Check_Flag then - -- This is a pain in the neck case, since we normally need a node to - -- call Check_Restrictions, and all we have is a source pointer. The - -- easiest thing is to construct a dummy node. A bit kludgy, but this - -- is a marginal case. It's not worth trying to do things more - -- cleanly. - - Check_Restriction (No_Obsolescent_Features, New_Node (N_Empty, S)); - end if; - end Obsolescent_Check; - --------------- -- Post_Scan -- --------------- procedure Post_Scan is begin case Token is when Tok_Char_Literal => --- 336,396 ---- end loop; end Initialize_Scanner; --------------- -- Post_Scan -- --------------- procedure Post_Scan is + procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr); + -- This checks for Obsolescent_Features restriction being active, and + -- if so, flags the restriction as occurring at the given scan location. + + procedure Check_Obsolete_Base_Char; + -- Check for numeric literal using ':' instead of '#' for based case + + -------------------------------------------- + -- Check_Obsolescent_Features_Restriction -- + -------------------------------------------- + + procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr) is + begin + -- Normally we have a node handy for posting restrictions. We don't + -- have such a node here, so construct a dummy one with the right + -- scan pointer. This is only used to get the Sloc value anyway. + + Check_Restriction (No_Obsolescent_Features, New_Node (N_Empty, S)); + end Check_Obsolescent_Features_Restriction; + + ------------------------------ + -- Check_Obsolete_Base_Char -- + ------------------------------ + + procedure Check_Obsolete_Base_Char is + S : Source_Ptr; + + begin + if Based_Literal_Uses_Colon then + + -- Find the : for the restriction or warning message + + S := Token_Ptr; + while Source (S) /= ':' loop + S := S + 1; + end loop; + + Check_Obsolescent_Features_Restriction (S); + + if Warn_On_Obsolescent_Feature then + Error_Msg + ("use of "":"" is an obsolescent feature (RM J.2(3))?", S); + Error_Msg + ("\use ""'#"" instead?", S); + end if; + end if; + end Check_Obsolete_Base_Char; + + -- Start of processing for Post_Scan + begin case Token is when Tok_Char_Literal => *************** package body Scn is *** 376,385 **** --- 405,416 ---- when Tok_Real_Literal => Token_Node := New_Node (N_Real_Literal, Token_Ptr); Set_Realval (Token_Node, Real_Literal_Value); + Check_Obsolete_Base_Char; when Tok_Integer_Literal => Token_Node := New_Node (N_Integer_Literal, Token_Ptr); Set_Intval (Token_Node, Int_Literal_Value); + Check_Obsolete_Base_Char; when Tok_String_Literal => Token_Node := New_Node (N_String_Literal, Token_Ptr); *************** package body Scn is *** 389,399 **** --- 420,451 ---- (Token_Node, Wide_Wide_Character_Found); Set_Strval (Token_Node, String_Literal_Id); + if Source (Token_Ptr) = '%' then + Check_Obsolescent_Features_Restriction (Token_Ptr); + + if Warn_On_Obsolescent_Feature then + Error_Msg_SC + ("use of ""'%"" is an obsolescent feature (RM J.2(4))?"); + Error_Msg_SC ("\use """""" instead?"); + end if; + end if; + when Tok_Operator_Symbol => Token_Node := New_Node (N_Operator_Symbol, Token_Ptr); Set_Chars (Token_Node, Token_Name); Set_Strval (Token_Node, String_Literal_Id); + when Tok_Vertical_Bar => + if Source (Token_Ptr) = '!' then + Check_Obsolescent_Features_Restriction (Token_Ptr); + + if Warn_On_Obsolescent_Feature then + Error_Msg_SC + ("use of ""'!"" is an obsolescent feature (RM J.2(2))?"); + Error_Msg_SC ("\use ""'|"" instead?"); + end if; + end if; + when others => null; end case; *************** package body Scn is *** 420,428 **** Token_Name := Name_Find; if not Used_As_Identifier (Token) or else Force_Msg then ! Error_Msg_Name_1 := Token_Name; ! Error_Msg_SC ("reserved word* cannot be used as identifier!"); ! Used_As_Identifier (Token) := True; end if; Token := Tok_Identifier; --- 472,489 ---- Token_Name := Name_Find; if not Used_As_Identifier (Token) or else Force_Msg then ! ! -- If "some" is made into a reserved work in Ada2012, the following ! -- check will make it into a regular identifier in earlier versions ! -- of the language. ! ! if Token = Tok_Some and then Ada_Version < Ada_2012 then ! null; ! else ! Error_Msg_Name_1 := Token_Name; ! Error_Msg_SC ("reserved word* cannot be used as identifier!"); ! Used_As_Identifier (Token) := True; ! end if; end if; Token := Tok_Identifier; *************** package body Scn is *** 430,442 **** Set_Chars (Token_Node, Token_Name); end Scan_Reserved_Identifier; - --------------------------- - -- Set_Obsolescent_Check -- - --------------------------- - - procedure Set_Obsolescent_Check (Value : Boolean) is - begin - Obsolescent_Check_Flag := Value; - end Set_Obsolescent_Check; - end Scn; --- 491,494 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/scn.ads gcc-4.6.0/gcc/ada/scn.ads *** gcc-4.5.2/gcc/ada/scn.ads Fri Apr 10 13:32:09 2009 --- gcc-4.6.0/gcc/ada/scn.ads Thu Sep 9 12:31:35 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Scn is *** 47,61 **** -- Determines the casing style of the current token, which is -- either a keyword or an identifier. See also package Casing. - procedure Obsolescent_Check (S : Source_Ptr); - -- Called to handle pragma restrictions check for usage of obsolescent - -- character replacements during the scan. - - procedure Set_Obsolescent_Check (Value : Boolean); - -- Activate or not obsolescent check - procedure Post_Scan; - pragma Inline (Post_Scan); -- Create nodes for tokens: Char_Literal, Identifier, Real_Literal, -- Integer_Literal, String_Literal and Operator_Symbol. --- 47,53 ---- *************** package Scn is *** 75,87 **** -- generic package Scng with routines appropriate to the compiler package Scanner is new Scng ! (Post_Scan => Post_Scan, ! Error_Msg => Error_Msg, ! Error_Msg_S => Error_Msg_S, ! Error_Msg_SC => Error_Msg_SC, ! Error_Msg_SP => Error_Msg_SP, ! Obsolescent_Check => Obsolescent_Check, ! Style => Style.Style_Inst); procedure Scan renames Scanner.Scan; -- Scan scans out the next token, and advances the scan state accordingly --- 67,78 ---- -- generic package Scng with routines appropriate to the compiler package Scanner is new Scng ! (Post_Scan => Post_Scan, ! Error_Msg => Error_Msg, ! Error_Msg_S => Error_Msg_S, ! Error_Msg_SC => Error_Msg_SC, ! Error_Msg_SP => Error_Msg_SP, ! Style => Style.Style_Inst); procedure Scan renames Scanner.Scan; -- Scan scans out the next token, and advances the scan state accordingly diff -Nrcpad gcc-4.5.2/gcc/ada/scng.adb gcc-4.6.0/gcc/ada/scng.adb *** gcc-4.5.2/gcc/ada/scng.adb Mon Nov 30 14:09:30 2009 --- gcc-4.6.0/gcc/ada/scng.adb Tue Oct 26 13:15:05 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Uintp; use Uintp; *** 37,45 **** --- 37,48 ---- with Urealp; use Urealp; with Widechar; use Widechar; + pragma Warnings (Off); + -- This package is used also by gnatcoll with System.CRC32; with System.UTF_32; use System.UTF_32; with System.WCh_Con; use System.WCh_Con; + pragma Warnings (On); package body Scng is *************** package body Scng is *** 61,66 **** --- 64,85 ---- procedure Accumulate_Token_Checksum; pragma Inline (Accumulate_Token_Checksum); + -- Called after each numeric literal and identifier/keyword. For keywords, + -- the token used is Tok_Identifier. This allows to detect additional + -- spaces added in sources when using the builder switch -m. + + procedure Accumulate_Token_Checksum_GNAT_6_3; + -- Used in place of Accumulate_Token_Checksum for GNAT versions 5.04 to + -- 6.3, when Tok_Some was not included in Token_Type and the actual + -- Token_Type was used for keywords. This procedure is never used in the + -- compiler or gnatmake, only in gprbuild. + + procedure Accumulate_Token_Checksum_GNAT_5_03; + -- Used in place of Accumulate_Token_Checksum for GNAT version 5.03, when + -- Tok_Interface, Tok_Some, Tok_Synchronized and Tok_Overriding were not + -- included in Token_Type and the actual Token_Type was used for keywords. + -- This procedure is never used in the compiler or gnatmake, only in + -- gprbuild. procedure Accumulate_Checksum (C : Character); pragma Inline (Accumulate_Checksum); *************** package body Scng is *** 117,122 **** --- 136,262 ---- Character'Val (Token_Type'Pos (Token))); end Accumulate_Token_Checksum; + ---------------------------------------- + -- Accumulate_Token_Checksum_GNAT_6_3 -- + ---------------------------------------- + + procedure Accumulate_Token_Checksum_GNAT_6_3 is + begin + -- Individual values of Token_Type are used, instead of subranges, so + -- that additions or suppressions of enumerated values in type + -- Token_Type are detected by the compiler. + + case Token is + when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal | + Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier | + Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus | + Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New | + Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe | + Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range | + Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor | + Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal | + Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not | + Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater | + Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array | + Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is | + Tok_Interface | Tok_Limited | Tok_Of | Tok_Out | Tok_Record | + Tok_Renames | Tok_Reverse => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token))); + + when Tok_Some => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Tok_Identifier))); + + when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept | + Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End | + Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma | + Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select | + Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare | + Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected | + Tok_Task | Tok_Type | Tok_Subtype | Tok_Overriding | + Tok_Synchronized | Tok_Use | Tok_Function | Tok_Generic | + Tok_Package | Tok_Procedure | Tok_Private | Tok_With | + Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow | + Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends | + Tok_External | Tok_External_As_List | Tok_Comment | + Tok_End_Of_Line | Tok_Special | No_Token => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token_Type'Pred (Token)))); + end case; + end Accumulate_Token_Checksum_GNAT_6_3; + + ----------------------------------------- + -- Accumulate_Token_Checksum_GNAT_5_03 -- + ----------------------------------------- + + procedure Accumulate_Token_Checksum_GNAT_5_03 is + begin + -- Individual values of Token_Type are used, instead of subranges, so + -- that additions or suppressions of enumerated values in type + -- Token_Type are detected by the compiler. + + case Token is + when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal | + Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier | + Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus | + Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New | + Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe | + Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range | + Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor | + Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal | + Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not | + Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater | + Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array | + Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token))); + + when Tok_Interface | Tok_Some | Tok_Overriding | Tok_Synchronized => + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Tok_Identifier))); + + when Tok_Limited | Tok_Of | Tok_Out | Tok_Record | + Tok_Renames | Tok_Reverse => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token) - 1)); + + when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept | + Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End | + Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma | + Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select | + Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare | + Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected | + Tok_Task | Tok_Type | Tok_Subtype => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token) - 2)); + + when Tok_Use | Tok_Function | Tok_Generic | + Tok_Package | Tok_Procedure | Tok_Private | Tok_With | + Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow | + Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends | + Tok_External | Tok_External_As_List | Tok_Comment | + Tok_End_Of_Line | Tok_Special | No_Token => + + System.CRC32.Update + (System.CRC32.CRC32 (Checksum), + Character'Val (Token_Type'Pos (Token) - 4)); + end case; + end Accumulate_Token_Checksum_GNAT_5_03; + ---------------------------- -- Determine_Token_Casing -- ---------------------------- *************** package body Scng is *** 238,243 **** --- 378,391 ---- -- past the closing quote of the string literal, Token and Token_Node -- are set appropriately, and the checksum is updated. + procedure Skip_Other_Format_Characters; + -- Skips past any "other format" category characters at the current + -- cursor location (does not skip past spaces or any other characters). + + function Start_Of_Wide_Character return Boolean; + -- Returns True if the scan pointer is pointing to the start of a wide + -- character sequence, does not modify the scan pointer in any case. + ----------------------- -- Check_End_Of_Line -- ----------------------- *************** package body Scng is *** 325,331 **** and then Source (Scan_Ptr + 2) = C then Scan_Ptr := Scan_Ptr + 1; ! Error_Msg_S ("no space allowed here"); Scan_Ptr := Scan_Ptr + 2; return True; --- 473,480 ---- and then Source (Scan_Ptr + 2) = C then Scan_Ptr := Scan_Ptr + 1; ! Error_Msg_S -- CODEFIX ! ("no space allowed here"); Scan_Ptr := Scan_Ptr + 2; return True; *************** package body Scng is *** 380,395 **** Error_Msg_S -- CODEFIX ("two consecutive underlines not permitted"); else ! Error_Msg_S -- CODEFIX??? ! ("underline cannot follow punctuation character"); end if; else if Source (Scan_Ptr - 1) = '_' then ! Error_Msg_S -- CODEFIX??? ! ("punctuation character cannot follow underline"); else ! Error_Msg_S -- CODEFIX??? ("two consecutive punctuation characters not permitted"); end if; end if; --- 529,542 ---- Error_Msg_S -- CODEFIX ("two consecutive underlines not permitted"); else ! Error_Msg_S ("underline cannot follow punctuation character"); end if; else if Source (Scan_Ptr - 1) = '_' then ! Error_Msg_S ("punctuation character cannot follow underline"); else ! Error_Msg_S ("two consecutive punctuation characters not permitted"); end if; end if; *************** package body Scng is *** 514,519 **** --- 661,667 ---- Base := 10; UI_Base := Uint_10; UI_Int_Value := Uint_0; + Based_Literal_Uses_Colon := False; Scale := 0; Scan_Integer; Point_Scanned := False; *************** package body Scng is *** 566,586 **** or else Source (Scan_Ptr + 1) in 'a' .. 'z')) then - if C = ':' then - Obsolescent_Check (Scan_Ptr); - - if Warn_On_Obsolescent_Feature then - Error_Msg_S - ("use of "":"" is an obsolescent feature (RM J.2(3))?"); - Error_Msg_S - ("\use ""'#"" instead?"); - end if; - end if; - Accumulate_Checksum (C); Base_Char := C; UI_Base := UI_Int_Value; if UI_Base < 2 or else UI_Base > 16 then Error_Msg_SC ("base not 2-16"); UI_Base := Uint_16; --- 714,727 ---- or else Source (Scan_Ptr + 1) in 'a' .. 'z')) then Accumulate_Checksum (C); Base_Char := C; UI_Base := UI_Int_Value; + if Base_Char = ':' then + Based_Literal_Uses_Colon := True; + end if; + if UI_Base < 2 or else UI_Base > 16 then Error_Msg_SC ("base not 2-16"); UI_Base := Uint_16; *************** package body Scng is *** 658,666 **** elsif not Identifier_Char (C) then if Base_Char = '#' then ! Error_Msg_S ("missing '#"); else ! Error_Msg_S ("missing ':"); end if; exit; --- 799,809 ---- elsif not Identifier_Char (C) then if Base_Char = '#' then ! Error_Msg_S -- CODEFIX ! ("missing '#"); else ! Error_Msg_S -- CODEFIX ! ("missing ':"); end if; exit; *************** package body Scng is *** 749,755 **** end if; end if; ! Accumulate_Token_Checksum; return; end Nlit; --- 892,900 ---- end if; end if; ! if Checksum_Accumulate_Token_Checksum then ! Accumulate_Token_Checksum; ! end if; return; end Nlit; *************** package body Scng is *** 875,881 **** end if; end if; ! Error_Msg_S -- CODEFIX ("missing string quote"); end Error_Unterminated_String; --- 1020,1026 ---- end if; end if; ! Error_Msg_S -- CODEFIX ("missing string quote"); end Error_Unterminated_String; *************** package body Scng is *** 1042,1056 **** Code := Get_Char_Code (C); Scan_Ptr := Scan_Ptr + 1; ! elsif (C = ESC ! and then Wide_Character_Encoding_Method ! in WC_ESC_Encoding_Method) ! or else (C in Upper_Half_Character ! and then Upper_Half_Encoding) ! or else (C = '[' ! and then Source (Scan_Ptr + 1) = '"' ! and then Identifier_Char (Source (Scan_Ptr + 2))) ! then Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); --- 1187,1193 ---- Code := Get_Char_Code (C); Scan_Ptr := Scan_Ptr + 1; ! elsif Start_Of_Wide_Character then Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); *************** package body Scng is *** 1065,1071 **** -- but in Ada 2005, the set of characters allowed has been -- restricted to graphic characters. ! if Ada_Version >= Ada_05 and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) then Error_Msg --- 1202,1208 ---- -- but in Ada 2005, the set of characters allowed has been -- restricted to graphic characters. ! if Ada_Version >= Ada_2005 and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) then Error_Msg *************** package body Scng is *** 1112,1117 **** --- 1249,1310 ---- return; end Slit; + ---------------------------------- + -- Skip_Other_Format_Characters -- + ---------------------------------- + + procedure Skip_Other_Format_Characters is + P : Source_Ptr; + Code : Char_Code; + Err : Boolean; + + begin + while Start_Of_Wide_Character loop + P := Scan_Ptr; + Scan_Wide (Source, Scan_Ptr, Code, Err); + + if not Is_UTF_32_Other (UTF_32 (Code)) then + Scan_Ptr := P; + return; + end if; + end loop; + end Skip_Other_Format_Characters; + + ----------------------------- + -- Start_Of_Wide_Character -- + ----------------------------- + + function Start_Of_Wide_Character return Boolean is + C : constant Character := Source (Scan_Ptr); + + begin + -- ESC encoding method with ESC present + + if C = ESC + and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method + then + return True; + + -- Upper half character with upper half encoding + + elsif C in Upper_Half_Character and then Upper_Half_Encoding then + return True; + + -- Brackets encoding + + elsif C = '[' + and then Source (Scan_Ptr + 1) = '"' + and then Identifier_Char (Source (Scan_Ptr + 2)) + then + return True; + + -- Not the start of a wide character + + else + return False; + end if; + end Start_Of_Wide_Character; + -- Start of processing for Scan begin *************** package body Scng is *** 1215,1221 **** Accumulate_Checksum ('&'); if Source (Scan_Ptr + 1) = '&' then ! Error_Msg_S ("'&'& should be `AND THEN`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_And; return; --- 1408,1415 ---- Accumulate_Checksum ('&'); if Source (Scan_Ptr + 1) = '&' then ! Error_Msg_S -- CODEFIX ! ("'&'& should be `AND THEN`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_And; return; *************** package body Scng is *** 1263,1269 **** and then Source (Scan_Ptr + 2) /= '-' then Token := Tok_Colon_Equal; ! Error_Msg (":- should be :=", Scan_Ptr); Scan_Ptr := Scan_Ptr + 2; return; --- 1457,1464 ---- and then Source (Scan_Ptr + 2) /= '-' then Token := Tok_Colon_Equal; ! Error_Msg -- CODEFIX ! (":- should be :=", Scan_Ptr); Scan_Ptr := Scan_Ptr + 2; return; *************** package body Scng is *** 1367,1373 **** return; elsif Source (Scan_Ptr + 1) = '=' then ! Error_Msg_S ("== should be ="); Scan_Ptr := Scan_Ptr + 1; end if; --- 1562,1569 ---- return; elsif Source (Scan_Ptr + 1) = '=' then ! Error_Msg_S -- CODEFIX ! ("== should be ="); Scan_Ptr := Scan_Ptr + 1; end if; *************** package body Scng is *** 1513,1524 **** -- If we have a wide character, we have to scan it out, -- because it might be a legitimate line terminator ! elsif (Source (Scan_Ptr) = ESC ! and then Identifier_Char (ESC)) ! or else ! (Source (Scan_Ptr) in Upper_Half_Character ! and then Upper_Half_Encoding) ! then declare Wptr : constant Source_Ptr := Scan_Ptr; Code : Char_Code; --- 1709,1715 ---- -- If we have a wide character, we have to scan it out, -- because it might be a legitimate line terminator ! elsif Start_Of_Wide_Character then declare Wptr : constant Source_Ptr := Scan_Ptr; Code : Char_Code; *************** package body Scng is *** 1573,1597 **** end if; end Minus_Case; ! -- Double quote starting a string literal ! ! when '"' => ! Slit; ! Post_Scan; ! return; ! ! -- Percent starting a string literal ! ! when '%' => ! Obsolescent_Check (Token_Ptr); ! ! if Warn_On_Obsolescent_Feature then ! Error_Msg_S ! ("use of ""'%"" is an obsolescent feature (RM J.2(4))?"); ! Error_Msg_S ! ("\use """""" instead?"); ! end if; Slit; Post_Scan; return; --- 1764,1772 ---- end if; end Minus_Case; ! -- Double quote or percent starting a string literal + when '"' | '%' => Slit; Post_Scan; return; *************** package body Scng is *** 1642,1659 **** else -- Case of wide character literal ! if (Source (Scan_Ptr) = ESC ! and then ! Wide_Character_Encoding_Method in WC_ESC_Encoding_Method) ! or else ! (Source (Scan_Ptr) in Upper_Half_Character ! and then ! Upper_Half_Encoding) ! or else ! (Source (Scan_Ptr) = '[' ! and then ! Source (Scan_Ptr + 1) = '"') ! then Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); Accumulate_Checksum (Code); --- 1817,1823 ---- else -- Case of wide character literal ! if Start_Of_Wide_Character then Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); Accumulate_Checksum (Code); *************** package body Scng is *** 1666,1681 **** -- literal, but in Ada 2005, the set of characters allowed -- is restricted to graphic characters. ! elsif Ada_Version >= Ada_05 and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) then ! Error_Msg ("(Ada 2005) non-graphic character not permitted " & "in character literal", Wptr); end if; if Source (Scan_Ptr) /= ''' then ! Error_Msg_S ("missing apostrophe"); else Scan_Ptr := Scan_Ptr + 1; end if; --- 1830,1845 ---- -- literal, but in Ada 2005, the set of characters allowed -- is restricted to graphic characters. ! elsif Ada_Version >= Ada_2005 and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) then ! Error_Msg -- CODEFIX???? ("(Ada 2005) non-graphic character not permitted " & "in character literal", Wptr); end if; if Source (Scan_Ptr) /= ''' then ! Error_Msg_S ("missing apostrophe"); else Scan_Ptr := Scan_Ptr + 1; end if; *************** package body Scng is *** 1789,1795 **** -- Special check for || to give nice message if Source (Scan_Ptr + 1) = '|' then ! Error_Msg_S ("""'|'|"" should be `OR ELSE`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; --- 1953,1960 ---- -- Special check for || to give nice message if Source (Scan_Ptr + 1) = '|' then ! Error_Msg_S -- CODEFIX ! ("""'|'|"" should be `OR ELSE`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; *************** package body Scng is *** 1802,1807 **** --- 1967,1973 ---- Style.Check_Vertical_Bar; end if; + Post_Scan; return; end if; end Vertical_Bar_Case; *************** package body Scng is *** 1810,1826 **** when '!' => Exclamation_Case : begin Accumulate_Checksum ('!'); - Obsolescent_Check (Token_Ptr); - - if Warn_On_Obsolescent_Feature then - Error_Msg_S - ("use of ""'!"" is an obsolescent feature (RM J.2(2))?"); - Error_Msg_S - ("\use ""'|"" instead?"); - end if; if Source (Scan_Ptr + 1) = '=' then ! Error_Msg_S ("'!= should be /="); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Not_Equal; return; --- 1976,1985 ---- when '!' => Exclamation_Case : begin Accumulate_Checksum ('!'); if Source (Scan_Ptr + 1) = '=' then ! Error_Msg_S -- CODEFIX ! ("'!= should be /="); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Not_Equal; return; *************** package body Scng is *** 1828,1833 **** --- 1987,1993 ---- else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; + Post_Scan; return; end if; end Exclamation_Case; *************** package body Scng is *** 1892,1897 **** --- 2052,2061 ---- Nlit; + -- Check for proper delimiter, ignoring other format characters + + Skip_Other_Format_Characters; + if Identifier_Char (Source (Scan_Ptr)) then Error_Msg_S ("delimiter required between literal and identifier"); *************** package body Scng is *** 2059,2064 **** --- 2223,2234 ---- elsif Is_UTF_32_Space (Cat) then goto Scan_Next_Character; + -- If other format character, ignore and keep scanning (again we + -- do not include in the checksum) (this is for AI-0079). + + elsif Is_UTF_32_Other (Cat) then + goto Scan_Next_Character; + -- If OK wide line terminator, terminate current line elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then *************** package body Scng is *** 2068,2075 **** -- Punctuation is an error (at start of identifier) elsif Is_UTF_32_Punctuation (Cat) then ! Error_Msg ! ("identifier cannot start with punctuation", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; --- 2238,2244 ---- -- Punctuation is an error (at start of identifier) elsif Is_UTF_32_Punctuation (Cat) then ! Error_Msg ("identifier cannot start with punctuation", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; *************** package body Scng is *** 2078,2095 **** -- Mark character is an error (at start of identifier) elsif Is_UTF_32_Mark (Cat) then ! Error_Msg ! ("identifier cannot start with mark character", Wptr); ! Scan_Ptr := Wptr; ! Name_Len := 0; ! Underline_Found := False; ! goto Scan_Identifier; ! ! -- Other format character is an error (at start of identifier) ! ! elsif Is_UTF_32_Other (Cat) then ! Error_Msg ! ("identifier cannot start with other format character", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; --- 2247,2253 ---- -- Mark character is an error (at start of identifier) elsif Is_UTF_32_Mark (Cat) then ! Error_Msg ("identifier cannot start with mark character", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; *************** package body Scng is *** 2277,2282 **** --- 2435,2467 ---- -- Here if not a normal identifier character else + Cat := Get_Category (UTF_32 (Code)); + + -- Wide character in Unicode category "Other, Format" + -- is not accepted in an identifier. This is because it + -- it is considered a security risk (AI-0091). + + -- However, it is OK for such a character to appear at + -- the end of an identifier. + + if Is_UTF_32_Other (Cat) then + if not Identifier_Char (Source (Scan_Ptr)) then + goto Scan_Identifier_Complete; + else + Error_Msg + ("identifier cannot contain other_format " + & "character", Wptr); + goto Scan_Identifier; + end if; + + -- Wide character in category Separator,Space terminates + + elsif Is_UTF_32_Space (Cat) then + goto Scan_Identifier_Complete; + end if; + + -- Here if wide character is part of the identifier + -- Make sure we are allowing wide characters in -- identifiers. Note that we allow wide character -- notation for an OK identifier character. This in *************** package body Scng is *** 2286,2299 **** -- Wide characters are always allowed in Ada 2005 if Identifier_Character_Set /= 'w' ! and then Ada_Version < Ada_05 then Error_Msg ! ("wide character not allowed in identifier", Wptr); end if; - Cat := Get_Category (UTF_32 (Code)); - -- If OK letter, store it folding to upper case. Note -- that we include the folded letter in the checksum. --- 2471,2482 ---- -- Wide characters are always allowed in Ada 2005 if Identifier_Character_Set /= 'w' ! and then Ada_Version < Ada_2005 then Error_Msg ! ("wide character not allowed in identifier", Wptr); end if; -- If OK letter, store it folding to upper case. Note -- that we include the folded letter in the checksum. *************** package body Scng is *** 2333,2355 **** Underline_Found := True; end if; - -- Wide character in Unicode category "Other, Format" - -- is accepted in an identifier, but is ignored and not - -- stored. It seems reasonable to exclude it from the - -- checksum. - - -- Note that it is correct (see AI-395) to simply strip - -- other format characters, before testing for double - -- underlines, or for reserved words). - - elsif Is_UTF_32_Other (Cat) then - null; - - -- Wide character in category Separator,Space terminates - - elsif Is_UTF_32_Space (Cat) then - goto Scan_Identifier_Complete; - -- Any other wide character is not acceptable else --- 2516,2521 ---- *************** package body Scng is *** 2383,2392 **** end if; end if; -- Here is where we check if it was a keyword if Is_Keyword_Name (Token_Name) then ! Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); -- Keyword style checks --- 2549,2577 ---- end if; end if; + -- We will assume it is an identifier, not a keyword, so that the + -- checksum is independent of the Ada version. + + Token := Tok_Identifier; + -- Here is where we check if it was a keyword if Is_Keyword_Name (Token_Name) then ! if Opt.Checksum_GNAT_6_3 then ! Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); ! ! if Checksum_Accumulate_Token_Checksum then ! if Checksum_GNAT_5_03 then ! Accumulate_Token_Checksum_GNAT_5_03; ! else ! Accumulate_Token_Checksum_GNAT_6_3; ! end if; ! end if; ! ! else ! Accumulate_Token_Checksum; ! Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); ! end if; -- Keyword style checks *************** package body Scng is *** 2438,2451 **** -- corresponding keyword. Token_Name := No_Name; - Accumulate_Token_Checksum; return; -- It is an identifier after all else ! Token := Tok_Identifier; ! Accumulate_Token_Checksum; Post_Scan; return; end if; --- 2623,2637 ---- -- corresponding keyword. Token_Name := No_Name; return; -- It is an identifier after all else ! if Checksum_Accumulate_Token_Checksum then ! Accumulate_Token_Checksum; ! end if; ! Post_Scan; return; end if; diff -Nrcpad gcc-4.5.2/gcc/ada/scng.ads gcc-4.6.0/gcc/ada/scng.ads *** gcc-4.5.2/gcc/ada/scng.ads Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/scng.ads Thu Sep 9 12:31:35 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,31 **** -- -- ------------------------------------------------------------------------------ ! -- This package contains a generic lexical analyzer. This is used ! -- for scanning Ada source files or text files with an Ada-like syntax, ! -- such as project files. It is instantiated in Scn and Prj.Err. with Casing; use Casing; with Styleg; --- 23,31 ---- -- -- ------------------------------------------------------------------------------ ! -- This package contains a generic lexical analyzer. This is used for scanning ! -- Ada source files or text files with an Ada-like syntax, such as project ! -- files. It is instantiated in Scn and Prj.Err. with Casing; use Casing; with Styleg; *************** with Types; use Types; *** 33,41 **** generic with procedure Post_Scan; ! -- Procedure called by Scan for the following tokens: ! -- Tok_Char_Literal, Tok_Identifier, Tok_Real_Literal, Tok_Real_Literal, ! -- Tok_Integer_Literal, Tok_String_Literal, Tok_Operator_Symbol. with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); -- Output a message at specified location --- 33,42 ---- generic with procedure Post_Scan; ! -- Procedure called by Scan for the following tokens: Tok_Char_Literal, ! -- Tok_Identifier, Tok_Real_Literal, Tok_Real_Literal, Tok_Integer_Literal, ! -- Tok_String_Literal, Tok_Operator_Symbol, and Tok_Vertical_Bar. Used to ! -- build Token_Node and also check for obsolescent features. with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); -- Output a message at specified location *************** generic *** 49,58 **** with procedure Error_Msg_SP (Msg : String); -- Output a message at the start of the previous token - with procedure Obsolescent_Check (S : Source_Ptr); - -- Called when one of the obsolescent character replacements is - -- used with S pointing to the character in question. - with package Style is new Styleg (Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP); -- Instantiation of Styleg with the same error reporting routines --- 50,55 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/scos.ads gcc-4.6.0/gcc/ada/scos.ads *** gcc-4.5.2/gcc/ada/scos.ads Tue Jan 26 13:49:56 2010 --- gcc-4.6.0/gcc/ada/scos.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2009-2010, 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- -- *************** package SCOs is *** 148,168 **** -- o object declaration -- r renaming declaration -- i generic instantiation ! -- C CASE statement (includes only the expression) -- E EXIT statement ! -- F FOR loop statement (includes only the iteration scheme) ! -- I IF statement (includes only the condition [in the RM sense, which ! -- is a decision in the SCO sense]) -- P PRAGMA -- R extended RETURN statement ! -- W WHILE loop statement (includes only the condition) ! -- and is omitted for all other cases. -- Decisions -- Note: in the following description, logical operator includes only the ! -- short circuited forms and NOT (so can be only NOT, AND THEN, OR ELSE). -- The reason that we can exclude AND/OR/XOR is that we expect SCO's to -- be generated using the restriction No_Direct_Boolean_Operators if we -- are interested in decision coverage, which does not permit the use of --- 148,174 ---- -- o object declaration -- r renaming declaration -- i generic instantiation ! -- C CASE statement (from CASE through end of expression) -- E EXIT statement ! -- F FOR loop statement (from FOR through end of iteration scheme) ! -- I IF statement (from IF through end of condition) -- P PRAGMA -- R extended RETURN statement ! -- W WHILE loop statement (from WHILE through end of condition) ! -- Note: for I and W, condition above is in the RM syntax sense (this ! -- condition is a decision in SCO terminology). ! ! -- and is omitted for all other cases ! ! -- Note: up to 6 entries can appear on a single CS line. If more than 6 ! -- entries appear in one logical statement sequence, continuation lines ! -- are marked by Cs and appear immediately after the CS line. -- Decisions -- Note: in the following description, logical operator includes only the ! -- short-circuited forms and NOT (so can be only NOT, AND THEN, OR ELSE). -- The reason that we can exclude AND/OR/XOR is that we expect SCO's to -- be generated using the restriction No_Direct_Boolean_Operators if we -- are interested in decision coverage, which does not permit the use of *************** package SCOs is *** 171,188 **** -- we are generating SCO's only for simple coverage, then we are not -- interested in decisions in any case. ! -- Decisions are either simple or complex. A simple decision is a boolean ! -- expresssion that occurs in the context of a control structure in the ! -- source program, including WHILE, IF, EXIT WHEN, or in an Assert, ! -- Check, Pre_Condition or Post_Condition pragma. For pragmas, decision ! -- SCOs are generated only if the corresponding pragma is enabled. Note ! -- that a boolean expression in any other context, for example as right ! -- hand side of an assignment, is not considered to be a simple decision. ! -- A complex decision is an occurrence of a logical operator which is not ! -- itself an operand of some other logical operator. If any operand of ! -- the logical operator is itself a logical operator, this is not a ! -- separate decision, it is part of the same decision. -- So for example, if we have --- 177,203 ---- -- we are generating SCO's only for simple coverage, then we are not -- interested in decisions in any case. ! -- Note: the reason we include NOT is for informational purposes. The ! -- presence of NOT does not generate additional coverage obligations, ! -- but if we know where the NOT's are, the coverage tool can generate ! -- more accurate diagnostics on uncovered tests. ! -- A top level boolean expression is a boolean expression that is not an ! -- operand of a logical operator. ! ! -- Decisions are either simple or complex. A simple decision is a top ! -- level boolean expression that has only one condition and that occurs ! -- in the context of a control structure in the source program, including ! -- WHILE, IF, EXIT WHEN, or in an Assert, Check, Pre_Condition or ! -- Post_Condition pragma. For pragmas, decision SCOs are generated only ! -- if the corresponding pragma is enabled. Note that a top level boolean ! -- expression with only one condition that occurs in any other context, ! -- for example as right hand side of an assignment, is not considered to ! -- be a (simple) decision. ! ! -- A complex decision is a top level boolean expression that has more ! -- than one condition. A complex decision may occur in any boolean ! -- expression context. -- So for example, if we have *************** package SCOs is *** 201,207 **** -- For each decision, a decision line is generated with the form: ! -- C*sloc expression -- Here * is one of the following characters: --- 216,222 ---- -- For each decision, a decision line is generated with the form: ! -- C* sloc expression [chaining] -- Here * is one of the following characters: *************** package SCOs is *** 214,223 **** -- For I, E, P, W, sloc is the source location of the IF, EXIT, PRAGMA or -- WHILE token. ! -- For X, sloc is omitted. -- The expression is a prefix polish form indicating the structure of ! -- the decision, including logical operators and short circuit forms. -- The following is a grammar showing the structure of expression: -- expression ::= term (if expr is not logical operator) --- 229,238 ---- -- For I, E, P, W, sloc is the source location of the IF, EXIT, PRAGMA or -- WHILE token. ! -- For X, sloc is omitted -- The expression is a prefix polish form indicating the structure of ! -- the decision, including logical operators and short-circuit forms. -- The following is a grammar showing the structure of expression: -- expression ::= term (if expr is not logical operator) *************** package SCOs is *** 225,231 **** -- expression ::= |sloc term term (if expr is OR or OR ELSE) -- expression ::= !sloc term (if expr is NOT) ! -- In the last four cases, sloc is the source location of the AND, OR, -- or NOT token, respectively. -- term ::= element --- 240,246 ---- -- expression ::= |sloc term term (if expr is OR or OR ELSE) -- expression ::= !sloc term (if expr is NOT) ! -- In the last three cases, sloc is the source location of the AND, OR, -- or NOT token, respectively. -- term ::= element *************** package SCOs is *** 242,255 **** -- where t/f are used to mark a condition that has been recognized by -- the compiler as always being true or false. ! -- & indicates AND THEN connecting two conditions. ! -- | indicates OR ELSE connecting two conditions. ! -- ! indicates NOT applied to the expression. ! -- In the context of Couverture, the No_Direct_Boolean_Opeartors ! -- restriction is assumed, and no other operator can appear. --------------------------------------------------------------------- -- Internal table used to store Source Coverage Obligations (SCOs) -- --- 257,325 ---- -- where t/f are used to mark a condition that has been recognized by -- the compiler as always being true or false. ! -- & indicates AND THEN connecting two conditions ! -- | indicates OR ELSE connecting two conditions ! -- ! indicates NOT applied to the expression ! -- Note that complex decisions do NOT include non-short-circuited logical ! -- operators (AND/XOR/OR). In the context of existing coverage tools the ! -- No_Direct_Boolean_Operators restriction is assumed, so these operators ! -- cannot appear in the source in any case. ! ! -- The SCO line for a decision always occurs after the CS line for the ! -- enclosing statement. The SCO line for a nested decision always occurs ! -- after the line for the enclosing decision. ! ! -- Note that membership tests are considered to be a single simple ! -- condition, and that is true even if the Ada 2005 set membership ! -- form is used, e.g. A in (2,7,11.15). ! ! -- The expression can be followed by chaining indicators of the form ! -- Tsloc-range or Fsloc-range. ! ! -- T* is present when the statement with the given sloc range is executed ! -- if, and only if, the decision evaluates to TRUE. ! ! -- F* is present when the statement with the given sloc range is executed ! -- if, and only if, the decision evaluates to FALSE. ! ! -- For an IF statement or ELSIF part, a T chaining indicator is always ! -- present, with the sloc range of the first statement in the ! -- corresponding sequence. ! ! -- For an ELSE part, the last decision in the IF statement (that of the ! -- last ELSIF part, if any, or that of the IF statement if there is no ! -- ELSIF part) has an F chaining indicator with the sloc range of the ! -- first statement in the sequence of the ELSE part. ! ! -- For a WHILE loop, a T chaining indicator is always present, with the ! -- sloc range of the first statement in the loop, but no F chaining ! -- indicator is ever present. ! ! -- For an EXIT WHEN statement, an F chaining indicator is present if ! -- there is an immediately following sequence in the same sequence of ! -- statements. ! ! -- In all other cases, chaining indicators are omitted ! ! -- Case Expressions ! ! -- For case statements, we rely on statement coverage to make sure that ! -- all branches of a case statement are covered, but that does not work ! -- for case expressions, since the entire expression is contained in a ! -- single statement. However, for complete coverage we really should be ! -- able to check that every branch of the case statement is covered, so ! -- we generate a SCO of the form: ! ! -- CC sloc-range sloc-range ... ! ! -- where sloc-range covers the range of the case expression ! ! -- Note: up to 6 entries can appear on a single CC line. If more than 6 ! -- entries appear in one logical statement sequence, continuation lines ! -- are marked by Cc and appear immediately after the CC line. --------------------------------------------------------------------- -- Internal table used to store Source Coverage Obligations (SCOs) -- *************** package SCOs is *** 289,307 **** -- Note: successive statements (possibly interspersed with entries of -- other kinds, that are ignored for this purpose), starting with one -- labeled with C1 = 'S', up to and including the first one labeled with ! -- Last=True, indicate the sequence to be output for a sequence of ! -- statements on a single CS line. ! -- Decision ! -- C1 = decision type code -- C2 = ' ' ! -- From = location of IF/EXIT/PRAGMA/WHILE token, ! -- No_Source_Location for X -- To = No_Source_Location -- Last = unused -- Operator ! -- C1 = '!', '^', '&', '|' -- C2 = ' ' -- From = location of NOT/AND/OR token -- To = No_Source_Location --- 359,403 ---- -- Note: successive statements (possibly interspersed with entries of -- other kinds, that are ignored for this purpose), starting with one -- labeled with C1 = 'S', up to and including the first one labeled with ! -- Last = True, indicate the sequence to be output for a sequence of ! -- statements on a single CS line (possibly followed by Cs continuation ! -- lines). ! -- Decision (IF/EXIT/WHILE) ! -- C1 = 'I'/'E'/'W' (for IF/EXIT/WHILE) -- C2 = ' ' ! -- From = IF/EXIT/WHILE token ! -- To = No_Source_Location ! -- Last = unused ! ! -- Decision (PRAGMA) ! -- C1 = 'P' ! -- C2 = 'e'/'d' for enabled/disabled ! -- From = PRAGMA token ! -- To = No_Source_Location ! -- Last = unused ! ! -- Note: when the parse tree is first scanned, we unconditionally build ! -- a pragma decision entry for any decision in a pragma (here as always ! -- in SCO contexts, the only pragmas with decisions are Assert, Check, ! -- Precondition and Postcondition), and we mark the pragma as disabled. ! -- ! -- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled to ! -- mark the SCO decision table entry as enabled (C2 set to 'e'). Then ! -- in Put_SCOs, we only output the decision for a pragma if C2 is 'e'. ! -- ! -- When we read SCOs from an ALI file (in Get_SCOs), we always set C2 ! -- to 'e', since clearly the pragma is enabled if it was written out. ! ! -- Decision (Expression) ! -- C1 = 'X' ! -- C2 = ' ' ! -- From = No_Source_Location -- To = No_Source_Location -- Last = unused -- Operator ! -- C1 = '!', '&', '|' -- C2 = ' ' -- From = location of NOT/AND/OR token -- To = No_Source_Location *************** package SCOs is *** 314,323 **** -- To = ending source location -- Last = False for all but the last entry, True for last entry -- Note: the sequence starting with a decision, and continuing with -- operators and elements up to and including the first one labeled with ! -- Last = True, indicate the sequence to be output for a complex decision ! -- on a single CD decision line. ---------------- -- Unit Table -- --- 410,424 ---- -- To = ending source location -- Last = False for all but the last entry, True for last entry + -- Element (chaining indicator) + -- C1 = 'H' (cHain) + -- C2 = 'T' or 'F' (chaining on decision true/false) + -- From = starting source location of chained statement + -- To = ending source location of chained statement + -- Note: the sequence starting with a decision, and continuing with -- operators and elements up to and including the first one labeled with ! -- Last = True, indicate the sequence to be output on one decision line. ---------------- -- Unit Table -- diff -Nrcpad gcc-4.5.2/gcc/ada/sem.adb gcc-4.6.0/gcc/ada/sem.adb *** gcc-4.5.2/gcc/ada/sem.adb Mon Nov 30 11:55:21 2009 --- gcc-4.6.0/gcc/ada/sem.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sem is *** 67,75 **** -- Controls debugging printouts for Walk_Library_Items Outer_Generic_Scope : Entity_Id := Empty; ! -- Global reference to the outer scope that is generic. In a non ! -- generic context, it is empty. At the moment, it is only used ! -- for avoiding freezing of external references in generics. Comp_Unit_List : Elist_Id := No_Elist; -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes --- 67,75 ---- -- Controls debugging printouts for Walk_Library_Items Outer_Generic_Scope : Entity_Id := Empty; ! -- Global reference to the outer scope that is generic. In a non-generic ! -- context, it is empty. At the moment, it is only used for avoiding ! -- freezing of external references in generics. Comp_Unit_List : Elist_Id := No_Elist; -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes *************** package body Sem is *** 80,88 **** generic with procedure Action (Withed_Unit : Node_Id); procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); ! -- Walk all the with clauses of CU, and call Action for the with'ed ! -- unit. Ignore limited withs, unless Include_Limited is True. ! -- CU must be an N_Compilation_Unit. generic with procedure Action (Withed_Unit : Node_Id); --- 80,88 ---- generic with procedure Action (Withed_Unit : Node_Id); procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); ! -- Walk all the with clauses of CU, and call Action for the with'ed unit. ! -- Ignore limited withs, unless Include_Limited is True. CU must be an ! -- N_Compilation_Unit. generic with procedure Action (Withed_Unit : Node_Id); *************** package body Sem is *** 158,163 **** --- 158,166 ---- when N_Block_Statement => Analyze_Block_Statement (N); + when N_Case_Expression => + Analyze_Case_Expression (N); + when N_Case_Statement => Analyze_Case_Statement (N); *************** package body Sem is *** 221,226 **** --- 224,232 ---- when N_Explicit_Dereference => Analyze_Explicit_Dereference (N); + when N_Expression_With_Actions => + Analyze_Expression_With_Actions (N); + when N_Extended_Return_Statement => Analyze_Extended_Return_Statement (N); *************** package body Sem is *** 231,240 **** Analyze_Formal_Object_Declaration (N); when N_Formal_Package_Declaration => ! Analyze_Formal_Package (N); when N_Formal_Subprogram_Declaration => ! Analyze_Formal_Subprogram (N); when N_Formal_Type_Declaration => Analyze_Formal_Type_Declaration (N); --- 237,246 ---- Analyze_Formal_Object_Declaration (N); when N_Formal_Package_Declaration => ! Analyze_Formal_Package_Declaration (N); when N_Formal_Subprogram_Declaration => ! Analyze_Formal_Subprogram_Declaration (N); when N_Formal_Type_Declaration => Analyze_Formal_Type_Declaration (N); *************** package body Sem is *** 246,252 **** Analyze_Freeze_Entity (N); when N_Full_Type_Declaration => ! Analyze_Type_Declaration (N); when N_Function_Call => Analyze_Function_Call (N); --- 252,258 ---- Analyze_Freeze_Entity (N); when N_Full_Type_Declaration => ! Analyze_Full_Type_Declaration (N); when N_Function_Call => Analyze_Function_Call (N); *************** package body Sem is *** 296,301 **** --- 302,310 ---- when N_Integer_Literal => Analyze_Integer_Literal (N); + when N_Iterator_Specification => + Analyze_Iterator_Specification (N); + when N_Itype_Reference => Analyze_Itype_Reference (N); *************** package body Sem is *** 431,436 **** --- 440,448 ---- when N_Parameter_Association => Analyze_Parameter_Association (N); + when N_Parameterized_Expression => + Analyze_Parameterized_Expression (N); + when N_Pragma => Analyze_Pragma (N); *************** package body Sem is *** 456,466 **** Analyze_Protected_Definition (N); when N_Protected_Type_Declaration => ! Analyze_Protected_Type (N); when N_Qualified_Expression => Analyze_Qualified_Expression (N); when N_Raise_Statement => Analyze_Raise_Statement (N); --- 468,481 ---- Analyze_Protected_Definition (N); when N_Protected_Type_Declaration => ! Analyze_Protected_Type_Declaration (N); when N_Qualified_Expression => Analyze_Qualified_Expression (N); + when N_Quantified_Expression => + Analyze_Quantified_Expression (N); + when N_Raise_Statement => Analyze_Raise_Statement (N); *************** package body Sem is *** 496,505 **** Analyze_Selective_Accept (N); when N_Single_Protected_Declaration => ! Analyze_Single_Protected (N); when N_Single_Task_Declaration => ! Analyze_Single_Task (N); when N_Slice => Analyze_Slice (N); --- 511,520 ---- Analyze_Selective_Accept (N); when N_Single_Protected_Declaration => ! Analyze_Single_Protected_Declaration (N); when N_Single_Task_Declaration => ! Analyze_Single_Task_Declaration (N); when N_Slice => Analyze_Slice (N); *************** package body Sem is *** 541,547 **** Analyze_Task_Definition (N); when N_Task_Type_Declaration => ! Analyze_Task_Type (N); when N_Terminate_Alternative => Analyze_Terminate_Alternative (N); --- 556,562 ---- Analyze_Task_Definition (N); when N_Task_Type_Declaration => ! Analyze_Task_Type_Declaration (N); when N_Terminate_Alternative => Analyze_Terminate_Alternative (N); *************** package body Sem is *** 576,589 **** when N_With_Clause => Analyze_With_Clause (N); ! -- A call to analyze the Empty node is an error, but most likely ! -- it is an error caused by an attempt to analyze a malformed ! -- piece of tree caused by some other error, so if there have ! -- been any other errors, we just ignore it, otherwise it is ! -- a real internal error which we complain about. ! -- We must also consider the case of call to a runtime function ! -- that is not available in the configurable runtime. when N_Empty => pragma Assert (Serious_Errors_Detected /= 0 --- 591,604 ---- when N_With_Clause => Analyze_With_Clause (N); ! -- A call to analyze the Empty node is an error, but most likely it ! -- is an error caused by an attempt to analyze a malformed piece of ! -- tree caused by some other error, so if there have been any other ! -- errors, we just ignore it, otherwise it is a real internal error ! -- which we complain about. ! -- We must also consider the case of call to a runtime function that ! -- is not available in the configurable runtime. when N_Empty => pragma Assert (Serious_Errors_Detected /= 0 *************** package body Sem is *** 609,619 **** -- analyzed. when ! N_SCIL_Dispatch_Table_Object_Init | ! N_SCIL_Dispatch_Table_Tag_Init | ! N_SCIL_Dispatching_Call | ! N_SCIL_Membership_Test | ! N_SCIL_Tag_Init => null; -- For the remaining node types, we generate compiler abort, because --- 624,632 ---- -- analyzed. when ! N_SCIL_Dispatch_Table_Tag_Init | ! N_SCIL_Dispatching_Call | ! N_SCIL_Membership_Test => null; -- For the remaining node types, we generate compiler abort, because *************** package body Sem is *** 629,634 **** --- 642,649 ---- N_Access_Function_Definition | N_Access_Procedure_Definition | N_Access_To_Object_Definition | + N_Aspect_Specification | + N_Case_Expression_Alternative | N_Case_Statement_Alternative | N_Compilation_Unit_Aux | N_Component_Association | *************** package body Sem is *** 841,847 **** return; end if; ! -- Now search the global entity suppress table for a matching entry -- We also search this in reverse order so that if there are multiple -- pragmas for the same entity, the last one applies. --- 856,862 ---- return; end if; ! -- Now search the global entity suppress table for a matching entry. -- We also search this in reverse order so that if there are multiple -- pragmas for the same entity, the last one applies. *************** package body Sem is *** 1109,1120 **** Node := First (L); Insert_List_After (N, L); ! -- Now just analyze from the original first node until we get to ! -- the successor of the original insertion point (which may be ! -- Empty if the insertion point was at the end of the list). Note ! -- that this properly handles the case where any of the analyze ! -- calls result in the insertion of nodes after the analyzed ! -- node (possibly calling this routine recursively). while Node /= After loop Analyze (Node); --- 1124,1135 ---- Node := First (L); Insert_List_After (N, L); ! -- Now just analyze from the original first node until we get to the ! -- successor of the original insertion point (which may be Empty if ! -- the insertion point was at the end of the list). Note that this ! -- properly handles the case where any of the analyze calls result in ! -- the insertion of nodes after the analyzed node (possibly calling ! -- this routine recursively). while Node /= After loop Analyze (Node); *************** package body Sem is *** 1160,1168 **** begin if Is_Non_Empty_List (L) then ! -- Capture the Node_Id of the first list node to be inserted. ! -- This will still be the first node after the insert operation, ! -- since Insert_List_After does not modify the Node_Id values. Node := First (L); Insert_List_Before (N, L); --- 1175,1183 ---- begin if Is_Non_Empty_List (L) then ! -- Capture the Node_Id of the first list node to be inserted. This ! -- will still be the first node after the insert operation, since ! -- Insert_List_After does not modify the Node_Id values. Node := First (L); Insert_List_Before (N, L); *************** package body Sem is *** 1217,1225 **** Ptr : Suppress_Stack_Entry_Ptr; begin ! -- First search the local entity suppress stack, we search this from the ! -- top of the stack down, so that we get the innermost entry that ! -- applies to this case if there are nested entries. Ptr := Local_Suppress_Stack_Top; while Ptr /= null loop --- 1232,1240 ---- Ptr : Suppress_Stack_Entry_Ptr; begin ! -- First search the local entity suppress stack. We search this from the ! -- top of the stack down so that we get the innermost entry that applies ! -- to this case if there are nested entries. Ptr := Local_Suppress_Stack_Top; while Ptr /= null loop *************** package body Sem is *** 1232,1238 **** Ptr := Ptr.Prev; end loop; ! -- Now search the global entity suppress table for a matching entry -- We also search this from the top down so that if there are multiple -- pragmas for the same entity, the last one applies (not clear what -- or whether the RM specifies this handling, but it seems reasonable). --- 1247,1253 ---- Ptr := Ptr.Prev; end loop; ! -- Now search the global entity suppress table for a matching entry. -- We also search this from the top down so that if there are multiple -- pragmas for the same entity, the last one applies (not clear what -- or whether the RM specifies this handling, but it seems reasonable). *************** package body Sem is *** 1322,1331 **** procedure Semantics (Comp_Unit : Node_Id) is -- The following locations save the corresponding global flags and ! -- variables so that they can be restored on completion. This is ! -- needed so that calls to Rtsfind start with the proper default ! -- values for these variables, and also that such calls do not ! -- disturb the settings for units being analyzed at a higher level. S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Full_Analysis : constant Boolean := Full_Analysis; --- 1337,1346 ---- procedure Semantics (Comp_Unit : Node_Id) is -- The following locations save the corresponding global flags and ! -- variables so that they can be restored on completion. This is needed ! -- so that calls to Rtsfind start with the proper default values for ! -- these variables, and also that such calls do not disturb the settings ! -- for units being analyzed at a higher level. S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Full_Analysis : constant Boolean := Full_Analysis; *************** package body Sem is *** 1343,1354 **** -- context, is compiled with expansion disabled. Save_Config_Switches : Config_Switches_Type; ! -- Variable used to save values of config switches while we analyze ! -- the new unit, to be restored on exit for proper recursive behavior. procedure Do_Analyze; ! -- Procedure to analyze the compilation unit. This is called more ! -- than once when the high level optimizer is activated. ---------------- -- Do_Analyze -- --- 1358,1369 ---- -- context, is compiled with expansion disabled. Save_Config_Switches : Config_Switches_Type; ! -- Variable used to save values of config switches while we analyze the ! -- new unit, to be restored on exit for proper recursive behavior. procedure Do_Analyze; ! -- Procedure to analyze the compilation unit. This is called more than ! -- once when the high level optimizer is activated. ---------------- -- Do_Analyze -- *************** package body Sem is *** 1447,1462 **** end if; -- Do analysis, and then append the compilation unit onto the ! -- Comp_Unit_List, if appropriate. This is done after analysis, so ! -- if this unit depends on some others, they have already been ! -- appended. We ignore bodies, except for the main unit itself. We ! -- have also to guard against ill-formed subunits that have an ! -- improper context. Do_Analyze; if Present (Comp_Unit) and then Nkind (Unit (Comp_Unit)) in N_Proper_Body and then not In_Extended_Main_Source_Unit (Comp_Unit) then null; --- 1462,1479 ---- end if; -- Do analysis, and then append the compilation unit onto the ! -- Comp_Unit_List, if appropriate. This is done after analysis, ! -- so if this unit depends on some others, they have already been ! -- appended. We ignore bodies, except for the main unit itself, and ! -- for subprogram bodies that act as specs. We have also to guard ! -- against ill-formed subunits that have an improper context. Do_Analyze; if Present (Comp_Unit) and then Nkind (Unit (Comp_Unit)) in N_Proper_Body + and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body + or else not Acts_As_Spec (Comp_Unit)) and then not In_Extended_Main_Source_Unit (Comp_Unit) then null; *************** package body Sem is *** 1517,1522 **** --- 1534,1542 ---- procedure Walk_Library_Items is type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; pragma Pack (Unit_Number_Set); + + Main_CU : constant Node_Id := Cunit (Main_Unit); + Seen, Done : Unit_Number_Set := (others => False); -- Seen (X) is True after we have seen unit X in the walk. This is used -- to prevent processing the same unit more than once. Done (X) is True *************** package body Sem is *** 1528,1533 **** --- 1548,1569 ---- -- This is needed because the spec of the main unit may appear in the -- context of some other unit. We do not want this to force processing -- of the main body before all other units have been processed. + -- + -- Another circularity pattern occurs when the main unit is a child unit + -- and the body of an ancestor has a with-clause of the main unit or on + -- one of its children. In both cases the body in question has a with- + -- clause on the main unit, and must be excluded from the traversal. In + -- some convoluted cases this may lead to a CodePeer error because the + -- spec of a subprogram declared in an instance within the parent will + -- not be seen in the main unit. + + function Depends_On_Main (CU : Node_Id) return Boolean; + -- The body of a unit that is withed by the spec of the main unit may in + -- turn have a with_clause on that spec. In that case do not traverse + -- the body, to prevent loops. It can also happen that the main body has + -- a with_clause on a child, which of course has an implicit with on its + -- parent. It's OK to traverse the child body if the main spec has been + -- processed, otherwise we also have a circularity to avoid. procedure Do_Action (CU : Node_Id; Item : Node_Id); -- Calls Action, with some validity checks *************** package body Sem is *** 1537,1542 **** --- 1573,1622 ---- -- this unit. If it's an instance body, do the spec first. If it is -- an instance spec, do the body last. + procedure Do_Withed_Unit (Withed_Unit : Node_Id); + -- Apply Do_Unit_And_Dependents to a unit in a context clause. + + procedure Process_Bodies_In_Context (Comp : Node_Id); + -- The main unit and its spec may depend on bodies that contain generics + -- that are instantiated in them. Iterate through the corresponding + -- contexts before processing main (spec/body) itself, to process bodies + -- that may be present, together with their context. The spec of main + -- is processed wherever it appears in the list of units, while the body + -- is processed as the last unit in the list. + + --------------------- + -- Depends_On_Main -- + --------------------- + + function Depends_On_Main (CU : Node_Id) return Boolean is + CL : Node_Id; + MCU : constant Node_Id := Unit (Main_CU); + + begin + CL := First (Context_Items (CU)); + + -- Problem does not arise with main subprograms + + if + not Nkind_In (MCU, N_Package_Body, N_Package_Declaration) + then + return False; + end if; + + while Present (CL) loop + if Nkind (CL) = N_With_Clause + and then Library_Unit (CL) = Main_CU + and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) + then + return True; + end if; + + Next (CL); + end loop; + + return False; + end Depends_On_Main; + --------------- -- Do_Action -- --------------- *************** package body Sem is *** 1565,1576 **** when N_Package_Body => ! -- Package bodies are processed immediately after the ! -- corresponding spec. null; ! when N_Subprogram_Body => -- A subprogram body must be the main unit --- 1645,1656 ---- when N_Package_Body => ! -- Package bodies are processed separately if the main unit ! -- depends on them. null; ! when N_Subprogram_Body => -- A subprogram body must be the main unit *************** package body Sem is *** 1578,1591 **** or else CU = Cunit (Main_Unit)); null; - -- All other cases cannot happen - when N_Function_Instantiation | N_Procedure_Instantiation | N_Package_Instantiation => ! pragma Assert (False, "instantiation"); null; when N_Subunit => pragma Assert (False, "subunit"); null; --- 1658,1674 ---- or else CU = Cunit (Main_Unit)); null; when N_Function_Instantiation | N_Procedure_Instantiation | N_Package_Instantiation => ! ! -- Can only happen if some generic body (needed for gnat2scil ! -- traversal, but not by GNAT) is not available, ignore. ! null; + -- All other cases cannot happen + when N_Subunit => pragma Assert (False, "subunit"); null; *************** package body Sem is *** 1622,1627 **** --- 1705,1711 ---- (Unit (Withed_Unit), N_Generic_Package_Declaration, N_Package_Body, + N_Package_Renaming_Declaration, N_Subprogram_Body) then Write_Unit_Name *************** package body Sem is *** 1647,1658 **** Write_Unit_Info (Unit_Num, Item, Withs => True); end if; ! -- Main unit should come last (except in the case where we -- skipped System_Aux_Id, in which case we missed the things it ! -- depends on). pragma Assert ! (not Done (Main_Unit) or else Present (System_Aux_Id)); -- We shouldn't do the same thing twice --- 1731,1744 ---- Write_Unit_Info (Unit_Num, Item, Withs => True); end if; ! -- Main unit should come last, except in the case where we -- skipped System_Aux_Id, in which case we missed the things it ! -- depends on, and in the case of parent bodies if present. pragma Assert ! (not Done (Main_Unit) ! or else Present (System_Aux_Id) ! or else Nkind (Item) = N_Package_Body); -- We shouldn't do the same thing twice *************** package body Sem is *** 1677,1714 **** Action (Item); end Do_Action; ! ---------------------------- ! -- Do_Unit_And_Dependents -- ! ---------------------------- ! ! procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is ! Unit_Num : constant Unit_Number_Type := ! Get_Cunit_Unit_Number (CU); ! procedure Do_Withed_Unit (Withed_Unit : Node_Id); ! -- Pass the buck to Do_Unit_And_Dependents ! -------------------- ! -- Do_Withed_Unit -- ! -------------------- ! procedure Do_Withed_Unit (Withed_Unit : Node_Id) is ! Save_Do_Main : constant Boolean := Do_Main; ! begin ! -- Do not process the main unit if coming from a with_clause, ! -- as would happen with a parent body that has a child spec ! -- in its context. ! Do_Main := False; ! Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); ! Do_Main := Save_Do_Main; ! end Do_Withed_Unit; procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); - -- Start of processing for Do_Unit_And_Dependents - begin if not Seen (Unit_Num) then --- 1763,1801 ---- Action (Item); end Do_Action; ! -------------------- ! -- Do_Withed_Unit -- ! -------------------- ! procedure Do_Withed_Unit (Withed_Unit : Node_Id) is ! begin ! Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); ! -- If the unit in the with_clause is a generic instance, the clause ! -- now denotes the instance body. Traverse the corresponding spec ! -- because there may be no other dependence that will force the ! -- traversal of its own context. ! if Nkind (Unit (Withed_Unit)) = N_Package_Body ! and then Is_Generic_Instance ! (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) ! then ! Do_Withed_Unit (Library_Unit (Withed_Unit)); ! end if; ! end Do_Withed_Unit; ! ---------------------------- ! -- Do_Unit_And_Dependents -- ! ---------------------------- ! procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is ! Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); ! Child : Node_Id; ! Body_U : Unit_Number_Type; ! Parent_CU : Node_Id; procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); begin if not Seen (Unit_Num) then *************** package body Sem is *** 1716,1814 **** Do_Withed_Units (CU, Include_Limited => False); ! -- Process the unit if it is a spec. If it is the main unit, ! -- process it only if we have done all other units. if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) or else Acts_As_Spec (CU) then ! if CU = Cunit (Main_Unit) and then not Do_Main then Seen (Unit_Num) := False; else Seen (Unit_Num) := True; Do_Action (CU, Item); Done (Unit_Num) := True; end if; end if; end if; ! -- Process bodies. The spec, if present, has been processed already. ! -- A body appears if it is the main, or the body of a spec that is ! -- in the context of the main unit, and that is instantiated, or else ! -- contains a generic that is instantiated, or a subprogram that is ! -- or a subprogram that is inlined in the main unit. ! -- We exclude bodies that may appear in a circular dependency list, ! -- where spec A depends on spec B and body of B depends on spec A. ! -- This is not an elaboration issue, but body B must be excluded ! -- from the processing. ! declare ! Body_Unit : Node_Id := Empty; ! Body_Num : Unit_Number_Type; ! function Circular_Dependence (B : Node_Id) return Boolean; ! -- Check whether this body depends on a spec that is pending, ! -- that is to say has been seen but not processed yet. ! ------------------------- ! -- Circular_Dependence -- ! ------------------------- ! function Circular_Dependence (B : Node_Id) return Boolean is ! Item : Node_Id; ! UN : Unit_Number_Type; ! begin ! Item := First (Context_Items (B)); ! while Present (Item) loop ! if Nkind (Item) = N_With_Clause then ! UN := Get_Cunit_Unit_Number (Library_Unit (Item)); ! if Seen (UN) ! and then not Done (UN) ! then ! return True; ! end if; end if; ! ! Next (Item); ! end loop; ! ! return False; ! end Circular_Dependence; ! ! begin ! if Nkind (Item) = N_Package_Declaration then ! Body_Unit := Library_Unit (CU); ! ! elsif Nkind_In (Item, N_Package_Body, N_Subprogram_Body) then ! Body_Unit := CU; end if; ! if Present (Body_Unit) ! ! -- Since specs and bodies are not done at the same time, ! -- guard against listing a body more than once. Bodies are ! -- only processed when the main unit is being processed, ! -- after all other units in the list. The DEC extension ! -- to System is excluded because of circularities. ! ! and then not Seen (Get_Cunit_Unit_Number (Body_Unit)) ! and then ! (No (System_Aux_Id) ! or else Unit_Num /= Get_Source_Unit (System_Aux_Id)) ! and then not Circular_Dependence (Body_Unit) ! and then Do_Main ! then ! Body_Num := Get_Cunit_Unit_Number (Body_Unit); ! Seen (Body_Num) := True; ! Do_Action (Body_Unit, Unit (Body_Unit)); ! Done (Body_Num) := True; ! end if; ! end; ! end Do_Unit_And_Dependents; -- Local Declarations --- 1803,1912 ---- Do_Withed_Units (CU, Include_Limited => False); ! -- Process the unit if it is a spec or the main unit, if it ! -- has no previous spec or we have done all other units. if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) or else Acts_As_Spec (CU) then ! if CU = Cunit (Main_Unit) ! and then not Do_Main ! then Seen (Unit_Num) := False; else Seen (Unit_Num) := True; + + if CU = Library_Unit (Main_CU) then + Process_Bodies_In_Context (CU); + + -- If main is a child unit, examine parent unit contexts + -- to see if they include instantiated units. Also, if + -- the parent itself is an instance, process its body + -- because it may contain subprograms that are called + -- in the main unit. + + if Is_Child_Unit (Cunit_Entity (Main_Unit)) then + Child := Cunit_Entity (Main_Unit); + while Is_Child_Unit (Child) loop + Parent_CU := + Cunit + (Get_Cunit_Entity_Unit_Number (Scope (Child))); + Process_Bodies_In_Context (Parent_CU); + + if Nkind (Unit (Parent_CU)) = N_Package_Body + and then + Nkind (Original_Node (Unit (Parent_CU))) + = N_Package_Instantiation + and then + not Seen (Get_Cunit_Unit_Number (Parent_CU)) + then + Body_U := Get_Cunit_Unit_Number (Parent_CU); + Seen (Body_U) := True; + Do_Action (Parent_CU, Unit (Parent_CU)); + Done (Body_U) := True; + end if; + + Child := Scope (Child); + end loop; + end if; + end if; + Do_Action (CU, Item); Done (Unit_Num) := True; end if; end if; end if; + end Do_Unit_And_Dependents; ! ------------------------------- ! -- Process_Bodies_In_Context -- ! ------------------------------- ! procedure Process_Bodies_In_Context (Comp : Node_Id) is ! Body_CU : Node_Id; ! Body_U : Unit_Number_Type; ! Clause : Node_Id; ! Spec : Node_Id; ! procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); ! -- Start of processing for Process_Bodies_In_Context ! begin ! Clause := First (Context_Items (Comp)); ! while Present (Clause) loop ! if Nkind (Clause) = N_With_Clause then ! Spec := Library_Unit (Clause); ! Body_CU := Library_Unit (Spec); ! -- If we are processing the spec of the main unit, load bodies ! -- only if the with_clause indicates that it forced the loading ! -- of the body for a generic instantiation. Note that bodies of ! -- parents that are instances have been loaded already. ! if Present (Body_CU) ! and then Body_CU /= Cunit (Main_Unit) ! and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body ! and then (Nkind (Unit (Comp)) /= N_Package_Declaration ! or else Present (Withed_Body (Clause))) ! then ! Body_U := Get_Cunit_Unit_Number (Body_CU); ! if not Seen (Body_U) ! and then not Depends_On_Main (Body_CU) ! then ! Seen (Body_U) := True; ! Do_Withed_Units (Body_CU, Include_Limited => False); ! Do_Action (Body_CU, Unit (Body_CU)); ! Done (Body_U) := True; end if; ! end if; end if; ! Next (Clause); ! end loop; ! end Process_Bodies_In_Context; -- Local Declarations *************** package body Sem is *** 1848,1905 **** end; end loop; ! -- Now traverse compilation units in order Cur := First_Elmt (Comp_Unit_List); while Present (Cur) loop declare ! CU : constant Node_Id := Node (Cur); ! N : constant Node_Id := Unit (CU); begin pragma Assert (Nkind (CU) = N_Compilation_Unit); case Nkind (N) is ! -- If it's a body, ignore it. Bodies appear in the list only ! -- because of inlining/instantiations, and they are processed ! -- immediately after the corresponding specs. The main unit is ! -- processed separately after all other units. ! when N_Package_Body | N_Subprogram_Body => ! null; ! -- It's a spec, so just do it when others => ! Do_Unit_And_Dependents (CU, N); end case; end; Next_Elmt (Cur); end loop; if not Done (Main_Unit) then Do_Main := True; ! declare ! Main_CU : constant Node_Id := Cunit (Main_Unit); begin ! -- If the main unit is an instantiation, the body appears before ! -- the instance spec, which is added later to the unit list. Do ! -- the spec if present, body will follow. ! if Nkind (Original_Node (Unit (Main_CU))) ! in N_Generic_Instantiation ! and then Present (Library_Unit (Main_CU)) ! then ! Do_Unit_And_Dependents ! (Library_Unit (Main_CU), Unit (Library_Unit (Main_CU))); ! else ! Do_Unit_And_Dependents (Main_CU, Unit (Main_CU)); end if; ! end; end if; if Debug_Unit_Walk then --- 1946,2105 ---- end; end loop; ! -- Now traverse compilation units (specs) in order Cur := First_Elmt (Comp_Unit_List); while Present (Cur) loop declare ! CU : constant Node_Id := Node (Cur); ! N : constant Node_Id := Unit (CU); ! Par : Entity_Id; begin pragma Assert (Nkind (CU) = N_Compilation_Unit); case Nkind (N) is ! -- If it is a subprogram body, process it if it has no ! -- separate spec. ! -- If it's a package body, ignore it, unless it is a body ! -- created for an instance that is the main unit. In the case ! -- of subprograms, the body is the wrapper package. In case of ! -- a package, the original file carries the body, and the spec ! -- appears as a later entry in the units list. ! -- Otherwise bodies appear in the list only because of inlining ! -- or instantiations, and they are processed only if relevant. ! -- The flag Withed_Body on a context clause indicates that a ! -- unit contains an instantiation that may be needed later, ! -- and therefore the body that contains the generic body (and ! -- its context) must be traversed immediately after the ! -- corresponding spec (see Do_Unit_And_Dependents). ! ! -- The main unit itself is processed separately after all other ! -- specs, and relevant bodies are examined in Process_Main. ! ! when N_Subprogram_Body => ! if Acts_As_Spec (N) then ! Do_Unit_And_Dependents (CU, N); ! end if; ! ! when N_Package_Body => ! if CU = Main_CU ! and then Nkind (Original_Node (Unit (Main_CU))) in ! N_Generic_Instantiation ! and then Present (Library_Unit (Main_CU)) ! then ! Do_Unit_And_Dependents ! (Library_Unit (Main_CU), ! Unit (Library_Unit (Main_CU))); ! end if; ! ! -- It's a spec, process it, and the units it depends on, ! -- unless it is a descendent of the main unit. This can ! -- happen when the body of a parent depends on some other ! -- descendent. when others => ! Par := Scope (Defining_Entity (Unit (CU))); ! ! if Is_Child_Unit (Defining_Entity (Unit (CU))) then ! while Present (Par) ! and then Par /= Standard_Standard ! and then Par /= Cunit_Entity (Main_Unit) ! loop ! Par := Scope (Par); ! end loop; ! end if; ! ! if Par /= Cunit_Entity (Main_Unit) then ! Do_Unit_And_Dependents (CU, N); ! end if; end case; end; Next_Elmt (Cur); end loop; + -- Now process package bodies on which main depends, followed by bodies + -- of parents, if present, and finally main itself. + if not Done (Main_Unit) then Do_Main := True; ! Process_Main : declare ! Parent_CU : Node_Id; ! Body_CU : Node_Id; ! Body_U : Unit_Number_Type; ! Child : Entity_Id; ! ! function Is_Subunit_Of_Main (U : Node_Id) return Boolean; ! -- If the main unit has subunits, their context may include ! -- bodies that are needed in the body of main. We must examine ! -- the context of the subunits, which are otherwise not made ! -- explicit in the main unit. ! ! ------------------------ ! -- Is_Subunit_Of_Main -- ! ------------------------ ! ! function Is_Subunit_Of_Main (U : Node_Id) return Boolean is ! Lib : Node_Id; ! begin ! if No (U) then ! return False; ! else ! Lib := Library_Unit (U); ! return Nkind (Unit (U)) = N_Subunit ! and then ! (Lib = Cunit (Main_Unit) ! or else Is_Subunit_Of_Main (Lib)); ! end if; ! end Is_Subunit_Of_Main; ! ! -- Start of processing for Process_Main begin ! Process_Bodies_In_Context (Main_CU); ! for Unit_Num in Done'Range loop ! if Is_Subunit_Of_Main (Cunit (Unit_Num)) then ! Process_Bodies_In_Context (Cunit (Unit_Num)); ! end if; ! end loop; ! ! -- If the main unit is a child unit, parent bodies may be present ! -- because they export instances or inlined subprograms. Check for ! -- presence of these, which are not present in context clauses. ! -- Note that if the parents are instances, their bodies have been ! -- processed before the main spec, because they may be needed ! -- therein, so the following loop only affects non-instances. ! ! if Is_Child_Unit (Cunit_Entity (Main_Unit)) then ! Child := Cunit_Entity (Main_Unit); ! while Is_Child_Unit (Child) loop ! Parent_CU := ! Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); ! Body_CU := Library_Unit (Parent_CU); ! ! if Present (Body_CU) ! and then not Seen (Get_Cunit_Unit_Number (Body_CU)) ! and then not Depends_On_Main (Body_CU) ! then ! Body_U := Get_Cunit_Unit_Number (Body_CU); ! Seen (Body_U) := True; ! Do_Action (Body_CU, Unit (Body_CU)); ! Done (Body_U) := True; ! end if; ! ! Child := Scope (Child); ! end loop; end if; ! ! Do_Action (Main_CU, Unit (Main_CU)); ! Done (Main_Unit) := True; ! end Process_Main; end if; if Debug_Unit_Walk then *************** package body Sem is *** 1996,2001 **** --- 2196,2203 ---- pragma Assert (Nkind (CU) = N_Compilation_Unit); Context_Item : Node_Id; + Lib_Unit : Node_Id; + Body_CU : Node_Id; begin Context_Item := First (Context_Items (CU)); *************** package body Sem is *** 2004,2010 **** and then (Include_Limited or else not Limited_Present (Context_Item)) then ! Action (Library_Unit (Context_Item)); end if; Context_Item := Next (Context_Item); --- 2206,2237 ---- and then (Include_Limited or else not Limited_Present (Context_Item)) then ! Lib_Unit := Library_Unit (Context_Item); ! Action (Lib_Unit); ! ! -- If the context item indicates that a package body is needed ! -- because of an instantiation in CU, traverse the body now, even ! -- if CU is not related to the main unit. If the generic itself ! -- appears in a package body, the context item is this body, and ! -- it already appears in the traversal order, so we only need to ! -- examine the case of a context item being a package declaration. ! ! if Present (Withed_Body (Context_Item)) ! and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration ! and then Present (Corresponding_Body (Unit (Lib_Unit))) ! then ! Body_CU := ! Parent ! (Unit_Declaration_Node ! (Corresponding_Body (Unit (Lib_Unit)))); ! ! -- A body may have an implicit with on its own spec, in which ! -- case we must ignore this context item to prevent looping. ! ! if Unit (CU) /= Unit (Body_CU) then ! Action (Body_CU); ! end if; ! end if; end if; Context_Item := Next (Context_Item); diff -Nrcpad gcc-4.5.2/gcc/ada/sem.ads gcc-4.6.0/gcc/ada/sem.ads *** gcc-4.5.2/gcc/ada/sem.ads Fri Jun 19 12:29:26 2009 --- gcc-4.6.0/gcc/ada/sem.ads Mon Oct 18 14:05:56 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem is *** 462,467 **** --- 462,470 ---- Save_Check_Policy_List : Node_Id; -- Save contents of Check_Policy_List on entry to restore on exit + Save_Default_Storage_Pool : Node_Id; + -- Save contents of Default_Storage_Pool on entry to restore on exit + Is_Transient : Boolean; -- Marks transient scopes (see Exp_Ch7 body for details) diff -Nrcpad gcc-4.5.2/gcc/ada/sem_aggr.adb gcc-4.6.0/gcc/ada/sem_aggr.adb *** gcc-4.5.2/gcc/ada/sem_aggr.adb Tue Jan 26 09:42:04 2010 --- gcc-4.6.0/gcc/ada/sem_aggr.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Sinfo; use Sinfo; *** 54,59 **** --- 54,60 ---- with Snames; use Snames; with Stringt; use Stringt; with Stand; use Stand; + with Style; use Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; *************** package body Sem_Aggr is *** 525,534 **** Is_Fully_Positional : Boolean := True; procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos); ! -- N is an array (sub-)aggregate. Dim is the dimension corresponding to ! -- (sub-)aggregate N. This procedure collects the constrained N_Range ! -- nodes corresponding to each index dimension of our aggregate itype. ! -- These N_Range nodes are collected in Aggr_Range above. -- -- Likewise collect in Aggr_Low & Aggr_High above the low and high -- bounds of each index dimension. If, when collecting, two bounds --- 526,536 ---- Is_Fully_Positional : Boolean := True; procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos); ! -- N is an array (sub-)aggregate. Dim is the dimension corresponding ! -- to (sub-)aggregate N. This procedure collects and removes the side ! -- effects of the constrained N_Range nodes corresponding to each index ! -- dimension of our aggregate itype. These N_Range nodes are collected ! -- in Aggr_Range above. -- -- Likewise collect in Aggr_Low & Aggr_High above the low and high -- bounds of each index dimension. If, when collecting, two bounds *************** package body Sem_Aggr is *** 551,556 **** --- 553,561 ---- Expr : Node_Id; begin + Remove_Side_Effects (This_Low, Variable_Ref => True); + Remove_Side_Effects (This_High, Variable_Ref => True); + -- Collect the first N_Range for a given dimension that you find. -- For a given dimension they must be all equal anyway. *************** package body Sem_Aggr is *** 568,574 **** Set_Raises_Constraint_Error (N); Error_Msg_N ("sub-aggregate low bound mismatch?", N); Error_Msg_N ! ("\Constraint_Error will be raised at run-time?", N); end if; end if; --- 573,579 ---- Set_Raises_Constraint_Error (N); Error_Msg_N ("sub-aggregate low bound mismatch?", N); Error_Msg_N ! ("\Constraint_Error will be raised at run time?", N); end if; end if; *************** package body Sem_Aggr is *** 582,588 **** Set_Raises_Constraint_Error (N); Error_Msg_N ("sub-aggregate high bound mismatch?", N); Error_Msg_N ! ("\Constraint_Error will be raised at run-time?", N); end if; end if; end if; --- 587,593 ---- Set_Raises_Constraint_Error (N); Error_Msg_N ("sub-aggregate high bound mismatch?", N); Error_Msg_N ! ("\Constraint_Error will be raised at run time?", N); end if; end if; end if; *************** package body Sem_Aggr is *** 631,637 **** Set_Parent (Index_Constraints, N); Collect_Aggr_Bounds (N, 1); ! -- Build the list of constrained indices of our aggregate itype for J in 1 .. Aggr_Dimension loop Create_Index : declare --- 636,642 ---- Set_Parent (Index_Constraints, N); Collect_Aggr_Bounds (N, 1); ! -- Build the list of constrained indexes of our aggregate itype for J in 1 .. Aggr_Dimension loop Create_Index : declare *************** package body Sem_Aggr is *** 886,892 **** ----------------------- procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is ! Pkind : constant Node_Kind := Nkind (Parent (N)); Aggr_Subtyp : Entity_Id; -- The actual aggregate subtype. This is not necessarily the same as Typ --- 891,898 ---- ----------------------- procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Pkind : constant Node_Kind := Nkind (Parent (N)); Aggr_Subtyp : Entity_Id; -- The actual aggregate subtype. This is not necessarily the same as Typ *************** package body Sem_Aggr is *** 916,922 **** -- Ada 2005 (AI-287): Limited aggregates allowed ! if Is_Limited_Type (Typ) and then Ada_Version < Ada_05 then Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); --- 922,928 ---- -- Ada 2005 (AI-287): Limited aggregates allowed ! if Is_Limited_Type (Typ) and then Ada_Version < Ada_2005 then Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); *************** package body Sem_Aggr is *** 973,980 **** Next (Expr); end loop; ! Rewrite (N, ! Make_String_Literal (Sloc (N), End_String)); Analyze_And_Resolve (N, Typ); return; --- 979,985 ---- Next (Expr); end loop; ! Rewrite (N, Make_String_Literal (Loc, End_String)); Analyze_And_Resolve (N, Typ); return; *************** package body Sem_Aggr is *** 994,1009 **** -- subtype for the final aggregate. begin ! -- In the following we determine whether an others choice is -- allowed inside the array aggregate. The test checks the context -- in which the array aggregate occurs. If the context does not ! -- permit it, or the aggregate type is unconstrained, an others -- choice is not allowed. -- If expansion is disabled (generic context, or semantics-only -- mode) actual subtypes cannot be constructed, and the type of an -- object may be its unconstrained nominal type. However, if the ! -- context is an assignment, we assume that "others" is allowed, -- because the target of the assignment will have a constrained -- subtype when fully compiled. --- 999,1014 ---- -- subtype for the final aggregate. begin ! -- In the following we determine whether an OTHERS choice is -- allowed inside the array aggregate. The test checks the context -- in which the array aggregate occurs. If the context does not ! -- permit it, or the aggregate type is unconstrained, an OTHERS -- choice is not allowed. -- If expansion is disabled (generic context, or semantics-only -- mode) actual subtypes cannot be constructed, and the type of an -- object may be its unconstrained nominal type. However, if the ! -- context is an assignment, we assume that OTHERS is allowed, -- because the target of the assignment will have a constrained -- subtype when fully compiled. *************** package body Sem_Aggr is *** 1049,1054 **** --- 1054,1060 ---- Index_Constr => First_Index (Typ), Component_Typ => Component_Type (Typ), Others_Allowed => True); + else Aggr_Resolved := Resolve_Array_Aggregate *************** package body Sem_Aggr is *** 1087,1093 **** if Raises_Constraint_Error (N) then Aggr_Subtyp := Etype (N); Rewrite (N, ! Make_Raise_Constraint_Error (Sloc (N), Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (N); Set_Etype (N, Aggr_Subtyp); --- 1093,1099 ---- if Raises_Constraint_Error (N) then Aggr_Subtyp := Etype (N); Rewrite (N, ! Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (N); Set_Etype (N, Aggr_Subtyp); *************** package body Sem_Aggr is *** 1128,1137 **** -- analyzed expression. procedure Check_Bound (BH : Node_Id; AH : in out Node_Id); ! -- Checks that AH (the upper bound of an array aggregate) is <= BH ! -- (the upper bound of the index base type). If the check fails a ! -- warning is emitted, the Raises_Constraint_Error flag of N is set, ! -- and AH is replaced with a duplicate of BH. procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id); -- Checks that range AL .. AH is compatible with range L .. H. Emits a --- 1134,1143 ---- -- analyzed expression. procedure Check_Bound (BH : Node_Id; AH : in out Node_Id); ! -- Checks that AH (the upper bound of an array aggregate) is less than ! -- or equal to BH (the upper bound of the index base type). If the check ! -- fails, a warning is emitted, the Raises_Constraint_Error flag of N is ! -- set, and AH is replaced with a duplicate of BH. procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id); -- Checks that range AL .. AH is compatible with range L .. H. Emits a *************** package body Sem_Aggr is *** 1155,1161 **** -- Resolves aggregate expression Expr. Returns False if resolution -- fails. If Single_Elmt is set to False, the expression Expr may be -- used to initialize several array aggregate elements (this can happen ! -- for discrete choices such as "L .. H => Expr" or the others choice). -- In this event we do not resolve Expr unless expansion is disabled. -- To know why, see the DELAYED COMPONENT RESOLUTION note above. --- 1161,1167 ---- -- Resolves aggregate expression Expr. Returns False if resolution -- fails. If Single_Elmt is set to False, the expression Expr may be -- used to initialize several array aggregate elements (this can happen ! -- for discrete choices such as "L .. H => Expr" or the OTHERS choice). -- In this event we do not resolve Expr unless expansion is disabled. -- To know why, see the DELAYED COMPONENT RESOLUTION note above. *************** package body Sem_Aggr is *** 1206,1213 **** if not Is_Enumeration_Type (Index_Base) then Expr := Make_Op_Add (Loc, ! Left_Opnd => Duplicate_Subexpr (To), ! Right_Opnd => Make_Integer_Literal (Loc, Val)); -- If we are dealing with enumeration return -- Index_Typ'Val (Index_Typ'Pos (To) + Val) --- 1212,1219 ---- if not Is_Enumeration_Type (Index_Base) then Expr := Make_Op_Add (Loc, ! Left_Opnd => Duplicate_Subexpr (To), ! Right_Opnd => Make_Integer_Literal (Loc, Val)); -- If we are dealing with enumeration return -- Index_Typ'Val (Index_Typ'Pos (To) + Val) *************** package body Sem_Aggr is *** 1231,1236 **** --- 1237,1266 ---- Prefix => New_Reference_To (Index_Typ, Loc), Attribute_Name => Name_Val, Expressions => New_List (Expr_Pos)); + + -- If the index type has a non standard representation, the + -- attributes 'Val and 'Pos expand into function calls and the + -- resulting expression is considered non-safe for reevaluation + -- by the backend. Relocate it into a constant temporary in order + -- to make it safe for reevaluation. + + if Has_Non_Standard_Rep (Etype (N)) then + declare + Def_Id : Entity_Id; + + begin + Def_Id := Make_Temporary (Loc, 'R', Expr); + Set_Etype (Def_Id, Index_Typ); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Index_Typ, Loc), + Constant_Present => True, + Expression => Relocate_Node (Expr))); + + Expr := New_Reference_To (Def_Id, Loc); + end; + end if; end if; return Expr; *************** package body Sem_Aggr is *** 1254,1263 **** if OK_BH and then OK_AH and then Val_BH < Val_AH then Set_Raises_Constraint_Error (N); Error_Msg_N ("upper bound out of range?", AH); ! Error_Msg_N ("\Constraint_Error will be raised at run-time?", AH); -- You need to set AH to BH or else in the case of enumerations ! -- indices we will not be able to resolve the aggregate bounds. AH := Duplicate_Subexpr (BH); end if; --- 1284,1293 ---- if OK_BH and then OK_AH and then Val_BH < Val_AH then Set_Raises_Constraint_Error (N); Error_Msg_N ("upper bound out of range?", AH); ! Error_Msg_N ("\Constraint_Error will be raised at run time?", AH); -- You need to set AH to BH or else in the case of enumerations ! -- indexes we will not be able to resolve the aggregate bounds. AH := Duplicate_Subexpr (BH); end if; *************** package body Sem_Aggr is *** 1297,1309 **** if OK_L and then Val_L > Val_AL then Set_Raises_Constraint_Error (N); Error_Msg_N ("lower bound of aggregate out of range?", N); ! Error_Msg_N ("\Constraint_Error will be raised at run-time?", N); end if; if OK_H and then Val_H < Val_AH then Set_Raises_Constraint_Error (N); Error_Msg_N ("upper bound of aggregate out of range?", N); ! Error_Msg_N ("\Constraint_Error will be raised at run-time?", N); end if; end Check_Bounds; --- 1327,1339 ---- if OK_L and then Val_L > Val_AL then Set_Raises_Constraint_Error (N); Error_Msg_N ("lower bound of aggregate out of range?", N); ! Error_Msg_N ("\Constraint_Error will be raised at run time?", N); end if; if OK_H and then Val_H < Val_AH then Set_Raises_Constraint_Error (N); Error_Msg_N ("upper bound of aggregate out of range?", N); ! Error_Msg_N ("\Constraint_Error will be raised at run time?", N); end if; end Check_Bounds; *************** package body Sem_Aggr is *** 1343,1349 **** if Range_Len < Len then Set_Raises_Constraint_Error (N); Error_Msg_N ("too many elements?", N); ! Error_Msg_N ("\Constraint_Error will be raised at run-time?", N); end if; end Check_Length; --- 1373,1379 ---- if Range_Len < Len then Set_Raises_Constraint_Error (N); Error_Msg_N ("too many elements?", N); ! Error_Msg_N ("\Constraint_Error will be raised at run time?", N); end if; end Check_Length; *************** package body Sem_Aggr is *** 1410,1415 **** --- 1440,1453 ---- -- Set to False if resolution of the expression failed begin + -- Defend against previous errors + + if Nkind (Expr) = N_Error + or else Error_Posted (Expr) + then + return True; + end if; + -- If the array type against which we are resolving the aggregate -- has several dimensions, the expressions nested inside the -- aggregate must be further aggregates (or strings). *************** package body Sem_Aggr is *** 1443,1450 **** -- a missing component association for a 1-aggregate. if Paren_Count (Expr) > 0 then ! Error_Msg_N ("\if single-component aggregate is intended," ! & " write e.g. (1 ='> ...)", Expr); end if; return Failure; end if; --- 1481,1489 ---- -- a missing component association for a 1-aggregate. if Paren_Count (Expr) > 0 then ! Error_Msg_N ! ("\if single-component aggregate is intended," ! & " write e.g. (1 ='> ...)", Expr); end if; return Failure; end if; *************** package body Sem_Aggr is *** 1744,1750 **** -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_05 and then Known_Null (Expression (Assoc)) then Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); --- 1783,1789 ---- -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_2005 and then Known_Null (Expression (Assoc)) then Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); *************** package body Sem_Aggr is *** 1785,1790 **** --- 1824,1842 ---- Expander_Mode_Save_And_Set (False); Full_Analysis := False; Analyze (Expr); + + -- If the expression is a literal, propagate this info + -- to the expression in the association, to enable some + -- optimizations downstream. + + if Is_Entity_Name (Expr) + and then Present (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Enumeration_Literal + then + Analyze_And_Resolve + (Expression (Assoc), Component_Typ); + end if; + Full_Analysis := Save_Analysis; Expander_Mode_Restore; *************** package body Sem_Aggr is *** 1798,1805 **** elsif Is_Tagged_Type (Etype (Expression (Assoc))) then Check_Dynamically_Tagged_Expression ! (Expr => Expression (Assoc), ! Typ => Component_Type (Etype (N)), Related_Nod => N); end if; --- 1850,1857 ---- elsif Is_Tagged_Type (Etype (Expression (Assoc))) then Check_Dynamically_Tagged_Expression ! (Expr => Expression (Assoc), ! Typ => Component_Type (Etype (N)), Related_Nod => N); end if; *************** package body Sem_Aggr is *** 2033,2039 **** -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_05 and then Known_Null (Expr) then Check_Can_Never_Be_Null (Etype (N), Expr); --- 2085,2091 ---- -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_2005 and then Known_Null (Expr) then Check_Can_Never_Be_Null (Etype (N), Expr); *************** package body Sem_Aggr is *** 2060,2066 **** -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_05 and then Known_Null (Assoc) then Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); --- 2112,2118 ---- -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_2005 and then Known_Null (Assoc) then Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); *************** package body Sem_Aggr is *** 2288,2293 **** --- 2340,2357 ---- then A_Type := Etype (Imm_Type); return True; + + -- The parent type may be a private extension. The aggregate is + -- legal if the type of the aggregate is an extension of it that + -- is not a private extension. + + elsif Is_Private_Type (A_Type) + and then not Is_Private_Type (Imm_Type) + and then Present (Full_View (A_Type)) + and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type) + then + return True; + else Imm_Type := Etype (Base_Type (Imm_Type)); end if; *************** package body Sem_Aggr is *** 2316,2322 **** -- Ada 2005 (AI-287): Limited aggregates are allowed ! if Ada_Version < Ada_05 then Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); return; --- 2380,2386 ---- -- Ada 2005 (AI-287): Limited aggregates are allowed ! if Ada_Version < Ada_2005 then Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); return; *************** package body Sem_Aggr is *** 2356,2362 **** -- Only consider limited interpretations in the Ada 2005 case if Is_Tagged_Type (It.Typ) ! and then (Ada_Version >= Ada_05 or else not Is_Limited_Type (It.Typ)) then if A_Type /= Any_Type then --- 2420,2426 ---- -- Only consider limited interpretations in the Ada 2005 case if Is_Tagged_Type (It.Typ) ! and then (Ada_Version >= Ada_2005 or else not Is_Limited_Type (It.Typ)) then if A_Type /= Any_Type then *************** package body Sem_Aggr is *** 2371,2377 **** end loop; if A_Type = Any_Type then ! if Ada_Version >= Ada_05 then Error_Msg_N ("ancestor part must be of a tagged type", A); else Error_Msg_N --- 2435,2441 ---- end loop; if A_Type = Any_Type then ! if Ada_Version >= Ada_2005 then Error_Msg_N ("ancestor part must be of a tagged type", A); else Error_Msg_N *************** package body Sem_Aggr is *** 2403,2408 **** --- 2467,2502 ---- Error_Msg_N ("type of limited ancestor part must be constrained", A); + -- Reject the use of CPP constructors that leave objects partially + -- initialized. For example: + + -- type CPP_Root is tagged limited record ... + -- pragma Import (CPP, CPP_Root); + + -- type CPP_DT is new CPP_Root and Iface ... + -- pragma Import (CPP, CPP_DT); + + -- type Ada_DT is new CPP_DT with ... + + -- Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>); + + -- Using the constructor of CPP_Root the slots of the dispatch + -- table of CPP_DT cannot be set, and the secondary tag of + -- CPP_DT is unknown. + + elsif Nkind (A) = N_Function_Call + and then Is_CPP_Constructor_Call (A) + and then Enclosing_CPP_Parent (Typ) /= A_Type + then + Error_Msg_NE + ("?must use 'C'P'P constructor for type &", A, + Enclosing_CPP_Parent (Typ)); + + -- The following call is not needed if the previous warning + -- is promoted to an error. + + Resolve_Record_Aggregate (N, Typ); + elsif Is_Class_Wide_Type (Etype (A)) and then Nkind (Original_Node (A)) = N_Function_Call then *************** package body Sem_Aggr is *** 2488,2508 **** -- whose value may already have been specified by N's ancestor part. -- This routine checks whether this is indeed the case and if so returns -- False, signaling that no value for Discr should appear in N's ! -- aggregate part. Also, in this case, the routine appends ! -- New_Assoc_List Discr the discriminant value specified in the ancestor ! -- part. ! -- Can't parse previous sentence, appends what where??? function Get_Value (Compon : Node_Id; From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id; ! -- Given a record component stored in parameter Compon, the following ! -- function returns its value as it appears in the list From, which is ! -- a list of N_Component_Association nodes. ! -- What is this referring to??? There is no "following function" in ! -- sight??? -- If no component association has a choice for the searched component, -- the value provided by the others choice is returned, if there is one, -- and Consider_Others_Choice is set to true. Otherwise Empty is --- 2582,2605 ---- -- whose value may already have been specified by N's ancestor part. -- This routine checks whether this is indeed the case and if so returns -- False, signaling that no value for Discr should appear in N's ! -- aggregate part. Also, in this case, the routine appends to ! -- New_Assoc_List the discriminant value specified in the ancestor part. ! -- ! -- If the aggregate is in a context with expansion delayed, it will be ! -- reanalyzed. The inherited discriminant values must not be reinserted ! -- in the component list to prevent spurious errors, but they must be ! -- present on first analysis to build the proper subtype indications. ! -- The flag Inherited_Discriminant is used to prevent the re-insertion. function Get_Value (Compon : Node_Id; From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id; ! -- Given a record component stored in parameter Compon, this function ! -- returns its value as it appears in the list From, which is a list ! -- of N_Component_Association nodes. ! -- -- If no component association has a choice for the searched component, -- the value provided by the others choice is returned, if there is one, -- and Consider_Others_Choice is set to true. Otherwise Empty is *************** package body Sem_Aggr is *** 2556,2561 **** --- 2653,2659 ---- Loc : Source_Ptr; Ancestor : Node_Id; + Comp_Assoc : Node_Id; Discr_Expr : Node_Id; Ancestor_Typ : Entity_Id; *************** package body Sem_Aggr is *** 2570,2575 **** --- 2668,2688 ---- return True; end if; + -- Check whether inherited discriminant values have already been + -- inserted in the aggregate. This will be the case if we are + -- re-analyzing an aggregate whose expansion was delayed. + + if Present (Component_Associations (N)) then + Comp_Assoc := First (Component_Associations (N)); + while Present (Comp_Assoc) loop + if Inherited_Discriminant (Comp_Assoc) then + return True; + end if; + + Next (Comp_Assoc); + end loop; + end if; + Ancestor := Ancestor_Part (N); Ancestor_Typ := Etype (Ancestor); Loc := Sloc (Ancestor); *************** package body Sem_Aggr is *** 2627,2632 **** --- 2740,2746 ---- end if; Resolve_Aggr_Expr (Discr_Expr, Discr); + Set_Inherited_Discriminant (Last (New_Assoc_List)); return False; end if; *************** package body Sem_Aggr is *** 2720,2726 **** -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_05 and then Known_Null (Expression (Assoc)) then Check_Can_Never_Be_Null (Compon, Expression (Assoc)); --- 2834,2840 ---- -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_2005 and then Known_Null (Expression (Assoc)) then Check_Can_Never_Be_Null (Compon, Expression (Assoc)); *************** package body Sem_Aggr is *** 2962,2968 **** -- aggregate for a null record type was established by AI05-016. elsif No (First_Entity (Typ)) ! and then Ada_Version < Ada_05 then Error_Msg_N ("record aggregate must be null", N); return; --- 3076,3082 ---- -- aggregate for a null record type was established by AI05-016. elsif No (First_Entity (Typ)) ! and then Ada_Version < Ada_2005 then Error_Msg_N ("record aggregate must be null", N); return; *************** package body Sem_Aggr is *** 2991,3003 **** if Selector_Name /= First (Choices (Assoc)) or else Present (Next (Selector_Name)) then ! Error_Msg_N ("OTHERS must appear alone in a choice list", ! Selector_Name); return; elsif Present (Next (Assoc)) then ! Error_Msg_N ("OTHERS must appear last in an aggregate", ! Selector_Name); return; -- (Ada2005): If this is an association with a box, --- 3105,3119 ---- if Selector_Name /= First (Choices (Assoc)) or else Present (Next (Selector_Name)) then ! Error_Msg_N ! ("OTHERS must appear alone in a choice list", ! Selector_Name); return; elsif Present (Next (Assoc)) then ! Error_Msg_N ! ("OTHERS must appear last in an aggregate", ! Selector_Name); return; -- (Ada2005): If this is an association with a box, *************** package body Sem_Aggr is *** 3057,3063 **** -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_05 and then Known_Null (Positional_Expr) then Check_Can_Never_Be_Null (Discrim, Positional_Expr); --- 3173,3179 ---- -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_2005 and then Known_Null (Positional_Expr) then Check_Can_Never_Be_Null (Discrim, Positional_Expr); *************** package body Sem_Aggr is *** 3213,3230 **** Error_Msg_NE ("type of aggregate has private ancestor&!", N, Root_Typ); ! Error_Msg_N ("must use extension aggregate!", N); return; end if; Dnode := Declaration_Node (Base_Type (Root_Typ)); ! -- If we don't get a full declaration, then we have some ! -- error which will get signalled later so skip this part. ! -- Otherwise, gather components of root that apply to the ! -- aggregate type. We use the base type in case there is an ! -- applicable stored constraint that renames the discriminants ! -- of the root. if Nkind (Dnode) = N_Full_Type_Declaration then Record_Def := Type_Definition (Dnode); --- 3329,3345 ---- Error_Msg_NE ("type of aggregate has private ancestor&!", N, Root_Typ); ! Error_Msg_N ("must use extension aggregate!", N); return; end if; Dnode := Declaration_Node (Base_Type (Root_Typ)); ! -- If we don't get a full declaration, then we have some error ! -- which will get signalled later so skip this part. Otherwise ! -- gather components of root that apply to the aggregate type. ! -- We use the base type in case there is an applicable stored ! -- constraint that renames the discriminants of the root. if Nkind (Dnode) = N_Full_Type_Declaration then Record_Def := Type_Definition (Dnode); *************** package body Sem_Aggr is *** 3259,3264 **** --- 3374,3388 ---- Ancestor_Part (N), Parent_Typ); return; end if; + + -- The current view of ancestor part may be a private type, + -- while the context type is always non-private. + + elsif Is_Private_Type (Root_Typ) + and then Present (Full_View (Root_Typ)) + and then Nkind (N) = N_Extension_Aggregate + then + exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ; end if; end loop; *************** package body Sem_Aggr is *** 3332,3338 **** -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_05 and then Known_Null (Positional_Expr) then Check_Can_Never_Be_Null (Component, Positional_Expr); --- 3456,3462 ---- -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_2005 and then Known_Null (Positional_Expr) then Check_Can_Never_Be_Null (Component, Positional_Expr); *************** package body Sem_Aggr is *** 3453,3467 **** -- for the rest, if other components are present. -- The type of the aggregate is the known subtype of -- the component. The capture of discriminants must ! -- be recursive because subcomponents may be contrained -- (transitively) by discriminants of enclosing types. -- For a private type with discriminants, a call to the -- initialization procedure will be generated, and no -- subaggregate is needed. Capture_Discriminants : declare ! Loc : constant Source_Ptr := Sloc (N); ! Expr : Node_Id; procedure Add_Discriminant_Values (New_Aggr : Node_Id; --- 3577,3591 ---- -- for the rest, if other components are present. -- The type of the aggregate is the known subtype of -- the component. The capture of discriminants must ! -- be recursive because subcomponents may be constrained -- (transitively) by discriminants of enclosing types. -- For a private type with discriminants, a call to the -- initialization procedure will be generated, and no -- subaggregate is needed. Capture_Discriminants : declare ! Loc : constant Source_Ptr := Sloc (N); ! Expr : Node_Id; procedure Add_Discriminant_Values (New_Aggr : Node_Id; *************** package body Sem_Aggr is *** 3475,3482 **** procedure Propagate_Discriminants (Aggr : Node_Id; ! Assoc_List : List_Id; ! Comp : Entity_Id); -- Nested components may themselves be discriminated -- types constrained by outer discriminants, whose -- values must be captured before the aggregate is --- 3599,3605 ---- procedure Propagate_Discriminants (Aggr : Node_Id; ! Assoc_List : List_Id); -- Nested components may themselves be discriminated -- types constrained by outer discriminants, whose -- values must be captured before the aggregate is *************** package body Sem_Aggr is *** 3558,3585 **** procedure Propagate_Discriminants (Aggr : Node_Id; ! Assoc_List : List_Id; ! Comp : Entity_Id) is ! Inner_Comp : Entity_Id; ! Comp_Type : Entity_Id; Needs_Box : Boolean := False; ! New_Aggr : Node_Id; ! begin ! Inner_Comp := First_Component (Etype (Comp)); ! while Present (Inner_Comp) loop ! Comp_Type := Etype (Inner_Comp); ! if Is_Record_Type (Comp_Type) ! and then Has_Discriminants (Comp_Type) then New_Aggr := Make_Aggregate (Loc, New_List, New_List); ! Set_Etype (New_Aggr, Comp_Type); Add_Association ! (Inner_Comp, New_Aggr, Component_Associations (Aggr)); -- Collect discriminant values and recurse --- 3681,3722 ---- procedure Propagate_Discriminants (Aggr : Node_Id; ! Assoc_List : List_Id) is ! Aggr_Type : constant Entity_Id := ! Base_Type (Etype (Aggr)); ! Def_Node : constant Node_Id := ! Type_Definition ! (Declaration_Node (Aggr_Type)); ! ! Comp : Node_Id; ! Comp_Elmt : Elmt_Id; ! Components : constant Elist_Id := New_Elmt_List; Needs_Box : Boolean := False; ! Errors : Boolean; ! procedure Process_Component (Comp : Entity_Id); ! -- Add one component with a box association to the ! -- inner aggregate, and recurse if component is ! -- itself composite. ! ------------------------ ! -- Process_Component -- ! ------------------------ ! procedure Process_Component (Comp : Entity_Id) is ! T : constant Entity_Id := Etype (Comp); ! New_Aggr : Node_Id; ! ! begin ! if Is_Record_Type (T) ! and then Has_Discriminants (T) then New_Aggr := Make_Aggregate (Loc, New_List, New_List); ! Set_Etype (New_Aggr, T); Add_Association ! (Comp, New_Aggr, Component_Associations (Aggr)); -- Collect discriminant values and recurse *************** package body Sem_Aggr is *** 3587,3600 **** Add_Discriminant_Values (New_Aggr, Assoc_List); Propagate_Discriminants ! (New_Aggr, Assoc_List, Inner_Comp); else Needs_Box := True; end if; ! Next_Component (Inner_Comp); ! end loop; if Needs_Box then Append --- 3724,3778 ---- Add_Discriminant_Values (New_Aggr, Assoc_List); Propagate_Discriminants ! (New_Aggr, Assoc_List); else Needs_Box := True; end if; + end Process_Component; ! -- Start of processing for Propagate_Discriminants ! ! begin ! -- The component type may be a variant type, so ! -- collect the components that are ruled by the ! -- known values of the discriminants. Their values ! -- have already been inserted into the component ! -- list of the current aggregate. ! ! if Nkind (Def_Node) = N_Record_Definition ! and then ! Present (Component_List (Def_Node)) ! and then ! Present ! (Variant_Part (Component_List (Def_Node))) ! then ! Gather_Components (Aggr_Type, ! Component_List (Def_Node), ! Governed_By => Component_Associations (Aggr), ! Into => Components, ! Report_Errors => Errors); ! ! Comp_Elmt := First_Elmt (Components); ! while Present (Comp_Elmt) loop ! if ! Ekind (Node (Comp_Elmt)) /= E_Discriminant ! then ! Process_Component (Node (Comp_Elmt)); ! end if; ! ! Next_Elmt (Comp_Elmt); ! end loop; ! ! -- No variant part, iterate over all components ! ! else ! Comp := First_Component (Etype (Aggr)); ! while Present (Comp) loop ! Process_Component (Comp); ! Next_Component (Comp); ! end loop; ! end if; if Needs_Box then Append *************** package body Sem_Aggr is *** 3607,3636 **** end if; end Propagate_Discriminants; begin Expr := Make_Aggregate (Loc, New_List, New_List); Set_Etype (Expr, Ctyp); ! -- If the enclosing type has discriminants, they ! -- have been collected in the aggregate earlier, and ! -- they may appear as constraints of subcomponents. -- Similarly if this component has discriminants, they -- might in turn be propagated to their components. if Has_Discriminants (Typ) then Add_Discriminant_Values (Expr, New_Assoc_List); ! Propagate_Discriminants ! (Expr, New_Assoc_List, Component); elsif Has_Discriminants (Ctyp) then Add_Discriminant_Values ! (Expr, Component_Associations (Expr)); Propagate_Discriminants ! (Expr, Component_Associations (Expr), Component); else declare ! Comp : Entity_Id; begin -- If the type has additional components, create --- 3785,3816 ---- end if; end Propagate_Discriminants; + -- Start of processing for Capture_Discriminants + begin Expr := Make_Aggregate (Loc, New_List, New_List); Set_Etype (Expr, Ctyp); ! -- If the enclosing type has discriminants, they have ! -- been collected in the aggregate earlier, and they ! -- may appear as constraints of subcomponents. ! -- Similarly if this component has discriminants, they -- might in turn be propagated to their components. if Has_Discriminants (Typ) then Add_Discriminant_Values (Expr, New_Assoc_List); ! Propagate_Discriminants (Expr, New_Assoc_List); elsif Has_Discriminants (Ctyp) then Add_Discriminant_Values ! (Expr, Component_Associations (Expr)); Propagate_Discriminants ! (Expr, Component_Associations (Expr)); else declare ! Comp : Entity_Id; begin -- If the type has additional components, create *************** package body Sem_Aggr is *** 3737,3743 **** New_Assoc := First (New_Assoc_List); while Present (New_Assoc) loop Component := First (Choices (New_Assoc)); ! exit when Chars (Selectr) = Chars (Component); Next (New_Assoc); end loop; --- 3917,3931 ---- New_Assoc := First (New_Assoc_List); while Present (New_Assoc) loop Component := First (Choices (New_Assoc)); ! ! if Chars (Selectr) = Chars (Component) then ! if Style_Check then ! Check_Identifier (Selectr, Entity (Component)); ! end if; ! ! exit; ! end if; ! Next (New_Assoc); end loop; *************** package body Sem_Aggr is *** 3801,3808 **** elsif No (Typech) then Typech := Base_Type (Etype (Component)); elsif Typech /= Base_Type (Etype (Component)) then ! if not Box_Present (Parent (Selectr)) then Error_Msg_N ("components in choice list must have same type", Selectr); --- 3989,4011 ---- elsif No (Typech) then Typech := Base_Type (Etype (Component)); + -- AI05-0199: In Ada 2012, several components of anonymous + -- access types can appear in a choice list, as long as the + -- designated types match. + elsif Typech /= Base_Type (Etype (Component)) then ! if Ada_Version >= Ada_2012 ! and then Ekind (Typech) = E_Anonymous_Access_Type ! and then ! Ekind (Etype (Component)) = E_Anonymous_Access_Type ! and then Base_Type (Designated_Type (Typech)) = ! Base_Type (Designated_Type (Etype (Component))) ! and then ! Subtypes_Statically_Match (Typech, (Etype (Component))) ! then ! null; ! ! elsif not Box_Present (Parent (Selectr)) then Error_Msg_N ("components in choice list must have same type", Selectr); *************** package body Sem_Aggr is *** 3839,3845 **** begin pragma Assert ! (Ada_Version >= Ada_05 and then Present (Expr) and then Known_Null (Expr)); --- 4042,4048 ---- begin pragma Assert ! (Ada_Version >= Ada_2005 and then Present (Expr) and then Known_Null (Expr)); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_attr.adb gcc-4.6.0/gcc/ada/sem_attr.adb *** gcc-4.5.2/gcc/ada/sem_attr.adb Wed Oct 28 13:31:51 2009 --- gcc-4.6.0/gcc/ada/sem_attr.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Style; *** 66,72 **** with Stylesw; use Stylesw; with Targparm; use Targparm; with Ttypes; use Ttypes; - with Ttypef; use Ttypef; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; --- 66,71 ---- *************** package body Sem_Attr is *** 136,141 **** --- 135,141 ---- Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_Machine_Rounding | + Attribute_Mod | Attribute_Priority | Attribute_Stream_Size | Attribute_Wide_Wide_Width => True, *************** package body Sem_Attr is *** 211,216 **** --- 211,223 ---- -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. -- Internally, Id distinguishes which of the three cases is involved. + procedure Bad_Attribute_For_Predicate; + -- Output error message for use of a predicate (First, Last, Range) not + -- allowed with a type that has predicates. If the type is a generic + -- actual, then the message is a warning, and we generate code to raise + -- program error with an appropriate reason. No error message is given + -- for internally generated uses of the attributes. + procedure Check_Array_Or_Scalar_Type; -- Common procedure used by First, Last, Range attribute to check -- that the prefix is a constrained array or scalar type, or a name *************** package body Sem_Attr is *** 583,588 **** --- 590,599 ---- Check_For_Eliminated_Subprogram (P, Entity (P)); + -- Check for obsolescent subprogram reference + + Check_Obsolescent_2005_Entity (Entity (P), P); + -- Build the appropriate subprogram type Build_Access_Subprogram_Type (P); *************** package body Sem_Attr is *** 692,697 **** --- 703,714 ---- ("current instance attribute must appear alone", N); end if; + if Is_CPP_Class (Root_Type (Typ)) then + Error_Msg_N + ("?current instance unsupported for derivations of " + & "'C'P'P types", N); + end if; + -- OK if we are in initialization procedure for the type -- in question, in which case the reference to the type -- is rewritten as a reference to the current object. *************** package body Sem_Attr is *** 719,725 **** -- expression comes from source, e.g. when a single component -- association in an aggregate has a box association. ! elsif Ada_Version >= Ada_05 and then OK_Self_Reference then null; --- 736,742 ---- -- expression comes from source, e.g. when a single component -- association in an aggregate has a box association. ! elsif Ada_Version >= Ada_2005 and then OK_Self_Reference then null; *************** package body Sem_Attr is *** 816,821 **** --- 833,851 ---- end if; end Analyze_Access_Attribute; + --------------------------------- + -- Bad_Attribute_For_Predicate -- + --------------------------------- + + procedure Bad_Attribute_For_Predicate is + begin + if Comes_From_Source (N) then + Error_Msg_Name_1 := Aname; + Bad_Predicated_Subtype_Use + ("type& has predicates, attribute % not allowed", N, P_Type); + end if; + end Bad_Attribute_For_Predicate; + -------------------------------- -- Check_Array_Or_Scalar_Type -- -------------------------------- *************** package body Sem_Attr is *** 1338,1344 **** -- S : constant Integer := X.all'Size; -- ERROR -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR ! if Ada_Version >= Ada_05 and then Nkind (P) = N_Explicit_Dereference then E := P; --- 1368,1374 ---- -- S : constant Integer := X.all'Size; -- ERROR -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR ! if Ada_Version >= Ada_2005 and then Nkind (P) = N_Explicit_Dereference then E := P; *************** package body Sem_Attr is *** 1600,1606 **** end if; -- Check special case of Exception_Id and Exception_Occurrence which ! -- are not allowed for restriction No_Exception_Regstriation. if Is_RTE (P_Type, RE_Exception_Id) or else --- 1630,1636 ---- end if; -- Check special case of Exception_Id and Exception_Occurrence which ! -- are not allowed for restriction No_Exception_Registration. if Is_RTE (P_Type, RE_Exception_Id) or else *************** package body Sem_Attr is *** 1660,1666 **** if Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) and then Is_Task_Type (Designated_Type (Etype (P)))) ! or else (Ada_Version >= Ada_05 and then Ekind (Etype (P)) = E_Class_Wide_Type and then Is_Interface (Etype (P)) and then Is_Task_Interface (Etype (P))) --- 1690,1696 ---- if Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) and then Is_Task_Type (Designated_Type (Etype (P)))) ! or else (Ada_Version >= Ada_2005 and then Ekind (Etype (P)) = E_Class_Wide_Type and then Is_Interface (Etype (P)) and then Is_Task_Interface (Etype (P))) *************** package body Sem_Attr is *** 1668,1674 **** Resolve (P); else ! if Ada_Version >= Ada_05 then Error_Attr_P ("prefix of % attribute must be a task or a task " & "interface class-wide object"); --- 1698,1704 ---- Resolve (P); else ! if Ada_Version >= Ada_2005 then Error_Attr_P ("prefix of % attribute must be a task or a task " & "interface class-wide object"); *************** package body Sem_Attr is *** 1968,1974 **** -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current -- output compiling in Ada 95 mode for the case of ambiguous prefixes. ! if Ada_Version < Ada_05 and then Is_Overloaded (P) and then Aname /= Name_Access and then Aname /= Name_Address --- 1998,2004 ---- -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current -- output compiling in Ada 95 mode for the case of ambiguous prefixes. ! if Ada_Version < Ada_2005 and then Is_Overloaded (P) and then Aname /= Name_Access and then Aname /= Name_Address *************** package body Sem_Attr is *** 1979,1985 **** then Error_Attr ("ambiguous prefix for % attribute", P); ! elsif Ada_Version >= Ada_05 and then Is_Overloaded (P) and then Aname /= Name_Access and then Aname /= Name_Address --- 2009,2015 ---- then Error_Attr ("ambiguous prefix for % attribute", P); ! elsif Ada_Version >= Ada_2005 and then Is_Overloaded (P) and then Aname /= Name_Access and then Aname /= Name_Address *************** package body Sem_Attr is *** 1991,1997 **** -- entry wrappers, the attributes Count, Caller and AST_Entry require -- a context check ! if Ada_Version >= Ada_05 and then (Aname = Name_Count or else Aname = Name_Caller or else Aname = Name_AST_Entry) --- 2021,2027 ---- -- entry wrappers, the attributes Count, Caller and AST_Entry require -- a context check ! if Ada_Version >= Ada_2005 and then (Aname = Name_Count or else Aname = Name_Caller or else Aname = Name_AST_Entry) *************** package body Sem_Attr is *** 2384,2391 **** and then Base_Type (Typ) = Typ and then Warn_On_Redundant_Constructs then ! Error_Msg_NE ! ("?redundant attribute, & is its own base type", N, Typ); end if; Set_Etype (N, Base_Type (Entity (P))); --- 2414,2421 ---- and then Base_Type (Typ) = Typ and then Warn_On_Redundant_Constructs then ! Error_Msg_NE -- CODEFIX ! ("?redundant attribute, & is its own base type", N, Typ); end if; Set_Etype (N, Base_Type (Entity (P))); *************** package body Sem_Attr is *** 2534,2539 **** --- 2564,2588 ---- Check_E0; Find_Type (N); + -- Applying Class to untagged incomplete type is obsolescent in Ada + -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since + -- this flag gets set by Find_Type in this situation. + + if Restriction_Check_Required (No_Obsolescent_Features) + and then Ada_Version >= Ada_2005 + and then Ekind (P_Type) = E_Incomplete_Type + then + declare + DN : constant Node_Id := Declaration_Node (P_Type); + begin + if Nkind (DN) = N_Incomplete_Type_Declaration + and then not Tagged_Present (DN) + then + Check_Restriction (No_Obsolescent_Features, P); + end if; + end; + end if; + ------------------ -- Code_Address -- ------------------ *************** package body Sem_Attr is *** 2611,2617 **** -- Case from RM J.4(2) of constrained applied to private type if Is_Entity_Name (P) and then Is_Type (Entity (P)) then ! Check_Restriction (No_Obsolescent_Features, N); if Warn_On_Obsolescent_Feature then Error_Msg_N --- 2660,2666 ---- -- Case from RM J.4(2) of constrained applied to private type if Is_Entity_Name (P) and then Is_Type (Entity (P)) then ! Check_Restriction (No_Obsolescent_Features, P); if Warn_On_Obsolescent_Feature then Error_Msg_N *************** package body Sem_Attr is *** 2775,2784 **** exit; elsif Ekind (Scope (Ent)) in Task_Kind ! and then Ekind (S) /= E_Loop ! and then Ekind (S) /= E_Block ! and then Ekind (S) /= E_Entry ! and then Ekind (S) /= E_Entry_Family then Error_Attr ("Attribute % cannot appear in inner unit", N); --- 2824,2831 ---- exit; elsif Ekind (Scope (Ent)) in Task_Kind ! and then ! not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family) then Error_Attr ("Attribute % cannot appear in inner unit", N); *************** package body Sem_Attr is *** 2804,2810 **** -- Ada 2005 (AI-345): Do not consider primitive entry -- wrappers generated for task or protected types. ! elsif Ada_Version >= Ada_05 and then not Comes_From_Source (It.Nam) then null; --- 2851,2857 ---- -- Ada 2005 (AI-345): Do not consider primitive entry -- wrappers generated for task or protected types. ! elsif Ada_Version >= Ada_2005 and then not Comes_From_Source (It.Nam) then null; *************** package body Sem_Attr is *** 2961,2967 **** Ekind (Entity (P)) /= E_Enumeration_Literal) then Error_Attr_P ! ("prefix of %attribute must be " & "discrete type/object or enum literal"); end if; end if; --- 3008,3014 ---- Ekind (Entity (P)) /= E_Enumeration_Literal) then Error_Attr_P ! ("prefix of % attribute must be " & "discrete type/object or enum literal"); end if; end if; *************** package body Sem_Attr is *** 3051,3056 **** --- 3098,3104 ---- when Attribute_First => Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; --------------- -- First_Bit -- *************** package body Sem_Attr is *** 3147,3153 **** elsif Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) and then Is_Task_Type (Designated_Type (Etype (P)))) ! or else (Ada_Version >= Ada_05 and then Ekind (Etype (P)) = E_Class_Wide_Type and then Is_Interface (Etype (P)) and then Is_Task_Interface (Etype (P))) --- 3195,3201 ---- elsif Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) and then Is_Task_Type (Designated_Type (Etype (P)))) ! or else (Ada_Version >= Ada_2005 and then Ekind (Etype (P)) = E_Class_Wide_Type and then Is_Interface (Etype (P)) and then Is_Task_Interface (Etype (P))) *************** package body Sem_Attr is *** 3156,3162 **** Set_Etype (N, RTE (RO_AT_Task_Id)); else ! if Ada_Version >= Ada_05 then Error_Attr_P ("prefix of % attribute must be an exception, a " & "task or a task interface class-wide object"); --- 3204,3210 ---- Set_Etype (N, RTE (RO_AT_Task_Id)); else ! if Ada_Version >= Ada_2005 then Error_Attr_P ("prefix of % attribute must be an exception, a " & "task or a task interface class-wide object"); *************** package body Sem_Attr is *** 3265,3270 **** --- 3313,3319 ---- when Attribute_Last => Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; -------------- -- Last_Bit -- *************** package body Sem_Attr is *** 3392,3401 **** Set_Etype (N, P_Base_Type); ---------------------------------- -- Max_Size_In_Storage_Elements -- ---------------------------------- ! when Attribute_Max_Size_In_Storage_Elements => Check_E0; Check_Type; Check_Not_Incomplete_Type; --- 3441,3452 ---- Set_Etype (N, P_Base_Type); ---------------------------------- + -- Max_Alignment_For_Allocation -- -- Max_Size_In_Storage_Elements -- ---------------------------------- ! when Attribute_Max_Alignment_For_Allocation | ! Attribute_Max_Size_In_Storage_Elements => Check_E0; Check_Type; Check_Not_Incomplete_Type; *************** package body Sem_Attr is *** 3433,3439 **** elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P)) or else UI_To_Int (Intval (E1)) < 0 then ! Error_Attr ("invalid parameter number for %attribute", E1); end if; end if; --- 3484,3490 ---- elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P)) or else UI_To_Int (Intval (E1)) < 0 then ! Error_Attr ("invalid parameter number for % attribute", E1); end if; end if; *************** package body Sem_Attr is *** 3546,3558 **** ---------------------- procedure Must_Be_Imported (Proc_Ent : Entity_Id) is ! Pent : Entity_Id := Proc_Ent; begin - while Present (Alias (Pent)) loop - Pent := Alias (Pent); - end loop; - -- Ignore check if procedure not frozen yet (we will get -- another chance when the default parameter is reanalyzed) --- 3597,3605 ---- ---------------------- procedure Must_Be_Imported (Proc_Ent : Entity_Id) is ! Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent); begin -- Ignore check if procedure not frozen yet (we will get -- another chance when the default parameter is reanalyzed) *************** package body Sem_Attr is *** 3620,3625 **** --- 3667,3690 ---- --------- when Attribute_Old => + + -- The attribute reference is a primary. If expressions follow, the + -- attribute reference is an indexable object, so rewrite the node + -- accordingly. + + if Present (E1) then + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (N)), + Attribute_Name => Name_Old), + Expressions => Expressions (N))); + + Analyze (N); + return; + end if; + Check_E0; Set_Etype (N, P_Type); *************** package body Sem_Attr is *** 3644,3651 **** Subp : Entity_Id := Current_Subprogram; function Process (N : Node_Id) return Traverse_Result; ! -- Check that N does not contain references to local variables ! -- or other local entities of Subp. ------------- -- Process -- --- 3709,3716 ---- Subp : Entity_Id := Current_Subprogram; function Process (N : Node_Id) return Traverse_Result; ! -- Check that N does not contain references to local variables or ! -- other local entities of Subp. ------------- -- Process -- *************** package body Sem_Attr is *** 3654,3659 **** --- 3719,3725 ---- function Process (N : Node_Id) return Traverse_Result is begin if Is_Entity_Name (N) + and then Present (Entity (N)) and then not Is_Formal (Entity (N)) and then Enclosing_Subprogram (Entity (N)) = Subp then *************** package body Sem_Attr is *** 3680,3689 **** if Present (Enclosing_Subprogram (Current_Subprogram)) then -- Check that there is no reference to the enclosing ! -- subprogram local variables. Otherwise, we might end ! -- up being called from the enclosing subprogram and thus ! -- using 'Old on a local variable which is not defined ! -- at entry time. Subp := Enclosing_Subprogram (Current_Subprogram); Check_No_Local (P); --- 3746,3755 ---- if Present (Enclosing_Subprogram (Current_Subprogram)) then -- Check that there is no reference to the enclosing ! -- subprogram local variables. Otherwise, we might end up ! -- being called from the enclosing subprogram and thus using ! -- 'Old on a local variable which is not defined at entry ! -- time. Subp := Enclosing_Subprogram (Current_Subprogram); Check_No_Local (P); *************** package body Sem_Attr is *** 3729,3736 **** elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then ! Error_Attr_P ! ("prefix of % attribute must not be declared pure"); end if; end if; --- 3795,3801 ---- elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then ! Error_Attr_P ("prefix of% attribute must not be declared pure"); end if; end if; *************** package body Sem_Attr is *** 3804,3810 **** -- Ada 2005 (AI-327): Dynamic ceiling priorities when Attribute_Priority => ! if Ada_Version < Ada_05 then Error_Attr ("% attribute is allowed only in Ada 2005 mode", P); end if; --- 3869,3875 ---- -- Ada 2005 (AI-327): Dynamic ceiling priorities when Attribute_Priority => ! if Ada_Version < Ada_2005 then Error_Attr ("% attribute is allowed only in Ada 2005 mode", P); end if; *************** package body Sem_Attr is *** 3853,3858 **** --- 3918,3924 ---- when Attribute_Range => Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; if Ada_Version = Ada_83 and then Is_Scalar_Type (P_Type) *************** package body Sem_Attr is *** 3952,3960 **** Error_Attr; end if; ! Rewrite (N, ! Make_Identifier (Sloc (N), ! Chars => Name_uResult)); Analyze_And_Resolve (N, Etype (PS)); else --- 4018,4024 ---- Error_Attr; end if; ! Rewrite (N, Make_Identifier (Sloc (N), Name_uResult)); Analyze_And_Resolve (N, Etype (PS)); else *************** package body Sem_Attr is *** 3985,3990 **** --- 4049,4071 ---- Resolve (N, Standard_Void_Type); Note_Possible_Modification (E2, Sure => True); + --------- + -- Ref -- + --------- + + when Attribute_Ref => + Check_E1; + Analyze (P); + + if Nkind (P) /= N_Expanded_Name + or else not Is_RTE (P_Type, RE_Address) + then + Error_Attr_P ("prefix of % attribute must be System.Address"); + end if; + + Analyze_And_Resolve (E1, Any_Integer); + Set_Etype (N, RTE (RE_Address)); + --------------- -- Remainder -- --------------- *************** package body Sem_Attr is *** 4201,4206 **** --- 4282,4291 ---- if Is_Task_Type (P_Type) then Set_Etype (N, Universal_Integer); + -- Use with tasks is an obsolescent feature + + Check_Restriction (No_Obsolescent_Features, P); + elsif Is_Access_Type (P_Type) then if Ekind (P_Type) = E_Access_Subprogram_Type then Error_Attr_P *************** package body Sem_Attr is *** 4376,4382 **** if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then ! Error_Attr_P ("prefix of %attribute must be System"); end if; Generate_Reference (RTE (RE_Address), P); --- 4461,4467 ---- if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then ! Error_Attr_P ("prefix of % attribute must be System"); end if; Generate_Reference (RTE (RE_Address), P); *************** package body Sem_Attr is *** 4420,4425 **** --- 4505,4553 ---- Check_PolyORB_Attribute; Set_Etype (N, RTE (RE_TypeCode)); + -------------- + -- Type_Key -- + -------------- + + when Attribute_Type_Key => + Check_E0; + Check_Type; + + -- This processing belongs in Eval_Attribute ??? + + declare + function Type_Key return String_Id; + -- A very preliminary implementation. For now, a signature + -- consists of only the type name. This is clearly incomplete + -- (e.g., adding a new field to a record type should change the + -- type's Type_Key attribute). + + -------------- + -- Type_Key -- + -------------- + + function Type_Key return String_Id is + Full_Name : constant String_Id := + Fully_Qualified_Name_String (Entity (P)); + + begin + -- Copy all characters in Full_Name but the trailing NUL + + Start_String; + for J in 1 .. String_Length (Full_Name) - 1 loop + Store_String_Char (Get_String_Char (Full_Name, Int (J))); + end loop; + + Store_String_Chars ("'Type_Key"); + return End_String; + end Type_Key; + + begin + Rewrite (N, Make_String_Literal (Loc, Type_Key)); + end; + + Analyze_And_Resolve (N, Standard_String); + ----------------- -- UET_Address -- ----------------- *************** package body Sem_Attr is *** 4809,4817 **** -- processing, since otherwise gigi might see an attribute which it is -- unprepared to deal with. ! function Aft_Value return Nat; ! -- Computes Aft value for current attribute prefix (used by Aft itself ! -- and also by Width for computing the Width of a fixed point type). procedure Check_Expressions; -- In case where the attribute is not foldable, the expressions, if --- 4937,4947 ---- -- processing, since otherwise gigi might see an attribute which it is -- unprepared to deal with. ! procedure Check_Concurrent_Discriminant (Bound : Node_Id); ! -- If Bound is a reference to a discriminant of a task or protected type ! -- occurring within the object's body, rewrite attribute reference into ! -- a reference to the corresponding discriminal. Use for the expansion ! -- of checks against bounds of entry family index subtypes. procedure Check_Expressions; -- In case where the attribute is not foldable, the expressions, if *************** package body Sem_Attr is *** 4829,4863 **** -- but compile time known value given by Val. It includes the -- necessary checks for out of range values. - procedure Float_Attribute_Universal_Integer - (IEEES_Val : Int; - IEEEL_Val : Int; - IEEEX_Val : Int; - VAXFF_Val : Int; - VAXDF_Val : Int; - VAXGF_Val : Int; - AAMPS_Val : Int; - AAMPL_Val : Int); - -- This procedure evaluates a float attribute with no arguments that - -- returns a universal integer result. The parameters give the values - -- for the possible floating-point root types. See ttypef for details. - -- The prefix type is a float type (and is thus not a generic type). - - procedure Float_Attribute_Universal_Real - (IEEES_Val : String; - IEEEL_Val : String; - IEEEX_Val : String; - VAXFF_Val : String; - VAXDF_Val : String; - VAXGF_Val : String; - AAMPS_Val : String; - AAMPL_Val : String); - -- This procedure evaluates a float attribute with no arguments that - -- returns a universal real result. The parameters give the values - -- required for the possible floating-point root types in string - -- format as real literals with a possible leading minus sign. - -- The prefix type is a float type (and is thus not a generic type). - function Fore_Value return Nat; -- Computes the Fore value for the current attribute prefix, which is -- known to be a static fixed-point type. Used by Fore and Width. --- 4959,4964 ---- *************** package body Sem_Attr is *** 4878,4901 **** -- Verify that the prefix of a potentially static array attribute -- satisfies the conditions of 4.9 (14). ! --------------- ! -- Aft_Value -- ! --------------- ! function Aft_Value return Nat is ! Result : Nat; ! Delta_Val : Ureal; begin ! Result := 1; ! Delta_Val := Delta_Value (P_Type); ! while Delta_Val < Ureal_Tenth loop ! Delta_Val := Delta_Val * Ureal_10; ! Result := Result + 1; ! end loop; ! return Result; ! end Aft_Value; ----------------------- -- Check_Expressions -- --- 4979,5011 ---- -- Verify that the prefix of a potentially static array attribute -- satisfies the conditions of 4.9 (14). ! ----------------------------------- ! -- Check_Concurrent_Discriminant -- ! ----------------------------------- ! procedure Check_Concurrent_Discriminant (Bound : Node_Id) is ! Tsk : Entity_Id; ! -- The concurrent (task or protected) type begin ! if Nkind (Bound) = N_Identifier ! and then Ekind (Entity (Bound)) = E_Discriminant ! and then Is_Concurrent_Record_Type (Scope (Entity (Bound))) ! then ! Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound))); ! if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then ! ! -- Find discriminant of original concurrent type, and use ! -- its current discriminal, which is the renaming within ! -- the task/protected body. ! ! Rewrite (N, ! New_Occurrence_Of ! (Find_Body_Discriminal (Entity (Bound)), Loc)); ! end if; ! end if; ! end Check_Concurrent_Discriminant; ----------------------- -- Check_Expressions -- *************** package body Sem_Attr is *** 4950,5052 **** Compile_Time_Known_Value (Type_High_Bound (Typ)); end Compile_Time_Known_Bounds; - --------------------------------------- - -- Float_Attribute_Universal_Integer -- - --------------------------------------- - - procedure Float_Attribute_Universal_Integer - (IEEES_Val : Int; - IEEEL_Val : Int; - IEEEX_Val : Int; - VAXFF_Val : Int; - VAXDF_Val : Int; - VAXGF_Val : Int; - AAMPS_Val : Int; - AAMPL_Val : Int) - is - Val : Int; - Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type)); - - begin - if Vax_Float (P_Base_Type) then - if Digs = VAXFF_Digits then - Val := VAXFF_Val; - elsif Digs = VAXDF_Digits then - Val := VAXDF_Val; - else pragma Assert (Digs = VAXGF_Digits); - Val := VAXGF_Val; - end if; - - elsif Is_AAMP_Float (P_Base_Type) then - if Digs = AAMPS_Digits then - Val := AAMPS_Val; - else pragma Assert (Digs = AAMPL_Digits); - Val := AAMPL_Val; - end if; - - else - if Digs = IEEES_Digits then - Val := IEEES_Val; - elsif Digs = IEEEL_Digits then - Val := IEEEL_Val; - else pragma Assert (Digs = IEEEX_Digits); - Val := IEEEX_Val; - end if; - end if; - - Fold_Uint (N, UI_From_Int (Val), True); - end Float_Attribute_Universal_Integer; - - ------------------------------------ - -- Float_Attribute_Universal_Real -- - ------------------------------------ - - procedure Float_Attribute_Universal_Real - (IEEES_Val : String; - IEEEL_Val : String; - IEEEX_Val : String; - VAXFF_Val : String; - VAXDF_Val : String; - VAXGF_Val : String; - AAMPS_Val : String; - AAMPL_Val : String) - is - Val : Node_Id; - Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type)); - - begin - if Vax_Float (P_Base_Type) then - if Digs = VAXFF_Digits then - Val := Real_Convert (VAXFF_Val); - elsif Digs = VAXDF_Digits then - Val := Real_Convert (VAXDF_Val); - else pragma Assert (Digs = VAXGF_Digits); - Val := Real_Convert (VAXGF_Val); - end if; - - elsif Is_AAMP_Float (P_Base_Type) then - if Digs = AAMPS_Digits then - Val := Real_Convert (AAMPS_Val); - else pragma Assert (Digs = AAMPL_Digits); - Val := Real_Convert (AAMPL_Val); - end if; - - else - if Digs = IEEES_Digits then - Val := Real_Convert (IEEES_Val); - elsif Digs = IEEEL_Digits then - Val := Real_Convert (IEEEL_Val); - else pragma Assert (Digs = IEEEX_Digits); - Val := Real_Convert (IEEEX_Val); - end if; - end if; - - Set_Sloc (Val, Loc); - Rewrite (N, Val); - Set_Is_Static_Expression (N, Static); - Analyze_And_Resolve (N, C_Type); - end Float_Attribute_Universal_Real; - ---------------- -- Fore_Value -- ---------------- --- 5060,5065 ---- *************** package body Sem_Attr is *** 5256,5263 **** -- Start of processing for Eval_Attribute begin ! -- Acquire first two expressions (at the moment, no attributes ! -- take more than two expressions in any case). if Present (Expressions (N)) then E1 := First (Expressions (N)); --- 5269,5310 ---- -- Start of processing for Eval_Attribute begin ! -- No folding in spec expression that comes from source where the prefix ! -- is an unfrozen entity. This avoids premature folding in cases like: ! ! -- procedure DefExprAnal is ! -- type R is new Integer; ! -- procedure P (Arg : Integer := R'Size); ! -- for R'Size use 64; ! -- procedure P (Arg : Integer := R'Size) is ! -- begin ! -- Put_Line (Arg'Img); ! -- end P; ! -- begin ! -- P; ! -- end; ! ! -- which should print 64 rather than 32. The exclusion of non-source ! -- constructs from this test comes from some internal usage in packed ! -- arrays, which otherwise fails, could use more analysis perhaps??? ! ! -- We do however go ahead with generic actual types, otherwise we get ! -- some regressions, probably these types should be frozen anyway??? ! ! if In_Spec_Expression ! and then Comes_From_Source (N) ! and then not (Is_Entity_Name (P) ! and then ! (Is_Frozen (Entity (P)) ! or else (Is_Type (Entity (P)) ! and then ! Is_Generic_Actual_Type (Entity (P))))) ! then ! return; ! end if; ! ! -- Acquire first two expressions (at the moment, no attributes take more ! -- than two expressions in any case). if Present (Expressions (N)) then E1 := First (Expressions (N)); *************** package body Sem_Attr is *** 5274,5281 **** if Id = Attribute_Enabled then - -- Evaluate the Enabled attribute - -- We skip evaluation if the expander is not active. This is not just -- an optimization. It is of key importance that we not rewrite the -- attribute in a generic template, since we want to pick up the --- 5321,5326 ---- *************** package body Sem_Attr is *** 5457,5463 **** or else Id = Attribute_Type_Class or else ! Id = Attribute_Unconstrained_Array) and then not Is_Generic_Type (P_Entity) then P_Type := P_Entity; --- 5502,5510 ---- or else Id = Attribute_Type_Class or else ! Id = Attribute_Unconstrained_Array ! or else ! Id = Attribute_Max_Alignment_For_Allocation) and then not Is_Generic_Type (P_Entity) then P_Type := P_Entity; *************** package body Sem_Attr is *** 5582,5588 **** then Static := False; ! else if not Is_Constrained (P_Type) or else (Id /= Attribute_First and then Id /= Attribute_Last and then --- 5629,5635 ---- then Static := False; ! elsif Id /= Attribute_Max_Alignment_For_Allocation then if not Is_Constrained (P_Type) or else (Id /= Attribute_First and then Id /= Attribute_Last and then *************** package body Sem_Attr is *** 5626,5635 **** while Present (N) loop Static := Static and then Is_Static_Subtype (Etype (N)); ! -- If however the index type is generic, attributes cannot ! -- be folded. ! if Is_Generic_Type (Etype (N)) and then Id /= Attribute_Component_Size then return; --- 5673,5682 ---- while Present (N) loop Static := Static and then Is_Static_Subtype (Etype (N)); ! -- If however the index type is generic, or derived from ! -- one, attributes cannot be folded. ! if Is_Generic_Type (Root_Type (Etype (N))) and then Id /= Attribute_Component_Size then return; *************** package body Sem_Attr is *** 5756,5762 **** --------- when Attribute_Aft => ! Fold_Uint (N, UI_From_Int (Aft_Value), True); --------------- -- Alignment -- --- 5803,5809 ---- --------- when Attribute_Aft => ! Fold_Uint (N, Aft_Value (P_Type), True); --------------- -- Alignment -- *************** package body Sem_Attr is *** 5984,5989 **** --- 6031,6039 ---- else Fold_Uint (N, Expr_Value (Lo_Bound), Static); end if; + + else + Check_Concurrent_Discriminant (Lo_Bound); end if; end First_Attr; *************** package body Sem_Attr is *** 6172,6177 **** --- 6222,6230 ---- else Fold_Uint (N, Expr_Value (Hi_Bound), Static); end if; + + else + Check_Concurrent_Discriminant (Hi_Bound); end if; end Last; *************** package body Sem_Attr is *** 6192,6204 **** Ind : Node_Id; begin ! -- In the case of a generic index type, the bounds may appear static ! -- but the computation is not meaningful in this case, and may ! -- generate a spurious warning. Ind := First_Index (P_Type); while Present (Ind) loop ! if Is_Generic_Type (Etype (Ind)) then return; end if; --- 6245,6257 ---- Ind : Node_Id; begin ! -- If any index type is a formal type, or derived from one, the ! -- bounds are not static. Treating them as static can produce ! -- spurious warnings or improper constant folding. Ind := First_Index (P_Type); while Present (Ind) loop ! if Is_Generic_Type (Root_Type (Etype (Ind))) then return; end if; *************** package body Sem_Attr is *** 6260,6304 **** ------------------ when Attribute_Machine_Emax => ! Float_Attribute_Universal_Integer ( ! IEEES_Machine_Emax, ! IEEEL_Machine_Emax, ! IEEEX_Machine_Emax, ! VAXFF_Machine_Emax, ! VAXDF_Machine_Emax, ! VAXGF_Machine_Emax, ! AAMPS_Machine_Emax, ! AAMPL_Machine_Emax); ------------------ -- Machine_Emin -- ------------------ when Attribute_Machine_Emin => ! Float_Attribute_Universal_Integer ( ! IEEES_Machine_Emin, ! IEEEL_Machine_Emin, ! IEEEX_Machine_Emin, ! VAXFF_Machine_Emin, ! VAXDF_Machine_Emin, ! VAXGF_Machine_Emin, ! AAMPS_Machine_Emin, ! AAMPL_Machine_Emin); ---------------------- -- Machine_Mantissa -- ---------------------- when Attribute_Machine_Mantissa => ! Float_Attribute_Universal_Integer ( ! IEEES_Machine_Mantissa, ! IEEEL_Machine_Mantissa, ! IEEEX_Machine_Mantissa, ! VAXFF_Machine_Mantissa, ! VAXDF_Machine_Mantissa, ! VAXGF_Machine_Mantissa, ! AAMPS_Machine_Mantissa, ! AAMPL_Machine_Mantissa); ----------------------- -- Machine_Overflows -- --- 6313,6333 ---- ------------------ when Attribute_Machine_Emax => ! Fold_Uint (N, Machine_Emax_Value (P_Type), Static); ------------------ -- Machine_Emin -- ------------------ when Attribute_Machine_Emin => ! Fold_Uint (N, Machine_Emin_Value (P_Type), Static); ---------------------- -- Machine_Mantissa -- ---------------------- when Attribute_Machine_Mantissa => ! Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static); ----------------------- -- Machine_Overflows -- *************** package body Sem_Attr is *** 6346,6352 **** -- Note: for the folding case, it is fine to treat Machine_Rounding -- exactly the same way as Rounding, since this is one of the allowed -- behaviors, and performance is not an issue here. It might be a bit ! -- better to give the same result as it would give at run-time, even -- though the non-determinism is certainly permitted. when Attribute_Machine_Rounding => --- 6375,6381 ---- -- Note: for the folding case, it is fine to treat Machine_Rounding -- exactly the same way as Rounding, since this is one of the allowed -- behaviors, and performance is not an issue here. It might be a bit ! -- better to give the same result as it would give at run time, even -- though the non-determinism is certainly permitted. when Attribute_Machine_Rounding => *************** package body Sem_Attr is *** 6486,6491 **** --- 6515,6543 ---- end Max; ---------------------------------- + -- Max_Alignment_For_Allocation -- + ---------------------------------- + + -- Max_Alignment_For_Allocation is usually the Alignment. However, + -- arrays are allocated with dope, so we need to take into account both + -- the alignment of the array, which comes from the component alignment, + -- and the alignment of the dope. Also, if the alignment is unknown, we + -- use the max (it's OK to be pessimistic). + + when Attribute_Max_Alignment_For_Allocation => + declare + A : Uint := UI_From_Int (Ttypes.Maximum_Alignment); + begin + if Known_Alignment (P_Type) and then + (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A) + then + A := Alignment (P_Type); + end if; + + Fold_Uint (N, A, Static); + end; + + ---------------------------------- -- Max_Size_In_Storage_Elements -- ---------------------------------- *************** package body Sem_Attr is *** 6566,6625 **** ---------------- when Attribute_Model_Emin => ! Float_Attribute_Universal_Integer ( ! IEEES_Model_Emin, ! IEEEL_Model_Emin, ! IEEEX_Model_Emin, ! VAXFF_Model_Emin, ! VAXDF_Model_Emin, ! VAXGF_Model_Emin, ! AAMPS_Model_Emin, ! AAMPL_Model_Emin); ------------------- -- Model_Epsilon -- ------------------- when Attribute_Model_Epsilon => ! Float_Attribute_Universal_Real ( ! IEEES_Model_Epsilon'Universal_Literal_String, ! IEEEL_Model_Epsilon'Universal_Literal_String, ! IEEEX_Model_Epsilon'Universal_Literal_String, ! VAXFF_Model_Epsilon'Universal_Literal_String, ! VAXDF_Model_Epsilon'Universal_Literal_String, ! VAXGF_Model_Epsilon'Universal_Literal_String, ! AAMPS_Model_Epsilon'Universal_Literal_String, ! AAMPL_Model_Epsilon'Universal_Literal_String); -------------------- -- Model_Mantissa -- -------------------- when Attribute_Model_Mantissa => ! Float_Attribute_Universal_Integer ( ! IEEES_Model_Mantissa, ! IEEEL_Model_Mantissa, ! IEEEX_Model_Mantissa, ! VAXFF_Model_Mantissa, ! VAXDF_Model_Mantissa, ! VAXGF_Model_Mantissa, ! AAMPS_Model_Mantissa, ! AAMPL_Model_Mantissa); ----------------- -- Model_Small -- ----------------- when Attribute_Model_Small => ! Float_Attribute_Universal_Real ( ! IEEES_Model_Small'Universal_Literal_String, ! IEEEL_Model_Small'Universal_Literal_String, ! IEEEX_Model_Small'Universal_Literal_String, ! VAXFF_Model_Small'Universal_Literal_String, ! VAXDF_Model_Small'Universal_Literal_String, ! VAXGF_Model_Small'Universal_Literal_String, ! AAMPS_Model_Small'Universal_Literal_String, ! AAMPL_Model_Small'Universal_Literal_String); ------------- -- Modulus -- --- 6618,6645 ---- ---------------- when Attribute_Model_Emin => ! Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static); ------------------- -- Model_Epsilon -- ------------------- when Attribute_Model_Epsilon => ! Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static); -------------------- -- Model_Mantissa -- -------------------- when Attribute_Model_Mantissa => ! Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static); ----------------- -- Model_Small -- ----------------- when Attribute_Model_Small => ! Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static); ------------- -- Modulus -- *************** package body Sem_Attr is *** 6772,6777 **** --- 6792,6804 ---- end case; end; + --------- + -- Ref -- + --------- + + when Attribute_Ref => + Fold_Uint (N, Expr_Value (E1), True); + --------------- -- Remainder -- --------------- *************** package body Sem_Attr is *** 6830,6859 **** --------------- when Attribute_Safe_Emax => ! Float_Attribute_Universal_Integer ( ! IEEES_Safe_Emax, ! IEEEL_Safe_Emax, ! IEEEX_Safe_Emax, ! VAXFF_Safe_Emax, ! VAXDF_Safe_Emax, ! VAXGF_Safe_Emax, ! AAMPS_Safe_Emax, ! AAMPL_Safe_Emax); ---------------- -- Safe_First -- ---------------- when Attribute_Safe_First => ! Float_Attribute_Universal_Real ( ! IEEES_Safe_First'Universal_Literal_String, ! IEEEL_Safe_First'Universal_Literal_String, ! IEEEX_Safe_First'Universal_Literal_String, ! VAXFF_Safe_First'Universal_Literal_String, ! VAXDF_Safe_First'Universal_Literal_String, ! VAXGF_Safe_First'Universal_Literal_String, ! AAMPS_Safe_First'Universal_Literal_String, ! AAMPL_Safe_First'Universal_Literal_String); ---------------- -- Safe_Large -- --- 6857,6870 ---- --------------- when Attribute_Safe_Emax => ! Fold_Uint (N, Safe_Emax_Value (P_Type), Static); ---------------- -- Safe_First -- ---------------- when Attribute_Safe_First => ! Fold_Ureal (N, Safe_First_Value (P_Type), Static); ---------------- -- Safe_Large -- *************** package body Sem_Attr is *** 6864,6878 **** Fold_Ureal (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static); else ! Float_Attribute_Universal_Real ( ! IEEES_Safe_Large'Universal_Literal_String, ! IEEEL_Safe_Large'Universal_Literal_String, ! IEEEX_Safe_Large'Universal_Literal_String, ! VAXFF_Safe_Large'Universal_Literal_String, ! VAXDF_Safe_Large'Universal_Literal_String, ! VAXGF_Safe_Large'Universal_Literal_String, ! AAMPS_Safe_Large'Universal_Literal_String, ! AAMPL_Safe_Large'Universal_Literal_String); end if; --------------- --- 6875,6881 ---- Fold_Ureal (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static); else ! Fold_Ureal (N, Safe_Last_Value (P_Type), Static); end if; --------------- *************** package body Sem_Attr is *** 6880,6894 **** --------------- when Attribute_Safe_Last => ! Float_Attribute_Universal_Real ( ! IEEES_Safe_Last'Universal_Literal_String, ! IEEEL_Safe_Last'Universal_Literal_String, ! IEEEX_Safe_Last'Universal_Literal_String, ! VAXFF_Safe_Last'Universal_Literal_String, ! VAXDF_Safe_Last'Universal_Literal_String, ! VAXGF_Safe_Last'Universal_Literal_String, ! AAMPS_Safe_Last'Universal_Literal_String, ! AAMPL_Safe_Last'Universal_Literal_String); ---------------- -- Safe_Small -- --- 6883,6889 ---- --------------- when Attribute_Safe_Last => ! Fold_Ureal (N, Safe_Last_Value (P_Type), Static); ---------------- -- Safe_Small -- *************** package body Sem_Attr is *** 6906,6920 **** -- Ada 83 Safe_Small for floating-point cases else ! Float_Attribute_Universal_Real ( ! IEEES_Safe_Small'Universal_Literal_String, ! IEEEL_Safe_Small'Universal_Literal_String, ! IEEEX_Safe_Small'Universal_Literal_String, ! VAXFF_Safe_Small'Universal_Literal_String, ! VAXDF_Safe_Small'Universal_Literal_String, ! VAXGF_Safe_Small'Universal_Literal_String, ! AAMPS_Safe_Small'Universal_Literal_String, ! AAMPL_Safe_Small'Universal_Literal_String); end if; ----------- --- 6901,6907 ---- -- Ada 83 Safe_Small for floating-point cases else ! Fold_Ureal (N, Model_Small_Value (P_Type), Static); end if; ----------- *************** package body Sem_Attr is *** 7328,7334 **** -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) Fold_Uint ! (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True); end if; -- Discrete types --- 7315,7322 ---- -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) Fold_Uint ! (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), ! True); end if; -- Discrete types *************** package body Sem_Attr is *** 7363,7369 **** -- All wide characters look like Hex_hhhhhhhh if J > 255 then ! W := 12; else C := Character'Val (J); --- 7351,7360 ---- -- All wide characters look like Hex_hhhhhhhh if J > 255 then ! ! -- No need to compute this more than once! ! ! exit; else C := Character'Val (J); *************** package body Sem_Attr is *** 7376,7388 **** case C is when Reserved_128 | Reserved_129 | Reserved_132 | Reserved_153 - => Wt := 12; when BS | HT | LF | VT | FF | CR | SO | SI | EM | FS | GS | RS | US | RI | MW | ST | PM - => Wt := 2; when NUL | SOH | STX | ETX | EOT | --- 7367,7377 ---- *************** package body Sem_Attr is *** 7394,7406 **** SS2 | SS3 | DCS | PU1 | PU2 | STS | CCH | SPA | EPA | SOS | SCI | CSI | OSC | APC - => Wt := 3; when Space .. Tilde | No_Break_Space .. LC_Y_Diaeresis ! => Wt := 3; end case; W := Int'Max (W, Wt); --- 7383,7402 ---- SS2 | SS3 | DCS | PU1 | PU2 | STS | CCH | SPA | EPA | SOS | SCI | CSI | OSC | APC => Wt := 3; when Space .. Tilde | No_Break_Space .. LC_Y_Diaeresis + => + -- Special case of soft hyphen in Ada 2005 ! if C = Character'Val (16#AD#) ! and then Ada_Version >= Ada_2005 ! then ! Wt := 11; ! else ! Wt := 3; ! end if; end case; W := Int'Max (W, Wt); *************** package body Sem_Attr is *** 7487,7493 **** end if; end Width; ! -- The following attributes denote function that cannot be folded when Attribute_From_Any | Attribute_To_Any | --- 7483,7489 ---- end if; end Width; ! -- The following attributes denote functions that cannot be folded when Attribute_From_Any | Attribute_To_Any | *************** package body Sem_Attr is *** 7541,7546 **** --- 7537,7543 ---- Attribute_Target_Name | Attribute_Terminated | Attribute_To_Address | + Attribute_Type_Key | Attribute_UET_Address | Attribute_Unchecked_Access | Attribute_Universal_Literal_String | *************** package body Sem_Attr is *** 7645,7652 **** -- know will fail, so generate an appropriate warning. if In_Instance_Body then ! Error_Msg_F ! ("?non-local pointer cannot point to local object", P); Error_Msg_F ("\?Program_Error will be raised at run time", P); Rewrite (N, --- 7642,7648 ---- -- know will fail, so generate an appropriate warning. if In_Instance_Body then ! Error_Msg_F ("?non-local pointer cannot point to local object", P); Error_Msg_F ("\?Program_Error will be raised at run time", P); Rewrite (N, *************** package body Sem_Attr is *** 7656,7663 **** return; else ! Error_Msg_F ! ("non-local pointer cannot point to local object", P); -- Check for case where we have a missing access definition --- 7652,7658 ---- return; else ! Error_Msg_F ("non-local pointer cannot point to local object", P); -- Check for case where we have a missing access definition *************** package body Sem_Attr is *** 7686,7694 **** -- Start of processing for Resolve_Attribute begin ! -- If error during analysis, no point in continuing, except for ! -- array types, where we get better recovery by using unconstrained ! -- indices than nothing at all (see Check_Array_Type). if Error_Posted (N) and then Attr_Id /= Attribute_First --- 7681,7689 ---- -- Start of processing for Resolve_Attribute begin ! -- If error during analysis, no point in continuing, except for array ! -- types, where we get better recovery by using unconstrained indexes ! -- than nothing at all (see Check_Array_Type). if Error_Posted (N) and then Attr_Id /= Attribute_First *************** package body Sem_Attr is *** 7774,7780 **** -- Avoid insertion of freeze actions in spec expression mode if not In_Spec_Expression then ! Insert_Actions (N, Freeze_Entity (Entity (P), Loc)); end if; elsif Is_Type (Entity (P)) then --- 7769,7775 ---- -- Avoid insertion of freeze actions in spec expression mode if not In_Spec_Expression then ! Freeze_Before (N, Entity (P)); end if; elsif Is_Type (Entity (P)) then *************** package body Sem_Attr is *** 7813,7823 **** -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? ! if Ekind (Btyp) = E_Access_Subprogram_Type ! or else ! Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type ! or else ! Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type then -- Deal with convention mismatch --- 7808,7816 ---- -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? ! if Ekind_In (Btyp, E_Access_Subprogram_Type, ! E_Anonymous_Access_Subprogram_Type, ! E_Anonymous_Access_Protected_Subprogram_Type) then -- Deal with convention mismatch *************** package body Sem_Attr is *** 7874,7879 **** --- 7867,7873 ---- -- that generic unit. This includes any such attribute that -- occurs within the body of a generic unit that is a child -- of the generic unit where the subprogram is declared. + -- The rule also prohibits applying the attribute when the -- access type is a generic formal access type (since the -- level of the actual type is not known). This restriction *************** package body Sem_Attr is *** 7906,7912 **** --- 7900,7914 ---- -- when within an instance, because any violations will have -- been caught by the compilation of the generic unit. + -- Note that we relax this check in CodePeer mode for + -- compatibility with legacy code, since CodePeer is an + -- Ada source code analyzer, not a strict compiler. + -- ??? Note that a better approach would be to have a + -- separate switch to relax this rule, and enable this + -- switch in CodePeer mode. + elsif Attr_Id = Attribute_Access + and then not CodePeer_Mode and then not In_Instance and then Present (Enclosing_Generic_Unit (Entity (P))) and then Present (Enclosing_Generic_Body (N)) *************** package body Sem_Attr is *** 7923,7931 **** -- The attribute type's ultimate ancestor must be -- declared within the same generic unit as the -- subprogram is declared. The error message is ! -- specialized to say "ancestor" for the case where ! -- the access type is not its own ancestor, since ! -- saying simply "access type" would be very confusing. if Enclosing_Generic_Unit (Entity (P)) /= Enclosing_Generic_Unit (Root_Type (Btyp)) --- 7925,7933 ---- -- The attribute type's ultimate ancestor must be -- declared within the same generic unit as the -- subprogram is declared. The error message is ! -- specialized to say "ancestor" for the case where the ! -- access type is not its own ancestor, since saying ! -- simply "access type" would be very confusing. if Enclosing_Generic_Unit (Entity (P)) /= Enclosing_Generic_Unit (Root_Type (Btyp)) *************** package body Sem_Attr is *** 8066,8072 **** Des_Btyp := Designated_Type (Btyp); ! if Ada_Version >= Ada_05 and then Is_Incomplete_Type (Des_Btyp) then -- Ada 2005 (AI-412): If the (sub)type is a limited view of an --- 8068,8074 ---- Des_Btyp := Designated_Type (Btyp); ! if Ada_Version >= Ada_2005 and then Is_Incomplete_Type (Des_Btyp) then -- Ada 2005 (AI-412): If the (sub)type is a limited view of an *************** package body Sem_Attr is *** 8095,8101 **** -- components, and return objects. For a component definition -- the level is the same of the enclosing composite type. ! if Ada_Version >= Ada_05 and then Is_Local_Anonymous_Access (Btyp) and then Object_Access_Level (P) > Type_Access_Level (Btyp) and then Attr_Id = Attribute_Access --- 8097,8103 ---- -- components, and return objects. For a component definition -- the level is the same of the enclosing composite type. ! if Ada_Version >= Ada_2005 and then Is_Local_Anonymous_Access (Btyp) and then Object_Access_Level (P) > Type_Access_Level (Btyp) and then Attr_Id = Attribute_Access *************** package body Sem_Attr is *** 8202,8208 **** elsif Has_Discriminants (Designated_Type (Typ)) and then not Is_Constrained (Des_Btyp) and then ! (Ada_Version < Ada_05 or else not Has_Constrained_Partial_View (Designated_Type (Base_Type (Typ)))) --- 8204,8210 ---- elsif Has_Discriminants (Designated_Type (Typ)) and then not Is_Constrained (Des_Btyp) and then ! (Ada_Version < Ada_2005 or else not Has_Constrained_Partial_View (Designated_Type (Base_Type (Typ)))) *************** package body Sem_Attr is *** 8244,8252 **** end if; end if; ! if Ekind (Btyp) = E_Access_Protected_Subprogram_Type ! or else ! Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type then if Is_Entity_Name (P) and then not Is_Protected_Type (Scope (Entity (P))) --- 8246,8253 ---- end if; end if; ! if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, ! E_Anonymous_Access_Protected_Subprogram_Type) then if Is_Entity_Name (P) and then not Is_Protected_Type (Scope (Entity (P))) *************** package body Sem_Attr is *** 8268,8276 **** return; end if; ! elsif (Ekind (Btyp) = E_Access_Subprogram_Type ! or else ! Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type) and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type then Error_Msg_F ("context requires a non-protected subprogram", P); --- 8269,8276 ---- return; end if; ! elsif Ekind_In (Btyp, E_Access_Subprogram_Type, ! E_Anonymous_Access_Subprogram_Type) and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type then Error_Msg_F ("context requires a non-protected subprogram", P); *************** package body Sem_Attr is *** 8548,8561 **** -- Range -- ----------- ! -- We replace the Range attribute node with a range expression ! -- whose bounds are the 'First and 'Last attributes applied to the ! -- same prefix. The reason that we do this transformation here ! -- instead of in the expander is that it simplifies other parts of ! -- the semantic analysis which assume that the Range has been ! -- replaced; thus it must be done even when in semantic-only mode ! -- (note that the RM specifically mentions this equivalence, we ! -- take care that the prefix is only evaluated once). when Attribute_Range => Range_Attribute : declare --- 8548,8561 ---- -- Range -- ----------- ! -- We replace the Range attribute node with a range expression whose ! -- bounds are the 'First and 'Last attributes applied to the same ! -- prefix. The reason that we do this transformation here instead of ! -- in the expander is that it simplifies other parts of the semantic ! -- analysis which assume that the Range has been replaced; thus it ! -- must be done even when in semantic-only mode (note that the RM ! -- specifically mentions this equivalence, we take care that the ! -- prefix is only evaluated once). when Attribute_Range => Range_Attribute : declare *************** package body Sem_Attr is *** 8606,8611 **** --- 8606,8616 ---- Rewrite (N, Make_Range (Loc, LB, HB)); Analyze_And_Resolve (N, Typ); + -- Ensure that the expanded range does not have side effects + + Force_Evaluation (LB); + Force_Evaluation (HB); + -- Normally after resolving attribute nodes, Eval_Attribute -- is called to do any possible static evaluation of the node. -- However, here since the Range attribute has just been *************** package body Sem_Attr is *** 8799,8811 **** -- In Ada 2005, Input can invoke Read, and Output can invoke Write if Nam = TSS_Stream_Input ! and then Ada_Version >= Ada_05 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read) then return True; elsif Nam = TSS_Stream_Output ! and then Ada_Version >= Ada_05 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write) then return True; --- 8804,8816 ---- -- In Ada 2005, Input can invoke Read, and Output can invoke Write if Nam = TSS_Stream_Input ! and then Ada_Version >= Ada_2005 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read) then return True; elsif Nam = TSS_Stream_Output ! and then Ada_Version >= Ada_2005 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write) then return True; *************** package body Sem_Attr is *** 8822,8828 **** end if; end loop; ! if Ada_Version < Ada_05 then -- In Ada 95 mode, also consider a non-visible definition --- 8827,8833 ---- end if; end loop; ! if Ada_Version < Ada_2005 then -- In Ada 95 mode, also consider a non-visible definition diff -Nrcpad gcc-4.5.2/gcc/ada/sem_attr.ads gcc-4.6.0/gcc/ada/sem_attr.ads *** gcc-4.5.2/gcc/ada/sem_attr.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/sem_attr.ads Fri Oct 22 09:28:24 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Attr is *** 395,400 **** --- 395,409 ---- -- as Range applied to the array itself. The result is of type universal -- integer. + --------- + -- Ref -- + --------- + + Attribute_Ref => True, + -- System.Address'Ref (Address is the only permissible prefix) is + -- equivalent to System'To_Address, provided for compatibility with + -- other compilers. + ------------------ -- Storage_Unit -- ------------------ *************** package Sem_Attr is *** 439,445 **** ---------------- Attribute_To_Address => True, ! -- System'To_Address (Address is the only permissible prefix) is a -- function that takes any integer value, and converts it into an -- address value. The semantics is to first convert the integer value to -- type Integer_Address according to normal conversion rules, and then --- 448,454 ---- ---------------- Attribute_To_Address => True, ! -- System'To_Address (System is the only permissible prefix) is a -- function that takes any integer value, and converts it into an -- address value. The semantics is to first convert the integer value to -- type Integer_Address according to normal conversion rules, and then *************** package Sem_Attr is *** 493,507 **** ------------------------------ Attribute_Universal_Literal_String => True, ! -- The prefix of 'Universal_Literal_String must be a named number. The ! -- static result is the string consisting of the characters of the ! -- number as defined in the original source. This allows the user ! -- program to access the actual text of named numbers without ! -- intermediate conversions and without the need to enclose the strings ! -- in quotes (which would preclude their use as numbers). This is used ! -- internally for the construction of values of the floating-point ! -- attributes from the file ttypef.ads, but may also be used by user ! -- programs. ------------------------- -- Unrestricted_Access -- --- 502,513 ---- ------------------------------ Attribute_Universal_Literal_String => True, ! -- The prefix of 'Universal_Literal_String must be a named number. ! -- The static result is the string consisting of the characters of ! -- the number as defined in the original source. This allows the ! -- user program to access the actual text of named numbers without ! -- intermediate conversions and without the need to enclose the ! -- strings in quotes (which would preclude their use as numbers). ------------------------- -- Unrestricted_Access -- diff -Nrcpad gcc-4.5.2/gcc/ada/sem_aux.adb gcc-4.6.0/gcc/ada/sem_aux.adb *** gcc-4.5.2/gcc/ada/sem_aux.adb Wed Jul 29 08:43:58 2009 --- gcc-4.6.0/gcc/ada/sem_aux.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sem_Aux is *** 48,54 **** -- If this is first subtype, or is a base type, then there is no -- ancestor subtype, so we return Empty to indicate this fact. ! if Is_First_Subtype (Typ) or else Typ = Base_Type (Typ) then return Empty; end if; --- 48,54 ---- -- If this is first subtype, or is a base type, then there is no -- ancestor subtype, so we return Empty to indicate this fact. ! if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then return Empty; end if; *************** package body Sem_Aux is *** 204,211 **** begin pragma Assert ! (Has_Discriminants (Typ) ! or else Has_Unknown_Discriminants (Typ)); Ent := First_Entity (Typ); --- 204,210 ---- begin pragma Assert ! (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ)); Ent := First_Entity (Typ); *************** package body Sem_Aux is *** 312,319 **** Ent : Entity_Id; begin ! -- If the base type has no freeze node, it is a type in Standard, ! -- and always acts as its own first subtype unless it is one of the -- predefined integer types. If the type is formal, it is also a first -- subtype, and its base type has no freeze node. On the other hand, a -- subtype of a generic formal is not its own first subtype. Its base --- 311,318 ---- Ent : Entity_Id; begin ! -- If the base type has no freeze node, it is a type in Standard, and ! -- always acts as its own first subtype, except where it is one of the -- predefined integer types. If the type is formal, it is also a first -- subtype, and its base type has no freeze node. On the other hand, a -- subtype of a generic formal is not its own first subtype. Its base *************** package body Sem_Aux is *** 321,327 **** -- the first subtype is obtained. if No (F) then - if B = Base_Type (Standard_Integer) then return Standard_Integer; --- 320,325 ---- *************** package body Sem_Aux is *** 539,544 **** --- 537,561 ---- end if; end Is_Derived_Type; + ----------------------- + -- Is_Generic_Formal -- + ----------------------- + + function Is_Generic_Formal (E : Entity_Id) return Boolean is + Kind : Node_Kind; + begin + if No (E) then + return False; + else + Kind := Nkind (Parent (E)); + return + Nkind_In (Kind, N_Formal_Object_Declaration, + N_Formal_Package_Declaration, + N_Formal_Type_Declaration) + or else Is_Formal_Subprogram (E); + end if; + end Is_Generic_Formal; + --------------------------- -- Is_Indefinite_Subtype -- --------------------------- *************** package body Sem_Aux is *** 571,594 **** end if; end Is_Indefinite_Subtype; ! -------------------------------- ! -- Is_Inherently_Limited_Type -- ! -------------------------------- ! function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Base_Type (Ent); begin if Is_Private_Type (Btype) then ! declare ! Utyp : constant Entity_Id := Underlying_Type (Btype); ! begin ! if No (Utyp) then return False; else ! return Is_Inherently_Limited_Type (Utyp); end if; ! end; elsif Is_Concurrent_Type (Btype) then return True; --- 588,642 ---- end if; end Is_Indefinite_Subtype; ! ------------------------------- ! -- Is_Immutably_Limited_Type -- ! ------------------------------- ! function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Base_Type (Ent); begin + if Is_Limited_Record (Btype) then + return True; + + elsif Ekind (Btype) = E_Limited_Private_Type + and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration + then + return not In_Package_Body (Scope ((Btype))); + end if; + if Is_Private_Type (Btype) then ! ! -- AI05-0063: A type derived from a limited private formal type is ! -- not immutably limited in a generic body. ! ! if Is_Derived_Type (Btype) ! and then Is_Generic_Type (Etype (Btype)) ! then ! if not Is_Limited_Type (Etype (Btype)) then return False; + + -- A descendant of a limited formal type is not immutably limited + -- in the generic body, or in the body of a generic child. + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Btype)); + else ! return False; end if; ! ! else ! declare ! Utyp : constant Entity_Id := Underlying_Type (Btype); ! begin ! if No (Utyp) then ! return False; ! else ! return Is_Immutably_Limited_Type (Utyp); ! end if; ! end; ! end if; elsif Is_Concurrent_Type (Btype) then return True; *************** package body Sem_Aux is *** 602,612 **** -- handled as build in place even though they might return objects -- of a type that is not inherently limited. ! if Is_Limited_Record (Btype) then ! return True; ! ! elsif Is_Class_Wide_Type (Btype) then ! return Is_Inherently_Limited_Type (Root_Type (Btype)); else declare --- 650,657 ---- -- handled as build in place even though they might return objects -- of a type that is not inherently limited. ! if Is_Class_Wide_Type (Btype) then ! return Is_Immutably_Limited_Type (Root_Type (Btype)); else declare *************** package body Sem_Aux is *** 620,629 **** -- only occur in the case of a _parent component anyway). -- They don't have any components, plus it would cause this -- function to return true for nonlimited types derived from ! -- limited intefaces. if not Is_Interface (Etype (C)) ! and then Is_Inherently_Limited_Type (Etype (C)) then return True; end if; --- 665,674 ---- -- only occur in the case of a _parent component anyway). -- They don't have any components, plus it would cause this -- function to return true for nonlimited types derived from ! -- limited interfaces. if not Is_Interface (Etype (C)) ! and then Is_Immutably_Limited_Type (Etype (C)) then return True; end if; *************** package body Sem_Aux is *** 636,647 **** end if; elsif Is_Array_Type (Btype) then ! return Is_Inherently_Limited_Type (Component_Type (Btype)); else return False; end if; ! end Is_Inherently_Limited_Type; --------------------- -- Is_Limited_Type -- --- 681,692 ---- end if; elsif Is_Array_Type (Btype) then ! return Is_Immutably_Limited_Type (Component_Type (Btype)); else return False; end if; ! end Is_Immutably_Limited_Type; --------------------- -- Is_Limited_Type -- *************** package body Sem_Aux is *** 723,728 **** --- 768,813 ---- end if; end Is_Limited_Type; + ---------------------- + -- Nearest_Ancestor -- + ---------------------- + + function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is + D : constant Node_Id := Declaration_Node (Typ); + + begin + -- If we have a subtype declaration, get the ancestor subtype + + if Nkind (D) = N_Subtype_Declaration then + if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then + return Entity (Subtype_Mark (Subtype_Indication (D))); + else + return Entity (Subtype_Indication (D)); + end if; + + -- If derived type declaration, find who we are derived from + + elsif Nkind (D) = N_Full_Type_Declaration + and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition + then + declare + DTD : constant Entity_Id := Type_Definition (D); + SI : constant Entity_Id := Subtype_Indication (DTD); + begin + if Is_Entity_Name (SI) then + return Entity (SI); + else + return Entity (Subtype_Mark (SI)); + end if; + end; + + -- Otherwise, nothing useful to return, return Empty + + else + return Empty; + end if; + end Nearest_Ancestor; + --------------------------- -- Nearest_Dynamic_Scope -- --------------------------- *************** package body Sem_Aux is *** 800,803 **** --- 885,904 ---- Obsolescent_Warnings.Tree_Write; end Tree_Write; + -------------------- + -- Ultimate_Alias -- + -------------------- + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + pragma Assert (Alias (E) /= E); + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + end Sem_Aux; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_aux.ads gcc-4.6.0/gcc/ada/sem_aux.ads *** gcc-4.5.2/gcc/ada/sem_aux.ads Wed Jul 29 08:43:58 2009 --- gcc-4.6.0/gcc/ada/sem_aux.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Aux is *** 132,138 **** -- the entity chain of the derived type which are a copy of the -- discriminants of the root type. Furthermore their Is_Completely_Hidden -- flag is set since although they are actually stored in the object, they ! -- are not in the set of discriminants that is visble in the type. -- -- For derived untagged types, the set of stored discriminants are the real -- discriminants from Gigi's standpoint, i.e. those that will be stored in --- 132,138 ---- -- the entity chain of the derived type which are a copy of the -- discriminants of the root type. Furthermore their Is_Completely_Hidden -- flag is set since although they are actually stored in the object, they ! -- are not in the set of discriminants that is visible in the type. -- -- For derived untagged types, the set of stored discriminants are the real -- discriminants from Gigi's standpoint, i.e. those that will be stored in *************** package Sem_Aux is *** 159,178 **** -- Determines if the given entity Ent is a derived type. Result is always -- false if argument is not a type. function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean; -- Ent is any entity. Determines if given entity is an unconstrained array -- type or subtype, a discriminated record type or subtype with no initial -- discriminant values or a class wide type or subtype and returns True if -- so. False for other type entities, or any entities that are not types. ! function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. True for a type that is "inherently" limited (i.e. -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with -- a part that is of a task, protected, or explicitly limited record type". -- These are the types that are defined as return-by-reference types in Ada -- 95 (see RM95-6.5(11-16)). In Ada 2005, these are the types that require -- build-in-place for function calls. Note that build-in-place is allowed ! -- for other types, too. function Is_Limited_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. Returns true if Ent is a limited type (limited --- 159,184 ---- -- Determines if the given entity Ent is a derived type. Result is always -- false if argument is not a type. + function Is_Generic_Formal (E : Entity_Id) return Boolean; + -- Determine whether E is a generic formal parameter. In particular this is + -- used to set the visibility of generic formals of a generic package + -- declared with a box or with partial parametrization. + function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean; -- Ent is any entity. Determines if given entity is an unconstrained array -- type or subtype, a discriminated record type or subtype with no initial -- discriminant values or a class wide type or subtype and returns True if -- so. False for other type entities, or any entities that are not types. ! function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. True for a type that is "inherently" limited (i.e. -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with -- a part that is of a task, protected, or explicitly limited record type". -- These are the types that are defined as return-by-reference types in Ada -- 95 (see RM95-6.5(11-16)). In Ada 2005, these are the types that require -- build-in-place for function calls. Note that build-in-place is allowed ! -- for other types, too. This is also used for identifying pure procedures ! -- whose calls should not be eliminated (RM 10.2.1(18/2)). function Is_Limited_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. Returns true if Ent is a limited type (limited *************** package Sem_Aux is *** 180,185 **** --- 186,209 ---- -- composite containing a limited component, or a subtype of any of -- these types). + function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id; + -- Given a subtype Typ, this function finds out the nearest ancestor from + -- which constraints and predicates are inherited. There is no simple link + -- for doing this, consider: + -- + -- subtype R is Integer range 1 .. 10; + -- type T is new R; + -- + -- In this case the nearest ancestor is R, but the Etype of T'Base will + -- point to R'Base, so we have to go rummaging in the declarations to get + -- this information. It is used for making sure we freeze this before we + -- freeze Typ, and also for retrieving inherited predicate information. + -- For the case of base types or first subtypes, there is no useful entity + -- to return, so Empty is returned. + -- + -- Note: this is similar to Ancestor_Subtype except that it also deals + -- with the case of derived types. + function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id; -- This is similar to Enclosing_Dynamic_Scope except that if Ent is itself -- a dynamic scope, then it is returned. Otherwise the result is the same *************** package Sem_Aux is *** 193,196 **** --- 217,225 ---- function Number_Discriminants (Typ : Entity_Id) return Pos; -- Typ is a type with discriminants, yields number of discriminants in type + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Alias); + -- Return the last entity in the chain of aliased entities of Prim. If Prim + -- has no alias return Prim. + end Sem_Aux; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_case.adb gcc-4.6.0/gcc/ada/sem_case.adb *** gcc-4.5.2/gcc/ada/sem_case.adb Mon Nov 30 09:42:59 2009 --- gcc-4.6.0/gcc/ada/sem_case.adb Tue Oct 26 10:55:01 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2010, 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- -- *************** with Nmake; use Nmake; *** 32,38 **** with Opt; use Opt; with Sem; use Sem; with Sem_Aux; use Sem_Aux; - with Sem_Case; use Sem_Case; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; --- 32,37 ---- *************** with Sinfo; use Sinfo; *** 43,65 **** with Tbuild; use Tbuild; with Uintp; use Uintp; with GNAT.Heap_Sort_G; package body Sem_Case is ----------------------- -- Local Subprograms -- ----------------------- - type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds; - -- This new array type is used as the actual table type for sorting - -- discrete choices. The reason for not using Choice_Table_Type, is that - -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algorithm - -- (this is not absolutely necessary but it makes the code more - -- efficient). - procedure Check_Choices ! (Choice_Table : in out Sort_Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; Others_Present : Boolean; --- 42,72 ---- with Tbuild; use Tbuild; with Uintp; use Uintp; + with Ada.Unchecked_Deallocation; + with GNAT.Heap_Sort_G; package body Sem_Case is + type Choice_Bounds is record + Lo : Node_Id; + Hi : Node_Id; + Node : Node_Id; + end record; + -- Represent one choice bounds entry with Lo and Hi values, Node points + -- to the choice node itself. + + type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; + -- Table type used to sort the choices present in a case statement, array + -- aggregate or record variant. The actual entries are stored in 1 .. Last, + -- but we have a 0 entry for convenience in sorting. + ----------------------- -- Local Subprograms -- ----------------------- procedure Check_Choices ! (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; Others_Present : Boolean; *************** package body Sem_Case is *** 101,107 **** ------------------- procedure Check_Choices ! (Choice_Table : in out Sort_Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; Others_Present : Boolean; --- 108,114 ---- ------------------- procedure Check_Choices ! (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; Others_Present : Boolean; *************** package body Sem_Case is *** 306,313 **** Hi := Expr_Value (Choice_Table (J).Hi); if Lo <= Prev_Hi then ! Prev_Choice := Choice_Table (J - 1).Node; ! Choice := Choice_Table (J).Node; if Sloc (Prev_Choice) <= Sloc (Choice) then Error_Msg_Sloc := Sloc (Prev_Choice); --- 313,328 ---- Hi := Expr_Value (Choice_Table (J).Hi); if Lo <= Prev_Hi then ! Choice := Choice_Table (J).Node; ! ! -- Find first previous choice that overlaps ! ! for K in 1 .. J - 1 loop ! if Lo <= Expr_Value (Choice_Table (K).Hi) then ! Prev_Choice := Choice_Table (K).Node; ! exit; ! end if; ! end loop; if Sloc (Prev_Choice) <= Sloc (Choice) then Error_Msg_Sloc := Sloc (Prev_Choice); *************** package body Sem_Case is *** 321,327 **** Issue_Msg (Prev_Hi + 1, Lo - 1); end if; ! Prev_Hi := Hi; end loop; if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then --- 336,344 ---- Issue_Msg (Prev_Hi + 1, Lo - 1); end if; ! if Hi > Prev_Hi then ! Prev_Hi := Hi; ! end if; end loop; if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then *************** package body Sem_Case is *** 511,517 **** -- Start of processing for Expand_Others_Choice begin ! if Case_Table'Length = 0 then -- Special case: only an others case is present. -- The others case covers the full range of the type. --- 528,534 ---- -- Start of processing for Expand_Others_Choice begin ! if Case_Table'Last = 0 then -- Special case: only an others case is present. -- The others case covers the full range of the type. *************** package body Sem_Case is *** 537,545 **** Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); end if; ! Lo := Expr_Value (Case_Table (Case_Table'First).Lo); ! Hi := Expr_Value (Case_Table (Case_Table'First).Hi); ! Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi); -- Build the node for any missing choices that are smaller than any -- explicit choices given in the case. --- 554,562 ---- Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); end if; ! Lo := Expr_Value (Case_Table (1).Lo); ! Hi := Expr_Value (Case_Table (1).Hi); ! Previous_Hi := Expr_Value (Case_Table (1).Hi); -- Build the node for any missing choices that are smaller than any -- explicit choices given in the case. *************** package body Sem_Case is *** 551,557 **** -- Build the nodes representing any missing choices that lie between -- the explicit ones given in the case. ! for J in Case_Table'First + 1 .. Case_Table'Last loop Lo := Expr_Value (Case_Table (J).Lo); Hi := Expr_Value (Case_Table (J).Hi); --- 568,574 ---- -- Build the nodes representing any missing choices that lie between -- the explicit ones given in the case. ! for J in 2 .. Case_Table'Last loop Lo := Expr_Value (Case_Table (J).Lo); Hi := Expr_Value (Case_Table (J).Hi); *************** package body Sem_Case is *** 588,594 **** procedure No_OP (C : Node_Id) is pragma Warnings (Off, C); - begin null; end No_OP; --- 605,610 ---- *************** package body Sem_Case is *** 599,604 **** --- 615,633 ---- package body Generic_Choices_Processing is + -- The following type is used to gather the entries for the choice + -- table, so that we can then allocate the right length. + + type Link; + type Link_Ptr is access all Link; + + type Link is record + Val : Choice_Bounds; + Nxt : Link_Ptr; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); + --------------------- -- Analyze_Choices -- --------------------- *************** package body Sem_Case is *** 606,625 **** procedure Analyze_Choices (N : Node_Id; Subtyp : Entity_Id; - Choice_Table : out Choice_Table_Type; - Last_Choice : out Nat; Raises_CE : out Boolean; Others_Present : out Boolean) is - pragma Assert (Choice_Table'First = 1); - E : Entity_Id; Enode : Node_Id; -- This is where we post error messages for bounds out of range ! Nb_Choices : constant Nat := Choice_Table'Length; ! Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices); Choice_Type : constant Entity_Id := Base_Type (Subtyp); -- The actual type against which the discrete choices are resolved. --- 635,653 ---- procedure Analyze_Choices (N : Node_Id; Subtyp : Entity_Id; Raises_CE : out Boolean; Others_Present : out Boolean) is E : Entity_Id; Enode : Node_Id; -- This is where we post error messages for bounds out of range ! Choice_List : Link_Ptr := null; ! -- Gather list of choices ! ! Num_Choices : Nat := 0; ! -- Number of entries in Choice_List Choice_Type : constant Entity_Id := Base_Type (Subtyp); -- The actual type against which the discrete choices are resolved. *************** package body Sem_Case is *** 648,660 **** Kind : Node_Kind; -- The node kind of the current Choice Others_Choice : Node_Id := Empty; -- Remember others choice if it is present (empty otherwise) procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); -- Checks the validity of the bounds of a choice. When the bounds ! -- are static and no error occurred the bounds are entered into the ! -- choices table so that they can be sorted later on. ----------- -- Check -- --- 676,692 ---- Kind : Node_Kind; -- The node kind of the current Choice + Delete_Choice : Boolean; + -- Set to True to delete the current choice + Others_Choice : Node_Id := Empty; -- Remember others choice if it is present (empty otherwise) procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); -- Checks the validity of the bounds of a choice. When the bounds ! -- are static and no error occurred the bounds are collected for ! -- later entry into the choices table so that they can be sorted ! -- later on. ----------- -- Check -- *************** package body Sem_Case is *** 706,713 **** -- If the choice is an entity name, then it is a type, and we -- want to post the message on the reference to this entity. ! -- Otherwise we want to post it on the lower bound of the ! -- range. if Is_Entity_Name (Choice) then Enode := Choice; --- 738,744 ---- -- If the choice is an entity name, then it is a type, and we -- want to post the message on the reference to this entity. ! -- Otherwise post it on the lower bound of the range. if Is_Entity_Name (Choice) then Enode := Choice; *************** package body Sem_Case is *** 751,772 **** end if; end if; ! -- Store bounds in the table -- Note: we still store the bounds, even if they are out of range, -- since this may prevent unnecessary cascaded errors for values -- that are covered by such an excessive range. ! Last_Choice := Last_Choice + 1; ! Sort_Choice_Table (Last_Choice).Lo := Lo; ! Sort_Choice_Table (Last_Choice).Hi := Hi; ! Sort_Choice_Table (Last_Choice).Node := Choice; end Check; -- Start of processing for Analyze_Choices begin - Last_Choice := 0; Raises_CE := False; Others_Present := False; --- 782,801 ---- end if; end if; ! -- Collect bounds in the list -- Note: we still store the bounds, even if they are out of range, -- since this may prevent unnecessary cascaded errors for values -- that are covered by such an excessive range. ! Choice_List := ! new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); ! Num_Choices := Num_Choices + 1; end Check; -- Start of processing for Analyze_Choices begin Raises_CE := False; Others_Present := False; *************** package body Sem_Case is *** 811,816 **** --- 840,846 ---- else Choice := First (Get_Choices (Alt)); while Present (Choice) loop + Delete_Choice := False; Analyze (Choice); Kind := Nkind (Choice); *************** package body Sem_Case is *** 834,840 **** else E := Entity (Choice); ! if not Is_Static_Subtype (E) then Process_Non_Static_Choice (Choice); else Check --- 864,912 ---- else E := Entity (Choice); ! -- Case of predicated subtype ! ! if Has_Predicates (E) then ! ! -- Use of non-static predicate is an error ! ! if not Is_Discrete_Type (E) ! or else No (Static_Predicate (E)) ! then ! Bad_Predicated_Subtype_Use ! ("cannot use subtype& with non-static " ! & "predicate as case alternative", Choice, E); ! ! -- Static predicate case ! ! else ! declare ! Copy : constant List_Id := Empty_List; ! P : Node_Id; ! C : Node_Id; ! ! begin ! -- Loop through entries in predicate list, ! -- converting to choices. Note that if the ! -- list is empty, corresponding to a False ! -- predicate, then no choices are inserted. ! ! P := First (Static_Predicate (E)); ! while Present (P) loop ! C := New_Copy (P); ! Set_Sloc (C, Sloc (Choice)); ! Append_To (Copy, C); ! Next (P); ! end loop; ! ! Insert_List_After (Choice, Copy); ! Delete_Choice := True; ! end; ! end if; ! ! -- Not predicated subtype case ! ! elsif not Is_Static_Subtype (E) then Process_Non_Static_Choice (Choice); else Check *************** package body Sem_Case is *** 848,853 **** --- 920,927 ---- Resolve_Discrete_Subtype_Indication (Choice, Expected_Type); + -- Here for other than predicated subtype case + if Etype (Choice) /= Any_Type then declare C : constant Node_Id := Constraint (Choice); *************** package body Sem_Case is *** 911,917 **** Check (Choice, Choice, Choice); end if; ! Next (Choice); end loop; Process_Associated_Node (Alt); --- 985,1002 ---- Check (Choice, Choice, Choice); end if; ! -- Move to next choice, deleting the current one if the ! -- flag requesting this deletion is set True. ! ! declare ! C : constant Node_Id := Choice; ! begin ! Next (Choice); ! ! if Delete_Choice then ! Remove (C); ! end if; ! end; end loop; Process_Associated_Node (Alt); *************** package body Sem_Case is *** 920,984 **** Next (Alt); end loop; ! Check_Choices ! (Sort_Choice_Table (0 .. Last_Choice), ! Bounds_Type, ! Subtyp, ! Others_Present or else (Choice_Type = Universal_Integer), ! N); ! ! -- Now copy the sorted discrete choices ! ! for J in 1 .. Last_Choice loop ! Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J); ! end loop; ! ! -- If no others choice we are all done, otherwise we have one more ! -- step, which is to set the Others_Discrete_Choices field of the ! -- others choice (to contain all otherwise unspecified choices). ! -- Skip this if CE is known to be raised. ! ! if Others_Present and not Raises_CE then ! Expand_Others_Choice ! (Case_Table => Choice_Table (1 .. Last_Choice), ! Others_Choice => Others_Choice, ! Choice_Type => Bounds_Type); ! end if; ! end Analyze_Choices; ! ! ----------------------- ! -- Number_Of_Choices -- ! ----------------------- ! ! function Number_Of_Choices (N : Node_Id) return Nat is ! Alt : Node_Id; ! -- A case statement alternative or a record variant ! ! Choice : Node_Id; ! Count : Nat := 0; ! begin ! if No (Get_Alternatives (N)) then ! return 0; ! end if; ! Alt := First_Non_Pragma (Get_Alternatives (N)); ! while Present (Alt) loop ! Choice := First (Get_Choices (Alt)); ! while Present (Choice) loop ! if Nkind (Choice) /= N_Others_Choice then ! Count := Count + 1; ! end if; ! Next (Choice); ! end loop; ! Next_Non_Pragma (Alt); ! end loop; ! return Count; ! end Number_Of_Choices; end Generic_Choices_Processing; --- 1005,1051 ---- Next (Alt); end loop; ! -- Now we can create the Choice_Table, since we know how long ! -- it needs to be so we can allocate exactly the right length. ! declare ! Choice_Table : Choice_Table_Type (0 .. Num_Choices); ! begin ! -- Now copy the items we collected in the linked list into this ! -- newly allocated table (leave entry 0 unused for sorting). ! declare ! T : Link_Ptr; ! begin ! for J in 1 .. Num_Choices loop ! T := Choice_List; ! Choice_List := T.Nxt; ! Choice_Table (J) := T.Val; ! Free (T); ! end loop; ! end; ! Check_Choices ! (Choice_Table, ! Bounds_Type, ! Subtyp, ! Others_Present or else (Choice_Type = Universal_Integer), ! N); ! -- If no others choice we are all done, otherwise we have one more ! -- step, which is to set the Others_Discrete_Choices field of the ! -- others choice (to contain all otherwise unspecified choices). ! -- Skip this if CE is known to be raised. ! if Others_Present and not Raises_CE then ! Expand_Others_Choice ! (Case_Table => Choice_Table, ! Others_Choice => Others_Choice, ! Choice_Type => Bounds_Type); ! end if; ! end; ! end Analyze_Choices; end Generic_Choices_Processing; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_case.ads gcc-4.6.0/gcc/ada/sem_case.ads *** gcc-4.5.2/gcc/ada/sem_case.ads Sun Apr 13 17:25:22 2008 --- gcc-4.6.0/gcc/ada/sem_case.ads Fri Oct 22 13:58:49 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2010, 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- -- *************** with Types; use Types; *** 34,49 **** package Sem_Case is - type Choice_Bounds is record - Lo : Node_Id; - Hi : Node_Id; - Node : Node_Id; - end record; - - type Choice_Table_Type is array (Pos range <>) of Choice_Bounds; - -- Table type used to sort the choices present in a case statement, - -- array aggregate or record variant. - procedure No_OP (C : Node_Id); -- The no-operation routine. Does absolutely nothing. Can be used -- in the following generic for the parameter Process_Empty_Choice. --- 34,39 ---- *************** package Sem_Case is *** 68,113 **** -- Processing to carry out for a non static Choice with procedure Process_Associated_Node (A : Node_Id); ! -- Associated to each case alternative, aggregate component -- association or record variant A there is a node or list of nodes -- that need semantic processing. This routine implements that -- processing. package Generic_Choices_Processing is - function Number_Of_Choices (N : Node_Id) return Nat; - -- Iterates through the choices of N, (N can be a case statement, - -- array aggregate or record variant), counting all the Choice nodes - -- except for the Others choice. - procedure Analyze_Choices (N : Node_Id; Subtyp : Entity_Id; - Choice_Table : out Choice_Table_Type; - Last_Choice : out Nat; Raises_CE : out Boolean; Others_Present : out Boolean); ! -- From a case statement, array aggregate or record variant N, this ! -- routine analyzes the corresponding list of discrete choices. ! -- Subtyp is the subtype of the discrete choices. The type against ! -- which the discrete choices must be resolved is its base type. ! -- ! -- On entry Choice_Table must be big enough to contain all the discrete ! -- choices encountered. The lower bound of Choice_Table must be one. ! -- ! -- On exit Choice_Table contains all the static and non empty discrete ! -- choices in sorted order. Last_Choice gives the position of the last ! -- valid choice in Choice_Table, Choice_Table'First contains the first. ! -- We can have Last_Choice < Choice_Table'Last for one (or several) of ! -- the following reasons: ! -- ! -- (a) The list of choices contained a non static choice ! -- ! -- (b) The list of choices contained an empty choice ! -- (something like "1 .. 0 => ") ! -- ! -- (c) One of the bounds of a discrete choice contains an ! -- error or raises constraint error. -- -- In one of the bounds of a discrete choice raises a constraint -- error the flag Raise_CE is set. --- 58,79 ---- -- Processing to carry out for a non static Choice with procedure Process_Associated_Node (A : Node_Id); ! -- Associated with each case alternative, aggregate component -- association or record variant A there is a node or list of nodes -- that need semantic processing. This routine implements that -- processing. package Generic_Choices_Processing is procedure Analyze_Choices (N : Node_Id; Subtyp : Entity_Id; Raises_CE : out Boolean; Others_Present : out Boolean); ! -- From a case expression, case statement, array aggregate or record ! -- variant N, this routine analyzes the corresponding list of discrete ! -- choices. Subtyp is the subtype of the discrete choices. The type ! -- against which the discrete choices must be resolved is its base type. -- -- In one of the bounds of a discrete choice raises a constraint -- error the flag Raise_CE is set. diff -Nrcpad gcc-4.5.2/gcc/ada/sem_cat.adb gcc-4.6.0/gcc/ada/sem_cat.adb *** gcc-4.5.2/gcc/ada/sem_cat.adb Mon Aug 17 10:33:58 2009 --- gcc-4.6.0/gcc/ada/sem_cat.adb Tue Oct 26 13:00:05 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sem_Cat is *** 78,89 **** function In_RCI_Declaration (N : Node_Id) return Boolean; -- Determines if a declaration is within the visible part of a Remote ! -- Call Interface compilation unit, for semantic checking purposes only, -- (returns false within an instance and within the package body). function In_RT_Declaration return Boolean; ! -- Determines if current scope is within a Remote Types compilation unit, ! -- for semantic checking purposes. function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean; -- Returns true if the entity is a type whose full view is a non-remote --- 78,89 ---- function In_RCI_Declaration (N : Node_Id) return Boolean; -- Determines if a declaration is within the visible part of a Remote ! -- Call Interface compilation unit, for semantic checking purposes only -- (returns false within an instance and within the package body). function In_RT_Declaration return Boolean; ! -- Determines if current scope is within the declaration of a Remote Types ! -- unit, for semantic checking purposes. function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean; -- Returns true if the entity is a type whose full view is a non-remote *************** package body Sem_Cat is *** 206,211 **** --- 206,222 ---- and then In_Package_Body (Unit_Entity) then null; + + -- Special case: Remote_Types can depend on Preelaborated per + -- Ada 2005 AI 0206. + + elsif Unit_Category = Remote_Types + and then Is_Preelaborated (Depended_Entity) + then + null; + + -- All other cases, we do have an error + else Err := True; end if; *************** package body Sem_Cat is *** 215,224 **** if Err then ! -- These messages are warnings in GNAT mode, to allow it to be ! -- judiciously turned off. Otherwise it is a real error. ! Error_Msg_Warn := GNAT_Mode; -- Don't give error if main unit is not an internal unit, and the -- unit generating the message is an internal unit. This is the --- 226,244 ---- if Err then ! -- These messages are warnings in GNAT mode or if the -gnateP switch ! -- was set. Otherwise these are real errors for real illegalities. ! -- The reason we suppress these errors in GNAT mode is that the run- ! -- time has several instances of violations of the categorization ! -- errors (e.g. Pure units withing Preelaborate units. All these ! -- violations are harmless in the cases where we intend them, and ! -- we suppress the warnings with Warnings (Off). In cases where we ! -- do not intend the violation, warnings are errors in GNAT mode ! -- anyway, so we will still get an error. ! ! Error_Msg_Warn := ! Treat_Categorization_Errors_As_Warnings or GNAT_Mode; -- Don't give error if main unit is not an internal unit, and the -- unit generating the message is an internal unit. This is the *************** package body Sem_Cat is *** 387,393 **** -- currently visible. return Present (Rep_Item) ! and then (Ada_Version < Ada_05 or else At_Any_Place or else not Is_Hidden (Entity (Rep_Item))); end Has_Stream_Attribute_Definition; --- 407,413 ---- -- currently visible. return Present (Rep_Item) ! and then (Ada_Version < Ada_2005 or else At_Any_Place or else not Is_Hidden (Entity (Rep_Item))); end Has_Stream_Attribute_Definition; *************** package body Sem_Cat is *** 768,774 **** -- This test is skipped in Ada 2005 (see AI-366) ! if Ada_Version < Ada_05 and then Comes_From_Source (T) and then In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit --- 788,794 ---- -- This test is skipped in Ada 2005 (see AI-366) ! if Ada_Version < Ada_2005 and then Comes_From_Source (T) and then In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit *************** package body Sem_Cat is *** 965,971 **** -- Don't need this check in Ada 2005 mode, where this is all taken -- care of by the mechanism for Preelaborable Initialization. ! if Ada_Version >= Ada_05 then return; end if; --- 985,991 ---- -- Don't need this check in Ada 2005 mode, where this is all taken -- care of by the mechanism for Preelaborable Initialization. ! if Ada_Version >= Ada_2005 then return; end if; *************** package body Sem_Cat is *** 1061,1088 **** -- Exclude generic specs from the checks (this will get rechecked -- on instantiations). ! if Inside_A_Generic ! and then No (Enclosing_Generic_Body (Id)) ! then return; end if; ! -- Required checks for declaration that is in a preelaborated ! -- package and is not within some subprogram. if In_Preelaborated_Unit and then not In_Subprogram_Or_Concurrent_Unit then -- Check for default initialized variable case. Note that in ! -- accordance with (RM B.1(24)) imported objects are not ! -- subject to default initialization. -- If the initialization does not come from source and is an -- aggregate, it is a static initialization that replaces an -- implicit call, and must be treated as such. if Present (E) ! and then ! (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate) then null; --- 1081,1105 ---- -- Exclude generic specs from the checks (this will get rechecked -- on instantiations). ! if Inside_A_Generic and then No (Enclosing_Generic_Body (Id)) then return; end if; ! -- Required checks for declaration that is in a preelaborated package ! -- and is not within some subprogram. if In_Preelaborated_Unit and then not In_Subprogram_Or_Concurrent_Unit then -- Check for default initialized variable case. Note that in ! -- accordance with (RM B.1(24)) imported objects are not subject to ! -- default initialization. -- If the initialization does not come from source and is an -- aggregate, it is a static initialization that replaces an -- implicit call, and must be treated as such. if Present (E) ! and then (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate) then null; *************** package body Sem_Cat is *** 1149,1155 **** -- marked with this pragma in the predefined library are -- not treated specially. ! if Ada_Version < Ada_05 then Error_Msg_N ("private object not allowed in preelaborated unit", N); --- 1166,1172 ---- -- marked with this pragma in the predefined library are -- not treated specially. ! if Ada_Version < Ada_2005 then Error_Msg_N ("private object not allowed in preelaborated unit", N); *************** package body Sem_Cat is *** 1182,1188 **** then Error_Msg_Sloc := Sloc (Ent); ! if Ada_Version >= Ada_05 then Error_Msg_NE ("\would be legal if pragma Preelaborable_" & "Initialization given for & #", N, Ent); --- 1199,1205 ---- then Error_Msg_Sloc := Sloc (Ent); ! if Ada_Version >= Ada_2005 then Error_Msg_NE ("\would be legal if pragma Preelaborable_" & "Initialization given for & #", N, Ent); *************** package body Sem_Cat is *** 1210,1222 **** elsif Nkind (Odf) = N_Subtype_Indication then Ent := Etype (Subtype_Mark (Odf)); ! elsif ! Nkind (Odf) = N_Constrained_Array_Definition ! then Ent := Component_Type (T); - - -- else - -- return; end if; if Is_Task_Type (Ent) --- 1227,1234 ---- elsif Nkind (Odf) = N_Subtype_Indication then Ent := Etype (Subtype_Mark (Odf)); ! elsif Nkind (Odf) = N_Constrained_Array_Definition then Ent := Component_Type (T); end if; if Is_Task_Type (Ent) *************** package body Sem_Cat is *** 1230,1238 **** end; end if; ! -- Non-static discriminant not allowed in preelaborated unit ! -- Controlled object of a type with a user-defined Initialize ! -- is forbidden as well. if Is_Record_Type (Etype (Id)) then declare --- 1242,1250 ---- end; end if; ! -- Non-static discriminants not allowed in preelaborated unit. ! -- Objects of a controlled type with a user-defined Initialize ! -- are forbidden as well. if Is_Record_Type (Etype (Id)) then declare *************** package body Sem_Cat is *** 1248,1254 **** if Nkind (PEE) = N_Full_Type_Declaration and then not Static_Discriminant_Expr ! (Discriminant_Specifications (PEE)) then Error_Msg_N ("non-static discriminant in preelaborated unit", --- 1260,1266 ---- if Nkind (PEE) = N_Full_Type_Declaration and then not Static_Discriminant_Expr ! (Discriminant_Specifications (PEE)) then Error_Msg_N ("non-static discriminant in preelaborated unit", *************** package body Sem_Cat is *** 1270,1292 **** -- except within a subprogram, generic subprogram, task unit, or -- protected unit (RM 10.2.1(16)). ! if In_Pure_Unit ! and then not In_Subprogram_Task_Protected_Unit ! then Error_Msg_N ("declaration of variable not allowed in pure unit", N); -- The visible part of an RCI library unit must not contain the -- declaration of a variable (RM E.1.3(9)) elsif In_RCI_Declaration (N) then ! Error_Msg_N ("declaration of variable not allowed in rci unit", N); -- The visible part of a Shared Passive library unit must not contain -- the declaration of a variable (RM E.2.2(7)) ! elsif In_RT_Declaration then Error_Msg_N ! ("variable declaration not allowed in remote types unit", N); end if; end Validate_Object_Declaration; --- 1282,1302 ---- -- except within a subprogram, generic subprogram, task unit, or -- protected unit (RM 10.2.1(16)). ! if In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit then Error_Msg_N ("declaration of variable not allowed in pure unit", N); -- The visible part of an RCI library unit must not contain the -- declaration of a variable (RM E.1.3(9)) elsif In_RCI_Declaration (N) then ! Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N); -- The visible part of a Shared Passive library unit must not contain -- the declaration of a variable (RM E.2.2(7)) ! elsif In_RT_Declaration and then not In_Private_Part (Id) then Error_Msg_N ! ("visible variable not allowed in remote types unit", N); end if; end Validate_Object_Declaration; *************** package body Sem_Cat is *** 1333,1338 **** --- 1343,1354 ---- begin Desig_Type := Etype (Designated_Type (T)); + -- No action needed for concurrent types + + if Is_Concurrent_Type (Desig_Type) then + return; + end if; + Primitive_Subprograms := Primitive_Operations (Desig_Type); Subprogram_Elmt := First_Elmt (Primitive_Subprograms); *************** package body Sem_Cat is *** 1397,1404 **** null; ! elsif Ekind (Param_Type) = E_Anonymous_Access_Type ! or else Ekind (Param_Type) = E_Anonymous_Access_Subprogram_Type then -- From RM E.2.2(14), no anonymous access parameter other than -- controlling ones may be used (because an anonymous access --- 1413,1420 ---- null; ! elsif Ekind_In (Param_Type, E_Anonymous_Access_Type, ! E_Anonymous_Access_Subprogram_Type) then -- From RM E.2.2(14), no anonymous access parameter other than -- controlling ones may be used (because an anonymous access *************** package body Sem_Cat is *** 1454,1462 **** ("limited type not allowed in rci unit", Parent (E)); Explain_Limited_Type (E, Parent (E)); ! elsif Ekind (E) = E_Generic_Function ! or else Ekind (E) = E_Generic_Package ! or else Ekind (E) = E_Generic_Procedure then Error_Msg_N ("generic declaration not allowed in rci unit", Parent (E)); --- 1470,1478 ---- ("limited type not allowed in rci unit", Parent (E)); Explain_Limited_Type (E, Parent (E)); ! elsif Ekind_In (E, E_Generic_Function, ! E_Generic_Package, ! E_Generic_Procedure) then Error_Msg_N ("generic declaration not allowed in rci unit", Parent (E)); *************** package body Sem_Cat is *** 1551,1557 **** Type_Decl := Parent (Param_Type); if Ekind (Param_Type) = E_Anonymous_Access_Type then - if K = N_Subprogram_Declaration then Error_Node := Param_Spec; end if; --- 1567,1572 ---- *************** package body Sem_Cat is *** 1609,1615 **** Base_Under_Type := Base_Type (Underlying_Type (Base_Param_Type)); ! if (Ada_Version < Ada_05 and then (No (TSS (Base_Param_Type, TSS_Stream_Read)) or else --- 1624,1630 ---- Base_Under_Type := Base_Type (Underlying_Type (Base_Param_Type)); ! if (Ada_Version < Ada_2005 and then (No (TSS (Base_Param_Type, TSS_Stream_Read)) or else *************** package body Sem_Cat is *** 1619,1625 **** or else No (TSS (Base_Under_Type, TSS_Stream_Write)))) or else ! (Ada_Version >= Ada_05 and then (No (TSS (Base_Param_Type, TSS_Stream_Read)) or else --- 1634,1640 ---- or else No (TSS (Base_Under_Type, TSS_Stream_Write)))) or else ! (Ada_Version >= Ada_2005 and then (No (TSS (Base_Param_Type, TSS_Stream_Read)) or else *************** package body Sem_Cat is *** 1639,1645 **** Error_Node := Param_Spec; end if; ! if Ada_Version >= Ada_05 then Error_Msg_N ("limited parameter in 'R'C'I unit " & "must have visible read/write attributes ", --- 1654,1660 ---- Error_Node := Param_Spec; end if; ! if Ada_Version >= Ada_2005 then Error_Msg_N ("limited parameter in 'R'C'I unit " & "must have visible read/write attributes ", *************** package body Sem_Cat is *** 1754,1761 **** -- Start of processing for Validate_Remote_Access_Object_Type_Declaration begin ! -- We are called from Analyze_Type_Declaration, and the Nkind of the ! -- given node is N_Access_To_Object_Definition. if not Comes_From_Source (T) or else (not In_RCI_Declaration (Parent (T)) --- 1769,1776 ---- -- Start of processing for Validate_Remote_Access_Object_Type_Declaration begin ! -- We are called from Analyze_Full_Type_Declaration, and the Nkind of ! -- the given node is N_Access_To_Object_Definition. if not Comes_From_Source (T) or else (not In_RCI_Declaration (Parent (T)) *************** package body Sem_Cat is *** 2003,2009 **** "non-remote access type", U_Typ); end if; ! if Ada_Version >= Ada_05 then Error_Msg_N ("\must have visible Read and Write attribute " & "definition clauses (RM E.2.2(8))", U_Typ); --- 2018,2024 ---- "non-remote access type", U_Typ); end if; ! if Ada_Version >= Ada_2005 then Error_Msg_N ("\must have visible Read and Write attribute " & "definition clauses (RM E.2.2(8))", U_Typ); *************** package body Sem_Cat is *** 2055,2061 **** -- Start of processing for Validate_SP_Access_Object_Type_Decl begin ! -- We are called from Sem_Ch3.Analyze_Type_Declaration, and the -- Nkind of the given entity is N_Access_To_Object_Definition. if not Comes_From_Source (T) --- 2070,2076 ---- -- Start of processing for Validate_SP_Access_Object_Type_Decl begin ! -- We are called from Sem_Ch3.Analyze_Full_Type_Declaration, and the -- Nkind of the given entity is N_Access_To_Object_Definition. if not Comes_From_Source (T) diff -Nrcpad gcc-4.5.2/gcc/ada/sem_cat.ads gcc-4.6.0/gcc/ada/sem_cat.ads *** gcc-4.5.2/gcc/ada/sem_cat.ads Wed Apr 29 09:45:57 2009 --- gcc-4.6.0/gcc/ada/sem_cat.ads Tue Oct 26 10:51:36 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Cat is *** 143,152 **** -- T is the entity of the declared type. procedure Validate_Static_Object_Name (N : Node_Id); ! -- In the elaboration code of a preelaborated library unit, check ! -- that we do not have the evaluation of a primary that is a name of ! -- an object, unless the name is a static expression (RM 10.2.1(8)). ! -- Non-static constant and variable are the targets, generic parameters -- are not included because the generic declaration and body are -- preelaborable. --- 143,152 ---- -- T is the entity of the declared type. procedure Validate_Static_Object_Name (N : Node_Id); ! -- In the elaboration code of a preelaborated library unit, check that we ! -- do not have the evaluation of a primary that is a name of an object, ! -- unless the name is a static expression (RM 10.2.1(8)). Non-static ! -- constant and variable are the targets, generic parameters are not -- are not included because the generic declaration and body are -- preelaborable. diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch10.adb gcc-4.6.0/gcc/ada/sem_ch10.adb *** gcc-4.5.2/gcc/ada/sem_ch10.adb Tue Jan 26 09:42:04 2010 --- gcc-4.6.0/gcc/ada/sem_ch10.adb Tue Oct 26 13:20:47 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sem_Ch10 is *** 86,93 **** -- included in a standalone library. procedure Check_Private_Child_Unit (N : Node_Id); ! -- If a with_clause mentions a private child unit, the compilation ! -- unit must be a member of the same family, as described in 10.1.2. procedure Check_Stub_Level (N : Node_Id); -- Verify that a stub is declared immediately within a compilation unit, --- 86,93 ---- -- included in a standalone library. procedure Check_Private_Child_Unit (N : Node_Id); ! -- If a with_clause mentions a private child unit, the compilation unit ! -- must be a member of the same family, as described in 10.1.2. procedure Check_Stub_Level (N : Node_Id); -- Verify that a stub is declared immediately within a compilation unit, *************** package body Sem_Ch10 is *** 126,133 **** -- example through a limited_with clause in a parent unit. procedure Install_Context_Clauses (N : Node_Id); ! -- Subsidiary to Install_Context and Install_Parents. Process only with_ ! -- and use_clauses for current unit and its library unit if any. procedure Install_Limited_Context_Clauses (N : Node_Id); -- Subsidiary to Install_Context. Process only limited with_clauses for --- 126,133 ---- -- example through a limited_with clause in a parent unit. procedure Install_Context_Clauses (N : Node_Id); ! -- Subsidiary to Install_Context and Install_Parents. Process all with ! -- and use clauses for current unit and its library unit if any. procedure Install_Limited_Context_Clauses (N : Node_Id); -- Subsidiary to Install_Context. Process only limited with_clauses for *************** package body Sem_Ch10 is *** 187,204 **** -- that all parents are removed in the nested case. procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id); ! -- Reset all visibility flags on unit after compiling it, either as a ! -- main unit or as a unit in the context. procedure Unchain (E : Entity_Id); -- Remove single entity from visibility list procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id); -- Common processing for all stubs (subprograms, tasks, packages, and ! -- protected cases). N is the stub to be analyzed. Once the subunit ! -- name is established, load and analyze. Nam is the non-overloadable ! -- entity for which the proper body provides a completion. Subprogram ! -- stubs are handled differently because they can be declarations. procedure sm; -- A dummy procedure, for debugging use, called just before analyzing the --- 187,204 ---- -- that all parents are removed in the nested case. procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id); ! -- Reset all visibility flags on unit after compiling it, either as a main ! -- unit or as a unit in the context. procedure Unchain (E : Entity_Id); -- Remove single entity from visibility list procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id); -- Common processing for all stubs (subprograms, tasks, packages, and ! -- protected cases). N is the stub to be analyzed. Once the subunit name ! -- is established, load and analyze. Nam is the non-overloadable entity ! -- for which the proper body provides a completion. Subprogram stubs are ! -- handled differently because they can be declarations. procedure sm; -- A dummy procedure, for debugging use, called just before analyzing the *************** package body Sem_Ch10 is *** 219,227 **** -- To support this feature, the analysis of a limited_with clause must -- create an abbreviated view of the package, without performing any ! -- semantic analysis on it. This "package abstract" contains shadow ! -- types that are in one-one correspondence with the real types in the ! -- package, and that have the properties of incomplete types. -- The implementation creates two element lists: one to chain the shadow -- entities, and one to chain the corresponding type entities in the tree --- 219,227 ---- -- To support this feature, the analysis of a limited_with clause must -- create an abbreviated view of the package, without performing any ! -- semantic analysis on it. This "package abstract" contains shadow types ! -- that are in one-one correspondence with the real types in the package, ! -- and that have the properties of incomplete types. -- The implementation creates two element lists: one to chain the shadow -- entities, and one to chain the corresponding type entities in the tree *************** package body Sem_Ch10 is *** 272,282 **** Clause : Node_Id; Used : in out Boolean; Used_Type_Or_Elab : in out Boolean); ! -- Examine the context clauses of a package body, trying to match ! -- the name entity of Clause with any list element. If the match ! -- occurs on a use package clause, set Used to True, for a use ! -- type clause, pragma Elaborate or pragma Elaborate_All, set ! -- Used_Type_Or_Elab to True. procedure Process_Spec_Clauses (Context_List : List_Id; --- 272,281 ---- Clause : Node_Id; Used : in out Boolean; Used_Type_Or_Elab : in out Boolean); ! -- Examine the context clauses of a package body, trying to match the ! -- name entity of Clause with any list element. If the match occurs ! -- on a use package clause set Used to True, for a use type clause or ! -- pragma Elaborate[_All], set Used_Type_Or_Elab to True. procedure Process_Spec_Clauses (Context_List : List_Id; *************** package body Sem_Ch10 is *** 310,321 **** Use_Item : Node_Id; function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean; ! -- In an expanded name in a use clause, if the prefix is a ! -- renamed package, the entity is set to the original package ! -- as a result, when checking whether the package appears in a ! -- previous with_clause, the renaming has to be taken into ! -- account, to prevent spurious or incorrect warnings. The ! -- common case is the use of Text_IO. --------------- -- Same_Unit -- --- 309,319 ---- Use_Item : Node_Id; function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean; ! -- In an expanded name in a use clause, if the prefix is a renamed ! -- package, the entity is set to the original package as a result, ! -- when checking whether the package appears in a previous with ! -- clause, the renaming has to be taken into account, to prevent ! -- spurious/incorrect warnings. A common case is use of Text_IO. --------------- -- Same_Unit -- *************** package body Sem_Ch10 is *** 441,449 **** Cont_Item := First (Context_List); while Present (Cont_Item) loop ! -- Stop the search since the context items after Cont_Item ! -- have already been examined in a previous iteration of ! -- the reverse loop in Check_Redundant_Withs. if Exit_On_Self and Cont_Item = Clause --- 439,447 ---- Cont_Item := First (Context_List); while Present (Cont_Item) loop ! -- Stop the search since the context items after Cont_Item have ! -- already been examined in a previous iteration of the reverse ! -- loop in Check_Redundant_Withs. if Exit_On_Self and Cont_Item = Clause *************** package body Sem_Ch10 is *** 466,475 **** end loop; -- Package with clause. Avoid processing self, implicitly ! -- generated with clauses or limited with clauses. Note ! -- that we examine with clauses having pragmas Elaborate ! -- or Elaborate_All applied to them due to cases such as: -- -- with Pack; -- with Pack; -- pragma Elaborate (Pack); --- 464,474 ---- end loop; -- Package with clause. Avoid processing self, implicitly ! -- generated with clauses or limited with clauses. Note that ! -- we examine with clauses having pragmas Elaborate or ! -- Elaborate_All applied to them due to cases such as: -- + -- with Pack; -- with Pack; -- pragma Elaborate (Pack); *************** package body Sem_Ch10 is *** 496,504 **** Clause := Last (Context_Items); while Present (Clause) loop ! -- Avoid checking implicitly generated with clauses, limited ! -- with clauses or withs that have pragma Elaborate or ! -- Elaborate_All applied. if Nkind (Clause) = N_With_Clause and then not Implicit_With (Clause) --- 495,502 ---- Clause := Last (Context_Items); while Present (Clause) loop ! -- Avoid checking implicitly generated with clauses, limited with ! -- clauses or withs that have pragma Elaborate or Elaborate_All. if Nkind (Clause) = N_With_Clause and then not Implicit_With (Clause) *************** package body Sem_Ch10 is *** 552,558 **** or else Used_In_Spec) then ! Error_Msg_N ("?redundant with clause in body", Clause); end if; Used_In_Body := False; --- 550,557 ---- or else Used_In_Spec) then ! Error_Msg_N -- CODEFIX ! ("?redundant with clause in body", Clause); end if; Used_In_Body := False; *************** package body Sem_Ch10 is *** 580,586 **** Exit_On_Self => True); if Withed then ! Error_Msg_N ("?redundant with clause", Clause); end if; end; end if; --- 579,586 ---- Exit_On_Self => True); if Withed then ! Error_Msg_N -- CODEFIX ! ("?redundant with clause", Clause); end if; end; end if; *************** package body Sem_Ch10 is *** 640,648 **** -- analysis of the parent, which we proceed to do. Basically this gets -- handled from the top down and we don't want to do anything at this -- level (i.e. this subunit will be handled on the way down from the ! -- parent), so at this level we immediately return. If the subunit ! -- ends up not analyzed, it means that the parent did not contain a ! -- stub for it, or that there errors were detected in some ancestor. if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) --- 640,648 ---- -- analysis of the parent, which we proceed to do. Basically this gets -- handled from the top down and we don't want to do anything at this -- level (i.e. this subunit will be handled on the way down from the ! -- parent), so at this level we immediately return. If the subunit ends ! -- up not analyzed, it means that the parent did not contain a stub for ! -- it, or that there errors were detected in some ancestor. if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) *************** package body Sem_Ch10 is *** 660,672 **** return; end if; ! -- Analyze context (this will call Sem recursively for with'ed units) ! -- To detect circularities among with-clauses that are not caught during -- loading, we set the Context_Pending flag on the current unit. If the ! -- flag is already set there is a potential circularity. ! -- We exclude predefined units from this check because they are known ! -- to be safe. We also exclude package bodies that are present because ! -- circularities between bodies are harmless (and necessary). if Context_Pending (N) then declare --- 660,672 ---- return; end if; ! -- Analyze context (this will call Sem recursively for with'ed units) To ! -- detect circularities among with-clauses that are not caught during -- loading, we set the Context_Pending flag on the current unit. If the ! -- flag is already set there is a potential circularity. We exclude ! -- predefined units from this check because they are known to be safe. ! -- We also exclude package bodies that are present because circularities ! -- between bodies are harmless (and necessary). if Context_Pending (N) then declare *************** package body Sem_Ch10 is *** 690,697 **** end if; if Circularity then ! Error_Msg_N ! ("circular dependency caused by with_clauses", N); Error_Msg_N ("\possibly missing limited_with clause" & " in one of the following", N); --- 690,696 ---- end if; if Circularity then ! Error_Msg_N ("circular dependency caused by with_clauses", N); Error_Msg_N ("\possibly missing limited_with clause" & " in one of the following", N); *************** package body Sem_Ch10 is *** 978,986 **** end if; end if; ! -- Remove unit from visibility, so that environment is clean for ! -- the next compilation, which is either the main unit or some ! -- other unit in the context. if Nkind_In (Unit_Node, N_Package_Declaration, N_Package_Renaming_Declaration, --- 977,985 ---- end if; end if; ! -- Remove unit from visibility, so that environment is clean for the ! -- next compilation, which is either the main unit or some other unit ! -- in the context. if Nkind_In (Unit_Node, N_Package_Declaration, N_Package_Renaming_Declaration, *************** package body Sem_Ch10 is *** 993,1000 **** Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); -- If the unit is an instantiation whose body will be elaborated for ! -- inlining purposes, use the proper entity of the instance. The ! -- entity may be missing if the instantiation was illegal. elsif Nkind (Unit_Node) = N_Package_Instantiation and then not Error_Posted (Unit_Node) --- 992,999 ---- Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); -- If the unit is an instantiation whose body will be elaborated for ! -- inlining purposes, use the proper entity of the instance. The entity ! -- may be missing if the instantiation was illegal. elsif Nkind (Unit_Node) = N_Package_Instantiation and then not Error_Posted (Unit_Node) *************** package body Sem_Ch10 is *** 1204,1212 **** -- compilation unit actions list, and analyze them. declare ! Loc : constant Source_Ptr := Sloc (N); ! L : constant List_Id := ! Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc); begin while Is_Non_Empty_List (L) loop Insert_Library_Level_Action (Remove_Head (L)); --- 1203,1210 ---- -- compilation unit actions list, and analyze them. declare ! L : constant List_Id := ! Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N); begin while Is_Non_Empty_List (L) loop Insert_Library_Level_Action (Remove_Head (L)); *************** package body Sem_Ch10 is *** 1419,1426 **** P := Parent_Spec (Unit (N)); loop if Unit (P) = Lib_U then ! Error_Msg_N ("limited with_clause of immediate " ! & "ancestor not allowed", Item); exit; end if; --- 1417,1424 ---- P := Parent_Spec (Unit (N)); loop if Unit (P) = Lib_U then ! Error_Msg_N ("limited with_clause cannot " ! & "name ancestor", Item); exit; end if; *************** package body Sem_Ch10 is *** 1579,1588 **** Comp_Unit : Node_Id; begin ! -- Try to load subunit, but ignore any errors that occur during ! -- the loading of the subunit, by using the special feature in ! -- Errout to ignore all errors. Note that Fatal_Error will still ! -- be set, so we will be able to check for this case below. if not ASIS_Mode then Ignore_Errors_Enable := Ignore_Errors_Enable + 1; --- 1577,1586 ---- Comp_Unit : Node_Id; begin ! -- Try to load subunit, but ignore any errors that occur during the ! -- loading of the subunit, by using the special feature in Errout to ! -- ignore all errors. Note that Fatal_Error will still be set, so we ! -- will be able to check for this case below. if not ASIS_Mode then Ignore_Errors_Enable := Ignore_Errors_Enable + 1; *************** package body Sem_Ch10 is *** 1712,1720 **** return; -- If the subunit is not already loaded, and we are generating code, ! -- then this is the case where compilation started from the parent, ! -- and we are generating code for an entire subunit tree. In that ! -- case we definitely need to load the subunit. -- In order to continue the analysis with the rest of the parent, -- and other subunits, we load the unit without requiring its --- 1710,1718 ---- return; -- If the subunit is not already loaded, and we are generating code, ! -- then this is the case where compilation started from the parent, and ! -- we are generating code for an entire subunit tree. In that case we ! -- definitely need to load the subunit. -- In order to continue the analysis with the rest of the parent, -- and other subunits, we load the unit without requiring its *************** package body Sem_Ch10 is *** 1723,1735 **** elsif Original_Operating_Mode = Generate_Code then ! -- If the proper body is already linked to the stub node, ! -- the stub is in a generic unit and just needs analyzing. ! -- We update the version. Although we are not technically ! -- semantically dependent on the subunit, given our approach ! -- of macro substitution of subunits, it makes sense to ! -- include it in the version identification. if Present (Library_Unit (N)) then Set_Corresponding_Stub (Unit (Library_Unit (N)), N); --- 1721,1733 ---- elsif Original_Operating_Mode = Generate_Code then ! -- If the proper body is already linked to the stub node, the stub is ! -- in a generic unit and just needs analyzing. ! -- We update the version. Although we are not strictly technically ! -- semantically dependent on the subunit, given our approach of macro ! -- substitution of subunits, it makes sense to include it in the ! -- version identification. if Present (Library_Unit (N)) then Set_Corresponding_Stub (Unit (Library_Unit (N)), N); *************** package body Sem_Ch10 is *** 1739,1754 **** -- Otherwise we must load the subunit and link to it else Unum := Load_Unit (Load_Name => Subunit_Name, Required => False, Subunit => True, Error_Node => N); ! -- Give message if we did not get the unit ! -- Emit warning even if missing subunit is not ! -- within main unit, to simplify debugging. if Original_Operating_Mode = Generate_Code and then Unum = No_Unit --- 1737,1756 ---- -- Otherwise we must load the subunit and link to it else + -- Make sure that, if the subunit is preprocessed and -gnateG is + -- specified, the preprocessed file will be written. + + Lib.Analysing_Subunit_Of_Main := True; Unum := Load_Unit (Load_Name => Subunit_Name, Required => False, Subunit => True, Error_Node => N); + Lib.Analysing_Subunit_Of_Main := False; ! -- Give message if we did not get the unit Emit warning even if ! -- missing subunit is not within main unit, to simplify debugging. if Original_Operating_Mode = Generate_Code and then Unum = No_Unit *************** package body Sem_Ch10 is *** 1762,1769 **** end if; -- Load_Unit may reset Compiler_State, since it may have been ! -- necessary to parse an additional units, so we make sure ! -- that we reset it to the Analyzing state. Compiler_State := Analyzing; --- 1764,1771 ---- end if; -- Load_Unit may reset Compiler_State, since it may have been ! -- necessary to parse an additional units, so we make sure that ! -- we reset it to the Analyzing state. Compiler_State := Analyzing; *************** package body Sem_Ch10 is *** 1823,1833 **** end if; end if; ! -- The remaining case is when the subunit is not already loaded and ! -- we are not generating code. In this case we are just performing ! -- semantic analysis on the parent, and we are not interested in ! -- the subunit. For subprograms, analyze the stub as a body. For ! -- other entities the stub has already been marked as completed. else Optional_Subunit; --- 1825,1835 ---- end if; end if; ! -- The remaining case is when the subunit is not already loaded and we ! -- are not generating code. In this case we are just performing semantic ! -- analysis on the parent, and we are not interested in the subunit. For ! -- subprograms, analyze the stub as a body. For other entities the stub ! -- has already been marked as completed. else Optional_Subunit; *************** package body Sem_Ch10 is *** 2139,2144 **** --- 2141,2159 ---- -- Start of processing for Analyze_Subunit begin + if Style_Check then + declare + Nam : Node_Id := Name (Unit (N)); + + begin + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + Check_Identifier (Nam, Par_Unit); + end; + end if; + if not Is_Empty_List (Context_Items (N)) then -- Save current use clauses *************** package body Sem_Ch10 is *** 2207,2213 **** if Present (Enclosing_Child) then Install_Siblings (Enclosing_Child, N); end if; - end if; Analyze (Proper_Body (Unit (N))); --- 2222,2227 ---- *************** package body Sem_Ch10 is *** 2256,2262 **** else Set_Scope (Defining_Entity (N), Current_Scope); Generate_Reference (Nam, Defining_Identifier (N), 'b'); ! Set_Has_Completion (Etype (Nam)); Analyze_Proper_Body (N, Etype (Nam)); -- Set elaboration flag to indicate that entity is callable. This --- 2270,2285 ---- else Set_Scope (Defining_Entity (N), Current_Scope); Generate_Reference (Nam, Defining_Identifier (N), 'b'); ! ! -- Check for duplicate stub, if so give message and terminate ! ! if Has_Completion (Etype (Nam)) then ! Error_Msg_N ("duplicate stub for task", N); ! return; ! else ! Set_Has_Completion (Etype (Nam)); ! end if; ! Analyze_Proper_Body (N, Etype (Nam)); -- Set elaboration flag to indicate that entity is callable. This *************** package body Sem_Ch10 is *** 2270,2276 **** Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, ! New_External_Name (Chars (Etype (Nam)), 'E')), Expression => New_Reference_To (Standard_True, Loc))); end if; end if; --- 2293,2299 ---- Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, ! Chars => New_External_Name (Chars (Etype (Nam)), 'E')), Expression => New_Reference_To (Standard_True, Loc))); end if; end if; *************** package body Sem_Ch10 is *** 2303,2314 **** -- Set True if the unit currently being compiled is an internal unit Save_Style_Check : constant Boolean := Opt.Style_Check; ! Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := ! Cunit_Boolean_Restrictions_Save; begin U := Unit (Library_Unit (N)); -- Several actions are skipped for dummy packages (those supplied for -- with's where no matching file could be found). Such packages are -- identified by the Sloc value being set to No_Location. --- 2326,2360 ---- -- Set True if the unit currently being compiled is an internal unit Save_Style_Check : constant Boolean := Opt.Style_Check; ! Save_C_Restrict : Save_Cunit_Boolean_Restrictions; begin U := Unit (Library_Unit (N)); + -- If this is an internal unit which is a renaming, then this is a + -- violation of No_Obsolescent_Features. + + -- Note: this is not quite right if the user defines one of these units + -- himself, but that's a marginal case, and fixing it is hard ??? + + if Restriction_Check_Required (No_Obsolescent_Features) then + declare + F : constant File_Name_Type := + Unit_File_Name (Get_Source_Unit (U)); + begin + if Is_Predefined_File_Name (F, Renamings_Included => True) + and then not + Is_Predefined_File_Name (F, Renamings_Included => False) + then + Check_Restriction (No_Obsolescent_Features, N); + end if; + end; + end if; + + -- Save current restriction set, does not apply to with'ed unit + + Save_C_Restrict := Cunit_Boolean_Restrictions_Save; + -- Several actions are skipped for dummy packages (those supplied for -- with's where no matching file could be found). Such packages are -- identified by the Sloc value being set to No_Location. *************** package body Sem_Ch10 is *** 2339,2347 **** -- explicit with'ing of run-time units. if Configurable_Run_Time_Mode ! and then ! Is_Predefined_File_Name ! (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N))))) then Configurable_Run_Time_Mode := False; Semantics (Library_Unit (N)); --- 2385,2391 ---- -- explicit with'ing of run-time units. if Configurable_Run_Time_Mode ! and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U))) then Configurable_Run_Time_Mode := False; Semantics (Library_Unit (N)); *************** package body Sem_Ch10 is *** 2406,2416 **** "and version-dependent?", Name (N)); end if; ! elsif U_Kind = Ada_05_Unit ! and then Ada_Version < Ada_05 and then Warn_On_Ada_2005_Compatibility then Error_Msg_N ("& is an Ada 2005 unit?", Name (N)); end if; end; end if; --- 2450,2466 ---- "and version-dependent?", Name (N)); end if; ! elsif U_Kind = Ada_2005_Unit ! and then Ada_Version < Ada_2005 and then Warn_On_Ada_2005_Compatibility then Error_Msg_N ("& is an Ada 2005 unit?", Name (N)); + + elsif U_Kind = Ada_2012_Unit + and then Ada_Version < Ada_2012 + and then Warn_On_Ada_2012_Compatibility + then + Error_Msg_N ("& is an Ada 2012 unit?", Name (N)); end if; end; end if; *************** package body Sem_Ch10 is *** 2438,2443 **** --- 2488,2494 ---- elsif Unit_Kind = N_Package_Instantiation and then Nkind (U) = N_Package_Instantiation + and then Present (Instance_Spec (U)) then -- If the instance has not been rewritten as a package declaration, -- then it appeared already in a previous with clause. Retrieve *************** package body Sem_Ch10 is *** 2505,2510 **** --- 2556,2576 ---- Par_Name := Scope (E_Name); while Nkind (Pref) = N_Selected_Component loop Change_Selected_Component_To_Expanded_Name (Pref); + + if Present (Entity (Selector_Name (Pref))) + and then + Present (Renamed_Entity (Entity (Selector_Name (Pref)))) + and then Entity (Selector_Name (Pref)) /= Par_Name + then + -- The prefix is a child unit that denotes a renaming declaration. + -- Replace the prefix directly with the renamed unit, because the + -- rest of the prefix is irrelevant to the visibility of the real + -- unit. + + Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref))); + exit; + end if; + Set_Entity_With_Style_Check (Pref, Par_Name); Generate_Reference (Par_Name, Pref); *************** package body Sem_Ch10 is *** 2605,2613 **** Sub_Parent := Library_Unit (N); Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); ! -- If the parent itself is a subunit, Curr_Unit is the entity ! -- of the enclosing body, retrieve the spec entity which is ! -- the proper ancestor we need for the following tests. if Ekind (Curr_Unit) = E_Package_Body then Curr_Unit := Spec_Entity (Curr_Unit); --- 2671,2679 ---- Sub_Parent := Library_Unit (N); Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); ! -- If the parent itself is a subunit, Curr_Unit is the entity of the ! -- enclosing body, retrieve the spec entity which is the proper ! -- ancestor we need for the following tests. if Ekind (Curr_Unit) = E_Package_Body then Curr_Unit := Spec_Entity (Curr_Unit); *************** package body Sem_Ch10 is *** 2774,2790 **** begin if Nkind (Nam) = N_Identifier then ! -- If the parent unit P in the name of the with_clause for P.Q ! -- is a renaming of package R, then the entity of the parent is ! -- set to R, but the identifier retains Chars (P) to be consistent ! -- with the source (see details in lib-load). However, the ! -- implicit_with_clause for the parent must make the entity for ! -- P visible, because P.Q may be used as a prefix within the ! -- current unit. The entity for P is the current_entity with that ! -- name, because the package renaming declaration for it has just ! -- been analyzed. Note that this case can only happen if P.Q has ! -- already appeared in a previous with_clause in a related unit, ! -- such as the library body of the current unit. if Chars (Nam) /= Chars (Entity (Nam)) then Renaming := Current_Entity (Nam); --- 2840,2856 ---- begin if Nkind (Nam) = N_Identifier then ! -- If the parent unit P in the name of the with_clause for P.Q is ! -- a renaming of package R, then the entity of the parent is set ! -- to R, but the identifier retains Chars (P) to be consistent ! -- with the source (see details in lib-load). However the implicit ! -- with_clause for the parent must make the entity for P visible, ! -- because P.Q may be used as a prefix within the current unit. ! -- The entity for P is the current_entity with that name, because ! -- the package renaming declaration for it has just been analyzed. ! -- Note that this case can only happen if P.Q has already appeared ! -- in a previous with_clause in a related unit, such as the ! -- library body of the current unit. if Chars (Nam) /= Chars (Entity (Nam)) then Renaming := Current_Entity (Nam); *************** package body Sem_Ch10 is *** 2804,2813 **** Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) = N_Package_Renaming_Declaration then ! -- The name in the with_clause is of the form A.B.C, and B ! -- is given by a renaming declaration. In that case we may ! -- not have analyzed the unit for B, but replaced it directly ! -- in lib-load with the unit it renames. We have to make A.B -- visible, so analyze the declaration for B now, in case it -- has not been done yet. --- 2870,2879 ---- Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) = N_Package_Renaming_Declaration then ! -- The name in the with_clause is of the form A.B.C, and B is ! -- given by a renaming declaration. In that case we may not ! -- have analyzed the unit for B, but replaced it directly in ! -- lib-load with the unit it renames. We have to make A.B -- visible, so analyze the declaration for B now, in case it -- has not been done yet. *************** package body Sem_Ch10 is *** 3373,3378 **** --- 3439,3449 ---- -- units. The shadow entities are created when the inserted clause is -- analyzed. Implements Ada 2005 (AI-50217). + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean; + -- When compiling a unit Q descended from some parent unit P, a limited + -- with_clause in the context of P that names some other ancestor of Q + -- must not be installed because the ancestor is immediately visible. + --------------------- -- Check_Renamings -- --------------------- *************** package body Sem_Ch10 is *** 3612,3620 **** Subunit => False, Error_Node => Nam); ! -- Do not generate a limited_with_clause on the current unit. ! -- This path is taken when a unit has a limited_with clause on ! -- one of its child units. if Unum = Current_Sem_Unit then return; --- 3683,3691 ---- Subunit => False, Error_Node => Nam); ! -- Do not generate a limited_with_clause on the current unit. This ! -- path is taken when a unit has a limited_with clause on one of its ! -- child units. if Unum = Current_Sem_Unit then return; *************** package body Sem_Ch10 is *** 3645,3650 **** --- 3716,3737 ---- New_Nodes_OK := New_Nodes_OK - 1; end Expand_Limited_With_Clause; + ---------------------- + -- Is_Ancestor_Unit -- + ---------------------- + + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is + E1 : constant Entity_Id := Defining_Entity (Unit (U1)); + E2 : Entity_Id; + begin + if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then + E2 := Defining_Entity (Unit (Library_Unit (U2))); + return Is_Ancestor_Package (E1, E2); + else + return False; + end if; + end Is_Ancestor_Unit; + -- Start of processing for Install_Limited_Context_Clauses begin *************** package body Sem_Ch10 is *** 3652,3657 **** --- 3739,3745 ---- while Present (Item) loop if Nkind (Item) = N_With_Clause and then Limited_Present (Item) + and then not Error_Posted (Item) then if Nkind (Name (Item)) = N_Selected_Component then Expand_Limited_With_Clause *************** package body Sem_Ch10 is *** 3678,3683 **** --- 3766,3774 ---- if Library_Unit (Item) /= Cunit (Current_Sem_Unit) and then not Limited_View_Installed (Item) + and then + not Is_Ancestor_Unit + (Library_Unit (Item), Cunit (Current_Sem_Unit)) then if not Private_Present (Item) or else Private_Present (N) *************** package body Sem_Ch10 is *** 3693,3703 **** Next (Item); end loop; ! -- Ada 2005 (AI-412): Examine the visible declarations of a package ! -- spec, looking for incomplete subtype declarations of incomplete types -- visible through a limited with clause. ! if Ada_Version >= Ada_05 and then Analyzed (N) and then Nkind (Unit (N)) = N_Package_Declaration then --- 3784,3794 ---- Next (Item); end loop; ! -- Ada 2005 (AI-412): Examine visible declarations of a package spec, ! -- looking for incomplete subtype declarations of incomplete types -- visible through a limited with clause. ! if Ada_Version >= Ada_2005 and then Analyzed (N) and then Nkind (Unit (N)) = N_Package_Declaration then *************** package body Sem_Ch10 is *** 3723,3729 **** -- Convert an incomplete subtype declaration into a -- corresponding non-limited view subtype declaration. -- This is usually the case when analyzing a body that ! -- has regular with-clauses, when the spec has limited -- ones. -- If the non-limited view is still incomplete, it is --- 3814,3820 ---- -- Convert an incomplete subtype declaration into a -- corresponding non-limited view subtype declaration. -- This is usually the case when analyzing a body that ! -- has regular with clauses, when the spec has limited -- ones. -- If the non-limited view is still incomplete, it is *************** package body Sem_Ch10 is *** 4013,4019 **** function In_Context return Boolean; -- Scan context of current unit, to check whether there is -- a with_clause on the same unit as a private with-clause ! -- on a parent, in which case child unit is visible. ---------------- -- In_Context -- --- 4104,4111 ---- function In_Context return Boolean; -- Scan context of current unit, to check whether there is -- a with_clause on the same unit as a private with-clause ! -- on a parent, in which case child unit is visible. If the ! -- unit is a grand-child, the same applies to its parent. ---------------- -- In_Context -- *************** package body Sem_Ch10 is *** 4027,4036 **** if Nkind (Clause) = N_With_Clause and then Comes_From_Source (Clause) and then Is_Entity_Name (Name (Clause)) - and then Entity (Name (Clause)) = Id and then not Private_Present (Clause) then ! return True; end if; Next (Clause); --- 4119,4133 ---- if Nkind (Clause) = N_With_Clause and then Comes_From_Source (Clause) and then Is_Entity_Name (Name (Clause)) and then not Private_Present (Clause) then ! if Entity (Name (Clause)) = Id ! or else ! (Nkind (Name (Clause)) = N_Expanded_Name ! and then Entity (Prefix (Name (Clause))) = Id) ! then ! return True; ! end if; end if; Next (Clause); *************** package body Sem_Ch10 is *** 4302,4309 **** end loop; end; ! -- Finally, check whether there are subprograms that still ! -- require a body, i.e. are not renamings or null. if not Is_Empty_Elmt_List (Subp_List) then declare --- 4399,4406 ---- end loop; end; ! -- Finally, check whether there are subprograms that still require ! -- a body, i.e. are not renamings or null. if not Is_Empty_Elmt_List (Subp_List) then declare *************** package body Sem_Ch10 is *** 4395,4402 **** return True; end if; ! -- If there are more ancestors, climb up the tree, otherwise ! -- we are done. if Is_Child_Unit (Par) then Par := Scope (Par); --- 4492,4499 ---- return True; end if; ! -- If there are more ancestors, climb up the tree, otherwise we ! -- are done. if Is_Child_Unit (Par) then Par := Scope (Par); *************** package body Sem_Ch10 is *** 4553,4562 **** -- Do not install the limited view if this is the unit being analyzed. -- This unusual case will happen when a unit has a limited_with clause ! -- on one of its children. The compilation of the child forces the ! -- load of the parent which tries to install the limited view of the ! -- child again. Installing the limited view must also be disabled ! -- when compiling the body of the child unit. if P = Cunit_Entity (Current_Sem_Unit) or else --- 4650,4659 ---- -- Do not install the limited view if this is the unit being analyzed. -- This unusual case will happen when a unit has a limited_with clause ! -- on one of its children. The compilation of the child forces the load ! -- of the parent which tries to install the limited view of the child ! -- again. Installing the limited view must also be disabled when ! -- compiling the body of the child unit. if P = Cunit_Entity (Current_Sem_Unit) or else *************** package body Sem_Ch10 is *** 4566,4576 **** return; end if; ! -- This scenario is similar to the one above, the difference is that ! -- the compilation of sibling Par.Sib forces the load of parent Par ! -- which tries to install the limited view of Lim_Pack [1]. However ! -- Par.Sib has a with clause for Lim_Pack [2] in its body, and thus ! -- needs the non-limited views of all entities from Lim_Pack. -- limited with Lim_Pack; -- [1] -- package Par is ... package Lim_Pack is ... --- 4663,4673 ---- return; end if; ! -- This scenario is similar to the one above, the difference is that the ! -- compilation of sibling Par.Sib forces the load of parent Par which ! -- tries to install the limited view of Lim_Pack [1]. However Par.Sib ! -- has a with clause for Lim_Pack [2] in its body, and thus needs the ! -- non-limited views of all entities from Lim_Pack. -- limited with Lim_Pack; -- [1] -- package Par is ... package Lim_Pack is ... *************** package body Sem_Ch10 is *** 4599,4607 **** return; end if; ! -- A common use of the limited-with is to have a limited-with ! -- in the package spec, and a normal with in its package body. ! -- For example: -- limited with X; -- [1] -- package A is ... --- 4696,4703 ---- return; end if; ! -- A common use of the limited-with is to have a limited-with in the ! -- package spec, and a normal with in its package body. For example: -- limited with X; -- [1] -- package A is ... *************** package body Sem_Ch10 is *** 4621,4627 **** (Is_Immediately_Visible (P) or else (Is_Child_Package and then Is_Visible_Child_Unit (P))) then ! return; end if; if Debug_Flag_I then --- 4717,4765 ---- (Is_Immediately_Visible (P) or else (Is_Child_Package and then Is_Visible_Child_Unit (P))) then ! ! -- The presence of both the limited and the analyzed nonlimited view ! -- may also be an error, such as an illegal context for a limited ! -- with_clause. In that case, do not process the context item at all. ! ! if Error_Posted (N) then ! return; ! end if; ! ! if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then ! declare ! Item : Node_Id; ! begin ! Item := First (Context_Items (Cunit (Current_Sem_Unit))); ! while Present (Item) loop ! if Nkind (Item) = N_With_Clause ! and then Comes_From_Source (Item) ! and then Entity (Name (Item)) = P ! then ! return; ! end if; ! ! Next (Item); ! end loop; ! end; ! ! -- If this is a child body, assume that the nonlimited with_clause ! -- appears in an ancestor. Could be refined ??? ! ! if Is_Child_Unit ! (Defining_Entity ! (Unit (Library_Unit (Cunit (Current_Sem_Unit))))) ! then ! return; ! end if; ! ! else ! ! -- If in package declaration, nonlimited view brought in from ! -- parent unit or some error condition. ! ! return; ! end if; end if; if Debug_Flag_I then *************** package body Sem_Ch10 is *** 4732,4739 **** Prev := Current_Entity (Lim_Typ); E := Prev; ! -- Replace E in the homonyms list, so that the limited ! -- view becomes available. if E = Non_Limited_View (Lim_Typ) then Set_Homonym (Lim_Typ, Homonym (Prev)); --- 4870,4877 ---- Prev := Current_Entity (Lim_Typ); E := Prev; ! -- Replace E in the homonyms list, so that the limited view ! -- becomes available. if E = Non_Limited_View (Lim_Typ) then Set_Homonym (Lim_Typ, Homonym (Prev)); *************** package body Sem_Ch10 is *** 4743,4750 **** loop E := Homonym (Prev); ! -- E may have been removed when installing a ! -- previous limited_with_clause. exit when No (E); --- 4881,4888 ---- loop E := Homonym (Prev); ! -- E may have been removed when installing a previous ! -- limited_with_clause. exit when No (E); *************** package body Sem_Ch10 is *** 4786,4795 **** Check_Body_Required; end if; ! -- If the package in the limited_with clause is a child unit, the ! -- clause is unanalyzed and appears as a selected component. Recast ! -- it as an expanded name so that the entity can be properly set. Use ! -- entity of parent, if available, for higher ancestors in the name. if Nkind (Name (N)) = N_Selected_Component then declare --- 4924,4933 ---- Check_Body_Required; end if; ! -- If the package in the limited_with clause is a child unit, the clause ! -- is unanalyzed and appears as a selected component. Recast it as an ! -- expanded name so that the entity can be properly set. Use entity of ! -- parent, if available, for higher ancestors in the name. if Nkind (Name (N)) = N_Selected_Component then declare *************** package body Sem_Ch10 is *** 4945,4951 **** if Is_Child_Unit (Uname) and then Is_Visible_Child_Unit (Uname) ! and then Ada_Version >= Ada_05 then declare Decl1 : constant Node_Id := Unit_Declaration_Node (P); --- 5083,5089 ---- if Is_Child_Unit (Uname) and then Is_Visible_Child_Unit (Uname) ! and then Ada_Version >= Ada_2005 then declare Decl1 : constant Node_Id := Unit_Declaration_Node (P); *************** package body Sem_Ch10 is *** 5053,5059 **** -- If the unit is not generic, but contains a generic unit, it is loaded on -- demand, at the point of instantiation (see ch12). ! procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is Body_Name : Unit_Name_Type; Unum : Unit_Number_Type; --- 5191,5201 ---- -- If the unit is not generic, but contains a generic unit, it is loaded on -- demand, at the point of instantiation (see ch12). ! procedure Load_Needed_Body ! (N : Node_Id; ! OK : out Boolean; ! Do_Analyze : Boolean := True) ! is Body_Name : Unit_Name_Type; Unum : Unit_Number_Type; *************** package body Sem_Ch10 is *** 5086,5092 **** Write_Eol; end if; ! Semantics (Cunit (Unum)); end if; OK := True; --- 5228,5236 ---- Write_Eol; end if; ! if Do_Analyze then ! Semantics (Cunit (Unum)); ! end if; end if; OK := True; *************** package body Sem_Ch10 is *** 5346,5352 **** -- and the full-view. if No (Class_Wide_Type (T)) then ! CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); -- Set parent to be the same as the parent of the tagged type. -- We need a parent field set, and it is supposed to point to --- 5490,5496 ---- -- and the full-view. if No (Class_Wide_Type (T)) then ! CW := Make_Temporary (Loc, 'S'); -- Set parent to be the same as the parent of the tagged type. -- We need a parent field set, and it is supposed to point to *************** package body Sem_Ch10 is *** 5398,5406 **** Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is ! E : constant Entity_Id := ! Make_Defining_Identifier (Sloc_Value, ! Chars => New_Internal_Name (Id_Char)); begin Set_Ekind (E, Kind); --- 5542,5548 ---- Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is ! E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin Set_Ekind (E, Kind); *************** package body Sem_Ch10 is *** 5475,5483 **** -- Build the header of the limited_view ! Lim_Header := ! Make_Defining_Identifier (Sloc (N), ! Chars => New_Internal_Name (Id_Char => 'Z')); Set_Ekind (Lim_Header, E_Package); Set_Is_Internal (Lim_Header); Set_Limited_View (P, Lim_Header); --- 5617,5623 ---- -- Build the header of the limited_view ! Lim_Header := Make_Temporary (Sloc (N), 'Z'); Set_Ekind (Lim_Header, E_Package); Set_Is_Internal (Lim_Header); Set_Limited_View (P, Lim_Header); *************** package body Sem_Ch10 is *** 5535,5543 **** then return True; ! elsif Ekind (E) = E_Generic_Function ! or else Ekind (E) = E_Generic_Procedure ! then return True; elsif Ekind (E) = E_Generic_Package --- 5675,5681 ---- then return True; ! elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then return True; elsif Ekind (E) = E_Generic_Package *************** package body Sem_Ch10 is *** 5578,5587 **** then Set_Body_Needed_For_SAL (Unit_Name); ! elsif Ekind (Unit_Name) = E_Generic_Procedure ! or else ! Ekind (Unit_Name) = E_Generic_Function ! then Set_Body_Needed_For_SAL (Unit_Name); elsif Is_Subprogram (Unit_Name) --- 5716,5722 ---- then Set_Body_Needed_For_SAL (Unit_Name); ! elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then Set_Body_Needed_For_SAL (Unit_Name); elsif Is_Subprogram (Unit_Name) *************** package body Sem_Ch10 is *** 5729,5738 **** Write_Eol; end if; ! -- Prepare the removal of the shadow entities from visibility. The ! -- first element of the limited view is a header (an E_Package ! -- entity) that is used to reference the first shadow entity in the ! -- private part of the package Lim_Header := Limited_View (P); Lim_Typ := First_Entity (Lim_Header); --- 5864,5873 ---- Write_Eol; end if; ! -- Prepare the removal of the shadow entities from visibility. The first ! -- element of the limited view is a header (an E_Package entity) that is ! -- used to reference the first shadow entity in the private part of the ! -- package Lim_Header := Limited_View (P); Lim_Typ := First_Entity (Lim_Header); *************** package body Sem_Ch10 is *** 5927,5935 **** if Nkind (Item) = N_With_Clause and then Private_Present (Item) then ! -- If private_with_clause is redundant, remove it from ! -- context, as a small optimization to subsequent handling ! -- of private_with clauses in other nested packages.. if In_Regular_With_Clause (Entity (Name (Item))) then declare --- 6062,6070 ---- if Nkind (Item) = N_With_Clause and then Private_Present (Item) then ! -- If private_with_clause is redundant, remove it from context, ! -- as a small optimization to subsequent handling of private_with ! -- clauses in other nested packages. if In_Regular_With_Clause (Entity (Name (Item))) then declare diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch10.ads gcc-4.6.0/gcc/ada/sem_ch10.ads *** gcc-4.5.2/gcc/ada/sem_ch10.ads Tue Jun 23 10:15:47 2009 --- gcc-4.6.0/gcc/ada/sem_ch10.ads Mon Oct 11 10:24:08 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Ch10 is *** 63,73 **** -- rule imposes extra steps in order to install/remove the private_with -- clauses of an enclosing unit. ! procedure Load_Needed_Body (N : Node_Id; OK : out Boolean); ! -- Load and analyze the body of a context unit that is generic, or ! -- that contains generic units or inlined units. The body becomes ! -- part of the semantic dependency set of the unit that needs it. ! -- The returned result in OK is True if the load is successful, ! -- and False if the requested file cannot be found. end Sem_Ch10; --- 63,78 ---- -- rule imposes extra steps in order to install/remove the private_with -- clauses of an enclosing unit. ! procedure Load_Needed_Body ! (N : Node_Id; ! OK : out Boolean; ! Do_Analyze : Boolean := True); ! -- Load and analyze the body of a context unit that is generic, or that ! -- contains generic units or inlined units. The body becomes part of the ! -- semantic dependency set of the unit that needs it. The returned result ! -- in OK is True if the load is successful, and False if the requested file ! -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and ! -- parsed only. This allows a selective analysis in some inlining cases ! -- where a full analysis would lead so circularities in the back-end. end Sem_Ch10; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch11.adb gcc-4.6.0/gcc/ada/sem_ch11.adb *** gcc-4.5.2/gcc/ada/sem_ch11.adb Fri Jul 10 13:18:49 2009 --- gcc-4.6.0/gcc/ada/sem_ch11.adb Mon Oct 11 10:43:04 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; *************** with Rtsfind; use Rtsfind; *** 39,44 **** --- 40,46 ---- with Sem; use Sem; with Sem_Ch5; use Sem_Ch5; with Sem_Ch8; use Sem_Ch8; + with Sem_Ch13; use Sem_Ch13; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; *************** package body Sem_Ch11 is *** 63,68 **** --- 65,71 ---- Set_Etype (Id, Standard_Exception_Type); Set_Is_Statically_Allocated (Id); Set_Is_Pure (Id, PF); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Exception_Declaration; -------------------------------- *************** package body Sem_Ch11 is *** 538,543 **** --- 541,554 ---- end if; end if; + -- Check obsolescent use of Numeric_Error + + if Exception_Name = Standard_Numeric_Error then + Check_Restriction (No_Obsolescent_Features, Exception_Id); + end if; + + -- Kill last assignment indication + Kill_Current_Values (Last_Assignment_Only => True); end Analyze_Raise_Statement; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch12.adb gcc-4.6.0/gcc/ada/sem_ch12.adb *** gcc-4.5.2/gcc/ada/sem_ch12.adb Tue Oct 27 13:22:25 2009 --- gcc-4.6.0/gcc/ada/sem_ch12.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; *************** package body Sem_Ch12 is *** 469,480 **** -- Used to determine whether its body should be elaborated to allow -- front-end inlining. - function Is_Generic_Formal (E : Entity_Id) return Boolean; - -- Utility to determine whether a given entity is declared by means of - -- of a formal parameter declaration. Used to set properly the visibility - -- of generic formals of a generic package declared with a box or with - -- partial parametrization. - procedure Set_Instance_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); --- 470,475 ---- *************** package body Sem_Ch12 is *** 608,618 **** -- formals: the visible and private declarations themselves need not be -- created. ! -- In Ada 2005, the formal package may be only partially parametrized. In ! -- that case the visibility step must make visible those actuals whose -- corresponding formals were given with a box. A final complication ! -- involves inherited operations from formal derived types, which must be ! -- visible if the type is. function Is_In_Main_Unit (N : Node_Id) return Boolean; -- Test if given node is in the main unit --- 603,613 ---- -- formals: the visible and private declarations themselves need not be -- created. ! -- In Ada 2005, the formal package may be only partially parameterized. ! -- In that case the visibility step must make visible those actuals whose -- corresponding formals were given with a box. A final complication ! -- involves inherited operations from formal derived types, which must ! -- be visible if the type is. function Is_In_Main_Unit (N : Node_Id) return Boolean; -- Test if given node is in the main unit *************** package body Sem_Ch12 is *** 1054,1060 **** -- defining identifier for it. Decl := New_Copy_Tree (F); ! Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id)); if Nkind (F) in N_Formal_Subprogram_Declaration then Set_Defining_Unit_Name (Specification (Decl), Id); --- 1049,1055 ---- -- defining identifier for it. Decl := New_Copy_Tree (F); ! Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); if Nkind (F) in N_Formal_Subprogram_Declaration then Set_Defining_Unit_Name (Specification (Decl), Id); *************** package body Sem_Ch12 is *** 1380,1386 **** when N_Use_Package_Clause | N_Use_Type_Clause => if Nkind (Original_Node (I_Node)) = ! N_Formal_Package_Declaration then Append (New_Copy_Tree (Formal), Assoc); else --- 1375,1381 ---- when N_Use_Package_Clause | N_Use_Type_Clause => if Nkind (Original_Node (I_Node)) = ! N_Formal_Package_Declaration then Append (New_Copy_Tree (Formal), Assoc); else *************** package body Sem_Ch12 is *** 1867,1873 **** -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals ! if Ada_Version < Ada_05 and then Is_Limited_Type (T) then Error_Msg_N ("generic formal of mode IN must not be of limited type", N); Explain_Limited_Type (T, N); --- 1862,1868 ---- -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals ! if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then Error_Msg_N ("generic formal of mode IN must not be of limited type", N); Explain_Limited_Type (T, N); *************** package body Sem_Ch12 is *** 1929,1934 **** --- 1924,1931 ---- ("initialization not allowed for `IN OUT` formals", N); end if; end if; + + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Formal_Object_Declaration; ---------------------------------------------- *************** package body Sem_Ch12 is *** 1972,1982 **** Check_Restriction (No_Fixed_Point, Def); end Analyze_Formal_Ordinary_Fixed_Point_Type; ! ---------------------------- ! -- Analyze_Formal_Package -- ! ---------------------------- ! procedure Analyze_Formal_Package (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pack_Id : constant Entity_Id := Defining_Identifier (N); Formal : Entity_Id; --- 1969,1979 ---- Check_Restriction (No_Fixed_Point, Def); end Analyze_Formal_Ordinary_Fixed_Point_Type; ! ---------------------------------------- ! -- Analyze_Formal_Package_Declaration -- ! ---------------------------------------- ! procedure Analyze_Formal_Package_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pack_Id : constant Entity_Id := Defining_Identifier (N); Formal : Entity_Id; *************** package body Sem_Ch12 is *** 2109,2128 **** -- Check for a formal package that is a package renaming if Present (Renamed_Object (Gen_Unit)) then Gen_Unit := Renamed_Object (Gen_Unit); end if; if Ekind (Gen_Unit) /= E_Generic_Package then Error_Msg_N ("expect generic package name", Gen_Id); Restore_Env; ! return; elsif Gen_Unit = Current_Scope then Error_Msg_N ("generic package cannot be used as a formal package of itself", Gen_Id); Restore_Env; ! return; elsif In_Open_Scopes (Gen_Unit) then if Is_Compilation_Unit (Gen_Unit) --- 2106,2134 ---- -- Check for a formal package that is a package renaming if Present (Renamed_Object (Gen_Unit)) then + + -- Indicate that unit is used, before replacing it with renamed + -- entity for use below. + + if In_Extended_Main_Source_Unit (N) then + Set_Is_Instantiated (Gen_Unit); + Generate_Reference (Gen_Unit, N); + end if; + Gen_Unit := Renamed_Object (Gen_Unit); end if; if Ekind (Gen_Unit) /= E_Generic_Package then Error_Msg_N ("expect generic package name", Gen_Id); Restore_Env; ! goto Leave; elsif Gen_Unit = Current_Scope then Error_Msg_N ("generic package cannot be used as a formal package of itself", Gen_Id); Restore_Env; ! goto Leave; elsif In_Open_Scopes (Gen_Unit) then if Is_Compilation_Unit (Gen_Unit) *************** package body Sem_Ch12 is *** 2142,2148 **** & "within itself", Gen_Id); Restore_Env; ! return; end if; end if; --- 2148,2154 ---- & "within itself", Gen_Id); Restore_Env; ! goto Leave; end if; end if; *************** package body Sem_Ch12 is *** 2190,2196 **** Remove_Parent; end if; ! return; end; Rewrite (N, New_N); --- 2196,2202 ---- Remove_Parent; end if; ! goto Leave; end; Rewrite (N, New_N); *************** package body Sem_Ch12 is *** 2273,2279 **** Set_Etype (Pack_Id, Standard_Void_Type); Set_Scope (Pack_Id, Scope (Formal)); Set_Has_Completion (Pack_Id, True); ! end Analyze_Formal_Package; --------------------------------- -- Analyze_Formal_Private_Type -- --- 2279,2288 ---- Set_Etype (Pack_Id, Standard_Void_Type); Set_Scope (Pack_Id, Scope (Formal)); Set_Has_Completion (Pack_Id, True); ! ! <> ! Analyze_Aspect_Specifications (N, Pack_Id, Aspect_Specifications (N)); ! end Analyze_Formal_Package_Declaration; --------------------------------- -- Analyze_Formal_Private_Type -- *************** package body Sem_Ch12 is *** 2323,2333 **** Set_Parent (Base, Parent (Def)); end Analyze_Formal_Signed_Integer_Type; ! ------------------------------- ! -- Analyze_Formal_Subprogram -- ! ------------------------------- ! procedure Analyze_Formal_Subprogram (N : Node_Id) is Spec : constant Node_Id := Specification (N); Def : constant Node_Id := Default_Name (N); Nam : constant Entity_Id := Defining_Unit_Name (Spec); --- 2332,2342 ---- Set_Parent (Base, Parent (Def)); end Analyze_Formal_Signed_Integer_Type; ! ------------------------------------------- ! -- Analyze_Formal_Subprogram_Declaration -- ! ------------------------------------------- ! procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is Spec : constant Node_Id := Specification (N); Def : constant Node_Id := Default_Name (N); Nam : constant Entity_Id := Defining_Unit_Name (Spec); *************** package body Sem_Ch12 is *** 2340,2346 **** if Nkind (Nam) = N_Defining_Program_Unit_Name then Error_Msg_N ("name of formal subprogram must be a direct name", Nam); ! return; end if; Analyze_Subprogram_Declaration (N); --- 2349,2355 ---- if Nkind (Nam) = N_Defining_Program_Unit_Name then Error_Msg_N ("name of formal subprogram must be a direct name", Nam); ! goto Leave; end if; Analyze_Subprogram_Declaration (N); *************** package body Sem_Ch12 is *** 2384,2390 **** Analyze (Prefix (Def)); Valid_Default_Attribute (Nam, Def); ! return; end if; -- Default name may be overloaded, in which case the interpretation --- 2393,2399 ---- Analyze (Prefix (Def)); Valid_Default_Attribute (Nam, Def); ! goto Leave; end if; -- Default name may be overloaded, in which case the interpretation *************** package body Sem_Ch12 is *** 2394,2400 **** -- can be a protected operation. if Etype (Def) = Any_Type then ! return; elsif Nkind (Def) = N_Selected_Component then if not Is_Overloadable (Entity (Selector_Name (Def))) then --- 2403,2409 ---- -- can be a protected operation. if Etype (Def) = Any_Type then ! goto Leave; elsif Nkind (Def) = N_Selected_Component then if not Is_Overloadable (Entity (Selector_Name (Def))) then *************** package body Sem_Ch12 is *** 2408,2422 **** end if; elsif Nkind (Prefix (Def)) = N_Selected_Component then ! if Ekind (Entity (Selector_Name (Prefix (Def)))) ! /= E_Entry_Family then Error_Msg_N ("expect valid subprogram name as default", Def); end if; else Error_Msg_N ("expect valid subprogram name as default", Def); ! return; end if; elsif Nkind (Def) = N_Character_Literal then --- 2417,2431 ---- end if; elsif Nkind (Prefix (Def)) = N_Selected_Component then ! if Ekind (Entity (Selector_Name (Prefix (Def)))) /= ! E_Entry_Family then Error_Msg_N ("expect valid subprogram name as default", Def); end if; else Error_Msg_N ("expect valid subprogram name as default", Def); ! goto Leave; end if; elsif Nkind (Def) = N_Character_Literal then *************** package body Sem_Ch12 is *** 2429,2435 **** or else not Is_Overloadable (Entity (Def)) then Error_Msg_N ("expect valid subprogram name as default", Def); ! return; elsif not Is_Overloaded (Def) then Subp := Entity (Def); --- 2438,2444 ---- or else not Is_Overloadable (Entity (Def)) then Error_Msg_N ("expect valid subprogram name as default", Def); ! goto Leave; elsif not Is_Overloaded (Def) then Subp := Entity (Def); *************** package body Sem_Ch12 is *** 2491,2497 **** end if; end if; end if; ! end Analyze_Formal_Subprogram; ------------------------------------- -- Analyze_Formal_Type_Declaration -- --- 2500,2509 ---- end if; end if; end if; ! ! <> ! Analyze_Aspect_Specifications (N, Nam, Aspect_Specifications (N)); ! end Analyze_Formal_Subprogram_Declaration; ------------------------------------- -- Analyze_Formal_Type_Declaration -- *************** package body Sem_Ch12 is *** 2564,2569 **** --- 2576,2582 ---- end case; Set_Is_Generic_Type (T); + Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N)); end Analyze_Formal_Type_Declaration; ------------------------------------ *************** package body Sem_Ch12 is *** 2592,2598 **** then Error_Msg_N ("premature usage of incomplete type", Def); ! elsif Is_Internal (Designated_Type (T)) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; --- 2605,2611 ---- then Error_Msg_N ("premature usage of incomplete type", Def); ! elsif not Is_Entity_Name (Subtype_Indication (Def)) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; *************** package body Sem_Ch12 is *** 2740,2745 **** --- 2753,2760 ---- Check_References (Id); end if; end if; + + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Generic_Package_Declaration; -------------------------------------------- *************** package body Sem_Ch12 is *** 2800,2809 **** --- 2815,2845 ---- if Nkind (Result_Definition (Spec)) = N_Access_Definition then Result_Type := Access_Definition (Spec, Result_Definition (Spec)); Set_Etype (Id, Result_Type); + + -- Check restriction imposed by AI05-073: a generic function + -- cannot return an abstract type or an access to such. + + -- This is a binding interpretation should it apply to earlier + -- versions of Ada as well as Ada 2012??? + + if Is_Abstract_Type (Designated_Type (Result_Type)) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N ("generic function cannot have an access result" + & " that designates an abstract type", Spec); + end if; + else Find_Type (Result_Definition (Spec)); Typ := Entity (Result_Definition (Spec)); + if Is_Abstract_Type (Typ) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N + ("generic function cannot have abstract result type", Spec); + end if; + -- If a null exclusion is imposed on the result type, then create -- a null-excluding itype (an access subtype) and use it as the -- function's Etype. *************** package body Sem_Ch12 is *** 2844,2849 **** --- 2880,2888 ---- End_Scope; Exit_Generic_Scope (Id); Generate_Reference_To_Formals (Id); + + List_Inherited_Pre_Post_Aspects (Id); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Generic_Subprogram_Declaration; ----------------------------------- *************** package body Sem_Ch12 is *** 2993,2999 **** if Etype (Gen_Unit) = Any_Type then Restore_Env; ! return; elsif Ekind (Gen_Unit) /= E_Generic_Package then --- 3032,3038 ---- if Etype (Gen_Unit) = Any_Type then Restore_Env; ! goto Leave; elsif Ekind (Gen_Unit) /= E_Generic_Package then *************** package body Sem_Ch12 is *** 3008,3014 **** end if; Restore_Env; ! return; end if; if In_Extended_Main_Source_Unit (N) then --- 3047,3053 ---- end if; Restore_Env; ! goto Leave; end if; if In_Extended_Main_Source_Unit (N) then *************** package body Sem_Ch12 is *** 3051,3057 **** if In_Open_Scopes (Gen_Unit) then Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); Restore_Env; ! return; elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then Error_Msg_Node_2 := Current_Scope; --- 3090,3096 ---- if In_Open_Scopes (Gen_Unit) then Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); Restore_Env; ! goto Leave; elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then Error_Msg_Node_2 := Current_Scope; *************** package body Sem_Ch12 is *** 3059,3065 **** ("circular Instantiation: & instantiated in &!", N, Gen_Unit); Circularity_Detected := True; Restore_Env; ! return; else Gen_Decl := Unit_Declaration_Node (Gen_Unit); --- 3098,3104 ---- ("circular Instantiation: & instantiated in &!", N, Gen_Unit); Circularity_Detected := True; Restore_Env; ! goto Leave; else Gen_Decl := Unit_Declaration_Node (Gen_Unit); *************** package body Sem_Ch12 is *** 3275,3286 **** end if; end; ! -- If we are generating the calling stubs from the instantiation of ! -- a generic RCI package, we will not use the body of the generic ! -- package. if Distribution_Stub_Mode = Generate_Caller_Stub_Body ! and then Is_Compilation_Unit (Defining_Entity (N)) then Needs_Body := False; end if; --- 3314,3326 ---- end if; end; ! -- If we are generating calling stubs, we never need a body for an ! -- instantiation from source. However normal processing occurs for ! -- any generic instantiation appearing in generated code, since we ! -- do not generate stubs in that case. if Distribution_Stub_Mode = Generate_Caller_Stub_Body ! and then Comes_From_Source (N) then Needs_Body := False; end if; *************** package body Sem_Ch12 is *** 3387,3393 **** Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); end if; end if; --- 3427,3434 ---- Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, ! Version => Ada_Version)); end if; end if; *************** package body Sem_Ch12 is *** 3515,3520 **** --- 3556,3565 ---- Set_Defining_Identifier (N, Act_Decl_Id); end if; + <> + Analyze_Aspect_Specifications + (N, Act_Decl_Id, Aspect_Specifications (N)); + exception when Instantiation_Error => if Parent_Installed then *************** package body Sem_Ch12 is *** 3540,3547 **** Cunit_Entity (Get_Source_Unit (Gen_Unit)); Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); Curr_Scope : Entity_Id := Empty; ! Curr_Unit : constant Entity_Id := ! Cunit_Entity (Current_Sem_Unit); Removed : Boolean := False; Num_Scopes : Int := 0; --- 3585,3591 ---- Cunit_Entity (Get_Source_Unit (Gen_Unit)); Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); Curr_Scope : Entity_Id := Empty; ! Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); Removed : Boolean := False; Num_Scopes : Int := 0; *************** package body Sem_Ch12 is *** 3694,3700 **** Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), Inlined_Body => True); Pop_Scope; --- 3738,3745 ---- Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, ! Version => Ada_Version)), Inlined_Body => True); Pop_Scope; *************** package body Sem_Ch12 is *** 3809,3815 **** Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), Inlined_Body => True); end if; end Inline_Instance_Body; --- 3854,3861 ---- Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, ! Version => Ada_Version)), Inlined_Body => True); end if; end Inline_Instance_Body; *************** package body Sem_Ch12 is *** 3848,3854 **** Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); return True; else return False; --- 3894,3901 ---- Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, ! Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, ! Version => Ada_Version)); return True; else return False; *************** package body Sem_Ch12 is *** 3954,3959 **** --- 4001,4009 ---- Check_Formal_Packages (Pack_Id); Set_Is_Generic_Instance (Pack_Id, False); + -- Why do we clear Is_Generic_Instance??? We set it 20 lines + -- above??? + -- Body of the enclosing package is supplied when instantiating the -- subprogram body, after semantic analysis is completed. *************** package body Sem_Ch12 is *** 3999,4009 **** --- 4049,4062 ---- -- If the instance is a child unit, mark the Id accordingly. Mark -- the anonymous entity as well, which is the real subprogram and -- which is used when the instance appears in a context clause. + -- Similarly, propagate the Is_Eliminated flag to handle properly + -- nested eliminated subprograms. Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); New_Overloaded_Entity (Act_Decl_Id); Check_Eliminated (Act_Decl_Id); + Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); -- In compilation unit case, kill elaboration checks on the -- instantiation, since they are never needed -- the body is *************** package body Sem_Ch12 is *** 4072,4080 **** -- Verify that it is a generic subprogram of the right kind, and that -- it does not lead to a circular instantiation. ! if Ekind (Gen_Unit) /= E_Generic_Procedure ! and then Ekind (Gen_Unit) /= E_Generic_Function ! then Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id); elsif In_Open_Scopes (Gen_Unit) then --- 4125,4131 ---- -- Verify that it is a generic subprogram of the right kind, and that -- it does not lead to a circular instantiation. ! if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id); elsif In_Open_Scopes (Gen_Unit) then *************** package body Sem_Ch12 is *** 4127,4133 **** Error_Msg_NE ("circular Instantiation: & instantiated in &!", N, Gen_Unit); Circularity_Detected := True; ! return; end if; Gen_Decl := Unit_Declaration_Node (Gen_Unit); --- 4178,4184 ---- Error_Msg_NE ("circular Instantiation: & instantiated in &!", N, Gen_Unit); Circularity_Detected := True; ! goto Leave; end if; Gen_Decl := Unit_Declaration_Node (Gen_Unit); *************** package body Sem_Ch12 is *** 4209,4215 **** end if; if Is_Dispatching_Operation (Act_Decl_Id) ! and then Ada_Version >= Ada_05 then declare Formal : Entity_Id; --- 4260,4266 ---- end if; if Is_Dispatching_Operation (Act_Decl_Id) ! and then Ada_Version >= Ada_2005 then declare Formal : Entity_Id; *************** package body Sem_Ch12 is *** 4223,4229 **** then Error_Msg_NE ("access parameter& is controlling,", N, Formal); ! Error_Msg_NE ("\corresponding parameter of & must be" & " explicitly null-excluding", N, Gen_Id); end if; --- 4274,4281 ---- then Error_Msg_NE ("access parameter& is controlling,", N, Formal); ! Error_Msg_NE ! ("\corresponding parameter of & must be" & " explicitly null-excluding", N, Gen_Id); end if; *************** package body Sem_Ch12 is *** 4284,4289 **** --- 4336,4345 ---- Generic_Renamings_HTable.Reset; end if; + <> + Analyze_Aspect_Specifications + (N, Act_Decl_Id, Aspect_Specifications (N)); + exception when Instantiation_Error => if Parent_Installed then *************** package body Sem_Ch12 is *** 4440,4446 **** procedure Check_Access_Definition (N : Node_Id) is begin pragma Assert ! (Ada_Version >= Ada_05 and then Present (Access_Definition (N))); null; end Check_Access_Definition; --- 4496,4502 ---- procedure Check_Access_Definition (N : Node_Id) is begin pragma Assert ! (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); null; end Check_Access_Definition; *************** package body Sem_Ch12 is *** 4726,4732 **** -- that are attributes are rewritten as subprograms. If the -- subprogram in the formal package is defaulted, no check is -- needed. Note that this can only happen in Ada 2005 when the ! -- formal package can be partially parametrized. if Nkind (Unit_Declaration_Node (E1)) = N_Subprogram_Renaming_Declaration --- 4782,4788 ---- -- that are attributes are rewritten as subprograms. If the -- subprogram in the formal package is defaulted, no check is -- needed. Note that this can only happen in Ada 2005 when the ! -- formal package can be partially parameterized. if Nkind (Unit_Declaration_Node (E1)) = N_Subprogram_Renaming_Declaration *************** package body Sem_Ch12 is *** 4848,4855 **** --- 4904,4916 ---- -- To detect this case we have to rescan the list of formals, which -- is usually short enough to ignore the resulting inefficiency. + ----------------------------- + -- Denotes_Previous_Actual -- + ----------------------------- + function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is Prev : Entity_Id; + begin Prev := First_Entity (Instance); while Present (Prev) loop *************** package body Sem_Ch12 is *** 4859,4870 **** --- 4920,4934 ---- and then Entity (Subtype_Indication (Parent (Prev))) = Typ then return True; + elsif Prev = E then return False; + else Next_Entity (Prev); end if; end loop; + return False; end Denotes_Previous_Actual; *************** package body Sem_Ch12 is *** 5243,5248 **** --- 5307,5331 ---- then Install_Parent (Inst_Par); Parent_Installed := True; + + -- The generic unit may be the renaming of the implicit child + -- present in an instance. In that case the parent instance is + -- obtained from the name of the renamed entity. + + elsif Ekind (Entity (Gen_Id)) = E_Generic_Package + and then Present (Renamed_Entity (Entity (Gen_Id))) + and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) + then + declare + Renamed_Package : constant Node_Id := + Name (Parent (Entity (Gen_Id))); + begin + if Nkind (Renamed_Package) = N_Expanded_Name then + Inst_Par := Entity (Prefix (Renamed_Package)); + Install_Parent (Inst_Par); + Parent_Installed := True; + end if; + end; end if; end if; *************** package body Sem_Ch12 is *** 5418,5423 **** --- 5501,5507 ---- and then Is_Private_Type (Designated_Type (T)) and then not Has_Private_View (N) and then Present (Full_View (Designated_Type (T))) + and then Used_As_Generic_Actual (T) then Switch_View (Designated_Type (T)); *************** package body Sem_Ch12 is *** 5713,5718 **** --- 5797,5810 ---- New_N := New_Copy (N); + -- Copy aspects if present + + if Has_Aspects (N) then + Set_Has_Aspects (New_N, False); + Set_Aspect_Specifications + (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); + end if; + if Instantiating then Adjust_Instantiation_Sloc (New_N, S_Adjustment); end if; *************** package body Sem_Ch12 is *** 5874,5880 **** -- If we are not instantiating, then this is where we load and -- analyze subunits, i.e. at the point where the stub occurs. A ! -- more permissible system might defer this analysis to the point -- of instantiation, but this seems to complicated for now. if not Instantiating then --- 5966,5972 ---- -- If we are not instantiating, then this is where we load and -- analyze subunits, i.e. at the point where the stub occurs. A ! -- more permissive system might defer this analysis to the point -- of instantiation, but this seems to complicated for now. if not Instantiating then *************** package body Sem_Ch12 is *** 5885,5896 **** --- 5977,5995 ---- New_Body : Node_Id; begin + -- Make sure that, if it is a subunit of the main unit that is + -- preprocessed and if -gnateG is specified, the preprocessed + -- file will be written. + + Lib.Analysing_Subunit_Of_Main := + Lib.In_Extended_Main_Source_Unit (N); Unum := Load_Unit (Load_Name => Subunit_Name, Required => False, Subunit => True, Error_Node => N); + Lib.Analysing_Subunit_Of_Main := False; -- If the proper body is not found, a warning message will be -- emitted when analyzing the stub, or later at the point *************** package body Sem_Ch12 is *** 6141,6155 **** end if; end; ! elsif Nkind_In (N, N_Integer_Literal, ! N_Real_Literal, ! N_String_Literal) ! then -- No descendant fields need traversing null; ! -- For the remaining nodes, copy recursively their descendants else Copy_Descendants; --- 6240,6264 ---- end if; end; ! elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then ! -- No descendant fields need traversing null; ! elsif Nkind (N) = N_String_Literal ! and then Present (Etype (N)) ! and then Instantiating ! then ! -- If the string is declared in an outer scope, the string_literal ! -- subtype created for it may have the wrong scope. We force the ! -- reanalysis of the constant to generate a new itype in the proper ! -- context. ! ! Set_Etype (New_N, Empty); ! Set_Analyzed (New_N, False); ! ! -- For the remaining nodes, copy their descendants recursively else Copy_Descendants; *************** package body Sem_Ch12 is *** 7853,7860 **** if not Box_Present (Formal) then declare I_Pack : constant Entity_Id := ! Make_Defining_Identifier (Sloc (Actual), ! Chars => New_Internal_Name ('P')); begin Set_Is_Internal (I_Pack); --- 7962,7968 ---- if not Box_Present (Formal) then declare I_Pack : constant Entity_Id := ! Make_Temporary (Sloc (Actual), 'P'); begin Set_Is_Internal (I_Pack); *************** package body Sem_Ch12 is *** 8153,8161 **** -- to prevent freezing anomalies. declare ! Anon_Id : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('E')); begin Set_Defining_Unit_Name (New_Spec, Anon_Id); Insert_Before (Instantiation_Node, Decl_Node); --- 8261,8268 ---- -- to prevent freezing anomalies. declare ! Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); ! begin Set_Defining_Unit_Name (New_Spec, Anon_Id); Insert_Before (Instantiation_Node, Decl_Node); *************** package body Sem_Ch12 is *** 8185,8201 **** Actual : Node_Id; Analyzed_Formal : Node_Id) return List_Id is Acc_Def : Node_Id := Empty; Act_Assoc : constant Node_Id := Parent (Actual); Actual_Decl : Node_Id := Empty; - Formal_Id : constant Entity_Id := Defining_Identifier (Formal); Decl_Node : Node_Id; Def : Node_Id; Ftyp : Entity_Id; List : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Actual); ! Orig_Ftyp : constant Entity_Id := ! Etype (Defining_Identifier (Analyzed_Formal)); Subt_Decl : Node_Id := Empty; Subt_Mark : Node_Id := Empty; --- 8292,8309 ---- Actual : Node_Id; Analyzed_Formal : Node_Id) return List_Id is + Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); + A_Gen_Obj : constant Entity_Id := + Defining_Identifier (Analyzed_Formal); Acc_Def : Node_Id := Empty; Act_Assoc : constant Node_Id := Parent (Actual); Actual_Decl : Node_Id := Empty; Decl_Node : Node_Id; Def : Node_Id; Ftyp : Entity_Id; List : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Actual); ! Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); Subt_Decl : Node_Id := Empty; Subt_Mark : Node_Id := Empty; *************** package body Sem_Ch12 is *** 8209,8217 **** -- Sloc for error message on missing actual ! Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal))); ! if Get_Instance_Of (Formal_Id) /= Formal_Id then Error_Msg_N ("duplicate instantiation of generic parameter", Actual); end if; --- 8317,8325 ---- -- Sloc for error message on missing actual ! Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); ! if Get_Instance_Of (Gen_Obj) /= Gen_Obj then Error_Msg_N ("duplicate instantiation of generic parameter", Actual); end if; *************** package body Sem_Ch12 is *** 8232,8256 **** if No (Actual) then Error_Msg_NE ("missing actual&", ! Instantiation_Node, Formal_Id); Error_Msg_NE ("\in instantiation of & declared#", ! Instantiation_Node, ! Scope (Defining_Identifier (Analyzed_Formal))); Abandon_Instantiation (Instantiation_Node); end if; if Present (Subt_Mark) then Decl_Node := Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => New_Copy (Formal_Id), Subtype_Mark => New_Copy_Tree (Subt_Mark), Name => Actual); else pragma Assert (Present (Acc_Def)); Decl_Node := Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => New_Copy (Formal_Id), Access_Definition => New_Copy_Tree (Acc_Def), Name => Actual); end if; --- 8340,8363 ---- if No (Actual) then Error_Msg_NE ("missing actual&", ! Instantiation_Node, Gen_Obj); Error_Msg_NE ("\in instantiation of & declared#", ! Instantiation_Node, Scope (A_Gen_Obj)); Abandon_Instantiation (Instantiation_Node); end if; if Present (Subt_Mark) then Decl_Node := Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => New_Copy (Gen_Obj), Subtype_Mark => New_Copy_Tree (Subt_Mark), Name => Actual); else pragma Assert (Present (Acc_Def)); Decl_Node := Make_Object_Renaming_Declaration (Loc, ! Defining_Identifier => New_Copy (Gen_Obj), Access_Definition => New_Copy_Tree (Acc_Def), Name => Actual); end if; *************** package body Sem_Ch12 is *** 8283,8293 **** end if; -- The actual has to be resolved in order to check that it is a ! -- variable (due to cases such as F(1), where F returns ! -- access to an array, and for overloaded prefixes). ! Ftyp := ! Get_Instance_Of (Etype (Defining_Identifier (Analyzed_Formal))); if Is_Private_Type (Ftyp) and then not Is_Private_Type (Etype (Actual)) --- 8390,8417 ---- end if; -- The actual has to be resolved in order to check that it is a ! -- variable (due to cases such as F (1), where F returns access to an ! -- array, and for overloaded prefixes). ! Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); ! ! -- If the type of the formal is not itself a formal, and the ! -- current unit is a child unit, the formal type must be declared ! -- in a parent, and must be retrieved by visibility. ! ! if Ftyp = Orig_Ftyp ! and then Is_Generic_Unit (Scope (Ftyp)) ! and then Is_Child_Unit (Scope (A_Gen_Obj)) ! then ! declare ! Temp : constant Node_Id := ! New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); ! begin ! Set_Entity (Temp, Empty); ! Find_Type (Temp); ! Ftyp := Entity (Temp); ! end; ! end if; if Is_Private_Type (Ftyp) and then not Is_Private_Type (Etype (Actual)) *************** package body Sem_Ch12 is *** 8302,8309 **** Subt_Decl := Make_Subtype_Declaration (Loc, ! Defining_Identifier => ! Make_Defining_Identifier (Loc, New_Internal_Name ('P')), Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); Prepend (Subt_Decl, List); --- 8426,8432 ---- Subt_Decl := Make_Subtype_Declaration (Loc, ! Defining_Identifier => Make_Temporary (Loc, 'P'), Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); Prepend (Subt_Decl, List); *************** package body Sem_Ch12 is *** 8316,8322 **** if not Denotes_Variable (Actual) then Error_Msg_NE ! ("actual for& must be a variable", Actual, Formal_Id); elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then --- 8439,8445 ---- if not Denotes_Variable (Actual) then Error_Msg_NE ! ("actual for& must be a variable", Actual, Gen_Obj); elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then *************** package body Sem_Ch12 is *** 8324,8330 **** -- the type of the actual shall resolve to a specific anonymous -- access type. ! if Ada_Version < Ada_05 or else Ekind (Base_Type (Ftyp)) /= E_Anonymous_Access_Type --- 8447,8453 ---- -- the type of the actual shall resolve to a specific anonymous -- access type. ! if Ada_Version < Ada_2005 or else Ekind (Base_Type (Ftyp)) /= E_Anonymous_Access_Type *************** package body Sem_Ch12 is *** 8333,8339 **** E_Anonymous_Access_Type then Error_Msg_NE ("type of actual does not match type of&", ! Actual, Formal_Id); end if; end if; --- 8456,8462 ---- E_Anonymous_Access_Type then Error_Msg_NE ("type of actual does not match type of&", ! Actual, Gen_Obj); end if; end if; *************** package body Sem_Ch12 is *** 8372,8378 **** Decl_Node := Make_Object_Declaration (Loc, ! Defining_Identifier => New_Copy (Formal_Id), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy_Tree (Def), --- 8495,8501 ---- Decl_Node := Make_Object_Declaration (Loc, ! Defining_Identifier => New_Copy (Gen_Obj), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy_Tree (Def), *************** package body Sem_Ch12 is *** 8383,8391 **** -- A generic formal object of a tagged type is defined to be -- aliased so the new constant must also be treated as aliased. ! if Is_Tagged_Type ! (Etype (Defining_Identifier (Analyzed_Formal))) ! then Set_Aliased_Present (Decl_Node); end if; --- 8506,8512 ---- -- A generic formal object of a tagged type is defined to be -- aliased so the new constant must also be treated as aliased. ! if Is_Tagged_Type (Etype (A_Gen_Obj)) then Set_Aliased_Present (Decl_Node); end if; *************** package body Sem_Ch12 is *** 8405,8415 **** end if; declare ! Formal_Object : constant Entity_Id := ! Defining_Identifier (Analyzed_Formal); ! Formal_Type : constant Entity_Id := Etype (Formal_Object); ! ! Typ : Entity_Id; begin Typ := Get_Instance_Of (Formal_Type); --- 8526,8533 ---- end if; declare ! Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); ! Typ : Entity_Id; begin Typ := Get_Instance_Of (Formal_Type); *************** package body Sem_Ch12 is *** 8446,8452 **** Decl_Node := Make_Object_Declaration (Sloc (Formal), ! Defining_Identifier => New_Copy (Formal_Id), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy (Def), --- 8564,8570 ---- Decl_Node := Make_Object_Declaration (Sloc (Formal), ! Defining_Identifier => New_Copy (Gen_Obj), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy (Def), *************** package body Sem_Ch12 is *** 8459,8472 **** else Error_Msg_NE ("missing actual&", ! Instantiation_Node, Formal_Id); Error_Msg_NE ("\in instantiation of & declared#", ! Instantiation_Node, ! Scope (Defining_Identifier (Analyzed_Formal))); - if Is_Scalar_Type - (Etype (Defining_Identifier (Analyzed_Formal))) - then -- Create dummy constant declaration so that instance can be -- analyzed, to minimize cascaded visibility errors. --- 8577,8588 ---- else Error_Msg_NE ("missing actual&", ! Instantiation_Node, Gen_Obj); Error_Msg_NE ("\in instantiation of & declared#", ! Instantiation_Node, Scope (A_Gen_Obj)); ! ! if Is_Scalar_Type (Etype (A_Gen_Obj)) then -- Create dummy constant declaration so that instance can be -- analyzed, to minimize cascaded visibility errors. *************** package body Sem_Ch12 is *** 8478,8489 **** Decl_Node := Make_Object_Declaration (Loc, ! Defining_Identifier => New_Copy (Formal_Id), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy (Def), Expression => ! Make_Attribute_Reference (Sloc (Formal_Id), Attribute_Name => Name_First, Prefix => New_Copy (Def))); --- 8594,8605 ---- Decl_Node := Make_Object_Declaration (Loc, ! Defining_Identifier => New_Copy (Gen_Obj), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy (Def), Expression => ! Make_Attribute_Reference (Sloc (Gen_Obj), Attribute_Name => Name_First, Prefix => New_Copy (Def))); *************** package body Sem_Ch12 is *** 8509,8515 **** -- Otherwise, the subtype of the actual matching the formal object -- declaration shall exclude null. ! if Ada_Version >= Ada_05 and then Present (Actual_Decl) and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, --- 8625,8631 ---- -- Otherwise, the subtype of the actual matching the formal object -- declaration shall exclude null. ! if Ada_Version >= Ada_2005 and then Present (Actual_Decl) and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, *************** package body Sem_Ch12 is *** 8576,8581 **** --- 8692,8698 ---- Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; if No (Gen_Body_Id) then Load_Parent_Of_Generic *************** package body Sem_Ch12 is *** 8732,8742 **** -- If we have no body, and the unit requires a body, then complain. This -- complaint is suppressed if we have detected other errors (since a -- common reason for missing the body is that it had errors). elsif Unit_Requires_Body (Gen_Unit) and then not Body_Optional then ! if Serious_Errors_Detected = 0 then Error_Msg_NE ("cannot find body of generic package &", Inst_Node, Gen_Unit); --- 8849,8864 ---- -- If we have no body, and the unit requires a body, then complain. This -- complaint is suppressed if we have detected other errors (since a -- common reason for missing the body is that it had errors). + -- In CodePeer mode, a warning has been emitted already, no need for + -- further messages. elsif Unit_Requires_Body (Gen_Unit) and then not Body_Optional then ! if CodePeer_Mode then ! null; ! ! elsif Serious_Errors_Detected = 0 then Error_Msg_NE ("cannot find body of generic package &", Inst_Node, Gen_Unit); *************** package body Sem_Ch12 is *** 8832,8837 **** --- 8954,8960 ---- Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; if No (Gen_Body_Id) then *************** package body Sem_Ch12 is *** 9213,9220 **** elsif Ekind (A_Gen_T) = E_General_Access_Type and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type then ! Error_Msg_N ("actual must be general access type!", Actual); ! Error_Msg_NE ("add ALL to }!", Actual, Act_T); Abandon_Instantiation (Actual); end if; end if; --- 9336,9345 ---- elsif Ekind (A_Gen_T) = E_General_Access_Type and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type then ! Error_Msg_N -- CODEFIX ! ("actual must be general access type!", Actual); ! Error_Msg_NE -- CODEFIX ! ("add ALL to }!", Actual, Act_T); Abandon_Instantiation (Actual); end if; end if; *************** package body Sem_Ch12 is *** 9330,9336 **** I2 := First_Index (Act_T); for J in 1 .. Formal_Dimensions loop ! -- If the indices of the actual were given by a subtype_mark, -- the index was transformed into a range attribute. Retrieve -- the original type mark for checking. --- 9455,9461 ---- I2 := First_Index (Act_T); for J in 1 .. Formal_Dimensions loop ! -- If the indexes of the actual were given by a subtype_mark, -- the index was transformed into a range attribute. Retrieve -- the original type mark for checking. *************** package body Sem_Ch12 is *** 9519,9525 **** -- Ada 2005 (AI-251) ! if Ada_Version >= Ada_05 and then Is_Interface (Ancestor) then if not Interface_Present_In_Ancestor (Act_T, Ancestor) then --- 9644,9650 ---- -- Ada 2005 (AI-251) ! if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then if not Interface_Present_In_Ancestor (Act_T, Ancestor) then *************** package body Sem_Ch12 is *** 9539,9545 **** -- that the formal type declaration has been rewritten as a private -- extension. ! if Ada_Version >= Ada_05 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration and then Synchronized_Present (Parent (A_Gen_T)) then --- 9664,9670 ---- -- that the formal type declaration has been rewritten as a private -- extension. ! if Ada_Version >= Ada_2005 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration and then Synchronized_Present (Parent (A_Gen_T)) then *************** package body Sem_Ch12 is *** 9843,9851 **** -- then so far the subprograms correspond, so -- now check that any result types correspond. ! if No (Anc_Formal) ! and then No (Act_Formal) ! then Subprograms_Correspond := True; if Ekind (Act_Subp) = E_Function then --- 9968,9974 ---- -- then so far the subprograms correspond, so -- now check that any result types correspond. ! if No (Anc_Formal) and then No (Act_Formal) then Subprograms_Correspond := True; if Ekind (Act_Subp) = E_Function then *************** package body Sem_Ch12 is *** 9923,9934 **** -- interface then the generic formal is not unless declared -- explicitly so. If not declared limited, the actual cannot be -- limited (see AI05-0087). ! -- Disable check for now, limited interfaces implemented by ! -- protected types are common, Need to update tests ??? if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) ! and then False then Error_Msg_NE ("actual for non-limited & cannot be a limited type", Actual, --- 10046,10059 ---- -- interface then the generic formal is not unless declared -- explicitly so. If not declared limited, the actual cannot be -- limited (see AI05-0087). ! ! -- Even though this AI is a binding interpretation, we enable the ! -- check only in Ada 2012 mode, because this improper construct ! -- shows up in user code and in existing B-tests. if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) ! and then Ada_Version >= Ada_2012 then Error_Msg_NE ("actual for non-limited & cannot be a limited type", Actual, *************** package body Sem_Ch12 is *** 10297,10302 **** --- 10422,10431 ---- -- parent, but the analyzed formal that includes the interface -- operations of all its progenitors. + -- Same treatment for formal private types, so we can check whether the + -- type is tagged limited when validating derivations in the private + -- part. (See AI05-096). + if Nkind (Def) = N_Formal_Derived_Type_Definition then if Present (Interface_List (Def)) then Set_Generic_Parent_Type (Decl_Node, A_Gen_T); *************** package body Sem_Ch12 is *** 10305,10311 **** end if; elsif Nkind (Def) = N_Formal_Private_Type_Definition then ! Set_Generic_Parent_Type (Decl_Node, Ancestor); end if; -- If the actual is a synchronized type that implements an interface, --- 10434,10440 ---- end if; elsif Nkind (Def) = N_Formal_Private_Type_Definition then ! Set_Generic_Parent_Type (Decl_Node, A_Gen_T); end if; -- If the actual is a synchronized type that implements an interface, *************** package body Sem_Ch12 is *** 10327,10334 **** Corr_Decl : Node_Id; begin ! New_Corr := Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); Corr_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => New_Corr, --- 10456,10462 ---- Corr_Decl : Node_Id; begin ! New_Corr := Make_Temporary (Loc, 'S'); Corr_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => New_Corr, *************** package body Sem_Ch12 is *** 10351,10379 **** return Decl_Nodes; end Instantiate_Type; - ----------------------- - -- Is_Generic_Formal -- - ----------------------- - - function Is_Generic_Formal (E : Entity_Id) return Boolean is - Kind : Node_Kind; - begin - if No (E) then - return False; - else - Kind := Nkind (Parent (E)); - return - Nkind_In (Kind, N_Formal_Object_Declaration, - N_Formal_Package_Declaration, - N_Formal_Type_Declaration) - or else - (Is_Formal_Subprogram (E) - and then - Nkind (Parent (Parent (E))) in - N_Formal_Subprogram_Declaration); - end if; - end Is_Generic_Formal; - --------------------- -- Is_In_Main_Unit -- --------------------- --- 10479,10484 ---- *************** package body Sem_Ch12 is *** 10434,10441 **** -- instantiations are available, we must analyze them, to ensure that -- the public symbols generated are the same when the unit is compiled -- to generate code, and when it is compiled in the context of a unit ! -- that needs a particular nested instance. This process is applied ! -- to both package and subprogram instances. -------------------------------- -- Collect_Previous_Instances -- --- 10539,10546 ---- -- instantiations are available, we must analyze them, to ensure that -- the public symbols generated are the same when the unit is compiled -- to generate code, and when it is compiled in the context of a unit ! -- that needs a particular nested instance. This process is applied to ! -- both package and subprogram instances. -------------------------------- -- Collect_Previous_Instances -- *************** package body Sem_Ch12 is *** 10480,10489 **** --- 10585,10602 ---- Collect_Previous_Instances (Private_Declarations (Specification (Decl))); + -- Previous non-generic bodies may contain instances as well + elsif Nkind (Decl) = N_Package_Body and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package then Collect_Previous_Instances (Declarations (Decl)); + + elsif Nkind (Decl) = N_Subprogram_Body + and then not Acts_As_Spec (Decl) + and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) + then + Collect_Previous_Instances (Declarations (Decl)); end if; Next (Decl); *************** package body Sem_Ch12 is *** 10577,10585 **** -- enclosing body. Because the generic body we need may use -- global entities declared in the enclosing package (including -- aggregates) it is in general necessary to compile this body ! -- with expansion enabled. The exception is if we are within a ! -- generic package, in which case the usual generic rule ! -- applies. declare Exp_Status : Boolean := True; --- 10690,10697 ---- -- enclosing body. Because the generic body we need may use -- global entities declared in the enclosing package (including -- aggregates) it is in general necessary to compile this body ! -- with expansion enabled, except if we are within a generic ! -- package, in which case the usual generic rule applies. declare Exp_Status : Boolean := True; *************** package body Sem_Ch12 is *** 10648,10654 **** Get_Code_Unit (Sloc (Node (Decl))), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => ! Local_Suppress_Stack_Top); -- Package instance --- 10760,10767 ---- Get_Code_Unit (Sloc (Node (Decl))), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => ! Local_Suppress_Stack_Top, ! Version => Ada_Version); -- Package instance *************** package body Sem_Ch12 is *** 10688,10694 **** Get_Code_Unit (Sloc (Inst_Node)), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => ! Local_Suppress_Stack_Top)), Body_Optional => Body_Optional); end; end if; --- 10801,10808 ---- Get_Code_Unit (Sloc (Inst_Node)), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => ! Local_Suppress_Stack_Top, ! Version => Ada_Version)), Body_Optional => Body_Optional); end; end if; *************** package body Sem_Ch12 is *** 10711,10721 **** Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); begin ! Error_Msg_Unit_1 := Bname; ! Error_Msg_N ("this instantiation requires$!", N); ! Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False); ! Error_Msg_N ("\but file{ was not found!", N); ! raise Unrecoverable_Error; end; end if; end if; --- 10825,10844 ---- Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); begin ! -- In CodePeer mode, the missing body may make the analysis ! -- incomplete, but we do not treat it as fatal. ! ! if CodePeer_Mode then ! return; ! ! else ! Error_Msg_Unit_1 := Bname; ! Error_Msg_N ("this instantiation requires$!", N); ! Error_Msg_File_1 := ! Get_File_Name (Bname, Subunit => False); ! Error_Msg_N ("\but file{ was not found!", N); ! raise Unrecoverable_Error; ! end if; end; end if; end if; *************** package body Sem_Ch12 is *** 11042,11047 **** --- 11165,11171 ---- -- stack contains the parent instances of the instantiation, followed by -- the original S. + Cur_P : Entity_Id; E : Entity_Id; P : Entity_Id; Hidden : Elmt_Id; *************** package body Sem_Ch12 is *** 11064,11072 **** Next_Entity (E); end loop; ! if Is_Generic_Instance (Current_Scope) ! 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. --- 11188,11205 ---- Next_Entity (E); end loop; ! -- If instantiation is declared in a block, it is the enclosing ! -- scope that might be a parent instance. Note that only one ! -- block can be involved, because the parent instances have ! -- been installed within it. ! ! if Ekind (P) = E_Block then ! Cur_P := Scope (P); ! else ! Cur_P := P; ! end if; ! ! if Is_Generic_Instance (Cur_P) 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. *************** package body Sem_Ch12 is *** 11076,11082 **** end if; -- If the ultimate parent is a top-level unit recorded in ! -- 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.???) --- 11209,11215 ---- 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.???) *************** package body Sem_Ch12 is *** 11219,11233 **** while Present (M) loop Typ := Node (M); ! -- 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. ! if Ekind (Typ) = E_Private_Type ! or else Ekind (Typ) = E_Limited_Private_Type ! or else Ekind (Typ) = E_Record_Type_With_Private then Dep_Elmt := First_Elmt (Private_Dependents (Typ)); while Present (Dep_Elmt) loop --- 11352,11366 ---- while Present (M) loop Typ := Node (M); ! -- Subtypes of types whose views have been exchanged, and that are ! -- defined within the instance, were not on the Private_Dependents ! -- list 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_In (Typ, E_Private_Type, ! E_Limited_Private_Type, ! E_Record_Type_With_Private) then Dep_Elmt := First_Elmt (Private_Dependents (Typ)); while Present (Dep_Elmt) loop *************** package body Sem_Ch12 is *** 11267,11277 **** -- An unusual case of aliasing: the actual may also be directly -- visible in the generic, and be private there, while it is fully -- visible in the context of the instance. The internal subtype ! -- is private in the instance, but has full visibility like its -- parent in the enclosing scope. This enforces the invariant that -- the privacy status of all private dependents of a type coincide -- with that of the parent type. This can only happen when a ! -- generic child unit is instantiated within sibling. if Is_Private_Type (E) and then not Is_Private_Type (Etype (E)) --- 11400,11410 ---- -- An unusual case of aliasing: the actual may also be directly -- visible in the generic, and be private there, while it is fully -- visible in the context of the instance. The internal subtype ! -- is private in the instance but has full visibility like its -- parent in the enclosing scope. This enforces the invariant that -- the privacy status of all private dependents of a type coincide -- with that of the parent type. This can only happen when a ! -- generic child unit is instantiated within a sibling. if Is_Private_Type (E) and then not Is_Private_Type (Etype (E)) *************** package body Sem_Ch12 is *** 11287,11302 **** -- a formal package, make its own formals private as well. The -- actual in this case is itself the renaming of an instantiation. -- If the entity is not a package renaming, it is the entity ! -- created to validate formal package actuals: ignore. -- If the actual is itself a formal package for the enclosing -- generic, or the actual for such a formal package, it remains -- visible on exit from the instance, and therefore nothing needs -- to be done either, except to keep it accessible. ! if Is_Package ! and then Renamed_Object (E) = Pack_Id ! then exit; elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then --- 11420,11433 ---- -- a formal package, make its own formals private as well. The -- actual in this case is itself the renaming of an instantiation. -- If the entity is not a package renaming, it is the entity ! -- created to validate formal package actuals: ignore it. -- If the actual is itself a formal package for the enclosing -- generic, or the actual for such a formal package, it remains -- visible on exit from the instance, and therefore nothing needs -- to be done either, except to keep it accessible. ! if Is_Package and then Renamed_Object (E) = Pack_Id then exit; elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then *************** package body Sem_Ch12 is *** 11550,11564 **** N2 := Get_Associated_Node (N); E := Entity (N2); if Present (E) then if Is_Global (E) then Set_Global_Type (N, N2); elsif Nkind (N) = N_Op_Concat and then Is_Generic_Type (Etype (N2)) ! and then ! (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) ! or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) and then Is_Intrinsic_Subprogram (E) then null; --- 11681,11709 ---- N2 := Get_Associated_Node (N); E := Entity (N2); + -- If the entity is an itype created as a subtype of an access type + -- with a null exclusion restore source entity for proper visibility. + -- The itype will be created anew in the instance. + if Present (E) then + if Is_Itype (E) + and then Ekind (E) = E_Access_Subtype + and then Is_Entity_Name (N) + and then Chars (Etype (E)) = Chars (N) + then + E := Etype (E); + Set_Entity (N2, E); + Set_Etype (N2, E); + end if; + if Is_Global (E) then Set_Global_Type (N, N2); elsif Nkind (N) = N_Op_Concat and then Is_Generic_Type (Etype (N2)) ! and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) ! or else ! Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) and then Is_Intrinsic_Subprogram (E) then null; *************** package body Sem_Ch12 is *** 11801,11811 **** and then Is_Generic_Unit (Scope (Gen_Id)) and then In_Open_Scopes (Scope (Gen_Id)) then ! -- This is an instantiation of a child unit within a sibling, ! -- so that the generic parent is in scope. An eventual instance ! -- must occur within the scope of an instance of the parent. ! -- Make name in instance into an expanded name, to preserve the ! -- identifier of the parent, so it can be resolved subsequently. Rewrite (Name (N2), Make_Expanded_Name (Loc, --- 11946,11956 ---- and then Is_Generic_Unit (Scope (Gen_Id)) and then In_Open_Scopes (Scope (Gen_Id)) then ! -- This is an instantiation of a child unit within a sibling, so ! -- that the generic parent is in scope. An eventual instance must ! -- occur within the scope of an instance of the parent. Make name ! -- in instance into an expanded name, to preserve the identifier ! -- of the parent, so it can be resolved subsequently. Rewrite (Name (N2), Make_Expanded_Name (Loc, *************** package body Sem_Ch12 is *** 12023,12040 **** elsif Nkind (N2) = N_Explicit_Dereference then -- An identifier is rewritten as a dereference if it is the ! -- prefix in an implicit dereference. ! ! -- Check whether corresponding entity in prefix is global if Is_Entity_Name (Prefix (N2)) and then Present (Entity (Prefix (N2))) and then Is_Global (Entity (Prefix (N2))) then ! Rewrite (N, ! Make_Explicit_Dereference (Loc, ! Prefix => ! New_Occurrence_Of (Entity (Prefix (N2)), Loc))); elsif Nkind (Prefix (N2)) = N_Function_Call and then Is_Global (Entity (Name (Prefix (N2)))) then --- 12168,12184 ---- elsif Nkind (N2) = N_Explicit_Dereference then -- An identifier is rewritten as a dereference if it is the ! -- prefix in an implicit dereference (call or attribute). ! -- The analysis of an instantiation will expand the node ! -- again, so we preserve the original tree but link it to ! -- the resolved entity in case it is global. if Is_Entity_Name (Prefix (N2)) and then Present (Entity (Prefix (N2))) and then Is_Global (Entity (Prefix (N2))) then ! Set_Associated_Node (N, Prefix (N2)); ! elsif Nkind (Prefix (N2)) = N_Function_Call and then Is_Global (Entity (Name (Prefix (N2)))) then *************** package body Sem_Ch12 is *** 12156,12161 **** --- 12300,12325 ---- -- All other cases than aggregates else + -- For pragmas, we propagate the Enabled status for the + -- relevant pragmas to the original generic tree. This was + -- originally needed for SCO generation. It is no longer + -- needed there (since we use the Sloc value in calls to + -- Set_SCO_Pragma_Enabled), but it seems a generally good + -- idea to have this flag set properly. + + if Nkind (N) = N_Pragma + and then + (Pragma_Name (N) = Name_Assert or else + Pragma_Name (N) = Name_Check or else + Pragma_Name (N) = Name_Precondition or else + Pragma_Name (N) = Name_Postcondition) + and then Present (Associated_Node (Pragma_Identifier (N))) + then + Set_Pragma_Enabled (N, + Pragma_Enabled + (Parent (Associated_Node (Pragma_Identifier (N))))); + end if; + Save_Global_Descendant (Field1 (N)); Save_Global_Descendant (Field2 (N)); Save_Global_Descendant (Field3 (N)); *************** package body Sem_Ch12 is *** 12237,12255 **** Act_Unit : Entity_Id) is begin ! -- Regardless of the current mode, predefined units are analyzed in ! -- the most current Ada mode, and earlier version Ada checks do not ! -- apply to predefined units. Nothing needs to be done for non-internal ! -- units. These are always analyzed in the current mode. if Is_Internal_File_Name ! (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), ! Renamings_Included => True) then Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); end if; ! Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null); end Set_Instance_Env; ----------------- --- 12401,12422 ---- Act_Unit : Entity_Id) is begin ! -- Regardless of the current mode, predefined units are analyzed in the ! -- most current Ada mode, and earlier version Ada checks do not apply ! -- to predefined units. Nothing needs to be done for non-internal units. ! -- These are always analyzed in the current mode. if Is_Internal_File_Name ! (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), ! Renamings_Included => True) then Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); end if; ! Current_Instantiated_Parent := ! (Gen_Id => Gen_Unit, ! Act_Id => Act_Unit, ! Next_In_HTable => Assoc_Null); end Set_Instance_Env; ----------------- diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch12.ads gcc-4.6.0/gcc/ada/sem_ch12.ads *** gcc-4.5.2/gcc/ada/sem_ch12.ads Fri Aug 7 09:42:01 2009 --- gcc-4.6.0/gcc/ada/sem_ch12.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Ch12 is *** 34,41 **** procedure Analyze_Function_Instantiation (N : Node_Id); procedure Analyze_Formal_Object_Declaration (N : Node_Id); procedure Analyze_Formal_Type_Declaration (N : Node_Id); ! procedure Analyze_Formal_Subprogram (N : Node_Id); ! procedure Analyze_Formal_Package (N : Node_Id); procedure Start_Generic; -- Must be invoked before starting to process a generic spec or body --- 34,41 ---- procedure Analyze_Function_Instantiation (N : Node_Id); procedure Analyze_Formal_Object_Declaration (N : Node_Id); procedure Analyze_Formal_Type_Declaration (N : Node_Id); ! procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id); ! procedure Analyze_Formal_Package_Declaration (N : Node_Id); procedure Start_Generic; -- Must be invoked before starting to process a generic spec or body *************** package Sem_Ch12 is *** 53,59 **** -- the child unit that must be declared within. Similarly, if this is the -- name of a generic child unit within an instantiation of its own parent, -- retrieve the parent generic. If the parent is installed as a result of ! -- this call, then Parent_Installed is set True, otherwise Parent_Intalled -- is unchanged by the call. function Copy_Generic_Node --- 53,59 ---- -- the child unit that must be declared within. Similarly, if this is the -- name of a generic child unit within an instantiation of its own parent, -- retrieve the parent generic. If the parent is installed as a result of ! -- this call, then Parent_Installed is set True, otherwise Parent_Installed -- is unchanged by the call. function Copy_Generic_Node *************** package Sem_Ch12 is *** 64,70 **** -- repeatedly: once to produce a copy on which semantic analysis of -- the generic is performed, and once for each instantiation. The tree -- being copied is not semantically analyzed, except that references to ! -- global entities are marked on terminal nodes. function Get_Instance_Of (A : Entity_Id) return Entity_Id; -- Retrieve actual associated with given generic parameter. --- 64,72 ---- -- repeatedly: once to produce a copy on which semantic analysis of -- the generic is performed, and once for each instantiation. The tree -- being copied is not semantically analyzed, except that references to ! -- global entities are marked on terminal nodes. Note that this function ! -- copies any aspect specifications from the input node N to the returned ! -- node, as well as the setting of the Has_Aspects flag. function Get_Instance_Of (A : Entity_Id) return Entity_Id; -- Retrieve actual associated with given generic parameter. diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch13.adb gcc-4.6.0/gcc/ada/sem_ch13.adb *** gcc-4.5.2/gcc/ada/sem_ch13.adb Fri Aug 7 09:42:01 2009 --- gcc-4.6.0/gcc/ada/sem_ch13.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,32 **** --- 23,35 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; + with Elists; use Elists; with Errout; use Errout; + with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Lib; use Lib; *************** with Rtsfind; use Rtsfind; *** 41,56 **** with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; ! with Table; with Targparm; use Targparm; with Ttypes; use Ttypes; with Tbuild; use Tbuild; --- 44,61 ---- with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; + with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; + with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; ! with Stringt; use Stringt; with Targparm; use Targparm; with Ttypes; use Ttypes; with Tbuild; use Tbuild; *************** package body Sem_Ch13 is *** 73,81 **** -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. ! procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); ! -- Given two entities for record components or discriminants, checks ! -- if they have overlapping component clauses and issues errors if so. function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding --- 78,107 ---- -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. ! procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); ! -- If Typ has predicates (indicated by Has_Predicates being set for Typ, ! -- then either there are pragma Invariant entries on the rep chain for the ! -- type (note that Predicate aspects are converted to pragma Predicate), or ! -- there are inherited aspects from a parent type, or ancestor subtypes. ! -- This procedure builds the spec and body for the Predicate function that ! -- tests these predicates. N is the freeze node for the type. The spec of ! -- the function is inserted before the freeze node, and the body of the ! -- function is inserted after the freeze node. ! ! procedure Build_Static_Predicate ! (Typ : Entity_Id; ! Expr : Node_Id; ! Nam : Name_Id); ! -- Given a predicated type Typ, where Typ is a discrete static subtype, ! -- whose predicate expression is Expr, tests if Expr is a static predicate, ! -- and if so, builds the predicate range list. Nam is the name of the one ! -- argument to the predicate function. Occurrences of the type name in the ! -- predicate expression have been replaced by identifier references to this ! -- name, which is unique, so any identifier with Chars matching Nam must be ! -- a reference to the type. If the predicate is non-static, this procedure ! -- returns doing nothing. If the predicate is static, then the predicate ! -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as ! -- a canonicalized membership operation. function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding *************** package body Sem_Ch13 is *** 83,92 **** -- posted as required, and a value of No_Uint is returned. function Is_Operational_Item (N : Node_Id) return Boolean; ! -- A specification for a stream attribute is allowed before the full ! -- type is declared, as explained in AI-00137 and the corrigendum. ! -- Attributes that do not specify a representation characteristic are ! -- operational attributes. procedure New_Stream_Subprogram (N : Node_Id; --- 109,118 ---- -- posted as required, and a value of No_Uint is returned. function Is_Operational_Item (N : Node_Id) return Boolean; ! -- A specification for a stream attribute is allowed before the full type ! -- is declared, as explained in AI-00137 and the corrigendum. Attributes ! -- that do not specify a representation characteristic are operational ! -- attributes. procedure New_Stream_Subprogram (N : Node_Id; *************** package body Sem_Ch13 is *** 108,113 **** --- 134,160 ---- -- renaming_as_body. For tagged types, the specification is one of the -- primitive specs. + generic + with procedure Replace_Type_Reference (N : Node_Id); + procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id); + -- This is used to scan an expression for a predicate or invariant aspect + -- replacing occurrences of the name TName (the name of the subtype to + -- which the aspect applies) with appropriate references to the parameter + -- of the predicate function or invariant procedure. The procedure passed + -- as a generic parameter does the actual replacement of node N, which is + -- either a simple direct reference to TName, or a selected component that + -- represents an appropriately qualified occurrence of TName. + + procedure Set_Biased + (E : Entity_Id; + N : Node_Id; + Msg : String; + Biased : Boolean := True); + -- If Biased is True, sets Has_Biased_Representation flag for E, and + -- outputs a warning message at node N if Warn_On_Biased_Representation is + -- is True. This warning inserts the string Msg to describe the construct + -- causing biasing. + ---------------------------------------------- -- Table for Validate_Unchecked_Conversions -- ---------------------------------------------- *************** package body Sem_Ch13 is *** 164,170 **** -- The entity of the object being overlaid Off : Boolean; ! -- Whether the address is offseted within Y end record; package Address_Clause_Checks is new Table.Table ( --- 211,217 ---- -- The entity of the object being overlaid Off : Boolean; ! -- Whether the address is offset within Y end record; package Address_Clause_Checks is new Table.Table ( *************** package body Sem_Ch13 is *** 180,444 **** ----------------------------------------- procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is ! Max_Machine_Scalar_Size : constant Uint := ! UI_From_Int ! (Standard_Long_Long_Integer_Size); ! -- We use this as the maximum machine scalar size in the sense of AI-133 ! ! Num_CC : Natural; ! Comp : Entity_Id; ! SSU : constant Uint := UI_From_Int (System_Storage_Unit); begin ! -- This first loop through components does two things. First it deals ! -- with the case of components with component clauses whose length is ! -- greater than the maximum machine scalar size (either accepting them ! -- or rejecting as needed). Second, it counts the number of components ! -- with component clauses whose length does not exceed this maximum for ! -- later processing. ! ! Num_CC := 0; ! Comp := First_Component_Or_Discriminant (R); ! while Present (Comp) loop ! declare ! CC : constant Node_Id := Component_Clause (Comp); ! begin ! if Present (CC) then ! declare ! Fbit : constant Uint := Static_Integer (First_Bit (CC)); ! begin ! -- Case of component with size > max machine scalar ! if Esize (Comp) > Max_Machine_Scalar_Size then ! -- Must begin on byte boundary ! if Fbit mod SSU /= 0 then ! Error_Msg_N ! ("illegal first bit value for reverse bit order", ! First_Bit (CC)); ! Error_Msg_Uint_1 := SSU; ! Error_Msg_Uint_2 := Max_Machine_Scalar_Size; ! Error_Msg_N ! ("\must be a multiple of ^ if size greater than ^", ! First_Bit (CC)); ! -- Must end on byte boundary ! elsif Esize (Comp) mod SSU /= 0 then ! Error_Msg_N ! ("illegal last bit value for reverse bit order", ! Last_Bit (CC)); ! Error_Msg_Uint_1 := SSU; ! Error_Msg_Uint_2 := Max_Machine_Scalar_Size; ! Error_Msg_N ! ("\must be a multiple of ^ if size greater than ^", ! Last_Bit (CC)); ! -- OK, give warning if enabled ! elsif Warn_On_Reverse_Bit_Order then Error_Msg_N ("multi-byte field specified with non-standard" ! & " Bit_Order?", CC); if Bytes_Big_Endian then Error_Msg_N ! ("\bytes are not reversed " ! & "(component is big-endian)?", CC); else Error_Msg_N ! ("\bytes are not reversed " ! & "(component is little-endian)?", CC); end if; end if; ! -- Case where size is not greater than max machine ! -- scalar. For now, we just count these. else ! Num_CC := Num_CC + 1; end if; end; end if; - end; ! Next_Component_Or_Discriminant (Comp); ! end loop; ! -- We need to sort the component clauses on the basis of the Position ! -- values in the clause, so we can group clauses with the same Position. ! -- together to determine the relevant machine scalar size. ! declare ! Comps : array (0 .. Num_CC) of Entity_Id; ! -- Array to collect component and discriminant entities. The data ! -- starts at index 1, the 0'th entry is for the sort routine. ! function CP_Lt (Op1, Op2 : Natural) return Boolean; ! -- Compare routine for Sort ! procedure CP_Move (From : Natural; To : Natural); ! -- Move routine for Sort ! package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); ! Start : Natural; ! Stop : Natural; ! -- Start and stop positions in component list of set of components ! -- with the same starting position (that constitute components in ! -- a single machine scalar). ! MaxL : Uint; ! -- Maximum last bit value of any component in this set ! MSS : Uint; ! -- Corresponding machine scalar size ! ----------- ! -- CP_Lt -- ! ----------- ! function CP_Lt (Op1, Op2 : Natural) return Boolean is ! begin ! return Position (Component_Clause (Comps (Op1))) < ! Position (Component_Clause (Comps (Op2))); ! end CP_Lt; ! ------------- ! -- CP_Move -- ! ------------- ! procedure CP_Move (From : Natural; To : Natural) is ! begin ! Comps (To) := Comps (From); ! end CP_Move; ! begin ! -- Collect the component clauses ! Num_CC := 0; ! Comp := First_Component_Or_Discriminant (R); ! while Present (Comp) loop ! if Present (Component_Clause (Comp)) ! and then Esize (Comp) <= Max_Machine_Scalar_Size ! then ! Num_CC := Num_CC + 1; ! Comps (Num_CC) := Comp; ! end if; ! Next_Component_Or_Discriminant (Comp); ! end loop; ! -- Sort by ascending position number ! Sorting.Sort (Num_CC); ! -- We now have all the components whose size does not exceed the max ! -- machine scalar value, sorted by starting position. In this loop ! -- we gather groups of clauses starting at the same position, to ! -- process them in accordance with Ada 2005 AI-133. ! Stop := 0; ! while Stop < Num_CC loop ! Start := Stop + 1; ! Stop := Start; ! MaxL := ! Static_Integer (Last_Bit (Component_Clause (Comps (Start)))); ! while Stop < Num_CC loop ! if Static_Integer ! (Position (Component_Clause (Comps (Stop + 1)))) = ! Static_Integer ! (Position (Component_Clause (Comps (Stop)))) ! then ! Stop := Stop + 1; ! MaxL := ! UI_Max ! (MaxL, ! Static_Integer ! (Last_Bit (Component_Clause (Comps (Stop))))); ! else ! exit; end if; end loop; ! -- Now we have a group of component clauses from Start to Stop ! -- whose positions are identical, and MaxL is the maximum last bit ! -- value of any of these components. ! -- We need to determine the corresponding machine scalar size. ! -- This loop assumes that machine scalar sizes are even, and that ! -- each possible machine scalar has twice as many bits as the ! -- next smaller one. ! MSS := Max_Machine_Scalar_Size; ! while MSS mod 2 = 0 ! and then (MSS / 2) >= SSU ! and then (MSS / 2) > MaxL ! loop ! MSS := MSS / 2; ! end loop; ! -- Here is where we fix up the Component_Bit_Offset value to ! -- account for the reverse bit order. Some examples of what needs ! -- to be done for the case of a machine scalar size of 8 are: ! -- First_Bit .. Last_Bit Component_Bit_Offset ! -- old new old new ! -- 0 .. 0 7 .. 7 0 7 ! -- 0 .. 1 6 .. 7 0 6 ! -- 0 .. 2 5 .. 7 0 5 ! -- 0 .. 7 0 .. 7 0 4 ! -- 1 .. 1 6 .. 6 1 6 ! -- 1 .. 4 3 .. 6 1 3 ! -- 4 .. 7 0 .. 3 4 0 ! -- The general rule is that the first bit is obtained by ! -- subtracting the old ending bit from machine scalar size - 1. ! for C in Start .. Stop loop ! declare ! Comp : constant Entity_Id := Comps (C); ! CC : constant Node_Id := Component_Clause (Comp); ! LB : constant Uint := Static_Integer (Last_Bit (CC)); ! NFB : constant Uint := MSS - Uint_1 - LB; ! NLB : constant Uint := NFB + Esize (Comp) - 1; ! Pos : constant Uint := Static_Integer (Position (CC)); begin ! if Warn_On_Reverse_Bit_Order then ! Error_Msg_Uint_1 := MSS; ! Error_Msg_N ! ("info: reverse bit order in machine " & ! "scalar of length^?", First_Bit (CC)); ! Error_Msg_Uint_1 := NFB; ! Error_Msg_Uint_2 := NLB; ! if Bytes_Big_Endian then ! Error_Msg_NE ! ("?\info: big-endian range for " ! & "component & is ^ .. ^", ! First_Bit (CC), Comp); else ! Error_Msg_NE ! ("?\info: little-endian range " ! & "for component & is ^ .. ^", ! First_Bit (CC), Comp); end if; ! end if; ! Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); ! Set_Normalized_First_Bit (Comp, NFB mod SSU); ! end; ! end loop; ! end loop; ! end; end Adjust_Record_For_Reverse_Bit_Order; -------------------------------------- --- 227,663 ---- ----------------------------------------- procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is ! Comp : Node_Id; ! CC : Node_Id; begin ! -- Processing depends on version of Ada ! -- For Ada 95, we just renumber bits within a storage unit. We do the ! -- same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83, ! -- and are free to add this extension. ! if Ada_Version < Ada_2005 then ! Comp := First_Component_Or_Discriminant (R); ! while Present (Comp) loop ! CC := Component_Clause (Comp); ! -- If component clause is present, then deal with the non-default ! -- bit order case for Ada 95 mode. ! -- We only do this processing for the base type, and in fact that ! -- is important, since otherwise if there are record subtypes, we ! -- could reverse the bits once for each subtype, which is wrong. ! if Present (CC) ! and then Ekind (R) = E_Record_Type ! then ! declare ! CFB : constant Uint := Component_Bit_Offset (Comp); ! CSZ : constant Uint := Esize (Comp); ! CLC : constant Node_Id := Component_Clause (Comp); ! Pos : constant Node_Id := Position (CLC); ! FB : constant Node_Id := First_Bit (CLC); ! Storage_Unit_Offset : constant Uint := ! CFB / System_Storage_Unit; ! Start_Bit : constant Uint := ! CFB mod System_Storage_Unit; ! begin ! -- Cases where field goes over storage unit boundary ! if Start_Bit + CSZ > System_Storage_Unit then ! -- Allow multi-byte field but generate warning ! if Start_Bit mod System_Storage_Unit = 0 ! and then CSZ mod System_Storage_Unit = 0 ! then Error_Msg_N ("multi-byte field specified with non-standard" ! & " Bit_Order?", CLC); if Bytes_Big_Endian then Error_Msg_N ! ("bytes are not reversed " ! & "(component is big-endian)?", CLC); else Error_Msg_N ! ("bytes are not reversed " ! & "(component is little-endian)?", CLC); end if; + + -- Do not allow non-contiguous field + + else + Error_Msg_N + ("attempt to specify non-contiguous field " + & "not permitted", CLC); + Error_Msg_N + ("\caused by non-standard Bit_Order " + & "specified", CLC); + Error_Msg_N + ("\consider possibility of using " + & "Ada 2005 mode here", CLC); end if; ! -- Case where field fits in one storage unit else ! -- Give warning if suspicious component clause ! ! if Intval (FB) >= System_Storage_Unit ! and then Warn_On_Reverse_Bit_Order ! then ! Error_Msg_N ! ("?Bit_Order clause does not affect " & ! "byte ordering", Pos); ! Error_Msg_Uint_1 := ! Intval (Pos) + Intval (FB) / ! System_Storage_Unit; ! Error_Msg_N ! ("?position normalized to ^ before bit " & ! "order interpreted", Pos); ! end if; ! ! -- Here is where we fix up the Component_Bit_Offset value ! -- to account for the reverse bit order. Some examples of ! -- what needs to be done are: ! ! -- First_Bit .. Last_Bit Component_Bit_Offset ! -- old new old new ! ! -- 0 .. 0 7 .. 7 0 7 ! -- 0 .. 1 6 .. 7 0 6 ! -- 0 .. 2 5 .. 7 0 5 ! -- 0 .. 7 0 .. 7 0 4 ! ! -- 1 .. 1 6 .. 6 1 6 ! -- 1 .. 4 3 .. 6 1 3 ! -- 4 .. 7 0 .. 3 4 0 ! ! -- The rule is that the first bit is is obtained by ! -- subtracting the old ending bit from storage_unit - 1. ! ! Set_Component_Bit_Offset ! (Comp, ! (Storage_Unit_Offset * System_Storage_Unit) + ! (System_Storage_Unit - 1) - ! (Start_Bit + CSZ - 1)); ! ! Set_Normalized_First_Bit ! (Comp, ! Component_Bit_Offset (Comp) mod ! System_Storage_Unit); end if; end; end if; ! Next_Component_Or_Discriminant (Comp); ! end loop; ! -- For Ada 2005, we do machine scalar processing, as fully described In ! -- AI-133. This involves gathering all components which start at the ! -- same byte offset and processing them together. Same approach is still ! -- valid in later versions including Ada 2012. ! else ! declare ! Max_Machine_Scalar_Size : constant Uint := ! UI_From_Int ! (Standard_Long_Long_Integer_Size); ! -- We use this as the maximum machine scalar size ! Num_CC : Natural; ! SSU : constant Uint := UI_From_Int (System_Storage_Unit); ! begin ! -- This first loop through components does two things. First it ! -- deals with the case of components with component clauses whose ! -- length is greater than the maximum machine scalar size (either ! -- accepting them or rejecting as needed). Second, it counts the ! -- number of components with component clauses whose length does ! -- not exceed this maximum for later processing. ! Num_CC := 0; ! Comp := First_Component_Or_Discriminant (R); ! while Present (Comp) loop ! CC := Component_Clause (Comp); ! if Present (CC) then ! declare ! Fbit : constant Uint := ! Static_Integer (First_Bit (CC)); ! Lbit : constant Uint := ! Static_Integer (Last_Bit (CC)); ! begin ! -- Case of component with last bit >= max machine scalar ! if Lbit >= Max_Machine_Scalar_Size then ! -- This is allowed only if first bit is zero, and ! -- last bit + 1 is a multiple of storage unit size. ! if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then ! -- This is the case to give a warning if enabled ! if Warn_On_Reverse_Bit_Order then ! Error_Msg_N ! ("multi-byte field specified with " ! & " non-standard Bit_Order?", CC); ! if Bytes_Big_Endian then ! Error_Msg_N ! ("\bytes are not reversed " ! & "(component is big-endian)?", CC); ! else ! Error_Msg_N ! ("\bytes are not reversed " ! & "(component is little-endian)?", CC); ! end if; ! end if; ! -- Give error message for RM 13.4.1(10) violation ! else ! Error_Msg_FE ! ("machine scalar rules not followed for&", ! First_Bit (CC), Comp); ! Error_Msg_Uint_1 := Lbit; ! Error_Msg_Uint_2 := Max_Machine_Scalar_Size; ! Error_Msg_F ! ("\last bit (^) exceeds maximum machine " ! & "scalar size (^)", ! First_Bit (CC)); ! if (Lbit + 1) mod SSU /= 0 then ! Error_Msg_Uint_1 := SSU; ! Error_Msg_F ! ("\and is not a multiple of Storage_Unit (^) " ! & "('R'M 13.4.1(10))", ! First_Bit (CC)); ! else ! Error_Msg_Uint_1 := Fbit; ! Error_Msg_F ! ("\and first bit (^) is non-zero " ! & "('R'M 13.4.1(10))", ! First_Bit (CC)); ! end if; ! end if; ! -- OK case of machine scalar related component clause, ! -- For now, just count them. ! ! else ! Num_CC := Num_CC + 1; ! end if; ! end; end if; + + Next_Component_Or_Discriminant (Comp); end loop; ! -- We need to sort the component clauses on the basis of the ! -- Position values in the clause, so we can group clauses with ! -- the same Position. together to determine the relevant machine ! -- scalar size. ! Sort_CC : declare ! Comps : array (0 .. Num_CC) of Entity_Id; ! -- Array to collect component and discriminant entities. The ! -- data starts at index 1, the 0'th entry is for the sort ! -- routine. ! function CP_Lt (Op1, Op2 : Natural) return Boolean; ! -- Compare routine for Sort ! procedure CP_Move (From : Natural; To : Natural); ! -- Move routine for Sort ! package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); ! Start : Natural; ! Stop : Natural; ! -- Start and stop positions in the component list of the set of ! -- components with the same starting position (that constitute ! -- components in a single machine scalar). ! MaxL : Uint; ! -- Maximum last bit value of any component in this set ! MSS : Uint; ! -- Corresponding machine scalar size ! ----------- ! -- CP_Lt -- ! ----------- + function CP_Lt (Op1, Op2 : Natural) return Boolean is begin ! return Position (Component_Clause (Comps (Op1))) < ! Position (Component_Clause (Comps (Op2))); ! end CP_Lt; ! ------------- ! -- CP_Move -- ! ------------- ! ! procedure CP_Move (From : Natural; To : Natural) is ! begin ! Comps (To) := Comps (From); ! end CP_Move; ! ! -- Start of processing for Sort_CC ! ! begin ! -- Collect the machine scalar relevant component clauses ! ! Num_CC := 0; ! Comp := First_Component_Or_Discriminant (R); ! while Present (Comp) loop ! declare ! CC : constant Node_Id := Component_Clause (Comp); ! ! begin ! -- Collect only component clauses whose last bit is less ! -- than machine scalar size. Any component clause whose ! -- last bit exceeds this value does not take part in ! -- machine scalar layout considerations. The test for ! -- Error_Posted makes sure we exclude component clauses ! -- for which we already posted an error. ! ! if Present (CC) ! and then not Error_Posted (Last_Bit (CC)) ! and then Static_Integer (Last_Bit (CC)) < ! Max_Machine_Scalar_Size ! then ! Num_CC := Num_CC + 1; ! Comps (Num_CC) := Comp; ! end if; ! end; ! ! Next_Component_Or_Discriminant (Comp); ! end loop; ! ! -- Sort by ascending position number ! ! Sorting.Sort (Num_CC); ! ! -- We now have all the components whose size does not exceed ! -- the max machine scalar value, sorted by starting position. ! -- In this loop we gather groups of clauses starting at the ! -- same position, to process them in accordance with AI-133. ! ! Stop := 0; ! while Stop < Num_CC loop ! Start := Stop + 1; ! Stop := Start; ! MaxL := ! Static_Integer ! (Last_Bit (Component_Clause (Comps (Start)))); ! while Stop < Num_CC loop ! if Static_Integer ! (Position (Component_Clause (Comps (Stop + 1)))) = ! Static_Integer ! (Position (Component_Clause (Comps (Stop)))) ! then ! Stop := Stop + 1; ! MaxL := ! UI_Max ! (MaxL, ! Static_Integer ! (Last_Bit ! (Component_Clause (Comps (Stop))))); else ! exit; end if; ! end loop; ! -- Now we have a group of component clauses from Start to ! -- Stop whose positions are identical, and MaxL is the ! -- maximum last bit value of any of these components. ! ! -- We need to determine the corresponding machine scalar ! -- size. This loop assumes that machine scalar sizes are ! -- even, and that each possible machine scalar has twice ! -- as many bits as the next smaller one. ! ! MSS := Max_Machine_Scalar_Size; ! while MSS mod 2 = 0 ! and then (MSS / 2) >= SSU ! and then (MSS / 2) > MaxL ! loop ! MSS := MSS / 2; ! end loop; ! ! -- Here is where we fix up the Component_Bit_Offset value ! -- to account for the reverse bit order. Some examples of ! -- what needs to be done for the case of a machine scalar ! -- size of 8 are: ! ! -- First_Bit .. Last_Bit Component_Bit_Offset ! -- old new old new ! ! -- 0 .. 0 7 .. 7 0 7 ! -- 0 .. 1 6 .. 7 0 6 ! -- 0 .. 2 5 .. 7 0 5 ! -- 0 .. 7 0 .. 7 0 4 ! ! -- 1 .. 1 6 .. 6 1 6 ! -- 1 .. 4 3 .. 6 1 3 ! -- 4 .. 7 0 .. 3 4 0 ! ! -- The rule is that the first bit is obtained by subtracting ! -- the old ending bit from machine scalar size - 1. ! ! for C in Start .. Stop loop ! declare ! Comp : constant Entity_Id := Comps (C); ! CC : constant Node_Id := ! Component_Clause (Comp); ! LB : constant Uint := ! Static_Integer (Last_Bit (CC)); ! NFB : constant Uint := MSS - Uint_1 - LB; ! NLB : constant Uint := NFB + Esize (Comp) - 1; ! Pos : constant Uint := ! Static_Integer (Position (CC)); ! ! begin ! if Warn_On_Reverse_Bit_Order then ! Error_Msg_Uint_1 := MSS; ! Error_Msg_N ! ("info: reverse bit order in machine " & ! "scalar of length^?", First_Bit (CC)); ! Error_Msg_Uint_1 := NFB; ! Error_Msg_Uint_2 := NLB; ! ! if Bytes_Big_Endian then ! Error_Msg_NE ! ("?\info: big-endian range for " ! & "component & is ^ .. ^", ! First_Bit (CC), Comp); ! else ! Error_Msg_NE ! ("?\info: little-endian range " ! & "for component & is ^ .. ^", ! First_Bit (CC), Comp); ! end if; ! end if; ! ! Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); ! Set_Normalized_First_Bit (Comp, NFB mod SSU); ! end; ! end loop; ! end loop; ! end Sort_CC; ! end; ! end if; end Adjust_Record_For_Reverse_Bit_Order; -------------------------------------- *************** package body Sem_Ch13 is *** 460,465 **** --- 679,1192 ---- end if; end Alignment_Check_For_Esize_Change; + ----------------------------------- + -- Analyze_Aspect_Specifications -- + ----------------------------------- + + procedure Analyze_Aspect_Specifications + (N : Node_Id; + E : Entity_Id; + L : List_Id) + is + Aspect : Node_Id; + Aitem : Node_Id; + Ent : Node_Id; + + Ins_Node : Node_Id := N; + -- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node + + -- The general processing involves building an attribute definition + -- clause or a pragma node that corresponds to the access type. Then + -- one of two things happens: + + -- If we are required to delay the evaluation of this aspect to the + -- freeze point, we preanalyze the relevant argument, and then attach + -- the corresponding pragma/attribute definition clause to the aspect + -- specification node, which is then placed in the Rep Item chain. + -- In this case we mark the entity with the Has_Delayed_Aspects flag, + -- and we evaluate the rep item at the freeze point. + + -- If no delay is required, we just insert the pragma or attribute + -- after the declaration, and it will get processed by the normal + -- circuit. The From_Aspect_Specification flag is set on the pragma + -- or attribute definition node in either case to activate special + -- processing (e.g. not traversing the list of homonyms for inline). + + Delay_Required : Boolean; + -- Set True if delay is required + + begin + -- Return if no aspects + + if L = No_List then + return; + end if; + + -- Return if already analyzed (avoids duplicate calls in some cases + -- where type declarations get rewritten and processed twice). + + if Analyzed (N) then + return; + end if; + + -- Loop through aspects + + Aspect := First (L); + while Present (Aspect) loop + declare + Loc : constant Source_Ptr := Sloc (Aspect); + Id : constant Node_Id := Identifier (Aspect); + Expr : constant Node_Id := Expression (Aspect); + Nam : constant Name_Id := Chars (Id); + A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); + Anod : Node_Id; + T : Entity_Id; + + Eloc : Source_Ptr := Sloc (Expr); + -- Source location of expression, modified when we split PPC's + + begin + Set_Entity (Aspect, E); + Ent := New_Occurrence_Of (E, Sloc (Id)); + + -- Check for duplicate aspect. Note that the Comes_From_Source + -- test allows duplicate Pre/Post's that we generate internally + -- to escape being flagged here. + + Anod := First (L); + while Anod /= Aspect loop + if Nam = Chars (Identifier (Anod)) + and then Comes_From_Source (Aspect) + then + Error_Msg_Name_1 := Nam; + Error_Msg_Sloc := Sloc (Anod); + + -- Case of same aspect specified twice + + if Class_Present (Anod) = Class_Present (Aspect) then + if not Class_Present (Anod) then + Error_Msg_NE + ("aspect% for & previously given#", + Id, E); + else + Error_Msg_NE + ("aspect `%''Class` for & previously given#", + Id, E); + end if; + + -- Case of Pre and Pre'Class both specified + + elsif Nam = Name_Pre then + if Class_Present (Aspect) then + Error_Msg_NE + ("aspect `Pre''Class` for & is not allowed here", + Id, E); + Error_Msg_NE + ("\since aspect `Pre` previously given#", + Id, E); + + else + Error_Msg_NE + ("aspect `Pre` for & is not allowed here", + Id, E); + Error_Msg_NE + ("\since aspect `Pre''Class` previously given#", + Id, E); + end if; + end if; + + goto Continue; + end if; + + Next (Anod); + end loop; + + -- Processing based on specific aspect + + case A_Id is + + -- No_Aspect should be impossible + + when No_Aspect => + raise Program_Error; + + -- Aspects taking an optional boolean argument. For all of + -- these we just create a matching pragma and insert it, + -- setting flag Cancel_Aspect if the expression is False. + + when Aspect_Ada_2005 | + Aspect_Ada_2012 | + Aspect_Atomic | + Aspect_Atomic_Components | + Aspect_Discard_Names | + Aspect_Favor_Top_Level | + Aspect_Inline | + Aspect_Inline_Always | + Aspect_No_Return | + Aspect_Pack | + Aspect_Persistent_BSS | + Aspect_Preelaborable_Initialization | + Aspect_Pure_Function | + Aspect_Shared | + Aspect_Suppress_Debug_Info | + Aspect_Unchecked_Union | + Aspect_Universal_Aliasing | + Aspect_Unmodified | + Aspect_Unreferenced | + Aspect_Unreferenced_Objects | + Aspect_Volatile | + Aspect_Volatile_Components => + + -- Build corresponding pragma node + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List (Ent), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + + -- Deal with missing expression case, delay never needed + + if No (Expr) then + Delay_Required := False; + + -- Expression is present + + else + Preanalyze_Spec_Expression (Expr, Standard_Boolean); + + -- If preanalysis gives a static expression, we don't + -- need to delay (this will happen often in practice). + + if Is_OK_Static_Expression (Expr) then + Delay_Required := False; + + if Is_False (Expr_Value (Expr)) then + Set_Aspect_Cancel (Aitem); + end if; + + -- If we don't get a static expression, then delay, the + -- expression may turn out static by freeze time. + + else + Delay_Required := True; + end if; + end if; + + -- Aspects corresponding to attribute definition clauses + + when Aspect_Address | + Aspect_Alignment | + Aspect_Bit_Order | + Aspect_Component_Size | + Aspect_External_Tag | + Aspect_Machine_Radix | + Aspect_Object_Size | + Aspect_Size | + Aspect_Storage_Pool | + Aspect_Storage_Size | + Aspect_Stream_Size | + Aspect_Value_Size => + + -- Preanalyze the expression with the appropriate type + + case A_Id is + when Aspect_Address => + T := RTE (RE_Address); + when Aspect_Bit_Order => + T := RTE (RE_Bit_Order); + when Aspect_External_Tag => + T := Standard_String; + when Aspect_Storage_Pool => + T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); + when others => + T := Any_Integer; + end case; + + Preanalyze_Spec_Expression (Expr, T); + + -- Construct the attribute definition clause + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + -- We do not need a delay if we have a static expression + + if Is_OK_Static_Expression (Expression (Aitem)) then + Delay_Required := False; + + -- Here a delay is required + + else + Delay_Required := True; + end if; + + -- Aspects corresponding to pragmas with two arguments, where + -- the first argument is a local name referring to the entity, + -- and the second argument is the aspect definition expression. + + when Aspect_Suppress | + Aspect_Unsuppress => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List ( + New_Occurrence_Of (E, Eloc), + Relocate_Node (Expr)), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + + -- We don't have to play the delay game here, since the only + -- values are check names which don't get analyzed anyway. + + Delay_Required := False; + + -- Aspects corresponding to stream routines + + when Aspect_Input | + Aspect_Output | + Aspect_Read | + Aspect_Write => + + -- Construct the attribute definition clause + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + -- These are always delayed (typically the subprogram that + -- is referenced cannot have been declared yet, since it has + -- a reference to the type for which this aspect is defined. + + Delay_Required := True; + + -- Aspects corresponding to pragmas with two arguments, where + -- the second argument is a local name referring to the entity, + -- and the first argument is the aspect definition expression. + + when Aspect_Warnings => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List ( + Relocate_Node (Expr), + New_Occurrence_Of (E, Eloc)), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id)), + Class_Present => Class_Present (Aspect)); + + -- We don't have to play the delay game here, since the only + -- values are check names which don't get analyzed anyway. + + Delay_Required := False; + + -- Aspects Pre/Post generate Precondition/Postcondition pragmas + -- with a first argument that is the expression, and a second + -- argument that is an informative message if the test fails. + -- This is inserted right after the declaration, to get the + -- required pragma placement. The processing for the pragmas + -- takes care of the required delay. + + when Aspect_Pre | Aspect_Post => declare + Pname : Name_Id; + + begin + if A_Id = Aspect_Pre then + Pname := Name_Precondition; + else + Pname := Name_Postcondition; + end if; + + -- If the expressions is of the form A and then B, then + -- we generate separate Pre/Post aspects for the separate + -- clauses. Since we allow multiple pragmas, there is no + -- problem in allowing multiple Pre/Post aspects internally. + + -- We do not do this for Pre'Class, since we have to put + -- these conditions together in a complex OR expression + + if Pname = Name_Postcondition + or else not Class_Present (Aspect) + then + while Nkind (Expr) = N_And_Then loop + Insert_After (Aspect, + Make_Aspect_Specification (Sloc (Right_Opnd (Expr)), + Identifier => Identifier (Aspect), + Expression => Relocate_Node (Right_Opnd (Expr)), + Class_Present => Class_Present (Aspect), + Split_PPC => True)); + Rewrite (Expr, Relocate_Node (Left_Opnd (Expr))); + Eloc := Sloc (Expr); + end loop; + end if; + + -- Build the precondition/postcondition pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Pname), + Class_Present => Class_Present (Aspect), + Split_PPC => Split_PPC (Aspect), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Check, + Expression => Relocate_Node (Expr)))); + + -- Add message unless exception messages are suppressed + + if not Opt.Exception_Locations_Suppressed then + Append_To (Pragma_Argument_Associations (Aitem), + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Message, + Expression => + Make_String_Literal (Eloc, + Strval => "failed " + & Get_Name_String (Pname) + & " from " + & Build_Location_String (Eloc)))); + end if; + + Set_From_Aspect_Specification (Aitem, True); + + -- For Pre/Post cases, insert immediately after the entity + -- declaration, since that is the required pragma placement. + -- Note that for these aspects, we do not have to worry + -- about delay issues, since the pragmas themselves deal + -- with delay of visibility for the expression analysis. + + -- If the entity is a library-level subprogram, the pre/ + -- postconditions must be treated as late pragmas. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Add_Global_Declaration (Aitem); + else + Insert_After (N, Aitem); + end if; + + goto Continue; + end; + + -- Invariant aspects generate a corresponding pragma with a + -- first argument that is the entity, a second argument that is + -- the expression and a third argument that is an appropriate + -- message. This is inserted right after the declaration, to + -- get the required pragma placement. The pragma processing + -- takes care of the required delay. + + when Aspect_Invariant => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr)), + Class_Present => Class_Present (Aspect), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Invariant)); + + -- Add message unless exception messages are suppressed + + if not Opt.Exception_Locations_Suppressed then + Append_To (Pragma_Argument_Associations (Aitem), + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Message, + Expression => + Make_String_Literal (Eloc, + Strval => "failed invariant from " + & Build_Location_String (Eloc)))); + end if; + + Set_From_Aspect_Specification (Aitem, True); + + -- For Invariant case, insert immediately after the entity + -- declaration. We do not have to worry about delay issues + -- since the pragma processing takes care of this. + + Insert_After (N, Aitem); + goto Continue; + + -- Predicate aspects generate a corresponding pragma with a + -- first argument that is the entity, and the second argument + -- is the expression. This is inserted immediately after the + -- declaration, to get the required pragma placement. The + -- pragma processing takes care of the required delay. + + when Aspect_Predicate => + + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr)), + Class_Present => Class_Present (Aspect), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Predicate)); + + Set_From_Aspect_Specification (Aitem, True); + + -- Make sure we have a freeze node (it might otherwise be + -- missing in cases like subtype X is Y, and we would not + -- have a place to build the predicate function). + + Ensure_Freeze_Node (E); + + -- For Predicate case, insert immediately after the entity + -- declaration. We do not have to worry about delay issues + -- since the pragma processing takes care of this. + + Insert_After (N, Aitem); + goto Continue; + end case; + + Set_From_Aspect_Specification (Aitem, True); + + -- If a delay is required, we delay the freeze (not much point in + -- delaying the aspect if we don't delay the freeze!). The pragma + -- or clause is then attached to the aspect specification which + -- is placed in the rep item list. + + if Delay_Required then + Ensure_Freeze_Node (E); + Set_Is_Delayed_Aspect (Aitem); + Set_Has_Delayed_Aspects (E); + Set_Aspect_Rep_Item (Aspect, Aitem); + Record_Rep_Item (E, Aspect); + + -- If no delay required, insert the pragma/clause in the tree + + else + -- For Pre/Post cases, insert immediately after the entity + -- declaration, since that is the required pragma placement. + + if A_Id = Aspect_Pre or else A_Id = Aspect_Post then + Insert_After (N, Aitem); + + -- For all other cases, insert in sequence + + else + Insert_After (Ins_Node, Aitem); + Ins_Node := Aitem; + end if; + end if; + end; + + <> + Next (Aspect); + end loop; + end Analyze_Aspect_Specifications; + ----------------------- -- Analyze_At_Clause -- ----------------------- *************** package body Sem_Ch13 is *** 526,531 **** --- 1253,1264 ---- -- Common processing for 'Read, 'Write, 'Input and 'Output attribute -- definition clauses. + function Duplicate_Clause return Boolean; + -- This routine checks if the aspect for U_Ent being given by attribute + -- definition clause N is for an aspect that has already been specified, + -- and if so gives an error message. If there is a duplicate, True is + -- returned, otherwise if there is no error, False is returned. + ----------------------------------- -- Analyze_Stream_TSS_Definition -- ----------------------------------- *************** package body Sem_Ch13 is *** 662,667 **** --- 1395,1434 ---- end if; end Analyze_Stream_TSS_Definition; + ---------------------- + -- Duplicate_Clause -- + ---------------------- + + function Duplicate_Clause return Boolean is + A : Node_Id; + + begin + -- Nothing to do if this attribute definition clause comes from + -- an aspect specification, since we could not be duplicating an + -- explicit clause, and we dealt with the case of duplicated aspects + -- in Analyze_Aspect_Specifications. + + if From_Aspect_Specification (N) then + return False; + end if; + + -- Otherwise current clause may duplicate previous clause or a + -- previously given aspect specification for the same aspect. + + A := Get_Rep_Item_For_Entity (U_Ent, Chars (N)); + + if Present (A) then + if Entity (A) = U_Ent then + Error_Msg_Name_1 := Chars (N); + Error_Msg_Sloc := Sloc (A); + Error_Msg_NE ("aspect% for & previously given#", N, U_Ent); + return True; + end if; + end if; + + return False; + end Duplicate_Clause; + -- Start of processing for Analyze_Attribute_Definition_Clause begin *************** package body Sem_Ch13 is *** 704,710 **** Attribute_Write => null; ! -- Other cases are errors, which will be caught below when others => null; --- 1471,1478 ---- Attribute_Write => null; ! -- Other cases are errors ("attribute& cannot be set with ! -- definition clause"), which will be caught below. when others => null; *************** package body Sem_Ch13 is *** 769,774 **** --- 1537,1544 ---- return; end if; + Set_Entity (N, U_Ent); + -- Switch on particular attribute case Id is *************** package body Sem_Ch13 is *** 803,819 **** -- it imported. if Ignore_Rep_Clauses then ! if Ekind (U_Ent) = E_Variable ! or else Ekind (U_Ent) = E_Constant ! then Record_Rep_Item (U_Ent, N); end if; return; end if; ! if Present (Address_Clause (U_Ent)) then ! Error_Msg_N ("address already given for &", Nam); -- Case of address clause for subprogram --- 1573,1587 ---- -- it imported. if Ignore_Rep_Clauses then ! if Ekind_In (U_Ent, E_Variable, E_Constant) then Record_Rep_Item (U_Ent, N); end if; return; end if; ! if Duplicate_Clause then ! null; -- Case of address clause for subprogram *************** package body Sem_Ch13 is *** 1026,1038 **** -- check till after code generation to take full advantage -- of the annotation done by the back end. This entry is -- only made if the address clause comes from source. if Address_Clause_Overlay_Warnings and then Comes_From_Source (N) and then Present (O_Ent) and then Is_Object (O_Ent) then ! Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); -- If variable overlays a constant view, and we are -- warning on overlays, then mark the variable as --- 1794,1812 ---- -- check till after code generation to take full advantage -- of the annotation done by the back end. This entry is -- only made if the address clause comes from source. + -- If the entity has a generic type, the check will be + -- performed in the instance if the actual type justifies + -- it, and we do not insert the clause in the table to + -- prevent spurious warnings. if Address_Clause_Overlay_Warnings and then Comes_From_Source (N) and then Present (O_Ent) and then Is_Object (O_Ent) then ! if not Is_Generic_Type (Etype (U_Ent)) then ! Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); ! end if; -- If variable overlays a constant view, and we are -- warning on overlays, then mark the variable as *************** package body Sem_Ch13 is *** 1072,1080 **** then Error_Msg_N ("alignment cannot be given for &", Nam); ! elsif Has_Alignment_Clause (U_Ent) then ! Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); ! Error_Msg_N ("alignment clause previously given#", N); elsif Align /= No_Uint then Set_Has_Alignment_Clause (U_Ent); --- 1846,1853 ---- then Error_Msg_N ("alignment cannot be given for &", Nam); ! elsif Duplicate_Clause then ! null; elsif Align /= No_Uint then Set_Has_Alignment_Clause (U_Ent); *************** package body Sem_Ch13 is *** 1103,1108 **** --- 1876,1884 ---- Error_Msg_N ("Bit_Order can only be defined for record type", Nam); + elsif Duplicate_Clause then + null; + else Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); *************** package body Sem_Ch13 is *** 1129,1134 **** --- 1905,1911 ---- when Attribute_Component_Size => Component_Size_Case : declare Csize : constant Uint := Static_Integer (Expr); + Ctyp : Entity_Id; Btype : Entity_Id; Biased : Boolean; New_Ctyp : Entity_Id; *************** package body Sem_Ch13 is *** 1141,1170 **** end if; Btype := Base_Type (U_Ent); ! if Has_Component_Size_Clause (Btype) then ! Error_Msg_N ! ("component size clause for& previously given", Nam); ! elsif Csize /= No_Uint then ! Check_Size (Expr, Component_Type (Btype), Csize, Biased); ! if Has_Aliased_Components (Btype) ! and then Csize < 32 ! and then Csize /= 8 ! and then Csize /= 16 ! then ! Error_Msg_N ! ("component size incorrect for aliased components", N); ! return; ! end if; ! -- For the biased case, build a declaration for a subtype ! -- that will be used to represent the biased subtype that ! -- reflects the biased representation of components. We need ! -- this subtype to get proper conversions on referencing ! -- elements of the array. Note that component size clauses ! -- are ignored in VM mode. if VM_Target = No_VM then if Biased then --- 1918,1939 ---- end if; Btype := Base_Type (U_Ent); + Ctyp := Component_Type (Btype); ! if Duplicate_Clause then ! null; ! elsif Rep_Item_Too_Early (Btype, N) then ! null; ! elsif Csize /= No_Uint then ! Check_Size (Expr, Ctyp, Csize, Biased); ! -- For the biased case, build a declaration for a subtype that ! -- will be used to represent the biased subtype that reflects ! -- the biased representation of components. We need the subtype ! -- to get proper conversions on referencing elements of the ! -- array. Note: component size clauses are ignored in VM mode. if VM_Target = No_VM then if Biased then *************** package body Sem_Ch13 is *** 1186,1202 **** Set_Esize (New_Ctyp, Csize); Set_RM_Size (New_Ctyp, Csize); Init_Alignment (New_Ctyp); - Set_Has_Biased_Representation (New_Ctyp, True); Set_Is_Itype (New_Ctyp, True); Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); Set_Component_Type (Btype, New_Ctyp); ! ! if Warn_On_Biased_Representation then ! Error_Msg_N ! ("?component size clause forces biased " ! & "representation", N); ! end if; end if; Set_Component_Size (Btype, Csize); --- 1955,1965 ---- Set_Esize (New_Ctyp, Csize); Set_RM_Size (New_Ctyp, Csize); Init_Alignment (New_Ctyp); Set_Is_Itype (New_Ctyp, True); Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); Set_Component_Type (Btype, New_Ctyp); ! Set_Biased (New_Ctyp, N, "component size clause"); end if; Set_Component_Size (Btype, Csize); *************** package body Sem_Ch13 is *** 1213,1220 **** end if; end if; Set_Has_Component_Size_Clause (Btype, True); ! Set_Has_Non_Standard_Rep (Btype, True); end if; end Component_Size_Case; --- 1976,1994 ---- end if; end if; + -- Deal with warning on overridden size + + if Warn_On_Overridden_Size + and then Has_Size_Clause (Ctyp) + and then RM_Size (Ctyp) /= Csize + then + Error_Msg_NE + ("?component size overrides size clause for&", + N, Ctyp); + end if; + Set_Has_Component_Size_Clause (Btype, True); ! Set_Has_Non_Standard_Rep (Btype, True); end if; end Component_Size_Case; *************** package body Sem_Ch13 is *** 1228,1255 **** Error_Msg_N ("should be a tagged type", Nam); end if; ! Analyze_And_Resolve (Expr, Standard_String); ! ! if not Is_Static_Expression (Expr) then ! Flag_Non_Static_Expr ! ("static string required for tag name!", Nam); ! end if; - if VM_Target = No_VM then - Set_Has_External_Tag_Rep_Clause (U_Ent); else ! Error_Msg_Name_1 := Attr; ! Error_Msg_N ! ("% attribute unsupported in this configuration", Nam); ! end if; ! if not Is_Library_Level_Entity (U_Ent) then ! Error_Msg_NE ! ("?non-unique external tag supplied for &", N, U_Ent); ! Error_Msg_N ! ("?\same external tag applies to all subprogram calls", N); ! Error_Msg_N ! ("?\corresponding internal tag cannot be obtained", N); end if; end External_Tag; --- 2002,2034 ---- Error_Msg_N ("should be a tagged type", Nam); end if; ! if Duplicate_Clause then ! null; else ! Analyze_And_Resolve (Expr, Standard_String); ! if not Is_Static_Expression (Expr) then ! Flag_Non_Static_Expr ! ("static string required for tag name!", Nam); ! end if; ! ! if VM_Target = No_VM then ! Set_Has_External_Tag_Rep_Clause (U_Ent); ! else ! Error_Msg_Name_1 := Attr; ! Error_Msg_N ! ("% attribute unsupported in this configuration", Nam); ! end if; ! ! if not Is_Library_Level_Entity (U_Ent) then ! Error_Msg_NE ! ("?non-unique external tag supplied for &", N, U_Ent); ! Error_Msg_N ! ("?\same external tag applies to all subprogram calls", N); ! Error_Msg_N ! ("?\corresponding internal tag cannot be obtained", N); ! end if; end if; end External_Tag; *************** package body Sem_Ch13 is *** 1274,1282 **** if not Is_Decimal_Fixed_Point_Type (U_Ent) then Error_Msg_N ("decimal fixed-point type expected for &", Nam); ! elsif Has_Machine_Radix_Clause (U_Ent) then ! Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); ! Error_Msg_N ("machine radix clause previously given#", N); elsif Radix /= No_Uint then Set_Has_Machine_Radix_Clause (U_Ent); --- 2053,2060 ---- if not Is_Decimal_Fixed_Point_Type (U_Ent) then Error_Msg_N ("decimal fixed-point type expected for &", Nam); ! elsif Duplicate_Clause then ! null; elsif Radix /= No_Uint then Set_Has_Machine_Radix_Clause (U_Ent); *************** package body Sem_Ch13 is *** 1308,1315 **** if not Is_Type (U_Ent) then Error_Msg_N ("Object_Size cannot be given for &", Nam); ! elsif Has_Object_Size_Clause (U_Ent) then ! Error_Msg_N ("Object_Size already given for &", Nam); else Check_Size (Expr, U_Ent, Size, Biased); --- 2086,2093 ---- if not Is_Type (U_Ent) then Error_Msg_N ("Object_Size cannot be given for &", Nam); ! elsif Duplicate_Clause then ! null; else Check_Size (Expr, U_Ent, Size, Biased); *************** package body Sem_Ch13 is *** 1363,1370 **** begin FOnly := True; ! if Has_Size_Clause (U_Ent) then ! Error_Msg_N ("size already given for &", Nam); elsif not Is_Type (U_Ent) and then Ekind (U_Ent) /= E_Variable --- 2141,2148 ---- begin FOnly := True; ! if Duplicate_Clause then ! null; elsif not Is_Type (U_Ent) and then Ekind (U_Ent) /= E_Variable *************** package body Sem_Ch13 is *** 1379,1384 **** --- 2157,2173 ---- ("size cannot be given for unconstrained array", Nam); elsif Size /= No_Uint then + + if VM_Target /= No_VM and then not GNAT_Mode then + + -- Size clause is not handled properly on VM targets. + -- Display a warning unless we are in GNAT mode, in which + -- case this is useless. + + Error_Msg_N + ("?size clauses are ignored in this configuration", N); + end if; + if Is_Type (U_Ent) then Etyp := U_Ent; else *************** package body Sem_Ch13 is *** 1396,1407 **** or else Has_Small_Clause (U_Ent) then Check_Size (Expr, Etyp, Size, Biased); ! Set_Has_Biased_Representation (U_Ent, Biased); ! ! if Biased and Warn_On_Biased_Representation then ! Error_Msg_N ! ("?size clause forces biased representation", N); ! end if; end if; -- For types set RM_Size and Esize if possible --- 2185,2191 ---- or else Has_Small_Clause (U_Ent) then Check_Size (Expr, Etyp, Size, Biased); ! Set_Biased (U_Ent, N, "size clause", Biased); end if; -- For types set RM_Size and Esize if possible *************** package body Sem_Ch13 is *** 1528,1535 **** Nam); return; ! elsif Ekind (U_Ent) /= E_Access_Type ! and then Ekind (U_Ent) /= E_General_Access_Type then Error_Msg_N ("storage pool can only be given for access types", Nam); --- 2312,2319 ---- Nam); return; ! elsif not ! Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) then Error_Msg_N ("storage pool can only be given for access types", Nam); *************** package body Sem_Ch13 is *** 1540,1547 **** ("storage pool cannot be given for a derived access type", Nam); ! elsif Has_Storage_Size_Clause (U_Ent) then ! Error_Msg_N ("storage size already given for &", Nam); return; elsif Present (Associated_Storage_Pool (U_Ent)) then --- 2324,2330 ---- ("storage pool cannot be given for a derived access type", Nam); ! elsif Duplicate_Clause then return; elsif Present (Associated_Storage_Pool (U_Ent)) then *************** package body Sem_Ch13 is *** 1586,1594 **** if not Is_Entity_Name (Expr) and then Is_Object_Reference (Expr) then ! Pool := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('P')); declare Rnode : constant Node_Id := --- 2369,2375 ---- if not Is_Entity_Name (Expr) and then Is_Object_Reference (Expr) then ! Pool := Make_Temporary (Loc, 'P', Expr); declare Rnode : constant Node_Id := *************** package body Sem_Ch13 is *** 1596,1602 **** Defining_Identifier => Pool, Subtype_Mark => New_Occurrence_Of (Etype (Expr), Loc), ! Name => Expr); begin Insert_Before (N, Rnode); --- 2377,2383 ---- Defining_Identifier => Pool, Subtype_Mark => New_Occurrence_Of (Etype (Expr), Loc), ! Name => Expr); begin Insert_Before (N, Rnode); *************** package body Sem_Ch13 is *** 1656,1663 **** Error_Msg_N ("storage size clause for task is an " & "obsolescent feature (RM J.9)?", N); ! Error_Msg_N ! ("\use Storage_Size pragma instead?", N); end if; FOnly := True; --- 2437,2443 ---- Error_Msg_N ("storage size clause for task is an " & "obsolescent feature (RM J.9)?", N); ! Error_Msg_N ("\use Storage_Size pragma instead?", N); end if; FOnly := True; *************** package body Sem_Ch13 is *** 1673,1680 **** ("storage size cannot be given for a derived access type", Nam); ! elsif Has_Storage_Size_Clause (Btype) then ! Error_Msg_N ("storage size already given for &", Nam); else Analyze_And_Resolve (Expr, Any_Integer); --- 2453,2460 ---- ("storage size cannot be given for a derived access type", Nam); ! elsif Duplicate_Clause then ! null; else Analyze_And_Resolve (Expr, Any_Integer); *************** package body Sem_Ch13 is *** 1685,1691 **** return; end if; ! if Compile_Time_Known_Value (Expr) and then Expr_Value (Expr) = 0 then Set_No_Pool_Assigned (Btype); --- 2465,2471 ---- return; end if; ! if Is_OK_Static_Expression (Expr) and then Expr_Value (Expr) = 0 then Set_No_Pool_Assigned (Btype); *************** package body Sem_Ch13 is *** 1718,1725 **** Check_Restriction (No_Implementation_Attributes, N); end if; ! if Has_Stream_Size_Clause (U_Ent) then ! Error_Msg_N ("Stream_Size already given for &", Nam); elsif Is_Elementary_Type (U_Ent) then if Size /= System_Storage_Unit --- 2498,2505 ---- Check_Restriction (No_Implementation_Attributes, N); end if; ! if Duplicate_Clause then ! null; elsif Is_Elementary_Type (U_Ent) then if Size /= System_Storage_Unit *************** package body Sem_Ch13 is *** 1763,1773 **** if not Is_Type (U_Ent) then Error_Msg_N ("Value_Size cannot be given for &", Nam); ! elsif Present ! (Get_Attribute_Definition_Clause ! (U_Ent, Attribute_Value_Size)) ! then ! Error_Msg_N ("Value_Size already given for &", Nam); elsif Is_Array_Type (U_Ent) and then not Is_Constrained (U_Ent) --- 2543,2550 ---- if not Is_Type (U_Ent) then Error_Msg_N ("Value_Size cannot be given for &", Nam); ! elsif Duplicate_Clause then ! null; elsif Is_Array_Type (U_Ent) and then not Is_Constrained (U_Ent) *************** package body Sem_Ch13 is *** 1778,1789 **** else if Is_Elementary_Type (U_Ent) then Check_Size (Expr, U_Ent, Size, Biased); ! Set_Has_Biased_Representation (U_Ent, Biased); ! ! if Biased and Warn_On_Biased_Representation then ! Error_Msg_N ! ("?value size clause forces biased representation", N); ! end if; end if; Set_RM_Size (U_Ent, Size); --- 2555,2561 ---- else if Is_Elementary_Type (U_Ent) then Check_Size (Expr, U_Ent, Size, Biased); ! Set_Biased (U_Ent, N, "value size clause", Biased); end if; Set_RM_Size (U_Ent, Size); *************** package body Sem_Ch13 is *** 1923,1932 **** Val : Uint; Err : Boolean := False; ! Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); ! Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); Min : Uint; Max : Uint; begin if Ignore_Rep_Clauses then --- 2695,2710 ---- Val : Uint; Err : Boolean := False; ! Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); ! Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); ! -- Allowed range of universal integer (= allowed range of enum lit vals) ! Min : Uint; Max : Uint; + -- Minimum and maximum values of entries + + Max_Node : Node_Id; + -- Pointer to node for literal providing max value begin if Ignore_Rep_Clauses then *************** package body Sem_Ch13 is *** 2085,2091 **** Err := True; end if; ! Set_Enumeration_Rep_Expr (Elit, Choice); Expr := Expression (Assoc); Val := Static_Integer (Expr); --- 2863,2869 ---- Err := True; end if; ! Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); Expr := Expression (Assoc); Val := Static_Integer (Expr); *************** package body Sem_Ch13 is *** 2131,2145 **** if Max /= No_Uint and then Val <= Max then Error_Msg_NE ("enumeration value for& not ordered!", ! Enumeration_Rep_Expr (Elit), Elit); end if; Max := Val; end if; ! -- If there is at least one literal whose representation ! -- is not equal to the Pos value, then note that this ! -- enumeration type has a non-standard representation. if Val /= Enumeration_Pos (Elit) then Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); --- 2909,2924 ---- if Max /= No_Uint and then Val <= Max then Error_Msg_NE ("enumeration value for& not ordered!", ! Enumeration_Rep_Expr (Elit), Elit); end if; + Max_Node := Enumeration_Rep_Expr (Elit); Max := Val; end if; ! -- If there is at least one literal whose representation is not ! -- equal to the Pos value, then note that this enumeration type ! -- has a non-standard representation. if Val /= Enumeration_Pos (Elit) then Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); *************** package body Sem_Ch13 is *** 2156,2173 **** begin if Has_Size_Clause (Enumtype) then ! if Esize (Enumtype) >= Minsize then null; else Minsize := UI_From_Int (Minimum_Size (Enumtype, Biased => True)); ! if Esize (Enumtype) < Minsize then ! Error_Msg_N ("previously given size is too small", N); else ! Set_Has_Biased_Representation (Enumtype); end if; end if; --- 2935,2966 ---- begin if Has_Size_Clause (Enumtype) then ! ! -- All OK, if size is OK now ! ! if RM_Size (Enumtype) >= Minsize then null; else + -- Try if we can get by with biasing + Minsize := UI_From_Int (Minimum_Size (Enumtype, Biased => True)); ! -- Error message if even biasing does not work ! ! if RM_Size (Enumtype) < Minsize then ! Error_Msg_Uint_1 := RM_Size (Enumtype); ! Error_Msg_Uint_2 := Max; ! Error_Msg_N ! ("previously given size (^) is too small " ! & "for this value (^)", Max_Node); ! ! -- If biasing worked, indicate that we now have biased rep else ! Set_Biased ! (Enumtype, Size_Clause (Enumtype), "size clause"); end if; end if; *************** package body Sem_Ch13 is *** 2206,2272 **** E : constant Entity_Id := Entity (N); begin -- For tagged types covering interfaces add internal entities that link -- the primitives of the interfaces with the primitives that cover them. - -- Note: These entities were originally generated only when generating -- code because their main purpose was to provide support to initialize -- the secondary dispatch tables. They are now generated also when -- compiling with no code generation to provide ASIS the relationship ! -- between interface primitives and tagged type primitives. ! if Ada_Version >= Ada_05 and then Ekind (E) = E_Record_Type and then Is_Tagged_Type (E) and then not Is_Interface (E) and then Has_Interfaces (E) then Add_Internal_Interface_Entities (E); end if; end Analyze_Freeze_Entity; ------------------------------------------ -- Analyze_Record_Representation_Clause -- ------------------------------------------ procedure Analyze_Record_Representation_Clause (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! Ident : constant Node_Id := Identifier (N); ! Rectype : Entity_Id; ! Fent : Entity_Id; CC : Node_Id; ! Posit : Uint; Fbit : Uint; - Lbit : Uint; Hbit : Uint := Uint_0; ! Comp : Entity_Id; Ocomp : Entity_Id; ! Pcomp : Entity_Id; ! Biased : Boolean; ! ! Max_Bit_So_Far : Uint; ! -- Records the maximum bit position so far. If all field positions ! -- are monotonically increasing, then we can skip the circuit for ! -- checking for overlap, since no overlap is possible. ! ! Tagged_Parent : Entity_Id := Empty; ! -- This is set in the case of a derived tagged type for which we have ! -- Is_Fully_Repped_Tagged_Type True (indicating that all components are ! -- positioned by record representation clauses). In this case we must ! -- check for overlap between components of this tagged type, and the ! -- components of its parent. Tagged_Parent will point to this parent ! -- type. For all other cases Tagged_Parent is left set to Empty. ! ! Parent_Last_Bit : Uint; ! -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the ! -- last bit position for any field in the parent type. We only need to ! -- check overlap for fields starting below this point. ! ! Overlap_Check_Required : Boolean; ! -- Used to keep track of whether or not an overlap check is required ! ! Ccount : Natural := 0; ! -- Number of component clauses in record rep clause CR_Pragma : Node_Id := Empty; -- Points to N_Pragma node if Complete_Representation pragma present --- 2999,3130 ---- E : constant Entity_Id := Entity (N); begin + -- Remember that we are processing a freezing entity. Required to + -- ensure correct decoration of internal entities associated with + -- interfaces (see New_Overloaded_Entity). + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + -- For tagged types covering interfaces add internal entities that link -- the primitives of the interfaces with the primitives that cover them. -- Note: These entities were originally generated only when generating -- code because their main purpose was to provide support to initialize -- the secondary dispatch tables. They are now generated also when -- compiling with no code generation to provide ASIS the relationship ! -- between interface primitives and tagged type primitives. They are ! -- also used to locate primitives covering interfaces when processing ! -- generics (see Derive_Subprograms). ! if Ada_Version >= Ada_2005 and then Ekind (E) = E_Record_Type and then Is_Tagged_Type (E) and then not Is_Interface (E) and then Has_Interfaces (E) then + -- This would be a good common place to call the routine that checks + -- overriding of interface primitives (and thus factorize calls to + -- Check_Abstract_Overriding located at different contexts in the + -- compiler). However, this is not possible because it causes + -- spurious errors in case of late overriding. + Add_Internal_Interface_Entities (E); end if; + + -- Check CPP types + + if Ekind (E) = E_Record_Type + and then Is_CPP_Class (E) + and then Is_Tagged_Type (E) + and then Tagged_Type_Expansion + and then Expander_Active + then + if CPP_Num_Prims (E) = 0 then + + -- If the CPP type has user defined components then it must import + -- primitives from C++. This is required because if the C++ class + -- has no primitives then the C++ compiler does not added the _tag + -- component to the type. + + pragma Assert (Chars (First_Entity (E)) = Name_uTag); + + if First_Entity (E) /= Last_Entity (E) then + Error_Msg_N + ("?'C'P'P type must import at least one primitive from C++", + E); + end if; + end if; + + -- Check that all its primitives are abstract or imported from C++. + -- Check also availability of the C++ constructor. + + declare + Has_Constructors : constant Boolean := Has_CPP_Constructors (E); + Elmt : Elmt_Id; + Error_Reported : Boolean := False; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Comes_From_Source (Prim) then + if Is_Abstract_Subprogram (Prim) then + null; + + elsif not Is_Imported (Prim) + or else Convention (Prim) /= Convention_CPP + then + Error_Msg_N + ("?primitives of 'C'P'P types must be imported from C++" + & " or abstract", Prim); + + elsif not Has_Constructors + and then not Error_Reported + then + Error_Msg_Name_1 := Chars (E); + Error_Msg_N + ("?'C'P'P constructor required for type %", Prim); + Error_Reported := True; + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + + -- If we have a type with predicates, build predicate function + + if Is_Type (E) and then Has_Predicates (E) then + Build_Predicate_Function (E, N); + end if; end Analyze_Freeze_Entity; ------------------------------------------ -- Analyze_Record_Representation_Clause -- ------------------------------------------ + -- Note: we check as much as we can here, but we can't do any checks + -- based on the position values (e.g. overlap checks) until freeze time + -- because especially in Ada 2005 (machine scalar mode), the processing + -- for non-standard bit order can substantially change the positions. + -- See procedure Check_Record_Representation_Clause (called from Freeze) + -- for the remainder of this processing. + procedure Analyze_Record_Representation_Clause (N : Node_Id) is ! Ident : constant Node_Id := Identifier (N); ! Biased : Boolean; CC : Node_Id; ! Comp : Entity_Id; Fbit : Uint; Hbit : Uint := Uint_0; ! Lbit : Uint; Ocomp : Entity_Id; ! Posit : Uint; ! Rectype : Entity_Id; CR_Pragma : Node_Id := Empty; -- Points to N_Pragma node if Complete_Representation pragma present *************** package body Sem_Ch13 is *** 2294,2303 **** ("record type required, found}", Ident, First_Subtype (Rectype)); return; - elsif Is_Unchecked_Union (Rectype) then - Error_Msg_N - ("record rep clause not allowed for Unchecked_Union", N); - elsif Scope (Rectype) /= Current_Scope then Error_Msg_N ("type must be declared in this scope", N); return; --- 3152,3157 ---- *************** package body Sem_Ch13 is *** 2364,2370 **** -- Get the alignment value to perform error checking Mod_Val := Get_Alignment_Value (Expression (M)); - end if; end; end if; --- 3218,3223 ---- *************** package body Sem_Ch13 is *** 2383,2421 **** end loop; end if; - -- See if we have a fully repped derived tagged type - - declare - PS : constant Entity_Id := Parent_Subtype (Rectype); - - begin - if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then - Tagged_Parent := PS; - - -- Find maximum bit of any component of the parent type - - Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if Ekind (Pcomp) = E_Discriminant - or else - Ekind (Pcomp) = E_Component - then - if Component_Bit_Offset (Pcomp) /= No_Uint - and then Known_Static_Esize (Pcomp) - then - Parent_Last_Bit := - UI_Max - (Parent_Last_Bit, - Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); - end if; - - Next_Entity (Pcomp); - end if; - end loop; - end if; - end; - -- All done if no component clauses CC := First (Component_Clauses (N)); --- 3236,3241 ---- *************** package body Sem_Ch13 is *** 2424,2474 **** return; end if; - -- If a tag is present, then create a component clause that places it - -- at the start of the record (otherwise gigi may place it after other - -- fields that have rep clauses). - - Fent := First_Entity (Rectype); - - if Nkind (Fent) = N_Defining_Identifier - and then Chars (Fent) = Name_uTag - then - Set_Component_Bit_Offset (Fent, Uint_0); - Set_Normalized_Position (Fent, Uint_0); - Set_Normalized_First_Bit (Fent, Uint_0); - Set_Normalized_Position_Max (Fent, Uint_0); - Init_Esize (Fent, System_Address_Size); - - Set_Component_Clause (Fent, - Make_Component_Clause (Loc, - Component_Name => - Make_Identifier (Loc, - Chars => Name_uTag), - - Position => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - First_Bit => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - Last_Bit => - Make_Integer_Literal (Loc, - UI_From_Int (System_Address_Size)))); - - Ccount := Ccount + 1; - end if; - -- A representation like this applies to the base type Set_Has_Record_Rep_Clause (Base_Type (Rectype)); Set_Has_Non_Standard_Rep (Base_Type (Rectype)); Set_Has_Specified_Layout (Base_Type (Rectype)); - Max_Bit_So_Far := Uint_Minus_1; - Overlap_Check_Required := False; - -- Process the component clauses while Present (CC) loop --- 3244,3255 ---- *************** package body Sem_Ch13 is *** 2487,2493 **** -- Processing for real component clause else - Ccount := Ccount + 1; Posit := Static_Integer (Position (CC)); Fbit := Static_Integer (First_Bit (CC)); Lbit := Static_Integer (Last_Bit (CC)); --- 3268,3273 ---- *************** package body Sem_Ch13 is *** 2547,2552 **** --- 3327,3350 ---- Error_Msg_N ("component clause is for non-existent field", CC); + -- Ada 2012 (AI05-0026): Any name that denotes a + -- discriminant of an object of an unchecked union type + -- shall not occur within a record_representation_clause. + + -- The general restriction of using record rep clauses on + -- Unchecked_Union types has now been lifted. Since it is + -- possible to introduce a record rep clause which mentions + -- the discriminant of an Unchecked_Union in non-Ada 2012 + -- code, this check is applied to all versions of the + -- language. + + elsif Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Rectype) + then + Error_Msg_N + ("cannot reference discriminant of Unchecked_Union", + Component_Name (CC)); + elsif Present (Component_Clause (Comp)) then -- Diagnose duplicate rep clause, or check consistency *************** package body Sem_Ch13 is *** 2596,2607 **** Fbit := Fbit + UI_From_Int (SSU) * Posit; Lbit := Lbit + UI_From_Int (SSU) * Posit; - if Fbit <= Max_Bit_So_Far then - Overlap_Check_Required := True; - else - Max_Bit_So_Far := Lbit; - end if; - if Has_Size_Clause (Rectype) and then Esize (Rectype) <= Lbit then --- 3394,3399 ---- *************** package body Sem_Ch13 is *** 2615,2629 **** Set_Normalized_First_Bit (Comp, Fbit mod SSU); Set_Normalized_Position (Comp, Fbit / SSU); ! Set_Normalized_Position_Max ! (Fent, Normalized_Position (Fent)); ! ! if Is_Tagged_Type (Rectype) ! and then Fbit < System_Address_Size then Error_Msg_NE ! ("component overlaps tag field of&", ! Component_Name (CC), Rectype); end if; -- This information is also set in the corresponding --- 3407,3419 ---- Set_Normalized_First_Bit (Comp, Fbit mod SSU); Set_Normalized_Position (Comp, Fbit / SSU); ! if Warn_On_Overridden_Size ! and then Has_Size_Clause (Etype (Comp)) ! and then RM_Size (Etype (Comp)) /= Esize (Comp) then Error_Msg_NE ! ("?component size overrides size clause for&", ! Component_Name (CC), Etype (Comp)); end if; -- This information is also set in the corresponding *************** package body Sem_Ch13 is *** 2642,2654 **** Esize (Comp), Biased); ! Set_Has_Biased_Representation (Comp, Biased); ! ! if Biased and Warn_On_Biased_Representation then ! Error_Msg_F ! ("?component clause forces biased " ! & "representation", CC); ! end if; if Present (Ocomp) then Set_Component_Clause (Ocomp, CC); --- 3432,3439 ---- Esize (Comp), Biased); ! Set_Biased ! (Comp, First_Node (CC), "component clause", Biased); if Present (Ocomp) then Set_Component_Clause (Ocomp, CC); *************** package body Sem_Ch13 is *** 2660,2665 **** --- 3445,3454 ---- Set_Normalized_Position_Max (Ocomp, Normalized_Position (Ocomp)); + -- Note: we don't use Set_Biased here, because we + -- already gave a warning above if needed, and we + -- would get a duplicate for the same name here. + Set_Has_Biased_Representation (Ocomp, Has_Biased_Representation (Comp)); end if; *************** package body Sem_Ch13 is *** 2668,2694 **** Error_Msg_N ("component size is negative", CC); end if; end if; - - -- If OK component size, check parent type overlap if - -- this component might overlap a parent field. - - if Present (Tagged_Parent) - and then Fbit <= Parent_Last_Bit - then - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if (Ekind (Pcomp) = E_Discriminant - or else - Ekind (Pcomp) = E_Component) - and then not Is_Tag (Pcomp) - and then Chars (Pcomp) /= Name_uParent - then - Check_Component_Overlap (Comp, Pcomp); - end if; - - Next_Entity (Pcomp); - end loop; - end if; end if; end if; end if; --- 3457,3462 ---- *************** package body Sem_Ch13 is *** 2697,3061 **** Next (CC); end loop; ! -- Now that we have processed all the component clauses, check for ! -- overlap. We have to leave this till last, since the components can ! -- appear in any arbitrary order in the representation clause. ! -- We do not need this check if all specified ranges were monotonic, ! -- as recorded by Overlap_Check_Required being False at this stage. ! -- This first section checks if there are any overlapping entries at ! -- all. It does this by sorting all entries and then seeing if there are ! -- any overlaps. If there are none, then that is decisive, but if there ! -- are overlaps, they may still be OK (they may result from fields in ! -- different variants). ! if Overlap_Check_Required then ! Overlap_Check1 : declare ! OC_Fbit : array (0 .. Ccount) of Uint; ! -- First-bit values for component clauses, the value is the offset ! -- of the first bit of the field from start of record. The zero ! -- entry is for use in sorting. ! OC_Lbit : array (0 .. Ccount) of Uint; ! -- Last-bit values for component clauses, the value is the offset ! -- of the last bit of the field from start of record. The zero ! -- entry is for use in sorting. ! OC_Count : Natural := 0; ! -- Count of entries in OC_Fbit and OC_Lbit ! function OC_Lt (Op1, Op2 : Natural) return Boolean; ! -- Compare routine for Sort ! procedure OC_Move (From : Natural; To : Natural); ! -- Move routine for Sort ! package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); ! ----------- ! -- OC_Lt -- ! ----------- ! function OC_Lt (Op1, Op2 : Natural) return Boolean is ! begin ! return OC_Fbit (Op1) < OC_Fbit (Op2); ! end OC_Lt; ! ------------- ! -- OC_Move -- ! ------------- ! procedure OC_Move (From : Natural; To : Natural) is ! begin ! OC_Fbit (To) := OC_Fbit (From); ! OC_Lbit (To) := OC_Lbit (From); ! end OC_Move; ! -- Start of processing for Overlap_Check begin ! CC := First (Component_Clauses (N)); ! while Present (CC) loop ! if Nkind (CC) /= N_Pragma then ! Posit := Static_Integer (Position (CC)); ! Fbit := Static_Integer (First_Bit (CC)); ! Lbit := Static_Integer (Last_Bit (CC)); ! if Posit /= No_Uint ! and then Fbit /= No_Uint ! and then Lbit /= No_Uint ! then ! OC_Count := OC_Count + 1; ! Posit := Posit * SSU; ! OC_Fbit (OC_Count) := Fbit + Posit; ! OC_Lbit (OC_Count) := Lbit + Posit; end if; - end if; ! Next (CC); ! end loop; ! Sorting.Sort (OC_Count); ! Overlap_Check_Required := False; ! for J in 1 .. OC_Count - 1 loop ! if OC_Lbit (J) >= OC_Fbit (J + 1) then ! Overlap_Check_Required := True; ! exit; end if; - end loop; - end Overlap_Check1; - end if; ! -- If Overlap_Check_Required is still True, then we have to do the full ! -- scale overlap check, since we have at least two fields that do ! -- overlap, and we need to know if that is OK since they are in ! -- different variant, or whether we have a definite problem. ! if Overlap_Check_Required then ! Overlap_Check2 : declare ! C1_Ent, C2_Ent : Entity_Id; ! -- Entities of components being checked for overlap ! Clist : Node_Id; ! -- Component_List node whose Component_Items are being checked ! Citem : Node_Id; ! -- Component declaration for component being checked ! begin ! C1_Ent := First_Entity (Base_Type (Rectype)); ! -- Loop through all components in record. For each component check ! -- for overlap with any of the preceding elements on the component ! -- list containing the component and also, if the component is in ! -- a variant, check against components outside the case structure. ! -- This latter test is repeated recursively up the variant tree. ! Main_Component_Loop : while Present (C1_Ent) loop ! if Ekind (C1_Ent) /= E_Component ! and then Ekind (C1_Ent) /= E_Discriminant ! then ! goto Continue_Main_Component_Loop; end if; ! -- Skip overlap check if entity has no declaration node. This ! -- happens with discriminants in constrained derived types. ! -- Probably we are missing some checks as a result, but that ! -- does not seem terribly serious ??? ! if No (Declaration_Node (C1_Ent)) then ! goto Continue_Main_Component_Loop; end if; ! Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); ! -- Loop through component lists that need checking. Check the ! -- current component list and all lists in variants above us. ! Component_List_Loop : loop ! -- If derived type definition, go to full declaration ! -- If at outer level, check discriminants if there are any. ! if Nkind (Clist) = N_Derived_Type_Definition then ! Clist := Parent (Clist); ! end if; ! -- Outer level of record definition, check discriminants ! if Nkind_In (Clist, N_Full_Type_Declaration, ! N_Private_Type_Declaration) ! then ! if Has_Discriminants (Defining_Identifier (Clist)) then ! C2_Ent := ! First_Discriminant (Defining_Identifier (Clist)); ! while Present (C2_Ent) loop ! exit when C1_Ent = C2_Ent; ! Check_Component_Overlap (C1_Ent, C2_Ent); ! Next_Discriminant (C2_Ent); ! end loop; ! end if; ! -- Record extension case ! elsif Nkind (Clist) = N_Derived_Type_Definition then ! Clist := Empty; ! -- Otherwise check one component list ! else ! Citem := First (Component_Items (Clist)); ! while Present (Citem) loop ! if Nkind (Citem) = N_Component_Declaration then ! C2_Ent := Defining_Identifier (Citem); ! exit when C1_Ent = C2_Ent; ! Check_Component_Overlap (C1_Ent, C2_Ent); ! end if; ! Next (Citem); ! end loop; ! end if; ! -- Check for variants above us (the parent of the Clist can ! -- be a variant, in which case its parent is a variant part, ! -- and the parent of the variant part is a component list ! -- whose components must all be checked against the current ! -- component for overlap). ! if Nkind (Parent (Clist)) = N_Variant then ! Clist := Parent (Parent (Parent (Clist))); ! -- Check for possible discriminant part in record, this is ! -- treated essentially as another level in the recursion. ! -- For this case the parent of the component list is the ! -- record definition, and its parent is the full type ! -- declaration containing the discriminant specifications. ! elsif Nkind (Parent (Clist)) = N_Record_Definition then ! Clist := Parent (Parent ((Clist))); ! -- If neither of these two cases, we are at the top of ! -- the tree. else ! exit Component_List_Loop; end if; ! end loop Component_List_Loop; ! <> ! Next_Entity (C1_Ent); ! end loop Main_Component_Loop; ! end Overlap_Check2; end if; ! -- For records that have component clauses for all components, and whose ! -- size is less than or equal to 32, we need to know the size in the ! -- front end to activate possible packed array processing where the ! -- component type is a record. ! -- At this stage Hbit + 1 represents the first unused bit from all the ! -- component clauses processed, so if the component clauses are ! -- complete, then this is the length of the record. ! -- For records longer than System.Storage_Unit, and for those where not ! -- all components have component clauses, the back end determines the ! -- length (it may for example be appropriate to round up the size ! -- to some convenient boundary, based on alignment considerations, etc). ! if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then ! -- Nothing to do if at least one component has no component clause ! Comp := First_Component_Or_Discriminant (Rectype); ! while Present (Comp) loop ! exit when No (Component_Clause (Comp)); ! Next_Component_Or_Discriminant (Comp); ! end loop; ! -- If we fall out of loop, all components have component clauses ! -- and so we can set the size to the maximum value. ! if No (Comp) then ! Set_RM_Size (Rectype, Hbit + 1); end if; end if; ! -- Check missing components if Complete_Representation pragma appeared ! if Present (CR_Pragma) then ! Comp := First_Component_Or_Discriminant (Rectype); ! while Present (Comp) loop ! if No (Component_Clause (Comp)) then ! Error_Msg_NE ! ("missing component clause for &", CR_Pragma, Comp); ! end if; ! Next_Component_Or_Discriminant (Comp); end loop; ! -- If no Complete_Representation pragma, warn if missing components - elsif Warn_On_Unrepped_Components then declare ! Num_Repped_Components : Nat := 0; ! Num_Unrepped_Components : Nat := 0; begin ! -- First count number of repped and unrepped components - Comp := First_Component_Or_Discriminant (Rectype); - while Present (Comp) loop - if Present (Component_Clause (Comp)) then - Num_Repped_Components := Num_Repped_Components + 1; else ! Num_Unrepped_Components := Num_Unrepped_Components + 1; end if; ! Next_Component_Or_Discriminant (Comp); ! end loop; ! -- We are only interested in the case where there is at least one ! -- unrepped component, and at least half the components have rep ! -- clauses. We figure that if less than half have them, then the ! -- partial rep clause is really intentional. If the component ! -- type has no underlying type set at this point (as for a generic ! -- formal type), we don't know enough to give a warning on the ! -- component. ! if Num_Unrepped_Components > 0 ! and then Num_Unrepped_Components < Num_Repped_Components then ! Comp := First_Component_Or_Discriminant (Rectype); ! while Present (Comp) loop ! if No (Component_Clause (Comp)) ! and then Comes_From_Source (Comp) ! and then Present (Underlying_Type (Etype (Comp))) ! and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) ! or else Size_Known_At_Compile_Time ! (Underlying_Type (Etype (Comp)))) ! and then not Has_Warnings_Off (Rectype) ! then ! Error_Msg_Sloc := Sloc (Comp); ! Error_Msg_NE ! ("?no component clause given for & declared #", ! N, Comp); ! end if; ! Next_Component_Or_Discriminant (Comp); ! end loop; end if; ! end; ! end if; ! end Analyze_Record_Representation_Clause; ! ----------------------------- ! -- Check_Component_Overlap -- ! ----------------------------- ! procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is ! begin ! if Present (Component_Clause (C1_Ent)) ! and then Present (Component_Clause (C2_Ent)) ! then ! -- Exclude odd case where we have two tag fields in the same record, ! -- both at location zero. This seems a bit strange, but it seems to ! -- happen in some circumstances ??? ! if Chars (C1_Ent) = Name_uTag ! and then Chars (C2_Ent) = Name_uTag then ! return; end if; ! -- Here we check if the two fields overlap declare ! S1 : constant Uint := Component_Bit_Offset (C1_Ent); ! S2 : constant Uint := Component_Bit_Offset (C2_Ent); ! E1 : constant Uint := S1 + Esize (C1_Ent); ! E2 : constant Uint := S2 + Esize (C2_Ent); begin ! if E2 <= S1 or else E1 <= S2 then ! null; else ! Error_Msg_Node_2 := ! Component_Name (Component_Clause (C2_Ent)); ! Error_Msg_Sloc := Sloc (Error_Msg_Node_2); ! Error_Msg_Node_1 := ! Component_Name (Component_Clause (C1_Ent)); ! Error_Msg_N ! ("component& overlaps & #", ! Component_Name (Component_Clause (C1_Ent))); end if; end; ! end if; ! end Check_Component_Overlap; ----------------------------------- -- Check_Constant_Address_Clause -- --- 3465,4930 ---- Next (CC); end loop; ! -- Check missing components if Complete_Representation pragma appeared ! if Present (CR_Pragma) then ! Comp := First_Component_Or_Discriminant (Rectype); ! while Present (Comp) loop ! if No (Component_Clause (Comp)) then ! Error_Msg_NE ! ("missing component clause for &", CR_Pragma, Comp); ! end if; ! Next_Component_Or_Discriminant (Comp); ! end loop; ! -- If no Complete_Representation pragma, warn if missing components ! elsif Warn_On_Unrepped_Components then ! declare ! Num_Repped_Components : Nat := 0; ! Num_Unrepped_Components : Nat := 0; ! begin ! -- First count number of repped and unrepped components ! Comp := First_Component_Or_Discriminant (Rectype); ! while Present (Comp) loop ! if Present (Component_Clause (Comp)) then ! Num_Repped_Components := Num_Repped_Components + 1; ! else ! Num_Unrepped_Components := Num_Unrepped_Components + 1; ! end if; ! Next_Component_Or_Discriminant (Comp); ! end loop; ! -- We are only interested in the case where there is at least one ! -- unrepped component, and at least half the components have rep ! -- clauses. We figure that if less than half have them, then the ! -- partial rep clause is really intentional. If the component ! -- type has no underlying type set at this point (as for a generic ! -- formal type), we don't know enough to give a warning on the ! -- component. ! if Num_Unrepped_Components > 0 ! and then Num_Unrepped_Components < Num_Repped_Components ! then ! Comp := First_Component_Or_Discriminant (Rectype); ! while Present (Comp) loop ! if No (Component_Clause (Comp)) ! and then Comes_From_Source (Comp) ! and then Present (Underlying_Type (Etype (Comp))) ! and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) ! or else Size_Known_At_Compile_Time ! (Underlying_Type (Etype (Comp)))) ! and then not Has_Warnings_Off (Rectype) ! then ! Error_Msg_Sloc := Sloc (Comp); ! Error_Msg_NE ! ("?no component clause given for & declared #", ! N, Comp); ! end if; ! Next_Component_Or_Discriminant (Comp); ! end loop; ! end if; ! end; ! end if; ! end Analyze_Record_Representation_Clause; ! ------------------------------- ! -- Build_Invariant_Procedure -- ! ------------------------------- ! -- The procedure that is constructed here has the form ! -- procedure typInvariant (Ixxx : typ) is ! -- begin ! -- pragma Check (Invariant, exp, "failed invariant from xxx"); ! -- pragma Check (Invariant, exp, "failed invariant from xxx"); ! -- ... ! -- pragma Check (Invariant, exp, "failed inherited invariant from xxx"); ! -- ... ! -- end typInvariant; ! procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (Typ); ! Stmts : List_Id; ! Spec : Node_Id; ! SId : Entity_Id; ! PDecl : Node_Id; ! PBody : Node_Id; ! ! Visible_Decls : constant List_Id := Visible_Declarations (N); ! Private_Decls : constant List_Id := Private_Declarations (N); ! ! procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); ! -- Appends statements to Stmts for any invariants in the rep item chain ! -- of the given type. If Inherit is False, then we only process entries ! -- on the chain for the type Typ. If Inherit is True, then we ignore any ! -- Invariant aspects, but we process all Invariant'Class aspects, adding ! -- "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'); ! -- Name for argument of invariant procedure ! ! Object_Entity : constant Node_Id := ! Make_Defining_Identifier (Loc, Object_Name); ! -- The procedure declaration entity for the argument ! ! -------------------- ! -- Add_Invariants -- ! -------------------- ! ! procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is ! Ritem : Node_Id; ! Arg1 : Node_Id; ! Arg2 : Node_Id; ! Arg3 : Node_Id; ! Exp : Node_Id; ! Loc : Source_Ptr; ! Assoc : List_Id; ! Str : String_Id; ! ! procedure Replace_Type_Reference (N : Node_Id); ! -- Replace a single occurrence N of the subtype name with a reference ! -- to the formal of the predicate function. N can be an identifier ! -- referencing the subtype, or a selected component, representing an ! -- appropriately qualified occurrence of the subtype name. ! ! procedure Replace_Type_References is ! new Replace_Type_References_Generic (Replace_Type_Reference); ! -- Traverse an expression replacing all occurrences of the subtype ! -- name with appropriate references to the object that is the formal ! -- parameter of the predicate function. Note that we must ensure ! -- that the type and entity information is properly set in the ! -- replacement node, since we will do a Preanalyze call of this ! -- expression without proper visibility of the procedure argument. + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- + + procedure Replace_Type_Reference (N : Node_Id) is begin ! -- Invariant'Class, replace with T'Class (obj) ! if Class_Present (Ritem) then ! Rewrite (N, ! Make_Type_Conversion (Loc, ! Subtype_Mark => ! Make_Attribute_Reference (Loc, ! Prefix => New_Occurrence_Of (T, Loc), ! Attribute_Name => Name_Class), ! Expression => Make_Identifier (Loc, Object_Name))); ! ! Set_Entity (Expression (N), Object_Entity); ! Set_Etype (Expression (N), Typ); ! ! -- Invariant, replace with obj ! ! else ! Rewrite (N, Make_Identifier (Loc, Object_Name)); ! Set_Entity (N, Object_Entity); ! Set_Etype (N, Typ); ! end if; ! end Replace_Type_Reference; ! ! -- Start of processing for Add_Invariants ! ! begin ! Ritem := First_Rep_Item (T); ! while Present (Ritem) loop ! if Nkind (Ritem) = N_Pragma ! and then Pragma_Name (Ritem) = Name_Invariant ! then ! Arg1 := First (Pragma_Argument_Associations (Ritem)); ! Arg2 := Next (Arg1); ! Arg3 := Next (Arg2); ! ! Arg1 := Get_Pragma_Arg (Arg1); ! Arg2 := Get_Pragma_Arg (Arg2); ! ! -- For Inherit case, ignore Invariant, process only Class case ! ! if Inherit then ! if not Class_Present (Ritem) then ! goto Continue; end if; ! -- For Inherit false, process only item for right type ! else ! if Entity (Arg1) /= Typ then ! goto Continue; ! end if; ! end if; ! if No (Stmts) then ! Stmts := Empty_List; end if; ! Exp := New_Copy_Tree (Arg2); ! Loc := Sloc (Exp); ! -- We need to replace any occurrences of the name of the type ! -- with references to the object, converted to type'Class in ! -- the case of Invariant'Class aspects. ! Replace_Type_References (Exp, Chars (T)); ! -- Now we need to preanalyze the expression to properly capture ! -- the visibility in the visible part. The expression will not ! -- be analyzed for real until the body is analyzed, but that is ! -- at the end of the private part and has the wrong visibility. ! Set_Parent (Exp, N); ! Preanalyze_Spec_Expression (Exp, Standard_Boolean); ! -- Build first two arguments for Check pragma ! Assoc := New_List ( ! Make_Pragma_Argument_Association (Loc, ! Expression => Make_Identifier (Loc, Name_Invariant)), ! Make_Pragma_Argument_Association (Loc, Expression => Exp)); ! ! -- Add message if present in Invariant pragma ! ! if Present (Arg3) then ! Str := Strval (Get_Pragma_Arg (Arg3)); ! ! -- If inherited case, and message starts "failed invariant", ! -- change it to be "failed inherited invariant". ! ! if Inherit then ! String_To_Name_Buffer (Str); ! ! if Name_Buffer (1 .. 16) = "failed invariant" then ! Insert_Str_In_Name_Buffer ("inherited ", 8); ! Str := String_From_Name_Buffer; ! end if; ! end if; ! ! Append_To (Assoc, ! Make_Pragma_Argument_Association (Loc, ! Expression => Make_String_Literal (Loc, Str))); end if; ! -- Add Check pragma to list of statements ! Append_To (Stmts, ! Make_Pragma (Loc, ! Pragma_Identifier => ! Make_Identifier (Loc, Name_Check), ! Pragma_Argument_Associations => Assoc)); ! ! -- If Inherited case and option enabled, output info msg. Note ! -- that we know this is a case of Invariant'Class. ! ! if Inherit and Opt.List_Inherited_Aspects then ! Error_Msg_Sloc := Sloc (Ritem); ! Error_Msg_N ! ("?info: & inherits `Invariant''Class` aspect from #", ! Typ); end if; + end if; ! <> ! Next_Rep_Item (Ritem); ! end loop; ! end Add_Invariants; ! -- Start of processing for Build_Invariant_Procedure ! begin ! Stmts := No_List; ! PDecl := Empty; ! PBody := Empty; ! Set_Etype (Object_Entity, Typ); ! -- Add invariants for the current type ! Add_Invariants (Typ, Inherit => False); ! -- Add invariants for parent types ! declare ! Current_Typ : Entity_Id; ! Parent_Typ : Entity_Id; ! begin ! Current_Typ := Typ; ! loop ! Parent_Typ := Etype (Current_Typ); ! if Is_Private_Type (Parent_Typ) ! and then Present (Full_View (Base_Type (Parent_Typ))) ! then ! Parent_Typ := Full_View (Base_Type (Parent_Typ)); ! end if; ! exit when Parent_Typ = Current_Typ; ! Current_Typ := Parent_Typ; ! Add_Invariants (Current_Typ, Inherit => True); ! end loop; ! end; ! -- Build the procedure if we generated at least one Check pragma ! 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)))); ! ! PBody := ! Make_Subprogram_Body (Loc, ! Specification => Spec, ! Declarations => Empty_List, ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => Stmts)); ! ! -- Insert procedure declaration and spec at the appropriate points. ! -- Skip this if there are no private declarations (that's an error ! -- that will be diagnosed elsewhere, and there is no point in having ! -- an invariant procedure set if the full declaration is missing). ! ! 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); ! ! -- 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 ! -- analyze call. We skip this if there are no private declarations ! -- (this is an error that will be caught elsewhere); ! ! Append_To (Private_Decls, PBody); ! end if; ! end if; ! end Build_Invariant_Procedure; ! ! ------------------------------ ! -- Build_Predicate_Function -- ! ------------------------------ ! ! -- The procedure that is constructed here has the form ! ! -- function typPredicate (Ixxx : typ) return Boolean is ! -- begin ! -- return ! -- exp1 and then exp2 and then ... ! -- and then typ1Predicate (typ1 (Ixxx)) ! -- and then typ2Predicate (typ2 (Ixxx)) ! -- and then ...; ! -- end typPredicate; ! ! -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that ! -- this is the point at which these expressions get analyzed, providing the ! -- required delay, and typ1, typ2, are entities from which predicates are ! -- inherited. Note that we do NOT generate Check pragmas, that's because we ! -- use this function even if checks are off, e.g. for membership tests. ! ! procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (Typ); ! Spec : Node_Id; ! SId : Entity_Id; ! FDecl : Node_Id; ! FBody : Node_Id; ! ! Expr : Node_Id; ! -- This is the expression for the return statement in the function. It ! -- is build by connecting the component predicates with AND THEN. ! ! procedure Add_Call (T : Entity_Id); ! -- Includes a call to the predicate function for type T in Expr if T ! -- has predicates and Predicate_Function (T) is non-empty. ! ! procedure Add_Predicates; ! -- Appends expressions for any Predicate pragmas in the rep item chain ! -- Typ to Expr. Note that we look only at items for this exact entity. ! -- Inheritance of predicates for the parent type is done by calling the ! -- Predicate_Function of the parent type, using Add_Call above. ! ! Object_Name : constant Name_Id := New_Internal_Name ('I'); ! -- Name for argument of Predicate procedure ! ! -------------- ! -- Add_Call -- ! -------------- ! ! procedure Add_Call (T : Entity_Id) is ! Exp : Node_Id; ! ! begin ! if Present (T) and then Present (Predicate_Function (T)) then ! Set_Has_Predicates (Typ); ! ! -- Build the call to the predicate function of T ! ! Exp := ! Make_Predicate_Call ! (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); ! ! -- Add call to evolving expression, using AND THEN if needed ! ! if No (Expr) then ! Expr := Exp; ! else ! Expr := ! Make_And_Then (Loc, ! Left_Opnd => Relocate_Node (Expr), ! Right_Opnd => Exp); ! end if; ! ! -- Output info message on inheritance if required. Note we do not ! -- give this information for generic actual types, since it is ! -- unwelcome noise in that case in instantiations. We also ! -- generally suppress the message in instantiations, and also ! -- if it involves internal names. ! ! if Opt.List_Inherited_Aspects ! and then not Is_Generic_Actual_Type (Typ) ! and then Instantiation_Depth (Sloc (Typ)) = 0 ! and then not Is_Internal_Name (Chars (T)) ! and then not Is_Internal_Name (Chars (Typ)) ! then ! Error_Msg_Sloc := Sloc (Predicate_Function (T)); ! Error_Msg_Node_2 := T; ! Error_Msg_N ("?info: & inherits predicate from & #", Typ); ! end if; ! end if; ! end Add_Call; ! ! -------------------- ! -- Add_Predicates -- ! -------------------- ! ! procedure Add_Predicates is ! Ritem : Node_Id; ! Arg1 : Node_Id; ! Arg2 : Node_Id; ! ! procedure Replace_Type_Reference (N : Node_Id); ! -- Replace a single occurrence N of the subtype name with a reference ! -- to the formal of the predicate function. N can be an identifier ! -- referencing the subtype, or a selected component, representing an ! -- appropriately qualified occurrence of the subtype name. ! ! procedure Replace_Type_References is ! new Replace_Type_References_Generic (Replace_Type_Reference); ! -- Traverse an expression changing every occurrence of an identifier ! -- whose name matches the name of the subtype with a reference to ! -- the formal parameter of the predicate function. ! ! ---------------------------- ! -- Replace_Type_Reference -- ! ---------------------------- ! ! procedure Replace_Type_Reference (N : Node_Id) is ! begin ! Rewrite (N, Make_Identifier (Loc, Object_Name)); ! end Replace_Type_Reference; ! ! -- Start of processing for Add_Predicates ! ! begin ! Ritem := First_Rep_Item (Typ); ! while Present (Ritem) loop ! if Nkind (Ritem) = N_Pragma ! and then Pragma_Name (Ritem) = Name_Predicate ! then ! Arg1 := First (Pragma_Argument_Associations (Ritem)); ! Arg2 := Next (Arg1); ! ! Arg1 := Get_Pragma_Arg (Arg1); ! Arg2 := Get_Pragma_Arg (Arg2); ! ! -- See if this predicate pragma is for the current type ! ! if Entity (Arg1) = Typ then ! ! -- We have a match, this entry is for our subtype ! ! -- First We need to replace any occurrences of the name of ! -- the type with references to the object. ! ! Replace_Type_References (Arg2, Chars (Typ)); ! ! -- OK, replacement complete, now we can add the expression ! ! if No (Expr) then ! Expr := Relocate_Node (Arg2); ! ! -- There already was a predicate, so add to it else ! Expr := ! Make_And_Then (Loc, ! Left_Opnd => Relocate_Node (Expr), ! Right_Opnd => Relocate_Node (Arg2)); end if; ! end if; ! end if; ! Next_Rep_Item (Ritem); ! end loop; ! end Add_Predicates; ! -- Start of processing for Build_Predicate_Function ! ! begin ! -- Initialize for construction of statement list ! ! Expr := Empty; ! ! -- Return if already built or if type does not have predicates ! ! if not Has_Predicates (Typ) ! or else Present (Predicate_Function (Typ)) ! then ! return; end if; ! -- Add Predicates for the current type ! Add_Predicates; ! -- Add predicates for ancestor if present ! declare ! Atyp : constant Entity_Id := Nearest_Ancestor (Typ); ! begin ! if Present (Atyp) then ! Add_Call (Atyp); ! end if; ! end; ! -- If we have predicates, build the function ! if Present (Expr) then ! -- Build function declaration ! pragma Assert (Has_Predicates (Typ)); ! SId := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Typ), "Predicate")); ! Set_Has_Predicates (SId); ! Set_Predicate_Function (Typ, SId); ! ! Spec := ! Make_Function_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))), ! Result_Definition => ! New_Occurrence_Of (Standard_Boolean, Loc)); ! ! FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); ! ! -- Build function body ! ! SId := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Typ), "Predicate")); ! ! Spec := ! Make_Function_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))), ! Result_Definition => ! New_Occurrence_Of (Standard_Boolean, Loc)); ! ! FBody := ! Make_Subprogram_Body (Loc, ! Specification => Spec, ! Declarations => Empty_List, ! Handled_Statement_Sequence => ! Make_Handled_Sequence_Of_Statements (Loc, ! Statements => New_List ( ! Make_Simple_Return_Statement (Loc, ! Expression => Expr)))); ! ! -- Insert declaration before freeze node and body after ! ! Insert_Before_And_Analyze (N, FDecl); ! Insert_After_And_Analyze (N, FBody); ! ! -- Deal with static predicate case ! ! if Ekind_In (Typ, E_Enumeration_Subtype, ! E_Modular_Integer_Subtype, ! E_Signed_Integer_Subtype) ! and then Is_Static_Subtype (Typ) ! then ! Build_Static_Predicate (Typ, Expr, Object_Name); end if; end if; + end Build_Predicate_Function; ! ---------------------------- ! -- Build_Static_Predicate -- ! ---------------------------- ! procedure Build_Static_Predicate ! (Typ : Entity_Id; ! Expr : Node_Id; ! Nam : Name_Id) ! is ! Loc : constant Source_Ptr := Sloc (Expr); ! Non_Static : exception; ! -- Raised if something non-static is found ! ! Btyp : constant Entity_Id := Base_Type (Typ); ! ! BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp)); ! BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp)); ! -- Low bound and high bound value of base type of Typ ! ! TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ)); ! THi : constant Uint := Expr_Value (Type_High_Bound (Typ)); ! -- Low bound and high bound values of static subtype Typ ! ! type REnt is record ! Lo, Hi : Uint; ! end record; ! -- One entry in a Rlist value, a single REnt (range entry) value ! -- denotes one range from Lo to Hi. To represent a single value ! -- range Lo = Hi = value. ! ! type RList is array (Nat range <>) of REnt; ! -- A list of ranges. The ranges are sorted in increasing order, ! -- and are disjoint (there is a gap of at least one value between ! -- each range in the table). A value is in the set of ranges in ! -- Rlist if it lies within one of these ranges ! ! False_Range : constant RList := ! RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); ! -- An empty set of ranges represents a range list that can never be ! -- satisfied, since there are no ranges in which the value could lie, ! -- so it does not lie in any of them. False_Range is a canonical value ! -- for this empty set, but general processing should test for an Rlist ! -- with length zero (see Is_False predicate), since other null ranges ! -- may appear which must be treated as False. ! ! True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); ! -- Range representing True, value must be in the base range ! ! function "and" (Left, Right : RList) return RList; ! -- And's together two range lists, returning a range list. This is ! -- a set intersection operation. ! ! function "or" (Left, Right : RList) return RList; ! -- Or's together two range lists, returning a range list. This is a ! -- set union operation. ! ! function "not" (Right : RList) return RList; ! -- Returns complement of a given range list, i.e. a range list ! -- representing all the values in TLo .. THi that are not in the ! -- input operand Right. ! ! function Build_Val (V : Uint) return Node_Id; ! -- Return an analyzed N_Identifier node referencing this value, suitable ! -- for use as an entry in the Static_Predicate list. This node is typed ! -- with the base type. ! ! function Build_Range (Lo, Hi : Uint) return Node_Id; ! -- Return an analyzed N_Range node referencing this range, suitable ! -- for use as an entry in the Static_Predicate list. This node is typed ! -- with the base type. ! ! function Get_RList (Exp : Node_Id) return RList; ! -- This is a recursive routine that converts the given expression into ! -- a list of ranges, suitable for use in building the static predicate. ! ! function Is_False (R : RList) return Boolean; ! pragma Inline (Is_False); ! -- Returns True if the given range list is empty, and thus represents ! -- a False list of ranges that can never be satisfied. ! ! function Is_True (R : RList) return Boolean; ! -- Returns True if R trivially represents the True predicate by having ! -- a single range from BLo to BHi. ! ! function Is_Type_Ref (N : Node_Id) return Boolean; ! pragma Inline (Is_Type_Ref); ! -- Returns if True if N is a reference to the type for the predicate in ! -- the expression (i.e. if it is an identifier whose Chars field matches ! -- the Nam given in the call). ! ! function Lo_Val (N : Node_Id) return Uint; ! -- Given static expression or static range from a Static_Predicate list, ! -- gets expression value or low bound of range. ! ! function Hi_Val (N : Node_Id) return Uint; ! -- Given static expression or static range from a Static_Predicate list, ! -- gets expression value of high bound of range. ! ! function Membership_Entry (N : Node_Id) return RList; ! -- Given a single membership entry (range, value, or subtype), returns ! -- the corresponding range list. Raises Static_Error if not static. ! ! function Membership_Entries (N : Node_Id) return RList; ! -- Given an element on an alternatives list of a membership operation, ! -- returns the range list corresponding to this entry and all following ! -- entries (i.e. returns the "or" of this list of values). ! ! function Stat_Pred (Typ : Entity_Id) return RList; ! -- Given a type, if it has a static predicate, then return the predicate ! -- as a range list, otherwise raise Non_Static. ! ! ----------- ! -- "and" -- ! ----------- ! ! function "and" (Left, Right : RList) return RList is ! FEnt : REnt; ! -- First range of result ! ! SLeft : Nat := Left'First; ! -- Start of rest of left entries ! ! SRight : Nat := Right'First; ! -- Start of rest of right entries ! ! begin ! -- If either range is True, return the other ! ! if Is_True (Left) then ! return Right; ! elsif Is_True (Right) then ! return Left; ! end if; ! ! -- If either range is False, return False ! ! if Is_False (Left) or else Is_False (Right) then ! return False_Range; ! end if; ! ! -- Loop to remove entries at start that are disjoint, and thus ! -- just get discarded from the result entirely. ! ! loop ! -- If no operands left in either operand, result is false ! ! if SLeft > Left'Last or else SRight > Right'Last then ! return False_Range; ! ! -- Discard first left operand entry if disjoint with right ! ! elsif Left (SLeft).Hi < Right (SRight).Lo then ! SLeft := SLeft + 1; ! ! -- Discard first right operand entry if disjoint with left ! ! elsif Right (SRight).Hi < Left (SLeft).Lo then ! SRight := SRight + 1; ! ! -- Otherwise we have an overlapping entry ! ! else ! exit; ! end if; end loop; ! -- Now we have two non-null operands, and first entries overlap. ! -- The first entry in the result will be the overlapping part of ! -- these two entries. ! ! FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), ! Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); ! ! -- Now we can remove the entry that ended at a lower value, since ! -- its contribution is entirely contained in Fent. ! ! if Left (SLeft).Hi <= Right (SRight).Hi then ! SLeft := SLeft + 1; ! else ! SRight := SRight + 1; ! end if; ! ! -- Compute result by concatenating this first entry with the "and" ! -- of the remaining parts of the left and right operands. Note that ! -- if either of these is empty, "and" will yield empty, so that we ! -- will end up with just Fent, which is what we want in that case. ! ! return ! FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); ! end "and"; ! ! ----------- ! -- "not" -- ! ----------- ! ! function "not" (Right : RList) return RList is ! begin ! -- Return True if False range ! ! if Is_False (Right) then ! return True_Range; ! end if; ! ! -- Return False if True range ! ! if Is_True (Right) then ! return False_Range; ! end if; ! ! -- Here if not trivial case declare ! Result : RList (1 .. Right'Length + 1); ! -- May need one more entry for gap at beginning and end ! ! Count : Nat := 0; ! -- Number of entries stored in Result begin ! -- Gap at start ! ! if Right (Right'First).Lo > TLo then ! Count := Count + 1; ! Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); ! end if; ! ! -- Gaps between ranges ! ! for J in Right'First .. Right'Last - 1 loop ! Count := Count + 1; ! Result (Count) := ! REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); ! end loop; ! ! -- Gap at end ! ! if Right (Right'Last).Hi < THi then ! Count := Count + 1; ! Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); ! end if; ! ! return Result (1 .. Count); ! end; ! end "not"; ! ! ---------- ! -- "or" -- ! ---------- ! ! function "or" (Left, Right : RList) return RList is ! FEnt : REnt; ! -- First range of result ! ! SLeft : Nat := Left'First; ! -- Start of rest of left entries ! ! SRight : Nat := Right'First; ! -- Start of rest of right entries ! ! begin ! -- If either range is True, return True ! ! if Is_True (Left) or else Is_True (Right) then ! return True_Range; ! end if; ! ! -- If either range is False (empty), return the other ! ! if Is_False (Left) then ! return Right; ! elsif Is_False (Right) then ! return Left; ! end if; ! ! -- Initialize result first entry from left or right operand ! -- depending on which starts with the lower range. ! ! if Left (SLeft).Lo < Right (SRight).Lo then ! FEnt := Left (SLeft); ! SLeft := SLeft + 1; ! else ! FEnt := Right (SRight); ! SRight := SRight + 1; ! end if; ! ! -- This loop eats ranges from left and right operands that ! -- are contiguous with the first range we are gathering. ! ! loop ! -- Eat first entry in left operand if contiguous or ! -- overlapped by gathered first operand of result. ! ! if SLeft <= Left'Last ! and then Left (SLeft).Lo <= FEnt.Hi + 1 ! then ! FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); ! SLeft := SLeft + 1; ! ! -- Eat first entry in right operand if contiguous or ! -- overlapped by gathered right operand of result. ! ! elsif SRight <= Right'Last ! and then Right (SRight).Lo <= FEnt.Hi + 1 ! then ! FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); ! SRight := SRight + 1; ! ! -- All done if no more entries to eat! ! ! else ! exit; ! end if; ! end loop; ! ! -- Obtain result as the first entry we just computed, concatenated ! -- to the "or" of the remaining results (if one operand is empty, ! -- this will just concatenate with the other ! ! return ! FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); ! end "or"; ! ! ----------------- ! -- Build_Range -- ! ----------------- ! ! function Build_Range (Lo, Hi : Uint) return Node_Id is ! Result : Node_Id; ! begin ! if Lo = Hi then ! return Build_Val (Hi); ! else ! Result := ! Make_Range (Loc, ! Low_Bound => Build_Val (Lo), ! High_Bound => Build_Val (Hi)); ! Set_Etype (Result, Btyp); ! Set_Analyzed (Result); ! return Result; ! end if; ! end Build_Range; ! ! --------------- ! -- Build_Val -- ! --------------- ! ! function Build_Val (V : Uint) return Node_Id is ! Result : Node_Id; ! ! begin ! if Is_Enumeration_Type (Typ) then ! Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); ! else ! Result := Make_Integer_Literal (Loc, V); ! end if; ! ! Set_Etype (Result, Btyp); ! Set_Is_Static_Expression (Result); ! Set_Analyzed (Result); ! return Result; ! end Build_Val; ! ! --------------- ! -- Get_RList -- ! --------------- ! ! function Get_RList (Exp : Node_Id) return RList is ! Op : Node_Kind; ! Val : Uint; ! ! begin ! -- Static expression can only be true or false ! ! if Is_OK_Static_Expression (Exp) then ! ! -- For False ! ! if Expr_Value (Exp) = 0 then ! return False_Range; ! else ! return True_Range; ! end if; ! end if; ! ! -- Otherwise test node type ! ! Op := Nkind (Exp); ! ! case Op is ! ! -- And ! ! when N_Op_And | N_And_Then => ! return Get_RList (Left_Opnd (Exp)) ! and ! Get_RList (Right_Opnd (Exp)); ! ! -- Or ! ! when N_Op_Or | N_Or_Else => ! return Get_RList (Left_Opnd (Exp)) ! or ! Get_RList (Right_Opnd (Exp)); ! ! -- Not ! ! when N_Op_Not => ! return not Get_RList (Right_Opnd (Exp)); ! ! -- Comparisons of type with static value ! ! when N_Op_Compare => ! -- Type is left operand ! ! if Is_Type_Ref (Left_Opnd (Exp)) ! and then Is_OK_Static_Expression (Right_Opnd (Exp)) ! then ! Val := Expr_Value (Right_Opnd (Exp)); ! ! -- Typ is right operand ! ! elsif Is_Type_Ref (Right_Opnd (Exp)) ! and then Is_OK_Static_Expression (Left_Opnd (Exp)) ! then ! Val := Expr_Value (Left_Opnd (Exp)); ! ! -- Invert sense of comparison ! ! case Op is ! when N_Op_Gt => Op := N_Op_Lt; ! when N_Op_Lt => Op := N_Op_Gt; ! when N_Op_Ge => Op := N_Op_Le; ! when N_Op_Le => Op := N_Op_Ge; ! when others => null; ! end case; ! ! -- Other cases are non-static else ! raise Non_Static; end if; ! -- Construct range according to comparison operation ! case Op is ! when N_Op_Eq => ! return RList'(1 => REnt'(Val, Val)); ! when N_Op_Ge => ! return RList'(1 => REnt'(Val, BHi)); ! ! when N_Op_Gt => ! return RList'(1 => REnt'(Val + 1, BHi)); ! ! when N_Op_Le => ! return RList'(1 => REnt'(BLo, Val)); ! ! when N_Op_Lt => ! return RList'(1 => REnt'(BLo, Val - 1)); ! ! when N_Op_Ne => ! return RList'(REnt'(BLo, Val - 1), ! REnt'(Val + 1, BHi)); ! ! when others => ! raise Program_Error; ! end case; ! ! -- Membership (IN) ! ! when N_In => ! if not Is_Type_Ref (Left_Opnd (Exp)) then ! raise Non_Static; ! end if; ! ! if Present (Right_Opnd (Exp)) then ! return Membership_Entry (Right_Opnd (Exp)); ! else ! return Membership_Entries (First (Alternatives (Exp))); ! end if; ! ! -- Negative membership (NOT IN) ! ! when N_Not_In => ! if not Is_Type_Ref (Left_Opnd (Exp)) then ! raise Non_Static; ! end if; ! ! if Present (Right_Opnd (Exp)) then ! return not Membership_Entry (Right_Opnd (Exp)); ! else ! return not Membership_Entries (First (Alternatives (Exp))); ! end if; ! ! -- Function call, may be call to static predicate ! ! when N_Function_Call => ! if Is_Entity_Name (Name (Exp)) then ! declare ! Ent : constant Entity_Id := Entity (Name (Exp)); ! begin ! if Has_Predicates (Ent) then ! return Stat_Pred (Etype (First_Formal (Ent))); ! end if; ! end; ! end if; ! ! -- Other function call cases are non-static ! ! raise Non_Static; ! ! -- Qualified expression, dig out the expression ! ! when N_Qualified_Expression => ! return Get_RList (Expression (Exp)); ! ! -- Xor operator ! ! when N_Op_Xor => ! return (Get_RList (Left_Opnd (Exp)) ! and not Get_RList (Right_Opnd (Exp))) ! or (Get_RList (Right_Opnd (Exp)) ! and not Get_RList (Left_Opnd (Exp))); ! ! -- Any other node type is non-static ! ! when others => ! raise Non_Static; ! end case; ! end Get_RList; ! ! ------------ ! -- Hi_Val -- ! ------------ ! ! function Hi_Val (N : Node_Id) return Uint is ! begin ! if Is_Static_Expression (N) then ! return Expr_Value (N); ! else ! pragma Assert (Nkind (N) = N_Range); ! return Expr_Value (High_Bound (N)); ! end if; ! end Hi_Val; ! ! -------------- ! -- Is_False -- ! -------------- ! ! function Is_False (R : RList) return Boolean is ! begin ! return R'Length = 0; ! end Is_False; ! ! ------------- ! -- Is_True -- ! ------------- ! ! function Is_True (R : RList) return Boolean is ! begin ! return R'Length = 1 ! and then R (R'First).Lo = BLo ! and then R (R'First).Hi = BHi; ! end Is_True; ! ! ----------------- ! -- Is_Type_Ref -- ! ----------------- ! ! function Is_Type_Ref (N : Node_Id) return Boolean is ! begin ! return Nkind (N) = N_Identifier and then Chars (N) = Nam; ! end Is_Type_Ref; ! ! ------------ ! -- Lo_Val -- ! ------------ ! ! function Lo_Val (N : Node_Id) return Uint is ! begin ! if Is_Static_Expression (N) then ! return Expr_Value (N); ! else ! pragma Assert (Nkind (N) = N_Range); ! return Expr_Value (Low_Bound (N)); ! end if; ! end Lo_Val; ! ! ------------------------ ! -- Membership_Entries -- ! ------------------------ ! ! function Membership_Entries (N : Node_Id) return RList is ! begin ! if No (Next (N)) then ! return Membership_Entry (N); ! else ! return Membership_Entry (N) or Membership_Entries (Next (N)); ! end if; ! end Membership_Entries; ! ! ---------------------- ! -- Membership_Entry -- ! ---------------------- ! ! function Membership_Entry (N : Node_Id) return RList is ! Val : Uint; ! SLo : Uint; ! SHi : Uint; ! ! begin ! -- Range case ! ! if Nkind (N) = N_Range then ! if not Is_Static_Expression (Low_Bound (N)) ! or else ! not Is_Static_Expression (High_Bound (N)) then ! raise Non_Static; ! else ! SLo := Expr_Value (Low_Bound (N)); ! SHi := Expr_Value (High_Bound (N)); ! return RList'(1 => REnt'(SLo, SHi)); ! end if; ! -- Static expression case ! ! elsif Is_Static_Expression (N) then ! Val := Expr_Value (N); ! return RList'(1 => REnt'(Val, Val)); ! ! -- Identifier (other than static expression) case ! ! else pragma Assert (Nkind (N) = N_Identifier); ! ! -- Type case ! ! if Is_Type (Entity (N)) then ! ! -- If type has predicates, process them ! ! if Has_Predicates (Entity (N)) then ! return Stat_Pred (Entity (N)); ! ! -- For static subtype without predicates, get range ! ! elsif Is_Static_Subtype (Entity (N)) then ! SLo := Expr_Value (Type_Low_Bound (Entity (N))); ! SHi := Expr_Value (Type_High_Bound (Entity (N))); ! return RList'(1 => REnt'(SLo, SHi)); ! ! -- Any other type makes us non-static ! ! else ! raise Non_Static; ! end if; ! ! -- Any other kind of identifier in predicate (e.g. a non-static ! -- expression value) means this is not a static predicate. ! ! else ! raise Non_Static; end if; ! end if; ! end Membership_Entry; ! --------------- ! -- Stat_Pred -- ! --------------- ! function Stat_Pred (Typ : Entity_Id) return RList is ! begin ! -- Not static if type does not have static predicates ! if not Has_Predicates (Typ) ! or else No (Static_Predicate (Typ)) then ! raise Non_Static; end if; ! -- Otherwise we convert the predicate list to a range list declare ! Result : RList (1 .. List_Length (Static_Predicate (Typ))); ! P : Node_Id; begin ! P := First (Static_Predicate (Typ)); ! for J in Result'Range loop ! Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); ! Next (P); ! end loop; ! ! return Result; ! end; ! end Stat_Pred; ! ! -- Start of processing for Build_Static_Predicate ! ! begin ! -- Now analyze the expression to see if it is a static predicate ! ! declare ! Ranges : constant RList := Get_RList (Expr); ! -- Range list from expression if it is static ! ! Plist : List_Id; ! ! begin ! -- Convert range list into a form for the static predicate. In the ! -- Ranges array, we just have raw ranges, these must be converted ! -- to properly typed and analyzed static expressions or range nodes. ! ! -- Note: here we limit ranges to the ranges of the subtype, so that ! -- a predicate is always false for values outside the subtype. That ! -- seems fine, such values are invalid anyway, and considering them ! -- to fail the predicate seems allowed and friendly, and furthermore ! -- simplifies processing for case statements and loops. ! ! Plist := New_List; ! ! for J in Ranges'Range loop ! declare ! Lo : Uint := Ranges (J).Lo; ! Hi : Uint := Ranges (J).Hi; ! ! begin ! -- Ignore completely out of range entry ! ! if Hi < TLo or else Lo > THi then ! null; ! ! -- Otherwise process entry ! ! else ! -- Adjust out of range value to subtype range ! ! if Lo < TLo then ! Lo := TLo; ! end if; ! ! if Hi > THi then ! Hi := THi; ! end if; ! ! -- Convert range into required form ! ! if Lo = Hi then ! Append_To (Plist, Build_Val (Lo)); ! else ! Append_To (Plist, Build_Range (Lo, Hi)); ! end if; ! end if; ! end; ! end loop; ! ! -- Processing was successful and all entries were static, so now we ! -- can store the result as the predicate list. ! ! Set_Static_Predicate (Typ, Plist); ! ! -- The processing for static predicates put the expression into ! -- canonical form as a series of ranges. It also eliminated ! -- duplicates and collapsed and combined ranges. We might as well ! -- replace the alternatives list of the right operand of the ! -- membership test with the static predicate list, which will ! -- usually be more efficient. ! ! declare ! New_Alts : constant List_Id := New_List; ! Old_Node : Node_Id; ! New_Node : Node_Id; ! ! begin ! Old_Node := First (Plist); ! while Present (Old_Node) loop ! New_Node := New_Copy (Old_Node); ! ! if Nkind (New_Node) = N_Range then ! Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); ! Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); ! end if; ! ! Append_To (New_Alts, New_Node); ! Next (Old_Node); ! end loop; ! ! -- If empty list, replace by False ! ! if Is_Empty_List (New_Alts) then ! Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); ! ! -- Else replace by set membership test ! else ! Rewrite (Expr, ! Make_In (Loc, ! Left_Opnd => Make_Identifier (Loc, Nam), ! Right_Opnd => Empty, ! Alternatives => New_Alts)); ! ! -- Resolve new expression in function context ! ! Install_Formals (Predicate_Function (Typ)); ! Push_Scope (Predicate_Function (Typ)); ! Analyze_And_Resolve (Expr, Standard_Boolean); ! Pop_Scope; end if; end; ! end; ! ! -- If non-static, return doing nothing ! ! exception ! when Non_Static => ! return; ! end Build_Static_Predicate; ----------------------------------- -- Check_Constant_Address_Clause -- *************** package body Sem_Ch13 is *** 3203,3213 **** -- Otherwise look at the identifier and see if it is OK ! if Ekind (Ent) = E_Named_Integer ! or else ! Ekind (Ent) = E_Named_Real ! or else ! Is_Type (Ent) then return; --- 5072,5079 ---- -- Otherwise look at the identifier and see if it is OK ! if Ekind_In (Ent, E_Named_Integer, E_Named_Real) ! or else Is_Type (Ent) then return; *************** package body Sem_Ch13 is *** 3403,3411 **** -- Start of processing for Check_Constant_Address_Clause begin ! Check_Expr_Constants (Expr); end Check_Constant_Address_Clause; ---------------- -- Check_Size -- ---------------- --- 5269,6020 ---- -- Start of processing for Check_Constant_Address_Clause begin ! -- If rep_clauses are to be ignored, no need for legality checks. In ! -- particular, no need to pester user about rep clauses that violate ! -- the rule on constant addresses, given that these clauses will be ! -- removed by Freeze before they reach the back end. ! ! if not Ignore_Rep_Clauses then ! Check_Expr_Constants (Expr); ! end if; end Check_Constant_Address_Clause; + ---------------------------------------- + -- Check_Record_Representation_Clause -- + ---------------------------------------- + + procedure Check_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ident : constant Node_Id := Identifier (N); + Rectype : Entity_Id; + Fent : Entity_Id; + CC : Node_Id; + Fbit : Uint; + Lbit : Uint; + Hbit : Uint := Uint_0; + Comp : Entity_Id; + Pcomp : Entity_Id; + + Max_Bit_So_Far : Uint; + -- Records the maximum bit position so far. If all field positions + -- are monotonically increasing, then we can skip the circuit for + -- checking for overlap, since no overlap is possible. + + Tagged_Parent : Entity_Id := Empty; + -- This is set in the case of a derived tagged type for which we have + -- Is_Fully_Repped_Tagged_Type True (indicating that all components are + -- positioned by record representation clauses). In this case we must + -- check for overlap between components of this tagged type, and the + -- components of its parent. Tagged_Parent will point to this parent + -- type. For all other cases Tagged_Parent is left set to Empty. + + Parent_Last_Bit : Uint; + -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the + -- last bit position for any field in the parent type. We only need to + -- check overlap for fields starting below this point. + + Overlap_Check_Required : Boolean; + -- Used to keep track of whether or not an overlap check is required + + Overlap_Detected : Boolean := False; + -- Set True if an overlap is detected + + Ccount : Natural := 0; + -- Number of component clauses in record rep clause + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); + -- Given two entities for record components or discriminants, checks + -- if they have overlapping component clauses and issues errors if so. + + procedure Find_Component; + -- Finds component entity corresponding to current component clause (in + -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin + -- start/stop bits for the field. If there is no matching component or + -- if the matching component does not have a component clause, then + -- that's an error and Comp is set to Empty, but no error message is + -- issued, since the message was already given. Comp is also set to + -- Empty if the current "component clause" is in fact a pragma. + + ----------------------------- + -- Check_Component_Overlap -- + ----------------------------- + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is + CC1 : constant Node_Id := Component_Clause (C1_Ent); + CC2 : constant Node_Id := Component_Clause (C2_Ent); + + begin + if Present (CC1) and then Present (CC2) then + + -- Exclude odd case where we have two tag fields in the same + -- record, both at location zero. This seems a bit strange, but + -- it seems to happen in some circumstances, perhaps on an error. + + if Chars (C1_Ent) = Name_uTag + and then + Chars (C2_Ent) = Name_uTag + then + return; + end if; + + -- Here we check if the two fields overlap + + declare + S1 : constant Uint := Component_Bit_Offset (C1_Ent); + S2 : constant Uint := Component_Bit_Offset (C2_Ent); + E1 : constant Uint := S1 + Esize (C1_Ent); + E2 : constant Uint := S2 + Esize (C2_Ent); + + begin + if E2 <= S1 or else E1 <= S2 then + null; + else + Error_Msg_Node_2 := Component_Name (CC2); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_Node_1 := Component_Name (CC1); + Error_Msg_N + ("component& overlaps & #", Component_Name (CC1)); + Overlap_Detected := True; + end if; + end; + end if; + end Check_Component_Overlap; + + -------------------- + -- Find_Component -- + -------------------- + + procedure Find_Component is + + procedure Search_Component (R : Entity_Id); + -- Search components of R for a match. If found, Comp is set. + + ---------------------- + -- Search_Component -- + ---------------------- + + procedure Search_Component (R : Entity_Id) is + begin + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + + -- Ignore error of attribute name for component name (we + -- already gave an error message for this, so no need to + -- complain here) + + if Nkind (Component_Name (CC)) = N_Attribute_Reference then + null; + else + exit when Chars (Comp) = Chars (Component_Name (CC)); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end Search_Component; + + -- Start of processing for Find_Component + + begin + -- Return with Comp set to Empty if we have a pragma + + if Nkind (CC) = N_Pragma then + Comp := Empty; + return; + end if; + + -- Search current record for matching component + + Search_Component (Rectype); + + -- If not found, maybe component of base type that is absent from + -- statically constrained first subtype. + + if No (Comp) then + Search_Component (Base_Type (Rectype)); + end if; + + -- If no component, or the component does not reference the component + -- clause in question, then there was some previous error for which + -- we already gave a message, so just return with Comp Empty. + + if No (Comp) + or else Component_Clause (Comp) /= CC + then + Comp := Empty; + + -- Normal case where we have a component clause + + else + Fbit := Component_Bit_Offset (Comp); + Lbit := Fbit + Esize (Comp) - 1; + end if; + end Find_Component; + + -- Start of processing for Check_Record_Representation_Clause + + begin + Find_Type (Ident); + Rectype := Entity (Ident); + + if Rectype = Any_Type then + return; + else + Rectype := Underlying_Type (Rectype); + end if; + + -- See if we have a fully repped derived tagged type + + declare + PS : constant Entity_Id := Parent_Subtype (Rectype); + + begin + if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then + Tagged_Parent := PS; + + -- Find maximum bit of any component of the parent type + + Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); + Pcomp := First_Entity (Tagged_Parent); + while Present (Pcomp) loop + if Ekind_In (Pcomp, E_Discriminant, E_Component) then + if Component_Bit_Offset (Pcomp) /= No_Uint + and then Known_Static_Esize (Pcomp) + then + Parent_Last_Bit := + UI_Max + (Parent_Last_Bit, + Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); + end if; + + Next_Entity (Pcomp); + end if; + end loop; + end if; + end; + + -- All done if no component clauses + + CC := First (Component_Clauses (N)); + + if No (CC) then + return; + end if; + + -- If a tag is present, then create a component clause that places it + -- at the start of the record (otherwise gigi may place it after other + -- fields that have rep clauses). + + Fent := First_Entity (Rectype); + + if Nkind (Fent) = N_Defining_Identifier + and then Chars (Fent) = Name_uTag + then + Set_Component_Bit_Offset (Fent, Uint_0); + Set_Normalized_Position (Fent, Uint_0); + Set_Normalized_First_Bit (Fent, Uint_0); + Set_Normalized_Position_Max (Fent, Uint_0); + Init_Esize (Fent, System_Address_Size); + + Set_Component_Clause (Fent, + Make_Component_Clause (Loc, + Component_Name => Make_Identifier (Loc, Name_uTag), + + Position => Make_Integer_Literal (Loc, Uint_0), + First_Bit => Make_Integer_Literal (Loc, Uint_0), + Last_Bit => + Make_Integer_Literal (Loc, + UI_From_Int (System_Address_Size)))); + + Ccount := Ccount + 1; + end if; + + Max_Bit_So_Far := Uint_Minus_1; + Overlap_Check_Required := False; + + -- Process the component clauses + + while Present (CC) loop + Find_Component; + + if Present (Comp) then + Ccount := Ccount + 1; + + -- We need a full overlap check if record positions non-monotonic + + if Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + end if; + + Max_Bit_So_Far := Lbit; + + -- Check bit position out of range of specified size + + if Has_Size_Clause (Rectype) + and then Esize (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); + + -- Check for overlap with tag field + + else + if Is_Tagged_Type (Rectype) + and then Fbit < System_Address_Size + then + Error_Msg_NE + ("component overlaps tag field of&", + Component_Name (CC), Rectype); + Overlap_Detected := True; + end if; + + if Hbit < Lbit then + Hbit := Lbit; + end if; + end if; + + -- Check parent overlap if component might overlap parent field + + if Present (Tagged_Parent) + and then Fbit <= Parent_Last_Bit + then + Pcomp := First_Component_Or_Discriminant (Tagged_Parent); + while Present (Pcomp) loop + if not Is_Tag (Pcomp) + and then Chars (Pcomp) /= Name_uParent + then + Check_Component_Overlap (Comp, Pcomp); + end if; + + Next_Component_Or_Discriminant (Pcomp); + end loop; + end if; + end if; + + Next (CC); + end loop; + + -- Now that we have processed all the component clauses, check for + -- overlap. We have to leave this till last, since the components can + -- appear in any arbitrary order in the representation clause. + + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. + + -- This first section checks if there are any overlapping entries at + -- all. It does this by sorting all entries and then seeing if there are + -- any overlaps. If there are none, then that is decisive, but if there + -- are overlaps, they may still be OK (they may result from fields in + -- different variants). + + if Overlap_Check_Required then + Overlap_Check1 : declare + + OC_Fbit : array (0 .. Ccount) of Uint; + -- First-bit values for component clauses, the value is the offset + -- of the first bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Lbit : array (0 .. Ccount) of Uint; + -- Last-bit values for component clauses, the value is the offset + -- of the last bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit + + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); + + ----------- + -- OC_Lt -- + ----------- + + function OC_Lt (Op1, Op2 : Natural) return Boolean is + begin + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; + + ------------- + -- OC_Move -- + ------------- + + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; + + -- Start of processing for Overlap_Check + + begin + CC := First (Component_Clauses (N)); + while Present (CC) loop + + -- Exclude component clause already marked in error + + if not Error_Posted (CC) then + Find_Component; + + if Present (Comp) then + OC_Count := OC_Count + 1; + OC_Fbit (OC_Count) := Fbit; + OC_Lbit (OC_Count) := Lbit; + end if; + end if; + + Next (CC); + end loop; + + Sorting.Sort (OC_Count); + + Overlap_Check_Required := False; + for J in 1 .. OC_Count - 1 loop + if OC_Lbit (J) >= OC_Fbit (J + 1) then + Overlap_Check_Required := True; + exit; + end if; + end loop; + end Overlap_Check1; + end if; + + -- If Overlap_Check_Required is still True, then we have to do the full + -- scale overlap check, since we have at least two fields that do + -- overlap, and we need to know if that is OK since they are in + -- different variant, or whether we have a definite problem. + + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap + + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked + + Citem : Node_Id; + -- Component declaration for component being checked + + begin + C1_Ent := First_Entity (Base_Type (Rectype)); + + -- Loop through all components in record. For each component check + -- for overlap with any of the preceding elements on the component + -- list containing the component and also, if the component is in + -- a variant, check against components outside the case structure. + -- This latter test is repeated recursively up the variant tree. + + Main_Component_Loop : while Present (C1_Ent) loop + if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then + goto Continue_Main_Component_Loop; + end if; + + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Possibly we are missing some checks as a result, but that + -- does not seem terribly serious. + + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; + end if; + + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); + + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. + + Component_List_Loop : loop + + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. + + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; + + -- Outer level of record definition, check discriminants + + if Nkind_In (Clist, N_Full_Type_Declaration, + N_Private_Type_Declaration) + then + if Has_Discriminants (Defining_Identifier (Clist)) then + C2_Ent := + First_Discriminant (Defining_Identifier (Clist)); + while Present (C2_Ent) loop + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + Next_Discriminant (C2_Ent); + end loop; + end if; + + -- Record extension case + + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; + + -- Otherwise check one component list + + else + Citem := First (Component_Items (Clist)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + C2_Ent := Defining_Identifier (Citem); + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + end if; + + Next (Citem); + end loop; + end if; + + -- Check for variants above us (the parent of the Clist can + -- be a variant, in which case its parent is a variant part, + -- and the parent of the variant part is a component list + -- whose components must all be checked against the current + -- component for overlap). + + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); + + -- Check for possible discriminant part in record, this + -- is treated essentially as another level in the + -- recursion. For this case the parent of the component + -- list is the record definition, and its parent is the + -- full type declaration containing the discriminant + -- specifications. + + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); + + -- If neither of these two cases, we are at the top of + -- the tree. + + else + exit Component_List_Loop; + end if; + end loop Component_List_Loop; + + <> + Next_Entity (C1_Ent); + + end loop Main_Component_Loop; + end Overlap_Check2; + end if; + + -- The following circuit deals with warning on record holes (gaps). We + -- skip this check if overlap was detected, since it makes sense for the + -- programmer to fix this illegality before worrying about warnings. + + if not Overlap_Detected and Warn_On_Record_Holes then + Record_Hole_Check : declare + Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); + -- Full declaration of record type + + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id); + -- Check component list CL for holes. The starting bit should be + -- Sbit. which is zero for the main record component list and set + -- appropriately for recursive calls for variants. DS is set to + -- a list of discriminant specifications to be included in the + -- consideration of components. It is No_List if none to consider. + + -------------------------- + -- Check_Component_List -- + -------------------------- + + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id) + is + Compl : Integer; + + begin + Compl := Integer (List_Length (Component_Items (CL))); + + if DS /= No_List then + Compl := Compl + Integer (List_Length (DS)); + end if; + + declare + Comps : array (Natural range 0 .. Compl) of Entity_Id; + -- Gather components (zero entry is for sort routine) + + Ncomps : Natural := 0; + -- Number of entries stored in Comps (starting at Comps (1)) + + Citem : Node_Id; + -- One component item or discriminant specification + + Nbit : Uint; + -- Starting bit for next component + + CEnt : Entity_Id; + -- Component entity + + Variant : Node_Id; + -- One variant + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Component_Bit_Offset (Comps (Op1)) + < + Component_Bit_Offset (Comps (Op2)); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end Move; + + begin + -- Gather discriminants into Comp + + if DS /= No_List then + Citem := First (DS); + while Present (Citem) loop + if Nkind (Citem) = N_Discriminant_Specification then + declare + Ent : constant Entity_Id := + Defining_Identifier (Citem); + begin + if Ekind (Ent) = E_Discriminant then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Ent; + end if; + end; + end if; + + Next (Citem); + end loop; + end if; + + -- Gather component entities into Comp + + Citem := First (Component_Items (CL)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Defining_Identifier (Citem); + end if; + + Next (Citem); + end loop; + + -- Now sort the component entities based on the first bit. + -- Note we already know there are no overlapping components. + + Sorting.Sort (Ncomps); + + -- Loop through entries checking for holes + + Nbit := Sbit; + for J in 1 .. Ncomps loop + CEnt := Comps (J); + Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit; + + if Error_Msg_Uint_1 > 0 then + Error_Msg_NE + ("?^-bit gap before component&", + Component_Name (Component_Clause (CEnt)), CEnt); + end if; + + Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); + end loop; + + -- Process variant parts recursively if present + + if Present (Variant_Part (CL)) then + Variant := First (Variants (Variant_Part (CL))); + while Present (Variant) loop + Check_Component_List + (Component_List (Variant), Nbit, No_List); + Next (Variant); + end loop; + end if; + end; + end Check_Component_List; + + -- Start of processing for Record_Hole_Check + + begin + declare + Sbit : Uint; + + begin + if Is_Tagged_Type (Rectype) then + Sbit := UI_From_Int (System_Address_Size); + else + Sbit := Uint_0; + end if; + + if Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + then + Check_Component_List + (Component_List (Type_Definition (Decl)), + Sbit, + Discriminant_Specifications (Decl)); + end if; + end; + end Record_Hole_Check; + end if; + + -- For records that have component clauses for all components, and whose + -- size is less than or equal to 32, we need to know the size in the + -- front end to activate possible packed array processing where the + -- component type is a record. + + -- At this stage Hbit + 1 represents the first unused bit from all the + -- component clauses processed, so if the component clauses are + -- complete, then this is the length of the record. + + -- For records longer than System.Storage_Unit, and for those where not + -- all components have component clauses, the back end determines the + -- length (it may for example be appropriate to round up the size + -- to some convenient boundary, based on alignment considerations, etc). + + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then + + -- Nothing to do if at least one component has no component clause + + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + exit when No (Component_Clause (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; + + -- If we fall out of loop, all components have component clauses + -- and so we can set the size to the maximum value. + + if No (Comp) then + Set_RM_Size (Rectype, Hbit + 1); + end if; + end if; + end Check_Record_Representation_Clause; + ---------------- -- Check_Size -- ---------------- *************** package body Sem_Ch13 is *** 3566,3571 **** --- 6175,6182 ---- procedure Initialize is begin + Address_Clause_Checks.Init; + Independence_Checks.Init; Unchecked_Conversions.Init; end Initialize; *************** package body Sem_Ch13 is *** 3879,3887 **** Out_Present => Out_P, Parameter_Type => T_Ref)); ! Spec := Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Subp_Id, ! Parameter_Specifications => Formals); end if; return Spec; --- 6490,6499 ---- Out_Present => Out_P, Parameter_Type => T_Ref)); ! Spec := ! Make_Procedure_Specification (Loc, ! Defining_Unit_Name => Subp_Id, ! Parameter_Specifications => Formals); end if; return Spec; *************** package body Sem_Ch13 is *** 3917,3924 **** else Subp_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Sname, 'V')); Subp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Subp_Id, --- 6529,6535 ---- else Subp_Id := ! Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V')); Subp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Subp_Id, *************** package body Sem_Ch13 is *** 3955,3962 **** elsif Is_Type (T) and then Is_Generic_Type (Root_Type (T)) then ! Error_Msg_N ! ("representation item not allowed for generic type", N); return True; end if; --- 6566,6572 ---- elsif Is_Type (T) and then Is_Generic_Type (Root_Type (T)) then ! Error_Msg_N ("representation item not allowed for generic type", N); return True; end if; *************** package body Sem_Ch13 is *** 4081,4086 **** --- 6691,6803 ---- return False; end Rep_Item_Too_Late; + ------------------------------------- + -- Replace_Type_References_Generic -- + ------------------------------------- + + procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is + + function Replace_Node (N : Node_Id) return Traverse_Result; + -- Processes a single node in the traversal procedure below, checking + -- if node N should be replaced, and if so, doing the replacement. + + procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node); + -- This instantiation provides the body of Replace_Type_References + + ------------------ + -- Replace_Node -- + ------------------ + + function Replace_Node (N : Node_Id) return Traverse_Result is + S : Entity_Id; + P : Node_Id; + + begin + -- Case of identifier + + if Nkind (N) = N_Identifier then + + -- If not the type name, all done with this node + + if Chars (N) /= TName then + return Skip; + + -- Otherwise do the replacement and we are done with this node + + else + Replace_Type_Reference (N); + return Skip; + end if; + + -- Case of selected component (which is what a qualification + -- looks like in the unanalyzed tree, which is what we have. + + elsif Nkind (N) = N_Selected_Component then + + -- If selector name is not our type, keeping going (we might + -- still have an occurrence of the type in the prefix). + + if Nkind (Selector_Name (N)) /= N_Identifier + or else Chars (Selector_Name (N)) /= TName + then + return OK; + + -- Selector name is our type, check qualification + + else + -- Loop through scopes and prefixes, doing comparison + + S := Current_Scope; + P := Prefix (N); + loop + -- Continue if no more scopes or scope with no name + + if No (S) or else Nkind (S) not in N_Has_Chars then + return OK; + end if; + + -- Do replace if prefix is an identifier matching the + -- scope that we are currently looking at. + + if Nkind (P) = N_Identifier + and then Chars (P) = Chars (S) + then + Replace_Type_Reference (N); + return Skip; + end if; + + -- Go check scope above us if prefix is itself of the + -- form of a selected component, whose selector matches + -- the scope we are currently looking at. + + if Nkind (P) = N_Selected_Component + and then Nkind (Selector_Name (P)) = N_Identifier + and then Chars (Selector_Name (P)) = Chars (S) + then + S := Scope (S); + P := Prefix (P); + + -- For anything else, we don't have a match, so keep on + -- going, there are still some weird cases where we may + -- still have a replacement within the prefix. + + else + return OK; + end if; + end loop; + end if; + + -- Continue for any other node kind + + else + return OK; + end if; + end Replace_Node; + + begin + Replace_Type_Refs (N); + end Replace_Type_References_Generic; + ------------------------- -- Same_Representation -- ------------------------- *************** package body Sem_Ch13 is *** 4256,4262 **** -- cases were already dealt with. elsif Is_Enumeration_Type (T1) then - Enumeration_Case : declare L1, L2 : Entity_Id; --- 6973,6978 ---- *************** package body Sem_Ch13 is *** 4284,4289 **** --- 7000,7026 ---- end if; end Same_Representation; + ---------------- + -- Set_Biased -- + ---------------- + + procedure Set_Biased + (E : Entity_Id; + N : Node_Id; + Msg : String; + Biased : Boolean := True) + is + begin + if Biased then + Set_Has_Biased_Representation (E); + + if Warn_On_Biased_Representation then + Error_Msg_NE + ("?" & Msg & " forces biased representation for&", N, E); + end if; + end if; + end Set_Biased; + -------------------- -- Set_Enum_Esize -- -------------------- *************** package body Sem_Ch13 is *** 4441,4446 **** --- 7178,7469 ---- end loop; end Validate_Address_Clauses; + --------------------------- + -- Validate_Independence -- + --------------------------- + + procedure Validate_Independence is + SU : constant Uint := UI_From_Int (System_Storage_Unit); + N : Node_Id; + E : Entity_Id; + IC : Boolean; + Comp : Entity_Id; + Addr : Node_Id; + P : Node_Id; + + procedure Check_Array_Type (Atyp : Entity_Id); + -- Checks if the array type Atyp has independent components, and + -- if not, outputs an appropriate set of error messages. + + procedure No_Independence; + -- Output message that independence cannot be guaranteed + + function OK_Component (C : Entity_Id) return Boolean; + -- Checks one component to see if it is independently accessible, and + -- if so yields True, otherwise yields False if independent access + -- cannot be guaranteed. This is a conservative routine, it only + -- returns True if it knows for sure, it returns False if it knows + -- there is a problem, or it cannot be sure there is no problem. + + procedure Reason_Bad_Component (C : Entity_Id); + -- Outputs continuation message if a reason can be determined for + -- the component C being bad. + + ---------------------- + -- Check_Array_Type -- + ---------------------- + + procedure Check_Array_Type (Atyp : Entity_Id) is + Ctyp : constant Entity_Id := Component_Type (Atyp); + + begin + -- OK if no alignment clause, no pack, and no component size + + if not Has_Component_Size_Clause (Atyp) + and then not Has_Alignment_Clause (Atyp) + and then not Is_Packed (Atyp) + then + return; + end if; + + -- Check actual component size + + if not Known_Component_Size (Atyp) + or else not (Addressable (Component_Size (Atyp)) + and then Component_Size (Atyp) < 64) + or else Component_Size (Atyp) mod Esize (Ctyp) /= 0 + then + No_Independence; + + -- Bad component size, check reason + + if Has_Component_Size_Clause (Atyp) then + P := + Get_Attribute_Definition_Clause + (Atyp, Attribute_Component_Size); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of Component_Size clause#", N); + return; + end if; + end if; + + if Is_Packed (Atyp) then + P := Get_Rep_Pragma (Atyp, Name_Pack); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of pragma Pack#", N); + return; + end if; + end if; + + -- No reason found, just return + + return; + end if; + + -- Array type is OK independence-wise + + return; + end Check_Array_Type; + + --------------------- + -- No_Independence -- + --------------------- + + procedure No_Independence is + begin + if Pragma_Name (N) = Name_Independent then + Error_Msg_NE + ("independence cannot be guaranteed for&", N, E); + else + Error_Msg_NE + ("independent components cannot be guaranteed for&", N, E); + end if; + end No_Independence; + + ------------------ + -- OK_Component -- + ------------------ + + function OK_Component (C : Entity_Id) return Boolean is + Rec : constant Entity_Id := Scope (C); + Ctyp : constant Entity_Id := Etype (C); + + begin + -- OK if no component clause, no Pack, and no alignment clause + + if No (Component_Clause (C)) + and then not Is_Packed (Rec) + and then not Has_Alignment_Clause (Rec) + then + return True; + end if; + + -- Here we look at the actual component layout. A component is + -- addressable if its size is a multiple of the Esize of the + -- component type, and its starting position in the record has + -- appropriate alignment, and the record itself has appropriate + -- alignment to guarantee the component alignment. + + -- Make sure sizes are static, always assume the worst for any + -- cases where we cannot check static values. + + if not (Known_Static_Esize (C) + and then Known_Static_Esize (Ctyp)) + then + return False; + end if; + + -- Size of component must be addressable or greater than 64 bits + -- and a multiple of bytes. + + if not Addressable (Esize (C)) + and then Esize (C) < Uint_64 + then + return False; + end if; + + -- Check size is proper multiple + + if Esize (C) mod Esize (Ctyp) /= 0 then + return False; + end if; + + -- Check alignment of component is OK + + if not Known_Component_Bit_Offset (C) + or else Component_Bit_Offset (C) < Uint_0 + or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0 + then + return False; + end if; + + -- Check alignment of record type is OK + + if not Known_Alignment (Rec) + or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 + then + return False; + end if; + + -- All tests passed, component is addressable + + return True; + end OK_Component; + + -------------------------- + -- Reason_Bad_Component -- + -------------------------- + + procedure Reason_Bad_Component (C : Entity_Id) is + Rec : constant Entity_Id := Scope (C); + Ctyp : constant Entity_Id := Etype (C); + + begin + -- If component clause present assume that's the problem + + if Present (Component_Clause (C)) then + Error_Msg_Sloc := Sloc (Component_Clause (C)); + Error_Msg_N ("\because of Component_Clause#", N); + return; + end if; + + -- If pragma Pack clause present, assume that's the problem + + if Is_Packed (Rec) then + P := Get_Rep_Pragma (Rec, Name_Pack); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of pragma Pack#", N); + return; + end if; + end if; + + -- See if record has bad alignment clause + + if Has_Alignment_Clause (Rec) + and then Known_Alignment (Rec) + and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 + then + P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment); + + if Present (P) then + Error_Msg_Sloc := Sloc (P); + Error_Msg_N ("\because of Alignment clause#", N); + end if; + end if; + + -- Couldn't find a reason, so return without a message + + return; + end Reason_Bad_Component; + + -- Start of processing for Validate_Independence + + begin + for J in Independence_Checks.First .. Independence_Checks.Last loop + N := Independence_Checks.Table (J).N; + E := Independence_Checks.Table (J).E; + IC := Pragma_Name (N) = Name_Independent_Components; + + -- Deal with component case + + if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then + if not OK_Component (E) then + No_Independence; + Reason_Bad_Component (E); + goto Continue; + end if; + end if; + + -- Deal with record with Independent_Components + + if IC and then Is_Record_Type (E) then + Comp := First_Component_Or_Discriminant (E); + while Present (Comp) loop + if not OK_Component (Comp) then + No_Independence; + Reason_Bad_Component (Comp); + goto Continue; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + + -- Deal with address clause case + + if Is_Object (E) then + Addr := Address_Clause (E); + + if Present (Addr) then + No_Independence; + Error_Msg_Sloc := Sloc (Addr); + Error_Msg_N ("\because of Address clause#", N); + goto Continue; + end if; + end if; + + -- Deal with independent components for array type + + if IC and then Is_Array_Type (E) then + Check_Array_Type (E); + end if; + + -- Deal with independent components for array object + + if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then + Check_Array_Type (Etype (E)); + end if; + + <> null; + end loop; + end Validate_Independence; + ----------------------------------- -- Validate_Unchecked_Conversion -- ----------------------------------- diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch13.ads gcc-4.6.0/gcc/ada/sem_ch13.ads *** gcc-4.5.2/gcc/ada/sem_ch13.ads Wed Jul 29 10:34:29 2009 --- gcc-4.6.0/gcc/ada/sem_ch13.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Table; with Types; use Types; with Uintp; use Uintp; *************** package Sem_Ch13 is *** 35,46 **** procedure Analyze_Record_Representation_Clause (N : Node_Id); procedure Analyze_Code_Statement (N : Node_Id); procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); -- Called from Freeze where R is a record entity for which reverse bit -- order is specified and there is at least one component clause. Adjusts ! -- component positions according to Ada 2005 AI-133. Note that this is only ! -- called in Ada 2005 mode. The Ada 95 handling for bit order is entirely ! -- contained in Freeze. procedure Initialize; -- Initialize internal tables for new compilation --- 36,77 ---- procedure Analyze_Record_Representation_Clause (N : Node_Id); procedure Analyze_Code_Statement (N : Node_Id); + procedure Analyze_Aspect_Specifications + (N : Node_Id; + E : Entity_Id; + L : List_Id); + -- This procedure is called to analyze aspect specifications for node N. E + -- is the corresponding entity declared by the declaration node N, and L is + -- the list of aspect specifications for this node. If L is No_List, the + -- call is ignored. Note that we can't use a simpler interface of just + -- passing the node N, since the analysis of the node may cause it to be + -- rewritten to a node not permitting aspect specifications. + procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); -- Called from Freeze where R is a record entity for which reverse bit -- order is specified and there is at least one component clause. Adjusts ! -- component positions according to either Ada 95 or Ada 2005 (AI-133). ! ! 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 ! -- rep chain, note that Invariant aspects have already been converted to ! -- pragma Invariant), then this procedure builds the spec and body for the ! -- corresponding Invariant procedure, inserting them at appropriate points ! -- in the package specification N. Invariant_Procedure is set for Typ. Note ! -- that this procedure is called at the end of processing the declarations ! -- in the visible part (i.e. the right point for visibility analysis of ! -- the invariant expression). ! ! procedure Check_Record_Representation_Clause (N : Node_Id); ! -- This procedure completes the analysis of a record representation clause ! -- N. It is called at freeze time after adjustment of component clause bit ! -- positions for possible non-standard bit order. In the case of Ada 2005 ! -- (machine scalar) mode, this adjustment can make substantial changes, so ! -- some checks, in particular for component overlaps cannot be done at the ! -- time the record representation clause is first seen, but must be delayed ! -- till freeze time, and in particular is called after calling the above ! -- procedure for adjusting record bit positions for reverse bit order. procedure Initialize; -- Initialize internal tables for new compilation *************** package Sem_Ch13 is *** 139,144 **** --- 170,180 ---- -- the case of a private or incomplete type. The protocol is to first -- check for Rep_Item_Too_Early using the initial entity, then take the -- underlying type, then call Rep_Item_Too_Late on the result. + -- + -- Note: Calls to Rep_Item_Too_Late are ignored for the case of attribute + -- definition clauses which have From_Aspect_Specification set. This is + -- because such clauses are linked on to the Rep_Item chain in procedure + -- Sem_Ch13.Analyze_Aspect_Specifications. See that procedure for details. function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean; -- Given two types, where the two types are related by possible derivation, *************** package Sem_Ch13 is *** 159,168 **** -- back end as required. procedure Validate_Unchecked_Conversions; ! -- This routine is called after calling the backend to validate ! -- unchecked conversions for size and alignment appropriateness. ! -- The reason it is called that late is to take advantage of any ! -- back-annotation of size and alignment performed by the backend. procedure Validate_Address_Clauses; -- This is called after the back end has been called (and thus after the --- 195,204 ---- -- back end as required. procedure Validate_Unchecked_Conversions; ! -- This routine is called after calling the backend to validate unchecked ! -- conversions for size and alignment appropriateness. The reason it is ! -- called that late is to take advantage of any back-annotation of size ! -- and alignment performed by the backend. procedure Validate_Address_Clauses; -- This is called after the back end has been called (and thus after the *************** package Sem_Ch13 is *** 170,173 **** --- 206,239 ---- -- table of saved address clauses checking for suspicious alignments and -- if necessary issuing warnings. + procedure Validate_Independence; + -- This is called after the back end has been called (and thus after the + -- layout of components has been back annotated). It goes through the + -- table of saved pragma Independent[_Component] entries, checking that + -- independence can be achieved, and if necessary issuing error messages. + + ------------------------------------- + -- Table for Validate_Independence -- + ------------------------------------- + + -- If a legal pragma Independent or Independent_Components is given for + -- an entity, then an entry is made in this table, to be checked by a + -- call to Validate_Independence after back annotation of layout is done. + + type Independence_Check_Record is record + N : Node_Id; + -- The pragma Independent or Independent_Components + + E : Entity_Id; + -- The entity to which it applies + end record; + + package Independence_Checks is new Table.Table ( + Table_Component_Type => Independence_Check_Record, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 200, + Table_Name => "Independence_Checks"); + end Sem_Ch13; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch3.adb gcc-4.6.0/gcc/ada/sem_ch3.adb *** gcc-4.5.2/gcc/ada/sem_ch3.adb Thu Dec 3 15:10:58 2009 --- gcc-4.6.0/gcc/ada/sem_ch3.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; *************** with Sem_Dist; use Sem_Dist; *** 61,66 **** --- 62,68 ---- with Sem_Elim; use Sem_Elim; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; + with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Smem; use Sem_Smem; with Sem_Type; use Sem_Type; *************** with Sem_Util; use Sem_Util; *** 68,73 **** --- 70,76 ---- with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; + with Sinput; use Sinput; with Snames; use Snames; with Targparm; use Targparm; with Tbuild; use Tbuild; *************** package body Sem_Ch3 is *** 281,289 **** (N : Node_Id; T : Entity_Id; Prev : Entity_Id := Empty); ! -- If T is the full declaration of an incomplete or private type, check the ! -- conformance of the discriminants, otherwise process them. Prev is the ! -- entity of the partial declaration, if any. procedure Check_Real_Bound (Bound : Node_Id); -- Check given bound for being of real type and static. If not, post an --- 284,294 ---- (N : Node_Id; T : Entity_Id; Prev : Entity_Id := Empty); ! -- If N is the full declaration of the completion T of an incomplete or ! -- private type, check its discriminants (which are already known to be ! -- conformant with those of the partial view, see Find_Type_Name), ! -- otherwise process them. Prev is the entity of the partial declaration, ! -- if any. procedure Check_Real_Bound (Bound : Node_Id); -- Check given bound for being of real type and static. If not, post an *************** package body Sem_Ch3 is *** 441,447 **** Related_Id : Entity_Id; Suffix : Character; Suffix_Index : Nat); ! -- Process an index constraint in a constrained array declaration. The -- constraint can be a subtype name, or a range with or without an explicit -- subtype mark. The index is the corresponding index of the unconstrained -- array. The Related_Id and Suffix parameters are used to build the --- 446,452 ---- Related_Id : Entity_Id; Suffix : Character; Suffix_Index : Nat); ! -- Process an index constraint S in a constrained array declaration. The -- constraint can be a subtype name, or a range with or without an explicit -- subtype mark. The index is the corresponding index of the unconstrained -- array. The Related_Id and Suffix parameters are used to build the *************** package body Sem_Ch3 is *** 481,488 **** -- operations of progenitors of Tagged_Type, and replace the subsidiary -- subtypes with Tagged_Type, to build the specs of the inherited interface -- primitives. The derived primitives are aliased to those of the ! -- interface. This routine takes care also of transferring to the full-view ! -- subprograms associated with the partial-view of Tagged_Type that cover -- interface primitives. procedure Derived_Standard_Character --- 486,493 ---- -- operations of progenitors of Tagged_Type, and replace the subsidiary -- subtypes with Tagged_Type, to build the specs of the inherited interface -- primitives. The derived primitives are aliased to those of the ! -- interface. This routine takes care also of transferring to the full view ! -- subprograms associated with the partial view of Tagged_Type that cover -- interface primitives. procedure Derived_Standard_Character *************** package body Sem_Ch3 is *** 573,586 **** -- copying the record declaration for the derived base. In the tagged case -- the value returned is irrelevant. - function Is_Progenitor - (Iface : Entity_Id; - Typ : Entity_Id) return Boolean; - -- Determine whether the interface Iface is implemented by Typ. It requires - -- traversing the list of abstract interfaces of the type, as well as that - -- of the ancestor types. The predicate is used to determine when a formal - -- in the signature of an inherited operation must carry the derived type. - function Is_Valid_Constraint_Kind (T_Kind : Type_Kind; Constraint_Kind : Node_Kind) return Boolean; --- 578,583 ---- *************** package body Sem_Ch3 is *** 787,793 **** (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); if All_Present (N) ! and then Ada_Version >= Ada_05 then Error_Msg_N ("ALL is not permitted for anonymous access types", N); end if; --- 784,790 ---- (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); if All_Present (N) ! and then Ada_Version >= Ada_2005 then Error_Msg_N ("ALL is not permitted for anonymous access types", N); end if; *************** package body Sem_Ch3 is *** 836,852 **** Layout_Type (Anon_Type); end if; - -- ???The following makes no sense, because Anon_Type is an access type - -- and therefore cannot have components, private or otherwise. Hence - -- the assertion. Not sure what was meant, here. - Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type)); - pragma Assert (not Depends_On_Private (Anon_Type)); - -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if -- the null value is allowed. In Ada 95 the null value is never allowed. ! if Ada_Version >= Ada_05 then Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); else Set_Can_Never_Be_Null (Anon_Type, True); --- 833,843 ---- Layout_Type (Anon_Type); end if; -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if -- the null value is allowed. In Ada 95 the null value is never allowed. ! if Ada_Version >= Ada_2005 then Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); else Set_Can_Never_Be_Null (Anon_Type, True); *************** package body Sem_Ch3 is *** 897,902 **** --- 888,894 ---- elsif Has_Task (Desig_Type) and then Comes_From_Source (Related_Nod) + and then not Restriction_Active (No_Task_Hierarchy) then if not Has_Master_Entity (Current_Scope) then Decl := *************** package body Sem_Ch3 is *** 1037,1044 **** begin -- Associate the Itype node with the inner full-type declaration or ! -- subprogram spec. This is required to handle nested anonymous ! -- declarations. For example: -- procedure P -- (X : access procedure --- 1029,1036 ---- begin -- Associate the Itype node with the inner full-type declaration or ! -- subprogram spec or entry body. This is required to handle nested ! -- anonymous declarations. For example: -- procedure P -- (X : access procedure *************** package body Sem_Ch3 is *** 1050,1056 **** N_Private_Type_Declaration, N_Private_Extension_Declaration, N_Procedure_Specification, ! N_Function_Specification) or else Nkind_In (D_Ityp, N_Object_Declaration, N_Object_Renaming_Declaration, --- 1042,1050 ---- N_Private_Type_Declaration, N_Private_Extension_Declaration, N_Procedure_Specification, ! N_Function_Specification, ! N_Entry_Body) ! or else Nkind_In (D_Ityp, N_Object_Declaration, N_Object_Renaming_Declaration, *************** package body Sem_Ch3 is *** 1122,1130 **** else if From_With_Type (Typ) then ! Error_Msg_NE ! ("illegal use of incomplete type&", ! Result_Definition (T_Def), Typ); elsif Ekind (Current_Scope) = E_Package and then In_Private_Part (Current_Scope) --- 1116,1133 ---- else if From_With_Type (Typ) then ! ! -- AI05-151: Incomplete types are allowed in all basic ! -- declarations, including access to subprograms. ! ! if Ada_Version >= Ada_2012 then ! null; ! ! else ! Error_Msg_NE ! ("illegal use of incomplete type&", ! Result_Definition (T_Def), Typ); ! end if; elsif Ekind (Current_Scope) = E_Package and then In_Private_Part (Current_Scope) *************** package body Sem_Ch3 is *** 1358,1370 **** pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); Def := Make_Component_Definition (Loc, Aliased_Present => True, Subtype_Indication => New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); ! Tag := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); Decl := Make_Component_Declaration (Loc, --- 1361,1379 ---- pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); + -- This is a reasonable place to propagate predicates + + if Has_Predicates (Iface) then + Set_Has_Predicates (Typ); + end if; + Def := Make_Component_Definition (Loc, Aliased_Present => True, Subtype_Indication => New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); ! Tag := Make_Temporary (Loc, 'V'); Decl := Make_Component_Declaration (Loc, *************** package body Sem_Ch3 is *** 1406,1413 **** Subtype_Indication => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); ! Offset := ! Make_Defining_Identifier (Loc, New_Internal_Name ('V')); Decl := Make_Component_Declaration (Loc, --- 1415,1421 ---- Subtype_Indication => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); ! Offset := Make_Temporary (Loc, 'V'); Decl := Make_Component_Declaration (Loc, *************** package body Sem_Ch3 is *** 1515,1603 **** ------------------------------------- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is ! Elmt : Elmt_Id; ! Iface : Entity_Id; ! Iface_Elmt : Elmt_Id; ! Iface_Prim : Entity_Id; ! Ifaces_List : Elist_Id; ! New_Subp : Entity_Id := Empty; ! Prim : Entity_Id; begin ! pragma Assert (Ada_Version >= Ada_05 and then Is_Record_Type (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) and then Has_Interfaces (Tagged_Type) and then not Is_Interface (Tagged_Type)); Collect_Interfaces (Tagged_Type, Ifaces_List); Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); ! -- Exclude from this processing interfaces that are parents of ! -- Tagged_Type because their primitives are located in the primary ! -- dispatch table (and hence no auxiliary internal entities are ! -- required to handle secondary dispatch tables in such case). ! if not Is_Ancestor (Iface, Tagged_Type) then ! Elmt := First_Elmt (Primitive_Operations (Iface)); ! while Present (Elmt) loop ! Iface_Prim := Node (Elmt); ! if not Is_Predefined_Dispatching_Operation (Iface_Prim) then ! Prim := ! Find_Primitive_Covering_Interface ! (Tagged_Type => Tagged_Type, ! Iface_Prim => Iface_Prim); ! pragma Assert (Present (Prim)); Derive_Subprogram (New_Subp => New_Subp, Parent_Subp => Iface_Prim, Derived_Type => Tagged_Type, Parent_Type => Iface); ! -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp ! -- associated with interface types. These entities are ! -- only registered in the list of primitives of its ! -- corresponding tagged type because they are only used ! -- to fill the contents of the secondary dispatch tables. ! -- Therefore they are removed from the homonym chains. ! Set_Is_Hidden (New_Subp); ! Set_Is_Internal (New_Subp); ! Set_Alias (New_Subp, Prim); ! Set_Is_Abstract_Subprogram (New_Subp, ! Is_Abstract_Subprogram (Prim)); ! Set_Interface_Alias (New_Subp, Iface_Prim); ! -- Internal entities associated with interface types are ! -- only registered in the list of primitives of the tagged ! -- type. They are only used to fill the contents of the ! -- secondary dispatch tables. Therefore they are not needed ! -- in the homonym chains. ! Remove_Homonym (New_Subp); ! -- Hidden entities associated with interfaces must have set ! -- the Has_Delay_Freeze attribute to ensure that, in case of ! -- locally defined tagged types (or compiling with static ! -- dispatch tables generation disabled) the corresponding ! -- entry of the secondary dispatch table is filled when ! -- such an entity is frozen. ! Set_Has_Delayed_Freeze (New_Subp); ! end if; ! Next_Elmt (Elmt); ! end loop; ! end if; Next_Elmt (Iface_Elmt); end loop; end Add_Internal_Interface_Entities; ----------------------------------- --- 1523,1644 ---- ------------------------------------- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is ! Elmt : Elmt_Id; ! Iface : Entity_Id; ! Iface_Elmt : Elmt_Id; ! Iface_Prim : Entity_Id; ! Ifaces_List : Elist_Id; ! New_Subp : Entity_Id := Empty; ! Prim : Entity_Id; ! Restore_Scope : Boolean := False; begin ! pragma Assert (Ada_Version >= Ada_2005 and then Is_Record_Type (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) and then Has_Interfaces (Tagged_Type) and then not Is_Interface (Tagged_Type)); + -- Ensure that the internal entities are added to the scope of the type + + if Scope (Tagged_Type) /= Current_Scope then + Push_Scope (Scope (Tagged_Type)); + Restore_Scope := True; + end if; + Collect_Interfaces (Tagged_Type, Ifaces_List); Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); ! -- Originally we excluded here from this processing interfaces that ! -- are parents of Tagged_Type because their primitives are located ! -- in the primary dispatch table (and hence no auxiliary internal ! -- entities are required to handle secondary dispatch tables in such ! -- case). However, these auxiliary entities are also required to ! -- handle derivations of interfaces in formals of generics (see ! -- Derive_Subprograms). ! Elmt := First_Elmt (Primitive_Operations (Iface)); ! while Present (Elmt) loop ! Iface_Prim := Node (Elmt); ! if not Is_Predefined_Dispatching_Operation (Iface_Prim) then ! Prim := ! Find_Primitive_Covering_Interface ! (Tagged_Type => Tagged_Type, ! Iface_Prim => Iface_Prim); ! pragma Assert (Present (Prim)); + -- Ada 2012 (AI05-0197): If the name of the covering primitive + -- differs from the name of the interface primitive then it is + -- a private primitive inherited from a parent type. In such + -- case, given that Tagged_Type covers the interface, the + -- inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. + + if Chars (Prim) /= Chars (Iface_Prim) then + pragma Assert (Has_Suffix (Prim, 'P')); Derive_Subprogram (New_Subp => New_Subp, Parent_Subp => Iface_Prim, Derived_Type => Tagged_Type, Parent_Type => Iface); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Prim)); + end if; ! Derive_Subprogram ! (New_Subp => New_Subp, ! Parent_Subp => Iface_Prim, ! Derived_Type => Tagged_Type, ! Parent_Type => Iface); ! -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp ! -- associated with interface types. These entities are ! -- only registered in the list of primitives of its ! -- corresponding tagged type because they are only used ! -- to fill the contents of the secondary dispatch tables. ! -- Therefore they are removed from the homonym chains. ! Set_Is_Hidden (New_Subp); ! Set_Is_Internal (New_Subp); ! Set_Alias (New_Subp, Prim); ! Set_Is_Abstract_Subprogram ! (New_Subp, Is_Abstract_Subprogram (Prim)); ! Set_Interface_Alias (New_Subp, Iface_Prim); ! -- Internal entities associated with interface types are ! -- only registered in the list of primitives of the tagged ! -- type. They are only used to fill the contents of the ! -- secondary dispatch tables. Therefore they are not needed ! -- in the homonym chains. ! Remove_Homonym (New_Subp); ! -- Hidden entities associated with interfaces must have set ! -- the Has_Delay_Freeze attribute to ensure that, in case of ! -- locally defined tagged types (or compiling with static ! -- dispatch tables generation disabled) the corresponding ! -- entry of the secondary dispatch table is filled when ! -- such an entity is frozen. ! Set_Has_Delayed_Freeze (New_Subp); ! end if; ! ! Next_Elmt (Elmt); ! end loop; Next_Elmt (Iface_Elmt); end loop; + + if Restore_Scope then + Pop_Scope; + end if; end Add_Internal_Interface_Entities; ----------------------------------- *************** package body Sem_Ch3 is *** 1775,1781 **** Preanalyze_Spec_Expression (E, T); Check_Initialization (T, E); ! if Ada_Version >= Ada_05 and then Ekind (T) = E_Anonymous_Access_Type and then Etype (E) /= Any_Type then --- 1816,1822 ---- Preanalyze_Spec_Expression (E, T); Check_Initialization (T, E); ! if Ada_Version >= Ada_2005 and then Ekind (T) = E_Anonymous_Access_Type and then Etype (E) /= Any_Type then *************** package body Sem_Ch3 is *** 1866,1872 **** -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks. ! if Ada_Version >= Ada_05 and then Can_Never_Be_Null (T) then Null_Exclusion_Static_Checks (N); --- 1907,1913 ---- -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks. ! if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then Null_Exclusion_Static_Checks (N); *************** package body Sem_Ch3 is *** 1913,1920 **** if Is_Interface (Root_Type (Current_Scope)) then Error_Msg_N ("\limitedness is not inherited from limited interface", N); ! Error_Msg_N ! ("\add LIMITED to type indication", N); end if; Explain_Limited_Type (T, N); --- 1954,1960 ---- if Is_Interface (Root_Type (Current_Scope)) then Error_Msg_N ("\limitedness is not inherited from limited interface", N); ! Error_Msg_N ("\add LIMITED to type indication", N); end if; Explain_Limited_Type (T, N); *************** package body Sem_Ch3 is *** 1934,1939 **** --- 1974,1980 ---- end if; Set_Original_Record_Component (Id, Id); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Component_Declaration; -------------------------- *************** package body Sem_Ch3 is *** 2057,2064 **** --- 2098,2431 ---- D := Next_Node; end loop; + + -- One more thing to do, we need to scan the declarations to check + -- for any precondition/postcondition pragmas (Pre/Post aspects have + -- by this stage been converted into corresponding pragmas). It is + -- at this point that we analyze the expressions in such pragmas, + -- to implement the delayed visibility requirement. + + declare + Decl : Node_Id; + Spec : Node_Id; + Sent : Entity_Id; + Prag : Node_Id; + + begin + Decl := First (L); + while Present (Decl) loop + if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then + Spec := Specification (Original_Node (Decl)); + Sent := Defining_Unit_Name (Spec); + Prag := Spec_PPC_List (Sent); + while Present (Prag) loop + Analyze_PPC_In_Decl_Part (Prag, Sent); + Prag := Next_Pragma (Prag); + end loop; + end if; + + Next (Decl); + end loop; + end; end Analyze_Declarations; + ----------------------------------- + -- Analyze_Full_Type_Declaration -- + ----------------------------------- + + procedure Analyze_Full_Type_Declaration (N : Node_Id) is + Def : constant Node_Id := Type_Definition (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; + Prev : Entity_Id; + + Is_Remote : constant Boolean := + (Is_Remote_Types (Current_Scope) + or else Is_Remote_Call_Interface (Current_Scope)) + and then not (In_Private_Part (Current_Scope) + or else In_Package_Body (Current_Scope)); + + procedure Check_Ops_From_Incomplete_Type; + -- If there is a tagged incomplete partial view of the type, transfer + -- its operations to the full view, and indicate that the type of the + -- controlling parameter (s) is this full view. + + ------------------------------------ + -- Check_Ops_From_Incomplete_Type -- + ------------------------------------ + + procedure Check_Ops_From_Incomplete_Type is + Elmt : Elmt_Id; + Formal : Entity_Id; + Op : Entity_Id; + + begin + if Prev /= T + and then Ekind (Prev) = E_Incomplete_Type + and then Is_Tagged_Type (Prev) + and then Is_Tagged_Type (T) + then + Elmt := First_Elmt (Primitive_Operations (Prev)); + while Present (Elmt) loop + Op := Node (Elmt); + Prepend_Elmt (Op, Primitive_Operations (T)); + + Formal := First_Formal (Op); + while Present (Formal) loop + if Etype (Formal) = Prev then + Set_Etype (Formal, T); + end if; + + Next_Formal (Formal); + end loop; + + if Etype (Op) = Prev then + Set_Etype (Op, T); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end Check_Ops_From_Incomplete_Type; + + -- Start of processing for Analyze_Full_Type_Declaration + + begin + Prev := Find_Type_Name (N); + + -- The full view, if present, now points to the current type + + -- Ada 2005 (AI-50217): If the type was previously decorated when + -- imported through a LIMITED WITH clause, it appears as incomplete + -- but has no full view. + + if Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + then + T := Full_View (Prev); + else + T := Prev; + end if; + + Set_Is_Pure (T, Is_Pure (Current_Scope)); + + -- We set the flag Is_First_Subtype here. It is needed to set the + -- corresponding flag for the Implicit class-wide-type created + -- during tagged types processing. + + Set_Is_First_Subtype (T, True); + + -- Only composite types other than array types are allowed to have + -- discriminants. + + case Nkind (Def) is + + -- For derived types, the rule will be checked once we've figured + -- out the parent type. + + when N_Derived_Type_Definition => + null; + + -- For record types, discriminants are allowed + + when N_Record_Definition => + null; + + when others => + if Present (Discriminant_Specifications (N)) then + Error_Msg_N + ("elementary or array type cannot have discriminants", + Defining_Identifier + (First (Discriminant_Specifications (N)))); + end if; + end case; + + -- Elaborate the type definition according to kind, and generate + -- subsidiary (implicit) subtypes where needed. We skip this if it was + -- already done (this happens during the reanalysis that follows a call + -- to the high level optimizer). + + if not Analyzed (T) then + Set_Analyzed (T); + + case Nkind (Def) is + + when N_Access_To_Subprogram_Definition => + Access_Subprogram_Declaration (T, Def); + + -- If this is a remote access to subprogram, we must create the + -- equivalent fat pointer type, and related subprograms. + + if Is_Remote then + Process_Remote_AST_Declaration (N); + end if; + + -- Validate categorization rule against access type declaration + -- usually a violation in Pure unit, Shared_Passive unit. + + Validate_Access_Type_Declaration (T, N); + + when N_Access_To_Object_Definition => + Access_Type_Declaration (T, Def); + + -- Validate categorization rule against access type declaration + -- usually a violation in Pure unit, Shared_Passive unit. + + Validate_Access_Type_Declaration (T, N); + + -- If we are in a Remote_Call_Interface package and define a + -- RACW, then calling stubs and specific stream attributes + -- must be added. + + if Is_Remote + and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) + then + Add_RACW_Features (Def_Id); + end if; + + -- Set no strict aliasing flag if config pragma seen + + if Opt.No_Strict_Aliasing then + Set_No_Strict_Aliasing (Base_Type (Def_Id)); + end if; + + when N_Array_Type_Definition => + Array_Type_Declaration (T, Def); + + when N_Derived_Type_Definition => + Derived_Type_Declaration (T, N, T /= Def_Id); + + when N_Enumeration_Type_Definition => + Enumeration_Type_Declaration (T, Def); + + when N_Floating_Point_Definition => + Floating_Point_Type_Declaration (T, Def); + + when N_Decimal_Fixed_Point_Definition => + Decimal_Fixed_Point_Type_Declaration (T, Def); + + when N_Ordinary_Fixed_Point_Definition => + Ordinary_Fixed_Point_Type_Declaration (T, Def); + + when N_Signed_Integer_Type_Definition => + Signed_Integer_Type_Declaration (T, Def); + + when N_Modular_Type_Definition => + Modular_Type_Declaration (T, Def); + + when N_Record_Definition => + Record_Type_Declaration (T, N, Prev); + + -- If declaration has a parse error, nothing to elaborate. + + when N_Error => + null; + + when others => + raise Program_Error; + + end case; + end if; + + if Etype (T) = Any_Type then + return; + end if; + + -- Some common processing for all types + + Set_Depends_On_Private (T, Has_Private_Component (T)); + Check_Ops_From_Incomplete_Type; + + -- Both the declared entity, and its anonymous base type if one + -- was created, need freeze nodes allocated. + + declare + B : constant Entity_Id := Base_Type (T); + + begin + -- In the case where the base type differs from the first subtype, we + -- pre-allocate a freeze node, and set the proper link to the first + -- subtype. Freeze_Entity will use this preallocated freeze node when + -- it freezes the entity. + + -- This does not apply if the base type is a generic type, whose + -- declaration is independent of the current derived definition. + + if B /= T and then not Is_Generic_Type (B) then + Ensure_Freeze_Node (B); + Set_First_Subtype_Link (Freeze_Node (B), T); + end if; + + -- A type that is imported through a limited_with clause cannot + -- generate any code, and thus need not be frozen. However, an access + -- type with an imported designated type needs a finalization list, + -- which may be referenced in some other package that has non-limited + -- visibility on the designated type. Thus we must create the + -- finalization list at the point the access type is frozen, to + -- prevent unsatisfied references at link time. + + if not From_With_Type (T) or else Is_Access_Type (T) then + Set_Has_Delayed_Freeze (T); + end if; + end; + + -- Case where T is the full declaration of some private type which has + -- been swapped in Defining_Identifier (N). + + if T /= Def_Id and then Is_Private_Type (Def_Id) then + Process_Full_View (N, T, Def_Id); + + -- Record the reference. The form of this is a little strange, since + -- the full declaration has been swapped in. So the first parameter + -- here represents the entity to which a reference is made which is + -- the "real" entity, i.e. the one swapped in, and the second + -- parameter provides the reference location. + + -- Also, we want to kill Has_Pragma_Unreferenced temporarily here + -- since we don't want a complaint about the full type being an + -- unwanted reference to the private type + + declare + B : constant Boolean := Has_Pragma_Unreferenced (T); + begin + Set_Has_Pragma_Unreferenced (T, False); + Generate_Reference (T, T, 'c'); + Set_Has_Pragma_Unreferenced (T, B); + end; + + Set_Completion_Referenced (Def_Id); + + -- For completion of incomplete type, process incomplete dependents + -- and always mark the full type as referenced (it is the incomplete + -- type that we get for any real reference). + + elsif Ekind (Prev) = E_Incomplete_Type then + Process_Incomplete_Dependents (N, T, Prev); + Generate_Reference (Prev, Def_Id, 'c'); + Set_Completion_Referenced (Def_Id); + + -- If not private type or incomplete type completion, this is a real + -- definition of a new entity, so record it. + + else + Generate_Definition (Def_Id); + end if; + + if Chars (Scope (Def_Id)) = Name_System + and then Chars (Def_Id) = Name_Address + and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N))) + then + Set_Is_Descendent_Of_Address (Def_Id); + Set_Is_Descendent_Of_Address (Base_Type (Def_Id)); + Set_Is_Descendent_Of_Address (Prev); + end if; + + Set_Optimize_Alignment_Flags (Def_Id); + Check_Eliminated (Def_Id); + + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); + end Analyze_Full_Type_Declaration; + ---------------------------------- -- Analyze_Incomplete_Type_Decl -- ---------------------------------- *************** package body Sem_Ch3 is *** 2090,2096 **** if Tagged_Present (N) then Set_Is_Tagged_Type (T); Make_Class_Wide_Type (T); ! Set_Primitive_Operations (T, New_Elmt_List); end if; Push_Scope (T); --- 2457,2463 ---- if Tagged_Present (N) then Set_Is_Tagged_Type (T); Make_Class_Wide_Type (T); ! Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; Push_Scope (T); *************** package body Sem_Ch3 is *** 2141,2159 **** or else Synchronized_Present (Def) or else Task_Present (Def)); - Set_Is_Protected_Interface (T, Protected_Present (Def)); - Set_Is_Task_Interface (T, Task_Present (Def)); - - -- Type is a synchronized interface if it includes the keyword task, - -- protected, or synchronized. - - Set_Is_Synchronized_Interface - (T, Synchronized_Present (Def) - or else Protected_Present (Def) - or else Task_Present (Def)); - Set_Interfaces (T, New_Elmt_List); ! Set_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already -- built (i.e. during the creation of the limited view) --- 2508,2515 ---- or else Synchronized_Present (Def) or else Task_Present (Def)); Set_Interfaces (T, New_Elmt_List); ! Set_Direct_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already -- built (i.e. during the creation of the limited view) *************** package body Sem_Ch3 is *** 2161,2169 **** if Present (CW) then Set_Is_Interface (CW); Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); - Set_Is_Protected_Interface (CW, Is_Protected_Interface (T)); - Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T)); - Set_Is_Task_Interface (CW, Is_Task_Interface (T)); end if; -- Check runtime support for synchronized interfaces --- 2517,2522 ---- *************** package body Sem_Ch3 is *** 2470,2476 **** T := Find_Type_Of_Object (Object_Definition (N), N); Set_Etype (Id, T); Set_Ekind (Id, E_Variable); ! return; end if; -- In the normal case, enter identifier at the start to catch premature --- 2823,2829 ---- T := Find_Type_Of_Object (Object_Definition (N), N); Set_Etype (Id, T); Set_Ekind (Id, E_Variable); ! goto Leave; end if; -- In the normal case, enter identifier at the start to catch premature *************** package body Sem_Ch3 is *** 2496,2509 **** if Error_Posted (Id) then Set_Etype (Id, T); Set_Ekind (Id, E_Variable); ! return; end if; end if; -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks ! if Ada_Version >= Ada_05 and then Can_Never_Be_Null (T) then -- In case of aggregates we must also take care of the correct --- 2849,2862 ---- if Error_Posted (Id) then Set_Etype (Id, T); Set_Ekind (Id, E_Variable); ! goto Leave; end if; end if; -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks ! if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then -- In case of aggregates we must also take care of the correct *************** package body Sem_Ch3 is *** 2603,2609 **** -- to make handlers not at the library level illegal. if Has_Interrupt_Handler (T) ! and then Ada_Version < Ada_05 then Error_Msg_N ("interrupt object can only be declared at library level", Id); --- 2956,2962 ---- -- to make handlers not at the library level illegal. if Has_Interrupt_Handler (T) ! and then Ada_Version < Ada_2005 then Error_Msg_N ("interrupt object can only be declared at library level", Id); *************** package body Sem_Ch3 is *** 2738,2749 **** -- Has_Stream just for efficiency reasons. There is no point in -- spending time on a Has_Stream check if the restriction is not set. ! if Restrictions.Set (No_Streams) then if Has_Stream (T) then Check_Restriction (No_Streams, N); end if; end if; -- Case of unconstrained type if Is_Indefinite_Subtype (T) then --- 3091,3123 ---- -- Has_Stream just for efficiency reasons. There is no point in -- spending time on a Has_Stream check if the restriction is not set. ! if Restriction_Check_Required (No_Streams) then if Has_Stream (T) then Check_Restriction (No_Streams, N); end if; end if; + -- Deal with predicate check before we start to do major rewriting. + -- it is OK to initialize and then check the initialized value, since + -- the object goes out of scope if we get a predicate failure. Note + -- that we do this in the analyzer and not the expander because the + -- analyzer does some substantial rewriting in some cases. + + -- We need a predicate check if the type has predicates, and if either + -- there is an initializing expression, or for default initialization + -- when we have at least one case of an explicit default initial value. + + if not Suppress_Assignment_Checks (N) + and then Present (Predicate_Function (T)) + and then + (Present (E) + or else + Is_Partially_Initialized_Type (T, Include_Implicit => False)) + then + Insert_After (N, + Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); + end if; + -- Case of unconstrained type if Is_Indefinite_Subtype (T) then *************** package body Sem_Ch3 is *** 2919,2931 **** -- Check No_Wide_Characters restriction ! if T = Standard_Wide_Character ! or else T = Standard_Wide_Wide_Character ! or else Root_Type (T) = Standard_Wide_String ! or else Root_Type (T) = Standard_Wide_Wide_String ! then ! Check_Restriction (No_Wide_Characters, Object_Definition (N)); ! end if; -- Indicate this is not set in source. Certainly true for constants, -- and true for variables so far (will be reset for a variable if and --- 3293,3299 ---- -- Check No_Wide_Characters restriction ! Check_Wide_Character_Restriction (T, Object_Definition (N)); -- Indicate this is not set in source. Certainly true for constants, -- and true for variables so far (will be reset for a variable if and *************** package body Sem_Ch3 is *** 2990,2996 **** and then Is_Record_Type (T) and then not Is_Constrained (T) and then Has_Discriminants (T) ! and then (Ada_Version < Ada_05 or else Is_Indefinite_Subtype (T)) then Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); end if; --- 3358,3364 ---- and then Is_Record_Type (T) and then not Is_Constrained (T) and then Has_Discriminants (T) ! and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T)) then Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); end if; *************** package body Sem_Ch3 is *** 3114,3120 **** -- A rather specialized test. If we see two tasks being declared -- of the same type in the same object declaration, and the task -- has an entry with an address clause, we know that program error ! -- will be raised at run-time since we can't have two tasks with -- entries at the same address. if Is_Task_Type (Etype (Id)) and then More_Ids (N) then --- 3482,3488 ---- -- A rather specialized test. If we see two tasks being declared -- of the same type in the same object declaration, and the task -- has an entry with an address clause, we know that program error ! -- will be raised at run time since we can't have two tasks with -- entries at the same address. if Is_Task_Type (Etype (Id)) and then More_Ids (N) then *************** package body Sem_Ch3 is *** 3223,3228 **** --- 3591,3599 ---- then Check_Restriction (No_Local_Timing_Events, N); end if; + + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Object_Declaration; --------------------------- *************** package body Sem_Ch3 is *** 3268,3274 **** end if; Generate_Definition (T); ! Enter_Name (T); Parent_Type := Find_Type_Of_Subtype_Indic (Indic); Parent_Base := Base_Type (Parent_Type); --- 3639,3666 ---- end if; Generate_Definition (T); ! ! -- For other than Ada 2012, just enter the name in the current scope ! ! if Ada_Version < Ada_2012 then ! Enter_Name (T); ! ! -- Ada 2012 (AI05-0162): Enter the name in the current scope handling ! -- case of private type that completes an incomplete type. ! ! else ! declare ! Prev : Entity_Id; ! ! begin ! Prev := Find_Type_Name (N); ! ! pragma Assert (Prev = T ! or else (Ekind (Prev) = E_Incomplete_Type ! and then Present (Full_View (Prev)) ! and then Full_View (Prev) = T)); ! end; ! end if; Parent_Type := Find_Type_Of_Subtype_Indic (Indic); Parent_Base := Base_Type (Parent_Type); *************** package body Sem_Ch3 is *** 3278,3295 **** then Set_Ekind (T, Ekind (Parent_Type)); Set_Etype (T, Any_Type); ! return; elsif not Is_Tagged_Type (Parent_Type) then Error_Msg_N ("parent of type extension must be a tagged type ", Indic); ! return; ! elsif Ekind (Parent_Type) = E_Void ! or else Ekind (Parent_Type) = E_Incomplete_Type ! then Error_Msg_N ("premature derivation of incomplete type", Indic); ! return; elsif Is_Concurrent_Type (Parent_Type) then Error_Msg_N --- 3670,3685 ---- then Set_Ekind (T, Ekind (Parent_Type)); Set_Etype (T, Any_Type); ! goto Leave; elsif not Is_Tagged_Type (Parent_Type) then Error_Msg_N ("parent of type extension must be a tagged type ", Indic); ! goto Leave; ! elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then Error_Msg_N ("premature derivation of incomplete type", Indic); ! goto Leave; elsif Is_Concurrent_Type (Parent_Type) then Error_Msg_N *************** package body Sem_Ch3 is *** 3300,3306 **** Set_Ekind (T, E_Limited_Private_Type); Set_Private_Dependents (T, New_Elmt_List); Set_Error_Posted (T); ! return; end if; -- Perhaps the parent type should be changed to the class-wide type's --- 3690,3696 ---- Set_Ekind (T, E_Limited_Private_Type); Set_Private_Dependents (T, New_Elmt_List); Set_Error_Posted (T); ! goto Leave; end if; -- Perhaps the parent type should be changed to the class-wide type's *************** package body Sem_Ch3 is *** 3309,3315 **** if Is_Class_Wide_Type (Parent_Type) then Error_Msg_N ("parent of type extension must not be a class-wide type", Indic); ! return; end if; if (not Is_Package_Or_Generic_Package (Current_Scope) --- 3699,3705 ---- if Is_Class_Wide_Type (Parent_Type) then Error_Msg_N ("parent of type extension must not be a class-wide type", Indic); ! goto Leave; end if; if (not Is_Package_Or_Generic_Package (Current_Scope) *************** package body Sem_Ch3 is *** 3341,3350 **** Build_Derived_Record_Type (N, Parent_Type, T); -- Ada 2005 (AI-443): Synchronized private extension or a rewritten -- synchronized formal derived type. ! if Ada_Version >= Ada_05 and then Synchronized_Present (N) then Set_Is_Limited_Record (T); --- 3731,3749 ---- Build_Derived_Record_Type (N, Parent_Type, T); + -- Propagate inherited invariant information. The new type has + -- invariants, if the parent type has inheritable invariants, + -- and these invariants can in turn be inherited. + + if Has_Inheritable_Invariants (Parent_Type) then + Set_Has_Inheritable_Invariants (T); + Set_Has_Invariants (T); + end if; + -- Ada 2005 (AI-443): Synchronized private extension or a rewritten -- synchronized formal derived type. ! if Ada_Version >= Ada_2005 and then Synchronized_Present (N) then Set_Is_Limited_Record (T); *************** package body Sem_Ch3 is *** 3432,3437 **** --- 3831,3839 ---- N, Parent_Type); end if; end if; + + <> + Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N)); end Analyze_Private_Extension_Declaration; --------------------------------- *************** package body Sem_Ch3 is *** 3488,3495 **** --- 3890,3912 ---- Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); Set_Is_Atomic (Id, Is_Atomic (T)); Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T)); + Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T)); Set_Convention (Id, Convention (T)); + -- If ancestor has predicates then so does the subtype, and in addition + -- we must delay the freeze to properly arrange predicate inheritance. + + -- The Ancestor_Type test is a big kludge, there seem to be cases in + -- which T = ID, so the above tests and assignments do nothing??? + + if Has_Predicates (T) + or else (Present (Ancestor_Subtype (T)) + and then Has_Predicates (Ancestor_Subtype (T))) + then + Set_Has_Predicates (Id); + Set_Has_Delayed_Freeze (Id); + end if; + -- In the case where there is no constraint given in the subtype -- indication, Process_Subtype just returns the Subtype_Mark, so its -- semantic attributes must be established here. *************** package body Sem_Ch3 is *** 3597,3604 **** if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Id); Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); ! Set_Primitive_Operations ! (Id, Primitive_Operations (T)); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); if Is_Interface (T) then --- 4014,4021 ---- if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Id); Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); ! Set_Direct_Primitive_Operations ! (Id, Direct_Primitive_Operations (T)); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); if Is_Interface (T) then *************** package body Sem_Ch3 is *** 3621,3630 **** (Id, Known_To_Have_Preelab_Init (T)); if Is_Tagged_Type (T) then ! Set_Is_Tagged_Type (Id); ! Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); ! Set_Primitive_Operations (Id, Primitive_Operations (T)); ! Set_Class_Wide_Type (Id, Class_Wide_Type (T)); end if; -- In general the attributes of the subtype of a private type --- 4038,4048 ---- (Id, Known_To_Have_Preelab_Init (T)); if Is_Tagged_Type (T) then ! Set_Is_Tagged_Type (Id); ! Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); ! Set_Class_Wide_Type (Id, Class_Wide_Type (T)); ! Set_Direct_Primitive_Operations (Id, ! Direct_Primitive_Operations (T)); end if; -- In general the attributes of the subtype of a private type *************** package body Sem_Ch3 is *** 3695,3701 **** end if; when E_Incomplete_Type => ! if Ada_Version >= Ada_05 then Set_Ekind (Id, E_Incomplete_Subtype); -- Ada 2005 (AI-412): Decorate an incomplete subtype --- 4113,4119 ---- end if; when E_Incomplete_Type => ! if Ada_Version >= Ada_2005 then Set_Ekind (Id, E_Incomplete_Subtype); -- Ada 2005 (AI-412): Decorate an incomplete subtype *************** package body Sem_Ch3 is *** 3729,3735 **** end if; if Etype (Id) = Any_Type then ! return; end if; -- Some common processing on all types --- 4147,4153 ---- end if; if Etype (Id) = Any_Type then ! goto Leave; end if; -- Some common processing on all types *************** package body Sem_Ch3 is *** 3750,3759 **** if Present (Generic_Parent_Type (N)) and then (Nkind ! (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration or else Nkind (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) ! /= N_Formal_Private_Type_Definition) then if Is_Tagged_Type (Id) then --- 4168,4177 ---- if Present (Generic_Parent_Type (N)) and then (Nkind ! (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration or else Nkind (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) ! /= N_Formal_Private_Type_Definition) then if Is_Tagged_Type (Id) then *************** package body Sem_Ch3 is *** 3841,3848 **** --- 4259,4283 ---- end if; end if; + -- Make sure that generic actual types are properly frozen. The subtype + -- is marked as a generic actual type when the enclosing instance is + -- analyzed, so here we identify the subtype from the tree structure. + + if Expander_Active + and then Is_Generic_Actual_Type (Id) + and then In_Instance + and then not Comes_From_Source (N) + and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication + and then Is_Frozen (T) + then + Freeze_Before (N, Id); + end if; + Set_Optimize_Alignment_Flags (Id); Check_Eliminated (Id); + + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Subtype_Declaration; -------------------------------- *************** package body Sem_Ch3 is *** 3866,4174 **** end if; end Analyze_Subtype_Indication; - ------------------------------ - -- Analyze_Type_Declaration -- - ------------------------------ - - procedure Analyze_Type_Declaration (N : Node_Id) is - Def : constant Node_Id := Type_Definition (N); - Def_Id : constant Entity_Id := Defining_Identifier (N); - T : Entity_Id; - Prev : Entity_Id; - - Is_Remote : constant Boolean := - (Is_Remote_Types (Current_Scope) - or else Is_Remote_Call_Interface (Current_Scope)) - and then not (In_Private_Part (Current_Scope) - or else In_Package_Body (Current_Scope)); - - procedure Check_Ops_From_Incomplete_Type; - -- If there is a tagged incomplete partial view of the type, transfer - -- its operations to the full view, and indicate that the type of the - -- controlling parameter (s) is this full view. - - ------------------------------------ - -- Check_Ops_From_Incomplete_Type -- - ------------------------------------ - - procedure Check_Ops_From_Incomplete_Type is - Elmt : Elmt_Id; - Formal : Entity_Id; - Op : Entity_Id; - - begin - if Prev /= T - and then Ekind (Prev) = E_Incomplete_Type - and then Is_Tagged_Type (Prev) - and then Is_Tagged_Type (T) - then - Elmt := First_Elmt (Primitive_Operations (Prev)); - while Present (Elmt) loop - Op := Node (Elmt); - Prepend_Elmt (Op, Primitive_Operations (T)); - - Formal := First_Formal (Op); - while Present (Formal) loop - if Etype (Formal) = Prev then - Set_Etype (Formal, T); - end if; - - Next_Formal (Formal); - end loop; - - if Etype (Op) = Prev then - Set_Etype (Op, T); - end if; - - Next_Elmt (Elmt); - end loop; - end if; - end Check_Ops_From_Incomplete_Type; - - -- Start of processing for Analyze_Type_Declaration - - begin - Prev := Find_Type_Name (N); - - -- The full view, if present, now points to the current type - - -- Ada 2005 (AI-50217): If the type was previously decorated when - -- imported through a LIMITED WITH clause, it appears as incomplete - -- but has no full view. - -- If the incomplete view is tagged, a class_wide type has been - -- created already. Use it for the full view as well, to prevent - -- multiple incompatible class-wide types that may be created for - -- self-referential anonymous access components. - - if Ekind (Prev) = E_Incomplete_Type - and then Present (Full_View (Prev)) - then - T := Full_View (Prev); - - if Is_Tagged_Type (Prev) - and then Present (Class_Wide_Type (Prev)) - then - Set_Ekind (T, Ekind (Prev)); -- will be reset later - Set_Class_Wide_Type (T, Class_Wide_Type (Prev)); - Set_Etype (Class_Wide_Type (T), T); - end if; - - else - T := Prev; - end if; - - Set_Is_Pure (T, Is_Pure (Current_Scope)); - - -- We set the flag Is_First_Subtype here. It is needed to set the - -- corresponding flag for the Implicit class-wide-type created - -- during tagged types processing. - - Set_Is_First_Subtype (T, True); - - -- Only composite types other than array types are allowed to have - -- discriminants. - - case Nkind (Def) is - - -- For derived types, the rule will be checked once we've figured - -- out the parent type. - - when N_Derived_Type_Definition => - null; - - -- For record types, discriminants are allowed - - when N_Record_Definition => - null; - - when others => - if Present (Discriminant_Specifications (N)) then - Error_Msg_N - ("elementary or array type cannot have discriminants", - Defining_Identifier - (First (Discriminant_Specifications (N)))); - end if; - end case; - - -- Elaborate the type definition according to kind, and generate - -- subsidiary (implicit) subtypes where needed. We skip this if it was - -- already done (this happens during the reanalysis that follows a call - -- to the high level optimizer). - - if not Analyzed (T) then - Set_Analyzed (T); - - case Nkind (Def) is - - when N_Access_To_Subprogram_Definition => - Access_Subprogram_Declaration (T, Def); - - -- If this is a remote access to subprogram, we must create the - -- equivalent fat pointer type, and related subprograms. - - if Is_Remote then - Process_Remote_AST_Declaration (N); - end if; - - -- Validate categorization rule against access type declaration - -- usually a violation in Pure unit, Shared_Passive unit. - - Validate_Access_Type_Declaration (T, N); - - when N_Access_To_Object_Definition => - Access_Type_Declaration (T, Def); - - -- Validate categorization rule against access type declaration - -- usually a violation in Pure unit, Shared_Passive unit. - - Validate_Access_Type_Declaration (T, N); - - -- If we are in a Remote_Call_Interface package and define a - -- RACW, then calling stubs and specific stream attributes - -- must be added. - - if Is_Remote - and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) - then - Add_RACW_Features (Def_Id); - end if; - - -- Set no strict aliasing flag if config pragma seen - - if Opt.No_Strict_Aliasing then - Set_No_Strict_Aliasing (Base_Type (Def_Id)); - end if; - - when N_Array_Type_Definition => - Array_Type_Declaration (T, Def); - - when N_Derived_Type_Definition => - Derived_Type_Declaration (T, N, T /= Def_Id); - - when N_Enumeration_Type_Definition => - Enumeration_Type_Declaration (T, Def); - - when N_Floating_Point_Definition => - Floating_Point_Type_Declaration (T, Def); - - when N_Decimal_Fixed_Point_Definition => - Decimal_Fixed_Point_Type_Declaration (T, Def); - - when N_Ordinary_Fixed_Point_Definition => - Ordinary_Fixed_Point_Type_Declaration (T, Def); - - when N_Signed_Integer_Type_Definition => - Signed_Integer_Type_Declaration (T, Def); - - when N_Modular_Type_Definition => - Modular_Type_Declaration (T, Def); - - when N_Record_Definition => - Record_Type_Declaration (T, N, Prev); - - when others => - raise Program_Error; - - end case; - end if; - - if Etype (T) = Any_Type then - return; - end if; - - -- Some common processing for all types - - Set_Depends_On_Private (T, Has_Private_Component (T)); - Check_Ops_From_Incomplete_Type; - - -- Both the declared entity, and its anonymous base type if one - -- was created, need freeze nodes allocated. - - declare - B : constant Entity_Id := Base_Type (T); - - begin - -- In the case where the base type differs from the first subtype, we - -- pre-allocate a freeze node, and set the proper link to the first - -- subtype. Freeze_Entity will use this preallocated freeze node when - -- it freezes the entity. - - -- This does not apply if the base type is a generic type, whose - -- declaration is independent of the current derived definition. - - if B /= T and then not Is_Generic_Type (B) then - Ensure_Freeze_Node (B); - Set_First_Subtype_Link (Freeze_Node (B), T); - end if; - - -- A type that is imported through a limited_with clause cannot - -- generate any code, and thus need not be frozen. However, an access - -- type with an imported designated type needs a finalization list, - -- which may be referenced in some other package that has non-limited - -- visibility on the designated type. Thus we must create the - -- finalization list at the point the access type is frozen, to - -- prevent unsatisfied references at link time. - - if not From_With_Type (T) or else Is_Access_Type (T) then - Set_Has_Delayed_Freeze (T); - end if; - end; - - -- Case where T is the full declaration of some private type which has - -- been swapped in Defining_Identifier (N). - - if T /= Def_Id and then Is_Private_Type (Def_Id) then - Process_Full_View (N, T, Def_Id); - - -- Record the reference. The form of this is a little strange, since - -- the full declaration has been swapped in. So the first parameter - -- here represents the entity to which a reference is made which is - -- the "real" entity, i.e. the one swapped in, and the second - -- parameter provides the reference location. - - -- Also, we want to kill Has_Pragma_Unreferenced temporarily here - -- since we don't want a complaint about the full type being an - -- unwanted reference to the private type - - declare - B : constant Boolean := Has_Pragma_Unreferenced (T); - begin - Set_Has_Pragma_Unreferenced (T, False); - Generate_Reference (T, T, 'c'); - Set_Has_Pragma_Unreferenced (T, B); - end; - - Set_Completion_Referenced (Def_Id); - - -- For completion of incomplete type, process incomplete dependents - -- and always mark the full type as referenced (it is the incomplete - -- type that we get for any real reference). - - elsif Ekind (Prev) = E_Incomplete_Type then - Process_Incomplete_Dependents (N, T, Prev); - Generate_Reference (Prev, Def_Id, 'c'); - Set_Completion_Referenced (Def_Id); - - -- If not private type or incomplete type completion, this is a real - -- definition of a new entity, so record it. - - else - Generate_Definition (Def_Id); - end if; - - if Chars (Scope (Def_Id)) = Name_System - and then Chars (Def_Id) = Name_Address - and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N))) - then - Set_Is_Descendent_Of_Address (Def_Id); - Set_Is_Descendent_Of_Address (Base_Type (Def_Id)); - Set_Is_Descendent_Of_Address (Prev); - end if; - - Set_Optimize_Alignment_Flags (Def_Id); - Check_Eliminated (Def_Id); - end Analyze_Type_Declaration; - -------------------------- -- Analyze_Variant_Part -- -------------------------- --- 4301,4306 ---- *************** package body Sem_Ch3 is *** 4223,4235 **** Discr_Name : Node_Id; Discr_Type : Entity_Id; - Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); - Last_Choice : Nat; Dont_Care : Boolean; Others_Present : Boolean := False; - pragma Warnings (Off, Case_Table); - pragma Warnings (Off, Last_Choice); pragma Warnings (Off, Dont_Care); pragma Warnings (Off, Others_Present); -- We don't care about the assigned values of any of these --- 4355,4363 ---- *************** package body Sem_Ch3 is *** 4263,4270 **** -- Call the instantiated Analyze_Choices which does the rest of the work ! Analyze_Choices ! (N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); end Analyze_Variant_Part; ---------------------------- --- 4391,4397 ---- -- Call the instantiated Analyze_Choices which does the rest of the work ! Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present); end Analyze_Variant_Part; ---------------------------- *************** package body Sem_Ch3 is *** 4325,4333 **** Decl : Entity_Id; begin ! New_E := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('T')); Set_Is_Internal (New_E); Decl := --- 4452,4458 ---- Decl : Entity_Id; begin ! New_E := Make_Temporary (Loc, 'T'); Set_Is_Internal (New_E); Decl := *************** package body Sem_Ch3 is *** 4357,4362 **** --- 4482,4496 ---- end if; Make_Index (Index, P, Related_Id, Nb_Index); + + -- Check error of subtype with predicate for index type + + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed as index subtype", + Index, Etype (Index)); + + -- Move to next index + Next_Index (Index); Nb_Index := Nb_Index + 1; end loop; *************** package body Sem_Ch3 is *** 4480,4486 **** -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the -- array type to ensure that objects of this type are initialized. ! if Ada_Version >= Ada_05 and then Can_Never_Be_Null (Element_Type) then Set_Can_Never_Be_Null (T); --- 4614,4620 ---- -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the -- array type to ensure that objects of this type are initialized. ! if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Element_Type) then Set_Can_Never_Be_Null (T); *************** package body Sem_Ch3 is *** 4529,4539 **** Error_Msg_N ("missing index definition in array type declaration", T); declare ! Indices : constant List_Id := New_List (New_Occurrence_Of (Any_Id, Sloc (T))); begin ! Set_Discrete_Subtype_Definitions (Def, Indices); ! Set_First_Index (T, First (Indices)); return; end; end if; --- 4663,4673 ---- Error_Msg_N ("missing index definition in array type declaration", T); declare ! Indexes : constant List_Id := New_List (New_Occurrence_Of (Any_Id, Sloc (T))); begin ! Set_Discrete_Subtype_Definitions (Def, Indexes); ! Set_First_Index (T, First (Indexes)); return; end; end if; *************** package body Sem_Ch3 is *** 4549,4555 **** end if; -- In the case of an unconstrained array the parser has already verified ! -- that all the indices are unconstrained but we still need to make sure -- that the element type is constrained. if Is_Indefinite_Subtype (Element_Type) then --- 4683,4689 ---- end if; -- In the case of an unconstrained array the parser has already verified ! -- that all the indexes are unconstrained but we still need to make sure -- that the element type is constrained. if Is_Indefinite_Subtype (Element_Type) then *************** package body Sem_Ch3 is *** 4576,4585 **** Curr_Scope : constant Scope_Stack_Entry := Scope_Stack.Table (Scope_Stack.Last); ! Anon : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); ! Acc : Node_Id; Comp : Node_Id; Decl : Node_Id; --- 4710,4716 ---- Curr_Scope : constant Scope_Stack_Entry := Scope_Stack.Table (Scope_Stack.Last); ! Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); Acc : Node_Id; Comp : Node_Id; Decl : Node_Id; *************** package body Sem_Ch3 is *** 4921,4929 **** is Loc : constant Source_Ptr := Sloc (N); ! Corr_Record : constant Entity_Id := ! Make_Defining_Identifier (Loc, New_Internal_Name ('C')); ! Corr_Decl : Node_Id; Corr_Decl_Needed : Boolean; -- If the derived type has fewer discriminants than its parent, the --- 5052,5058 ---- is Loc : constant Source_Ptr := Sloc (N); ! Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); Corr_Decl : Node_Id; Corr_Decl_Needed : Boolean; -- If the derived type has fewer discriminants than its parent, the *************** package body Sem_Ch3 is *** 4957,4989 **** end loop; end if; ! if Present (Old_Disc) then -- The new type has fewer discriminants, so we need to create a new -- corresponding record, which is derived from the corresponding -- record of the parent, and has a stored constraint that captures ! -- the values of the discriminant constraints. ! -- The type declaration for the derived corresponding record has ! -- the same discriminant part and constraints as the current ! -- declaration. Copy the unanalyzed tree to build declaration. Corr_Decl_Needed := True; New_N := Copy_Separate_Tree (N); Corr_Decl := Make_Full_Type_Declaration (Loc, ! Defining_Identifier => Corr_Record, Discriminant_Specifications => Discriminant_Specifications (New_N), ! Type_Definition => Make_Derived_Type_Definition (Loc, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Corresponding_Record_Type (Parent_Type), Loc), ! Constraint => Constraint (Subtype_Indication (Type_Definition (New_N)))))); end if; --- 5086,5120 ---- end loop; end if; ! if Present (Old_Disc) and then Expander_Active then -- The new type has fewer discriminants, so we need to create a new -- corresponding record, which is derived from the corresponding -- record of the parent, and has a stored constraint that captures ! -- the values of the discriminant constraints. The corresponding ! -- record is needed only if expander is active and code generation is ! -- enabled. ! -- The type declaration for the derived corresponding record has the ! -- same discriminant part and constraints as the current declaration. ! -- Copy the unanalyzed tree to build declaration. Corr_Decl_Needed := True; New_N := Copy_Separate_Tree (N); Corr_Decl := Make_Full_Type_Declaration (Loc, ! Defining_Identifier => Corr_Record, Discriminant_Specifications => Discriminant_Specifications (New_N), ! Type_Definition => Make_Derived_Type_Definition (Loc, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Corresponding_Record_Type (Parent_Type), Loc), ! Constraint => Constraint (Subtype_Indication (Type_Definition (New_N)))))); end if; *************** package body Sem_Ch3 is *** 5020,5026 **** Loc : constant Source_Ptr := Sloc (N); Anon : constant Entity_Id := Make_Defining_Identifier (Loc, ! New_External_Name (Chars (Derived_Type), 'T')); Decl : Node_Id; begin --- 5151,5157 ---- Loc : constant Source_Ptr := Sloc (N); Anon : constant Entity_Id := Make_Defining_Identifier (Loc, ! Chars => New_External_Name (Chars (Derived_Type), 'T')); Decl : Node_Id; begin *************** package body Sem_Ch3 is *** 5319,5325 **** Implicit_Base := Make_Defining_Identifier (Sloc (Derived_Type), ! New_External_Name (Chars (Derived_Type), 'B')); -- Indicate the proper nature of the derived type. This must be done -- before analysis of the literals, to recognize cases when a literal --- 5450,5456 ---- Implicit_Base := Make_Defining_Identifier (Sloc (Derived_Type), ! Chars => New_External_Name (Chars (Derived_Type), 'B')); -- Indicate the proper nature of the derived type. This must be done -- before analysis of the literals, to recognize cases when a literal *************** package body Sem_Ch3 is *** 5350,5358 **** --- 5481,5494 ---- Set_RM_Size (Implicit_Base, RM_Size (Parent_Type)); Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type)); + -- Copy other flags from parent type + Set_Has_Non_Standard_Rep (Implicit_Base, Has_Non_Standard_Rep (Parent_Type)); + Set_Has_Pragma_Ordered + (Implicit_Base, Has_Pragma_Ordered + (Parent_Type)); Set_Has_Delayed_Freeze (Implicit_Base); -- Process the subtype indication including a validation check on the *************** package body Sem_Ch3 is *** 5527,5534 **** end if; -- If we did not have a range constraint, then set the range from the ! -- parent type. Otherwise, the call to Process_Subtype has set the ! -- bounds. if No_Constraint or else not Has_Range_Constraint (Indic) --- 5663,5669 ---- end if; -- If we did not have a range constraint, then set the range from the ! -- parent type. Otherwise, the Process_Subtype call has set the bounds. if No_Constraint or else not Has_Range_Constraint (Indic) *************** package body Sem_Ch3 is *** 5569,5575 **** -- already have been set if there was a constraint present. Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); ! Set_Vax_Float (Implicit_Base, Vax_Float (Parent_Base)); if No_Constraint then Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); --- 5704,5710 ---- -- already have been set if there was a constraint present. Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); ! Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); if No_Constraint then Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); *************** package body Sem_Ch3 is *** 5726,5734 **** and then Expander_Active then declare ! Full_Der : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('T')); New_Ext : constant Node_Id := Copy_Separate_Tree (Record_Extension_Part (Type_Definition (N))); --- 5861,5867 ---- and then Expander_Active then declare ! Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); New_Ext : constant Node_Id := Copy_Separate_Tree (Record_Extension_Part (Type_Definition (N))); *************** package body Sem_Ch3 is *** 5816,5821 **** --- 5949,5955 ---- Full_Der := New_Copy (Derived_Type); Set_Comes_From_Source (Full_Decl, False); Set_Comes_From_Source (Full_Der, False); + Set_Parent (Full_Der, Full_Decl); Insert_After (N, Full_Decl); *************** package body Sem_Ch3 is *** 5889,5897 **** Set_Defining_Identifier (Full_Decl, Full_Der); Build_Derived_Record_Type (Full_Decl, Parent_Type, Full_Der, Derive_Subps); - Set_Analyzed (Full_Decl); end if; if Swapped then Uninstall_Declarations (Par_Scope); --- 6023,6038 ---- Set_Defining_Identifier (Full_Decl, Full_Der); Build_Derived_Record_Type (Full_Decl, Parent_Type, Full_Der, Derive_Subps); end if; + -- The full declaration has been introduced into the tree and + -- processed in the step above. It should not be analyzed again + -- (when encountered later in the current list of declarations) + -- to prevent spurious name conflicts. The full entity remains + -- invisible. + + Set_Analyzed (Full_Decl); + if Swapped then Uninstall_Declarations (Par_Scope); *************** package body Sem_Ch3 is *** 5961,5968 **** if not Is_Private_Type (Full_View (Parent_Type)) and then (In_Open_Scopes (Scope (Parent_Type))) then ! Full_Der := Make_Defining_Identifier (Sloc (Derived_Type), ! Chars (Derived_Type)); Set_Is_Itype (Full_Der); Set_Has_Private_Declaration (Full_Der); Set_Has_Private_Declaration (Derived_Type); --- 6102,6110 ---- if not Is_Private_Type (Full_View (Parent_Type)) and then (In_Open_Scopes (Scope (Parent_Type))) then ! Full_Der := ! Make_Defining_Identifier ! (Sloc (Derived_Type), Chars (Derived_Type)); Set_Is_Itype (Full_Der); Set_Has_Private_Declaration (Full_Der); Set_Has_Private_Declaration (Derived_Type); *************** package body Sem_Ch3 is *** 6034,6041 **** and then not Is_Completion then Full_Der := ! Make_Defining_Identifier (Sloc (Derived_Type), ! Chars => Chars (Derived_Type)); Set_Is_Itype (Full_Der); Set_Has_Private_Declaration (Full_Der); Set_Has_Private_Declaration (Derived_Type); --- 6176,6183 ---- and then not Is_Completion then Full_Der := ! Make_Defining_Identifier ! (Sloc (Derived_Type), Chars (Derived_Type)); Set_Is_Itype (Full_Der); Set_Has_Private_Declaration (Full_Der); Set_Has_Private_Declaration (Derived_Type); *************** package body Sem_Ch3 is *** 6108,6115 **** -- will be installed when the enclosing child body is compiled. Full_Der := ! Make_Defining_Identifier (Sloc (Derived_Type), ! Chars => Chars (Derived_Type)); Set_Is_Itype (Full_Der); Build_Itype_Reference (Full_Der, N); --- 6250,6257 ---- -- will be installed when the enclosing child body is compiled. Full_Der := ! Make_Defining_Identifier ! (Sloc (Derived_Type), Chars (Derived_Type)); Set_Is_Itype (Full_Der); Build_Itype_Reference (Full_Der, N); *************** package body Sem_Ch3 is *** 6663,6669 **** -- Create internal access types for components with anonymous -- access types. ! if Ada_Version >= Ada_05 then Check_Anonymous_Access_Components (N, Derived_Type, Derived_Type, Component_List (Record_Extension_Part (Type_Def))); --- 6805,6811 ---- -- Create internal access types for components with anonymous -- access types. ! if Ada_Version >= Ada_2005 then Check_Anonymous_Access_Components (N, Derived_Type, Derived_Type, Component_List (Record_Extension_Part (Type_Def))); *************** package body Sem_Ch3 is *** 6778,6783 **** --- 6920,6934 ---- Mark_Rewrite_Insertion (New_Decl); Insert_Before (N, New_Decl); + -- In the extension case, make sure ancestor is frozen appropriately + -- (see also non-discriminated case below). + + if Present (Record_Extension_Part (Type_Def)) + or else Is_Interface (Parent_Base) + then + Freeze_Before (New_Decl, Parent_Type); + end if; + -- Note that this call passes False for the Derive_Subps parameter -- because subprogram derivation is deferred until after creating -- the subtype (see below). *************** package body Sem_Ch3 is *** 6868,6876 **** -- The declaration of a specific descendant of an interface type -- freezes the interface type (RM 13.14). ! if not Private_Extension ! or else Is_Interface (Parent_Base) ! then Freeze_Before (N, Parent_Type); end if; --- 7019,7025 ---- -- The declaration of a specific descendant of an interface type -- freezes the interface type (RM 13.14). ! if not Private_Extension or else Is_Interface (Parent_Base) then Freeze_Before (N, Parent_Type); end if; *************** package body Sem_Ch3 is *** 6881,6887 **** -- cannot be declared in a generic body if it's derived directly -- or indirectly from a formal type of that generic. ! if Ada_Version >= Ada_05 then if Present (Enclosing_Generic_Body (Derived_Type)) then declare Ancestor_Type : Entity_Id; --- 7030,7036 ---- -- cannot be declared in a generic body if it's derived directly -- or indirectly from a formal type of that generic. ! if Ada_Version >= Ada_2005 then if Present (Enclosing_Generic_Body (Derived_Type)) then declare Ancestor_Type : Entity_Id; *************** package body Sem_Ch3 is *** 6954,6962 **** -- Ada 2005 (AI-251) ! if Ada_Version = Ada_05 ! and then Is_Tagged ! then -- "The declaration of a specific descendant of an interface type -- freezes the interface type" (RM 13.14). --- 7103,7110 ---- -- Ada 2005 (AI-251) ! if Ada_Version >= Ada_2005 and then Is_Tagged then ! -- "The declaration of a specific descendant of an interface type -- freezes the interface type" (RM 13.14). *************** package body Sem_Ch3 is *** 7043,7049 **** Check_Or_Process_Discriminants (N, Derived_Type); ! -- For non-tagged types the constraint on the Parent_Type must be -- present and is used to rename the discriminants. if not Is_Tagged and then not Has_Discriminants (Parent_Type) then --- 7191,7197 ---- Check_Or_Process_Discriminants (N, Derived_Type); ! -- For untagged types, the constraint on the Parent_Type must be -- present and is used to rename the discriminants. if not Is_Tagged and then not Has_Discriminants (Parent_Type) then *************** package body Sem_Ch3 is *** 7290,7296 **** -- Set fields for tagged types if Is_Tagged then ! Set_Primitive_Operations (Derived_Type, New_Elmt_List); -- All tagged types defined in Ada.Finalization are controlled --- 7438,7444 ---- -- Set fields for tagged types if Is_Tagged then ! Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); -- All tagged types defined in Ada.Finalization are controlled *************** package body Sem_Ch3 is *** 7319,7325 **** (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); end if; ! if Ada_Version >= Ada_05 then declare Ifaces_List : Elist_Id; --- 7467,7473 ---- (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); end if; ! if Ada_Version >= Ada_2005 then declare Ifaces_List : Elist_Id; *************** package body Sem_Ch3 is *** 7356,7361 **** --- 7504,7530 ---- Exclude_Parents => True); Set_Interfaces (Derived_Type, Ifaces_List); + + -- If the derived type is the anonymous type created for + -- a declaration whose parent has a constraint, propagate + -- the interface list to the source type. This must be done + -- prior to the completion of the analysis of the source type + -- because the components in the extension may contain current + -- instances whose legality depends on some ancestor. + + if Is_Itype (Derived_Type) then + declare + Def : constant Node_Id := + Associated_Node_For_Itype (Derived_Type); + begin + if Present (Def) + and then Nkind (Def) = N_Full_Type_Declaration + then + Set_Interfaces + (Defining_Identifier (Def), Ifaces_List); + end if; + end; + end if; end; end if; *************** package body Sem_Ch3 is *** 7527,7535 **** begin D := First_Entity (Derived_Type); while Present (D) loop ! if Ekind (D) = E_Discriminant ! or else Ekind (D) = E_Component ! then if Is_Itype (Etype (D)) and then Ekind (Etype (D)) = E_Anonymous_Access_Type then --- 7696,7702 ---- begin D := First_Entity (Derived_Type); while Present (D) loop ! if Ekind_In (D, E_Discriminant, E_Component) then if Is_Itype (Etype (D)) and then Ekind (Etype (D)) = E_Anonymous_Access_Type then *************** package body Sem_Ch3 is *** 7570,7575 **** --- 7737,7757 ---- Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); + -- Propagate invariant information. The new type has invariants if + -- they are inherited from the parent type, and these invariants can + -- be further inherited, so both flags are set. + + if Has_Inheritable_Invariants (Parent_Type) then + Set_Has_Inheritable_Invariants (Derived_Type); + Set_Has_Invariants (Derived_Type); + end if; + + -- We similarly inherit predicates + + if Has_Predicates (Parent_Type) then + Set_Has_Predicates (Derived_Type); + end if; + -- The derived type inherits the representation clauses of the parent. -- However, for a private type that is completed by a derivation, there -- may be operation attributes that have been specified already (stream *************** package body Sem_Ch3 is *** 7697,7709 **** begin -- A discriminal has the same name as the discriminant ! D_Minal := ! Make_Defining_Identifier (Sloc (Discrim), ! Chars => Chars (Discrim)); Set_Ekind (D_Minal, E_In_Parameter); Set_Mechanism (D_Minal, Default_Mechanism); Set_Etype (D_Minal, Etype (Discrim)); Set_Discriminal (Discrim, D_Minal); Set_Discriminal_Link (D_Minal, Discrim); --- 7879,7890 ---- begin -- A discriminal has the same name as the discriminant ! D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); Set_Ekind (D_Minal, E_In_Parameter); Set_Mechanism (D_Minal, Default_Mechanism); Set_Etype (D_Minal, Etype (Discrim)); + Set_Scope (D_Minal, Current_Scope); Set_Discriminal (Discrim, D_Minal); Set_Discriminal_Link (D_Minal, Discrim); *************** package body Sem_Ch3 is *** 7720,7725 **** --- 7901,7907 ---- Set_Ekind (CR_Disc, E_In_Parameter); Set_Mechanism (CR_Disc, Default_Mechanism); Set_Etype (CR_Disc, Etype (Discrim)); + Set_Scope (CR_Disc, Current_Scope); Set_Discriminal_Link (CR_Disc, Discrim); Set_CR_Discriminant (Discrim, CR_Disc); end if; *************** package body Sem_Ch3 is *** 8148,8160 **** -- concurrent record type (which has the list of primitive -- operations). ! if Ada_Version >= Ada_05 and then Is_Concurrent_Type (T) then Set_Corresponding_Record_Type (Def_Id, Corresponding_Record_Type (T)); else ! Set_Primitive_Operations (Def_Id, Primitive_Operations (T)); end if; Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); --- 8330,8343 ---- -- concurrent record type (which has the list of primitive -- operations). ! if Ada_Version >= Ada_2005 and then Is_Concurrent_Type (T) then Set_Corresponding_Record_Type (Def_Id, Corresponding_Record_Type (T)); else ! Set_Direct_Primitive_Operations (Def_Id, ! Direct_Primitive_Operations (T)); end if; Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); *************** package body Sem_Ch3 is *** 8361,8366 **** --- 8544,8697 ---- Subp : Entity_Id; Type_Def : Node_Id; + procedure Check_Pragma_Implemented (Subp : Entity_Id); + -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine + -- which has pragma Implemented already set. Check whether Subp's entity + -- kind conforms to the implementation kind of the overridden routine. + + procedure Check_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id); + -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine + -- Iface_Subp and both entities have pragma Implemented already set on + -- them. Check whether the two implementation kinds are conforming. + + procedure Inherit_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id); + -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface + -- subprogram Iface_Subp which has been marked by pragma Implemented. + -- Propagate the implementation kind of Iface_Subp to Subp. + + ------------------------------ + -- Check_Pragma_Implemented -- + ------------------------------ + + procedure Check_Pragma_Implemented (Subp : Entity_Id) is + Iface_Alias : constant Entity_Id := Interface_Alias (Subp); + Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); + Contr_Typ : Entity_Id; + + begin + -- Subp must have an alias since it is a hidden entity used to link + -- an interface subprogram to its overriding counterpart. + + pragma Assert (Present (Alias (Subp))); + + -- Extract the type of the controlling formal + + Contr_Typ := Etype (First_Formal (Alias (Subp))); + + if Is_Concurrent_Record_Type (Contr_Typ) then + Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); + end if; + + -- An interface subprogram whose implementation kind is By_Entry must + -- be implemented by an entry. + + if Impl_Kind = Name_By_Entry + and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry + then + Error_Msg_Node_2 := Iface_Alias; + Error_Msg_NE + ("type & must implement abstract subprogram & with an entry", + Alias (Subp), Contr_Typ); + + elsif Impl_Kind = Name_By_Protected_Procedure then + + -- An interface subprogram whose implementation kind is By_ + -- Protected_Procedure cannot be implemented by a primitive + -- procedure of a task type. + + if Ekind (Contr_Typ) /= E_Protected_Type then + Error_Msg_Node_2 := Contr_Typ; + Error_Msg_NE + ("interface subprogram & cannot be implemented by a " & + "primitive procedure of task type &", Alias (Subp), + Iface_Alias); + + -- An interface subprogram whose implementation kind is By_ + -- Protected_Procedure must be implemented by a procedure. + + elsif Is_Primitive_Wrapper (Alias (Subp)) + and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure + then + Error_Msg_Node_2 := Iface_Alias; + Error_Msg_NE + ("type & must implement abstract subprogram & with a " & + "procedure", Alias (Subp), Contr_Typ); + end if; + end if; + end Check_Pragma_Implemented; + + ------------------------------ + -- Check_Pragma_Implemented -- + ------------------------------ + + procedure Check_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id) + is + Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); + Subp_Kind : constant Name_Id := Implementation_Kind (Subp); + + begin + -- Ada 2012 (AI05-0030): The implementation kinds of an overridden + -- and overriding subprogram are different. In general this is an + -- error except when the implementation kind of the overridden + -- subprograms is By_Any. + + if Iface_Kind /= Subp_Kind + and then Iface_Kind /= Name_By_Any + then + if Iface_Kind = Name_By_Entry then + Error_Msg_N + ("incompatible implementation kind, overridden subprogram " & + "is marked By_Entry", Subp); + else + Error_Msg_N + ("incompatible implementation kind, overridden subprogram " & + "is marked By_Protected_Procedure", Subp); + end if; + end if; + end Check_Pragma_Implemented; + + -------------------------------- + -- Inherit_Pragma_Implemented -- + -------------------------------- + + procedure Inherit_Pragma_Implemented + (Subp : Entity_Id; + Iface_Subp : Entity_Id) + is + Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); + Loc : constant Source_Ptr := Sloc (Subp); + Impl_Prag : Node_Id; + + begin + -- Since the implementation kind is stored as a representation item + -- rather than a flag, create a pragma node. + + Impl_Prag := + Make_Pragma (Loc, + Chars => Name_Implemented, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + New_Reference_To (Subp, Loc)), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Iface_Kind)))); + + -- The pragma doesn't need to be analyzed because it is internally + -- build. It is safe to directly register it as a rep item since we + -- are only interested in the characters of the implementation kind. + + Record_Rep_Item (Subp, Impl_Prag); + end Inherit_Pragma_Implemented; + + -- Start of processing for Check_Abstract_Overriding + begin Op_List := Primitive_Operations (T); *************** package body Sem_Ch3 is *** 8394,8400 **** if Is_Null_Extension (T) and then Has_Controlling_Result (Subp) ! and then Ada_Version >= Ada_05 and then Present (Alias_Subp) and then not Comes_From_Source (Subp) and then not Is_Abstract_Subprogram (Alias_Subp) --- 8725,8731 ---- if Is_Null_Extension (T) and then Has_Controlling_Result (Subp) ! and then Ada_Version >= Ada_2005 and then Present (Alias_Subp) and then not Comes_From_Source (Subp) and then not Is_Abstract_Subprogram (Alias_Subp) *************** package body Sem_Ch3 is *** 8450,8456 **** if Nkind (Type_Def) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Type_Def)) and then ! (Ada_Version < Ada_05 or else not Is_Null_Extension (T) or else Ekind (Subp) = E_Procedure or else not Has_Controlling_Result (Subp) --- 8781,8787 ---- if Nkind (Type_Def) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Type_Def)) and then ! (Ada_Version < Ada_2005 or else not Is_Null_Extension (T) or else Ekind (Subp) = E_Procedure or else not Has_Controlling_Result (Subp) *************** package body Sem_Ch3 is *** 8566,8603 **** -- them all, and not just the first one). Error_Msg_Node_2 := Subp; ! Error_Msg_N ! ("nonabstract type& has abstract subprogram&!", T); end if; end if; ! -- Ada 2005 (AI05-0030): Inspect hidden subprograms which provide ! -- the mapping between interface and implementing type primitives. ! -- If the interface alias is marked as Implemented_By_Entry, the ! -- alias must be an entry wrapper. ! if Ada_Version >= Ada_05 and then Is_Hidden (Subp) and then Present (Interface_Alias (Subp)) ! and then Implemented_By_Entry (Interface_Alias (Subp)) ! and then Present (Alias_Subp) ! and then ! (not Is_Primitive_Wrapper (Alias_Subp) ! or else Ekind (Wrapped_Entity (Alias_Subp)) /= E_Entry) then ! declare ! Error_Ent : Entity_Id := T; ! begin ! if Is_Concurrent_Record_Type (Error_Ent) then ! Error_Ent := Corresponding_Concurrent_Type (Error_Ent); ! end if; ! Error_Msg_Node_2 := Interface_Alias (Subp); ! Error_Msg_NE ! ("type & must implement abstract subprogram & with an entry", ! Error_Ent, Error_Ent); ! end; end if; Next_Elmt (Elmt); --- 8897,8947 ---- -- them all, and not just the first one). Error_Msg_Node_2 := Subp; ! Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); end if; end if; ! -- Ada 2012 (AI05-0030): Perform some checks related to pragma ! -- Implemented ! -- Subp is an expander-generated procedure which maps an interface ! -- alias to a protected wrapper. The interface alias is flagged by ! -- pragma Implemented. Ensure that Subp is a procedure when the ! -- implementation kind is By_Protected_Procedure or an entry when ! -- By_Entry. ! ! if Ada_Version >= Ada_2012 and then Is_Hidden (Subp) and then Present (Interface_Alias (Subp)) ! and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented) then ! Check_Pragma_Implemented (Subp); ! end if; ! -- Subp is an interface primitive which overrides another interface ! -- primitive marked with pragma Implemented. ! if Ada_Version >= Ada_2012 ! and then Present (Overridden_Operation (Subp)) ! and then Has_Rep_Pragma ! (Overridden_Operation (Subp), Name_Implemented) ! then ! -- If the overriding routine is also marked by Implemented, check ! -- that the two implementation kinds are conforming. ! ! if Has_Rep_Pragma (Subp, Name_Implemented) then ! Check_Pragma_Implemented ! (Subp => Subp, ! Iface_Subp => Overridden_Operation (Subp)); ! ! -- Otherwise the overriding routine inherits the implementation ! -- kind from the overridden subprogram. ! ! else ! Inherit_Pragma_Implemented ! (Subp => Subp, ! Iface_Subp => Overridden_Operation (Subp)); ! end if; end if; Next_Elmt (Elmt); *************** package body Sem_Ch3 is *** 8616,8631 **** -- A discriminant_specification for an access discriminant shall appear -- only in the declaration for a task or protected type, or for a type -- with the reserved word 'limited' in its definition or in one of its ! -- ancestors. (RM 3.7(10)) ! if Nkind (Discriminant_Type (D)) = N_Access_Definition ! and then not Is_Concurrent_Type (Current_Scope) ! and then not Is_Concurrent_Record_Type (Current_Scope) ! and then not Is_Limited_Record (Current_Scope) ! and then Ekind (Current_Scope) /= E_Limited_Private_Type ! then ! Error_Msg_N ! ("access discriminants allowed only for limited types", Loc); end if; end Check_Access_Discriminant_Requires_Limited; --- 8960,8982 ---- -- A discriminant_specification for an access discriminant shall appear -- only in the declaration for a task or protected type, or for a type -- with the reserved word 'limited' in its definition or in one of its ! -- ancestors (RM 3.7(10)). ! -- AI-0063: The proper condition is that type must be immutably limited, ! -- or else be a partial view. ! ! if Nkind (Discriminant_Type (D)) = N_Access_Definition then ! if Is_Immutably_Limited_Type (Current_Scope) ! or else ! (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration ! and then Limited_Present (Parent (Current_Scope))) ! then ! null; ! ! else ! Error_Msg_N ! ("access discriminants allowed only for limited types", Loc); ! end if; end if; end Check_Access_Discriminant_Requires_Limited; *************** package body Sem_Ch3 is *** 8653,8659 **** and then Has_Discriminants (Etype (C)) and then not Is_Constrained (Etype (C)) and then not In_Instance_Body ! and then Ada_Version < Ada_05 then Error_Msg_N ("aliased component must be constrained (RM 3.6(11))", --- 9004,9010 ---- and then Has_Discriminants (Etype (C)) and then not Is_Constrained (Etype (C)) and then not In_Instance_Body ! and then Ada_Version < Ada_2005 then Error_Msg_N ("aliased component must be constrained (RM 3.6(11))", *************** package body Sem_Ch3 is *** 8668,8674 **** and then Has_Discriminants (Component_Type (T)) and then not Is_Constrained (Component_Type (T)) and then not In_Instance_Body ! and then Ada_Version < Ada_05 then Error_Msg_N ("aliased component type must be constrained (RM 3.6(11))", --- 9019,9025 ---- and then Has_Discriminants (Component_Type (T)) and then not Is_Constrained (Component_Type (T)) and then not In_Instance_Body ! and then Ada_Version < Ada_2005 then Error_Msg_N ("aliased component type must be constrained (RM 3.6(11))", *************** package body Sem_Ch3 is *** 8720,8728 **** begin if not Comes_From_Source (E) then ! if Ekind (E) = E_Task_Type ! or else Ekind (E) = E_Protected_Type ! then -- It may be an anonymous protected type created for a -- single variable. Post error on variable, if present. --- 9071,9077 ---- begin if not Comes_From_Source (E) then ! if Ekind_In (E, E_Task_Type, E_Protected_Type) then -- It may be an anonymous protected type created for a -- single variable. Post error on variable, if present. *************** package body Sem_Ch3 is *** 8770,8777 **** Error_Msg_NE ("missing full declaration for }", Parent (E), E); else ! Error_Msg_NE ! ("missing body for &", Parent (E), E); end if; -- Package body has no completion for a declaration that appears --- 9119,9125 ---- Error_Msg_NE ("missing full declaration for }", Parent (E), E); else ! Error_Msg_NE ("missing body for &", Parent (E), E); end if; -- Package body has no completion for a declaration that appears *************** package body Sem_Ch3 is *** 8782,8789 **** Error_Msg_Sloc := Sloc (E); if Is_Type (E) then ! Error_Msg_NE ! ("missing full declaration for }!", Body_Id, E); elsif Is_Overloadable (E) and then Current_Entity_In_Scope (E) /= E --- 9130,9136 ---- Error_Msg_Sloc := Sloc (E); if Is_Type (E) then ! Error_Msg_NE ("missing full declaration for }!", Body_Id, E); elsif Is_Overloadable (E) and then Current_Entity_In_Scope (E) /= E *************** package body Sem_Ch3 is *** 9021,9027 **** Error_Msg_N ("?cannot initialize entities of limited type!", Exp); ! elsif Ada_Version < Ada_05 then Error_Msg_N ("cannot initialize entities of limited type", Exp); Explain_Limited_Type (T, Exp); --- 9368,9374 ---- Error_Msg_N ("?cannot initialize entities of limited type!", Exp); ! elsif Ada_Version < Ada_2005 then Error_Msg_N ("cannot initialize entities of limited type", Exp); Explain_Limited_Type (T, Exp); *************** package body Sem_Ch3 is *** 9308,9314 **** -- If an incomplete or private type declaration was already given for the -- type, the discriminants may have already been processed if they were -- present on the incomplete declaration. In this case a full conformance ! -- check is performed otherwise just process them. procedure Check_Or_Process_Discriminants (N : Node_Id; --- 9655,9663 ---- -- If an incomplete or private type declaration was already given for the -- type, the discriminants may have already been processed if they were -- present on the incomplete declaration. In this case a full conformance ! -- check has been performed in Find_Type_Name, and we then recheck here ! -- some properties that can't be checked on the partial view alone. ! -- Otherwise we call Process_Discriminants. procedure Check_Or_Process_Discriminants (N : Node_Id; *************** package body Sem_Ch3 is *** 9318,9341 **** begin if Has_Discriminants (T) then ! -- Make the discriminants visible to component declarations declare ! D : Entity_Id; ! Prev : Entity_Id; begin ! D := First_Discriminant (T); while Present (D) loop ! Prev := Current_Entity (D); Set_Current_Entity (D); Set_Is_Immediately_Visible (D); ! Set_Homonym (D, Prev); -- Ada 2005 (AI-230): Access discriminant allowed in -- non-limited record types. ! if Ada_Version < Ada_05 then -- This restriction gets applied to the full type here. It -- has already been applied earlier to the partial view. --- 9667,9727 ---- begin if Has_Discriminants (T) then ! -- Discriminants are already set on T if they were already present ! -- on the partial view. Make them visible to component declarations. declare ! D : Entity_Id; ! -- Discriminant on T (full view) referencing expr on partial view ! ! Prev_D : Entity_Id; ! -- Entity of corresponding discriminant on partial view ! ! New_D : Node_Id; ! -- Discriminant specification for full view, expression is the ! -- syntactic copy on full view (which has been checked for ! -- conformance with partial view), only used here to post error ! -- message. begin ! D := First_Discriminant (T); ! New_D := First (Discriminant_Specifications (N)); while Present (D) loop ! Prev_D := Current_Entity (D); Set_Current_Entity (D); Set_Is_Immediately_Visible (D); ! Set_Homonym (D, Prev_D); ! ! -- Handle the case where there is an untagged partial view and ! -- the full view is tagged: must disallow discriminants with ! -- defaults, unless compiling for Ada 2012, which allows a ! -- limited tagged type to have defaulted discriminants (see ! -- AI05-0214). However, suppress the error here if it was ! -- already reported on the default expression of the partial ! -- view. ! ! if Is_Tagged_Type (T) ! and then Present (Expression (Parent (D))) ! and then (not Is_Limited_Type (Current_Scope) ! or else Ada_Version < Ada_2012) ! and then not Error_Posted (Expression (Parent (D))) ! then ! if Ada_Version >= Ada_2012 then ! Error_Msg_N ! ("discriminants of nonlimited tagged type cannot have" ! & " defaults", ! Expression (New_D)); ! else ! Error_Msg_N ! ("discriminants of tagged type cannot have defaults", ! Expression (New_D)); ! end if; ! end if; -- Ada 2005 (AI-230): Access discriminant allowed in -- non-limited record types. ! if Ada_Version < Ada_2005 then -- This restriction gets applied to the full type here. It -- has already been applied earlier to the partial view. *************** package body Sem_Ch3 is *** 9344,9349 **** --- 9730,9736 ---- end if; Next_Discriminant (D); + Next (New_D); end loop; end; *************** package body Sem_Ch3 is *** 9562,9569 **** if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); ! Set_Primitive_Operations (Full, Primitive_Operations (Full_Base)); ! Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); -- If this is a subtype of a protected or task type, constrain its -- corresponding record, unless this is a subtype without constraints, --- 9949,9964 ---- if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); ! Set_Direct_Primitive_Operations (Full, ! Direct_Primitive_Operations (Full_Base)); ! ! -- Inherit class_wide type of full_base in case the partial view was ! -- not tagged. Otherwise it has already been created when the private ! -- subtype was analyzed. ! ! if No (Class_Wide_Type (Full)) then ! Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); ! end if; -- If this is a subtype of a protected or task type, constrain its -- corresponding record, unless this is a subtype without constraints, *************** package body Sem_Ch3 is *** 9585,9590 **** --- 9980,10027 ---- Corresponding_Record_Type (Full_Base)); end if; end if; + + -- Link rep item chain, and also setting of Has_Predicates from private + -- subtype to full subtype, since we will need these on the full subtype + -- to create the predicate function. Note that the full subtype may + -- already have rep items, inherited from the full view of the base + -- type, so we must be sure not to overwrite these entries. + + declare + Item : Node_Id; + Next_Item : Node_Id; + + begin + Item := First_Rep_Item (Full); + + -- If no existing rep items on full type, we can just link directly + -- to the list of items on the private type. + + if No (Item) then + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + + -- Else search to end of items currently linked to the full subtype + + else + loop + Next_Item := Next_Rep_Item (Item); + exit when No (Next_Item); + Item := Next_Item; + end loop; + + -- And link the private type items at the end of the chain + + Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); + end if; + end; + + -- Make sure Has_Predicates is set on full type if it is set on the + -- private type. Note that it may already be set on the full type and + -- if so, we don't want to unset it. + + if Has_Predicates (Priv) then + Set_Has_Predicates (Full); + end if; end Complete_Private_Subtype; ---------------------------- *************** package body Sem_Ch3 is *** 9633,9646 **** then declare Loc : constant Source_Ptr := Sloc (N); ! Def_Id : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_Internal_Name ('S')); ! Decl : constant Node_Id := Make_Subtype_Declaration (Loc, ! Defining_Identifier => ! Def_Id, ! Subtype_Indication => Relocate_Node (Curr_Obj_Def)); begin --- 10070,10080 ---- then declare Loc : constant Source_Ptr := Sloc (N); ! Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); ! Decl : constant Node_Id := Make_Subtype_Declaration (Loc, ! Defining_Identifier => Def_Id, ! Subtype_Indication => Relocate_Node (Curr_Obj_Def)); begin *************** package body Sem_Ch3 is *** 9802,9814 **** and then not In_Private_Part (Current_Scope) then Error_Msg_Sloc := Sloc (Prev); ! Error_Msg_N ("full constant for declaration#" ! & " must be in private part", N); elsif Ekind (Current_Scope) = E_Package ! and then List_Containing (Parent (Prev)) ! /= Visible_Declarations ! (Specification (Unit_Declaration_Node (Current_Scope))) then Error_Msg_N ("deferred constant must be declared in visible part", --- 10236,10250 ---- and then not In_Private_Part (Current_Scope) then Error_Msg_Sloc := Sloc (Prev); ! Error_Msg_N ! ("full constant for declaration#" ! & " must be in private part", N); elsif Ekind (Current_Scope) = E_Package ! and then ! List_Containing (Parent (Prev)) /= ! Visible_Declarations ! (Specification (Unit_Declaration_Node (Current_Scope))) then Error_Msg_N ("deferred constant must be declared in visible part", *************** package body Sem_Ch3 is *** 9885,9891 **** end if; if (Ekind (T) = E_General_Access_Type ! or else Ada_Version >= Ada_05) and then Has_Private_Declaration (Desig_Type) and then In_Open_Scopes (Scope (Desig_Type)) and then Has_Discriminants (Desig_Type) --- 10321,10327 ---- end if; if (Ekind (T) = E_General_Access_Type ! or else Ada_Version >= Ada_2005) and then Has_Private_Declaration (Desig_Type) and then In_Open_Scopes (Scope (Desig_Type)) and then Has_Discriminants (Desig_Type) *************** package body Sem_Ch3 is *** 9989,10005 **** -- generic body, the rule is checked assuming that the actual type has -- defaulted discriminants. ! if Ada_Version >= Ada_05 or else Warn_On_Ada_2005_Compatibility then if Ekind (Base_Type (T)) = E_General_Access_Type and then Has_Defaulted_Discriminants (Desig_Type) then ! if Ada_Version < Ada_05 then Error_Msg_N ("access subtype of general access type would not " & "be allowed in Ada 2005?", S); else Error_Msg_N ! ("access subype of general access type not allowed", S); end if; Error_Msg_N ("\discriminants have defaults", S); --- 10425,10441 ---- -- generic body, the rule is checked assuming that the actual type has -- defaulted discriminants. ! if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then if Ekind (Base_Type (T)) = E_General_Access_Type and then Has_Defaulted_Discriminants (Desig_Type) then ! if Ada_Version < Ada_2005 then Error_Msg_N ("access subtype of general access type would not " & "be allowed in Ada 2005?", S); else Error_Msg_N ! ("access subtype of general access type not allowed", S); end if; Error_Msg_N ("\discriminants have defaults", S); *************** package body Sem_Ch3 is *** 10009,10015 **** and then Has_Discriminants (Desig_Type) and then In_Package_Body (Current_Scope) then ! if Ada_Version < Ada_05 then Error_Msg_N ("access subtype would not be allowed in generic body " & "in Ada 2005?", S); --- 10445,10451 ---- and then Has_Discriminants (Desig_Type) and then In_Package_Body (Current_Scope) then ! if Ada_Version < Ada_2005 then Error_Msg_N ("access subtype would not be allowed in generic body " & "in Ada 2005?", S); *************** package body Sem_Ch3 is *** 10055,10062 **** -- is such an array type... (RM 3.6.1) if Is_Constrained (T) then ! Error_Msg_N ! ("array type is already constrained", Subtype_Mark (SI)); Constraint_OK := False; else --- 10491,10497 ---- -- is such an array type... (RM 3.6.1) if Is_Constrained (T) then ! Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); Constraint_OK := False; else *************** package body Sem_Ch3 is *** 10150,10156 **** function Build_Constrained_Array_Type (Old_Type : Entity_Id) return Entity_Id; ! -- If Old_Type is an array type, one of whose indices is constrained -- by a discriminant, build an Itype whose constraint replaces the -- discriminant with its value in the constraint. --- 10585,10591 ---- function Build_Constrained_Array_Type (Old_Type : Entity_Id) return Entity_Id; ! -- If Old_Type is an array type, one of whose indexes is constrained -- by a discriminant, build an Itype whose constraint replaces the -- discriminant with its value in the constraint. *************** package body Sem_Ch3 is *** 10446,10452 **** Next_Elmt (E); end loop; ! -- The corresponding_Discriminant mechanism is incomplete, because -- the correspondence between new and old discriminants is not one -- to one: one new discriminant can constrain several old ones. In -- that case, scan sequentially the stored_constraint, the list of --- 10881,10887 ---- Next_Elmt (E); end loop; ! -- The Corresponding_Discriminant mechanism is incomplete, because -- the correspondence between new and old discriminants is not one -- to one: one new discriminant can constrain several old ones. In -- that case, scan sequentially the stored_constraint, the list of *************** package body Sem_Ch3 is *** 10783,10789 **** -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. -- Avoid generating an error for access-to-incomplete subtypes. ! if Ada_Version >= Ada_05 and then Ekind (T) = E_Incomplete_Type and then Nkind (Parent (S)) = N_Subtype_Declaration and then not Is_Itype (Def_Id) --- 11218,11224 ---- -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. -- Avoid generating an error for access-to-incomplete subtypes. ! if Ada_Version >= Ada_2005 and then Ekind (T) = E_Incomplete_Type and then Nkind (Parent (S)) = N_Subtype_Declaration and then not Is_Itype (Def_Id) *************** package body Sem_Ch3 is *** 10804,10811 **** Error_Msg_N ("(Ada 2005) incomplete subtype may not be constrained", C); else ! Error_Msg_N ! ("invalid constraint: type has no discriminant", C); end if; Fixup_Bad_Constraint; --- 11239,11245 ---- Error_Msg_N ("(Ada 2005) incomplete subtype may not be constrained", C); else ! Error_Msg_N ("invalid constraint: type has no discriminant", C); end if; Fixup_Bad_Constraint; *************** package body Sem_Ch3 is *** 11018,11023 **** --- 11452,11464 ---- elsif Base_Type (Entity (S)) /= Base_Type (T) then Wrong_Type (S, Base_Type (T)); + + -- Check error of subtype with predicate in index constraint + + else + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (S)); end if; return; *************** package body Sem_Ch3 is *** 11043,11048 **** --- 11484,11490 ---- else Set_Ekind (Def_Id, E_Enumeration_Subtype); Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); end if; Set_Size_Info (Def_Id, (T)); *************** package body Sem_Ch3 is *** 11198,11203 **** --- 11640,11651 ---- Rng : Node_Id; begin + -- Defend against previous errors + + if No (Scalar_Range (Derived_Type)) then + return; + end if; + Lo := Build_Scalar_Bound (Type_Low_Bound (Derived_Type), Parent_Type, Implicit_Base); *************** package body Sem_Ch3 is *** 11283,11288 **** --- 11731,11737 ---- Set_Is_Public (Full, Is_Public (Priv)); Set_Is_Pure (Full, Is_Pure (Priv)); Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); + Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); Set_Has_Pragma_Unreferenced_Objects (Full, Has_Pragma_Unreferenced_Objects *************** package body Sem_Ch3 is *** 11291,11299 **** Conditional_Delay (Full, Priv); if Is_Tagged_Type (Full) then ! Set_Primitive_Operations (Full, Primitive_Operations (Priv)); ! if Priv = Base_Type (Priv) then Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); end if; end if; --- 11740,11749 ---- Conditional_Delay (Full, Priv); if Is_Tagged_Type (Full) then ! Set_Direct_Primitive_Operations (Full, ! Direct_Primitive_Operations (Priv)); ! if Is_Base_Type (Priv) then Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); end if; end if; *************** package body Sem_Ch3 is *** 11318,11327 **** Access_Types_To_Process (Freeze_Node (Priv))); end if; ! -- Swap the two entities. Now Privat is the full type entity and ! -- Full is the private one. They will be swapped back at the end ! -- of the private part. This swapping ensures that the entity that ! -- is visible in the private part is the full declaration. Exchange_Entities (Priv, Full); Append_Entity (Full, Scope (Full)); --- 11768,11777 ---- Access_Types_To_Process (Freeze_Node (Priv))); end if; ! -- Swap the two entities. Now Private is the full type entity and Full ! -- is the private one. They will be swapped back at the end of the ! -- private part. This swapping ensures that the entity that is visible ! -- in the private part is the full declaration. Exchange_Entities (Priv, Full); Append_Entity (Full, Scope (Full)); *************** package body Sem_Ch3 is *** 11909,11915 **** Typ : Entity_Id; begin ! pragma Assert (Ada_Version >= Ada_05 and then Is_Record_Type (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) and then Has_Interfaces (Tagged_Type)); --- 12359,12365 ---- Typ : Entity_Id; begin ! pragma Assert (Ada_Version >= Ada_2005 and then Is_Record_Type (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) and then Has_Interfaces (Tagged_Type)); *************** package body Sem_Ch3 is *** 11927,11933 **** -- non-abstract tagged types that can reference abstract primitives -- through its Alias attribute are the internal entities that have -- attribute Interface_Alias, and these entities are generated later ! -- by Freeze_Record_Type). if In_Private_Part (Current_Scope) and then Is_Abstract_Type (Parent_Type) --- 12377,12383 ---- -- non-abstract tagged types that can reference abstract primitives -- through its Alias attribute are the internal entities that have -- attribute Interface_Alias, and these entities are generated later ! -- by Add_Internal_Interface_Entities). if In_Private_Part (Current_Scope) and then Is_Abstract_Type (Parent_Type) *************** package body Sem_Ch3 is *** 11993,11998 **** --- 12443,12464 ---- Derive_Subprogram (New_Subp, Iface_Subp, Tagged_Type, Iface); + -- Ada 2012 (AI05-0197): If the covering primitive's name + -- differs from the name of the interface primitive then it + -- is a private primitive inherited from a parent type. In + -- such case, given that Tagged_Type covers the interface, + -- the inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. + + elsif Chars (E) /= Chars (Iface_Subp) then + pragma Assert (Has_Suffix (E, 'P')); + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); + Set_Alias (New_Subp, E); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (E)); + -- Propagate to the full view interface entities associated -- with the partial view *************** package body Sem_Ch3 is *** 12205,12219 **** Set_Etype (New_Id, Base_Type (Derived_Type)); end if; - -- Ada 2005 (AI-251): Handle derivations of abstract interface - -- primitives. - - elsif Is_Interface (Etype (Id)) - and then not Is_Class_Wide_Type (Etype (Id)) - and then Is_Progenitor (Etype (Id), Derived_Type) - then - Set_Etype (New_Id, Derived_Type); - else Set_Etype (New_Id, Etype (Id)); end if; --- 12671,12676 ---- *************** package body Sem_Ch3 is *** 12233,12242 **** end if; end Set_Derived_Name; - -- Local variables - - Parent_Overrides_Interface_Primitive : Boolean := False; - -- Start of processing for Derive_Subprogram begin --- 12690,12695 ---- *************** package body Sem_Ch3 is *** 12244,12266 **** New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); Set_Ekind (New_Subp, Ekind (Parent_Subp)); - -- Check whether the parent overrides an interface primitive - - if Is_Overriding_Operation (Parent_Subp) then - declare - E : Entity_Id := Parent_Subp; - begin - while Present (Overridden_Operation (E)) loop - E := Ultimate_Alias (Overridden_Operation (E)); - end loop; - - Parent_Overrides_Interface_Primitive := - Is_Dispatching_Operation (E) - and then Present (Find_Dispatching_Type (E)) - and then Is_Interface (Find_Dispatching_Type (E)); - end; - end if; - -- Check whether the inherited subprogram is a private operation that -- should be inherited but not yet made visible. Such subprograms can -- become visible at a later point (e.g., the private part of a public --- 12697,12702 ---- *************** package body Sem_Ch3 is *** 12329,12335 **** -- overrides an interface primitive because interface primitives -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) ! elsif Parent_Overrides_Interface_Primitive then Set_Derived_Name; -- Otherwise, the type is inheriting a private operation, so enter --- 12765,12774 ---- -- overrides an interface primitive because interface primitives -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) ! elsif Ada_Version >= Ada_2005 ! and then Is_Dispatching_Operation (Parent_Subp) ! and then Covers_Some_Interface (Parent_Subp) ! then Set_Derived_Name; -- Otherwise, the type is inheriting a private operation, so enter *************** package body Sem_Ch3 is *** 12443,12448 **** --- 12882,12890 ---- if Ekind (Parent_Subp) = E_Procedure then Set_Is_Valued_Procedure (New_Subp, Is_Valued_Procedure (Parent_Subp)); + else + Set_Has_Controlling_Result + (New_Subp, Has_Controlling_Result (Parent_Subp)); end if; -- No_Return must be inherited properly. If this is overridden in the *************** package body Sem_Ch3 is *** 12466,12472 **** -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). ! elsif Ada_Version >= Ada_05 and then (Is_Abstract_Subprogram (Alias (New_Subp)) or else (Is_Tagged_Type (Derived_Type) and then Etype (New_Subp) = Derived_Type --- 12908,12914 ---- -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). ! elsif Ada_Version >= Ada_2005 and then (Is_Abstract_Subprogram (Alias (New_Subp)) or else (Is_Tagged_Type (Derived_Type) and then Etype (New_Subp) = Derived_Type *************** package body Sem_Ch3 is *** 12488,12494 **** Set_Requires_Overriding (New_Subp); end if; ! elsif Ada_Version < Ada_05 and then (Is_Abstract_Subprogram (Alias (New_Subp)) or else (Is_Tagged_Type (Derived_Type) and then Etype (New_Subp) = Derived_Type --- 12930,12936 ---- Set_Requires_Overriding (New_Subp); end if; ! elsif Ada_Version < Ada_2005 and then (Is_Abstract_Subprogram (Alias (New_Subp)) or else (Is_Tagged_Type (Derived_Type) and then Etype (New_Subp) = Derived_Type *************** package body Sem_Ch3 is *** 12496,12501 **** --- 12938,12952 ---- then Set_Is_Abstract_Subprogram (New_Subp); + -- AI05-0097 : an inherited operation that dispatches on result is + -- abstract if the derived type is abstract, even if the parent type + -- is concrete and the derived type is a null extension. + + elsif Has_Controlling_Result (Alias (New_Subp)) + and then Is_Abstract_Type (Etype (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); + -- Finally, if the parent type is abstract we must verify that all -- inherited operations are either non-abstract or overridden, or that -- the derived type itself is abstract (this check is performed at the *************** package body Sem_Ch3 is *** 12567,12575 **** Collect_Primitive_Operations (Parent_Type); function Check_Derived_Type return Boolean; ! -- Check that all primitive inherited from Parent_Type are found in -- the list of primitives of Derived_Type exactly in the same order. function Check_Derived_Type return Boolean is E : Entity_Id; Elmt : Elmt_Id; --- 13018,13035 ---- Collect_Primitive_Operations (Parent_Type); function Check_Derived_Type return Boolean; ! -- Check that all the entities derived from Parent_Type are found in -- the list of primitives of Derived_Type exactly in the same order. + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id); + -- Derive New_Subp from the ultimate alias of the parent subprogram Subp + -- (which is an interface primitive). If Generic_Actual is present then + -- Actual_Subp is the actual subprogram corresponding with the generic + -- subprogram Subp. + function Check_Derived_Type return Boolean is E : Entity_Id; Elmt : Elmt_Id; *************** package body Sem_Ch3 is *** 12645,12650 **** --- 13105,13149 ---- return True; end Check_Derived_Type; + --------------------------------- + -- Derive_Interface_Subprogram -- + --------------------------------- + + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id) + is + Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); + Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); + + begin + pragma Assert (Is_Interface (Iface_Type)); + + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Subp, + Derived_Type => Derived_Type, + Parent_Type => Iface_Type, + Actual_Subp => Actual_Subp); + + -- Given that this new interface entity corresponds with a primitive + -- of the parent that was not overridden we must leave it associated + -- with its parent primitive to ensure that it will share the same + -- dispatch table slot when overridden. + + if No (Actual_Subp) then + Set_Alias (New_Subp, Subp); + + -- For instantiations this is not needed since the previous call to + -- Derive_Subprogram leaves the entity well decorated. + + else + pragma Assert (Alias (New_Subp) = Actual_Subp); + null; + end if; + end Derive_Interface_Subprogram; + -- Local variables Alias_Subp : Entity_Id; *************** package body Sem_Ch3 is *** 12706,12711 **** --- 13205,13216 ---- -- corresponding operations of the actual. else + pragma Assert (No (Node (Act_Elmt)) + or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) + and then + Type_Conformant (Subp, Node (Act_Elmt), + Skip_Controlling_Formals => True))); + Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); *************** package body Sem_Ch3 is *** 12790,12802 **** Subp := Node (Elmt); Alias_Subp := Ultimate_Alias (Subp); ! -- At this early stage Derived_Type has no entities with attribute ! -- Interface_Alias. In addition, such primitives are always ! -- located at the end of the list of primitives of Parent_Type. ! -- Therefore, if found we can safely stop processing pending ! -- entities. ! exit when Present (Interface_Alias (Subp)); -- If the generic actual is present find the corresponding -- operation in the generic actual. If the parent type is a --- 13295,13307 ---- Subp := Node (Elmt); Alias_Subp := Ultimate_Alias (Subp); ! -- Do not derive internal entities of the parent that link ! -- interface primitives with their covering primitive. These ! -- entities will be added to this type when frozen. ! if Present (Interface_Alias (Subp)) then ! goto Continue; ! end if; -- If the generic actual is present find the corresponding -- operation in the generic actual. If the parent type is a *************** package body Sem_Ch3 is *** 12810,12836 **** if Need_Search or else (Present (Generic_Actual) ! and then Present (Act_Subp) ! and then not Primitive_Names_Match (Subp, Act_Subp)) then pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); - pragma Assert (Is_Interface (Parent_Base)); ! -- Remember that we need searching for all the pending ! -- primitives Need_Search := True; -- Handle entities associated with interface primitives ! if Present (Alias (Subp)) ! and then Is_Interface (Find_Dispatching_Type (Alias (Subp))) and then not Is_Predefined_Dispatching_Operation (Subp) then Act_Subp := Find_Primitive_Covering_Interface (Tagged_Type => Generic_Actual, ! Iface_Prim => Subp); -- Handle predefined primitives plus the rest of user-defined -- primitives --- 13315,13402 ---- if Need_Search or else (Present (Generic_Actual) ! and then Present (Act_Subp) ! and then not ! (Primitive_Names_Match (Subp, Act_Subp) ! and then ! Type_Conformant (Subp, Act_Subp, ! Skip_Controlling_Formals => True))) then pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); ! -- Remember that we need searching for all pending primitives Need_Search := True; -- Handle entities associated with interface primitives ! if Present (Alias_Subp) ! and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) and then not Is_Predefined_Dispatching_Operation (Subp) then + -- Search for the primitive in the homonym chain + Act_Subp := Find_Primitive_Covering_Interface (Tagged_Type => Generic_Actual, ! Iface_Prim => Alias_Subp); ! ! -- Previous search may not locate primitives covering ! -- interfaces defined in generics units or instantiations. ! -- (it fails if the covering primitive has formals whose ! -- type is also defined in generics or instantiations). ! -- In such case we search in the list of primitives of the ! -- generic actual for the internal entity that links the ! -- interface primitive and the covering primitive. ! ! if No (Act_Subp) ! and then Is_Generic_Type (Parent_Type) ! then ! -- This code has been designed to handle only generic ! -- formals that implement interfaces that are defined ! -- in a generic unit or instantiation. If this code is ! -- needed for other cases we must review it because ! -- (given that it relies on Original_Location to locate ! -- the primitive of Generic_Actual that covers the ! -- interface) it could leave linked through attribute ! -- Alias entities of unrelated instantiations). ! ! pragma Assert ! (Is_Generic_Unit ! (Scope (Find_Dispatching_Type (Alias_Subp))) ! or else ! Instantiation_Depth ! (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); ! ! declare ! Iface_Prim_Loc : constant Source_Ptr := ! Original_Location (Sloc (Alias_Subp)); ! Elmt : Elmt_Id; ! Prim : Entity_Id; ! begin ! Elmt := ! First_Elmt (Primitive_Operations (Generic_Actual)); ! ! Search : while Present (Elmt) loop ! Prim := Node (Elmt); ! ! if Present (Interface_Alias (Prim)) ! and then Original_Location ! (Sloc (Interface_Alias (Prim))) ! = Iface_Prim_Loc ! then ! Act_Subp := Alias (Prim); ! exit Search; ! end if; ! ! Next_Elmt (Elmt); ! end loop Search; ! end; ! end if; ! ! pragma Assert (Present (Act_Subp) ! or else Is_Abstract_Type (Generic_Actual) ! or else Serious_Errors_Detected > 0); -- Handle predefined primitives plus the rest of user-defined -- primitives *************** package body Sem_Ch3 is *** 12841,12852 **** Act_Subp := Node (Act_Elmt); exit when Primitive_Names_Match (Subp, Act_Subp) ! and then Type_Conformant (Subp, Act_Subp, ! Skip_Controlling_Formals => True) and then No (Interface_Alias (Act_Subp)); Next_Elmt (Act_Elmt); end loop; end if; end if; --- 13407,13423 ---- Act_Subp := Node (Act_Elmt); exit when Primitive_Names_Match (Subp, Act_Subp) ! and then Type_Conformant ! (Subp, Act_Subp, ! Skip_Controlling_Formals => True) and then No (Interface_Alias (Act_Subp)); Next_Elmt (Act_Elmt); end loop; + + if No (Act_Elmt) then + Act_Subp := Empty; + end if; end if; end if; *************** package body Sem_Ch3 is *** 12862,12887 **** then null; ! -- Case 2: Inherit entities associated with interfaces that ! -- were not covered by the parent type. We exclude here null ! -- interface primitives because they do not need special ! -- management. elsif Present (Alias (Subp)) and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) and then not (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification ! and then Null_Present (Parent (Alias_Subp))) then ! Derive_Subprogram ! (New_Subp => New_Subp, ! Parent_Subp => Alias_Subp, ! Derived_Type => Derived_Type, ! Parent_Type => Find_Dispatching_Type (Alias_Subp), ! Actual_Subp => Act_Subp); ! if No (Generic_Actual) then ! Set_Alias (New_Subp, Subp); end if; -- Case 3: Common derivation --- 13433,13524 ---- then null; ! -- Case 2: Inherit entities associated with interfaces that were ! -- not covered by the parent type. We exclude here null interface ! -- primitives because they do not need special management. ! ! -- We also exclude interface operations that are renamings. If the ! -- subprogram is an explicit renaming of an interface primitive, ! -- it is a regular primitive operation, and the presence of its ! -- alias is not relevant: it has to be derived like any other ! -- primitive. elsif Present (Alias (Subp)) + and then Nkind (Unit_Declaration_Node (Subp)) /= + N_Subprogram_Renaming_Declaration and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) and then not (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification ! and then Null_Present (Parent (Alias_Subp))) then ! -- If this is an abstract private type then we transfer the ! -- derivation of the interface primitive from the partial view ! -- to the full view. This is safe because all the interfaces ! -- must be visible in the partial view. Done to avoid adding ! -- a new interface derivation to the private part of the ! -- enclosing package; otherwise this new derivation would be ! -- decorated as hidden when the analysis of the enclosing ! -- package completes. ! if Is_Abstract_Type (Derived_Type) ! and then In_Private_Part (Current_Scope) ! and then Has_Private_Declaration (Derived_Type) ! then ! declare ! Partial_View : Entity_Id; ! Elmt : Elmt_Id; ! Ent : Entity_Id; ! ! begin ! Partial_View := First_Entity (Current_Scope); ! loop ! exit when No (Partial_View) ! or else (Has_Private_Declaration (Partial_View) ! and then ! Full_View (Partial_View) = Derived_Type); ! ! Next_Entity (Partial_View); ! end loop; ! ! -- If the partial view was not found then the source code ! -- has errors and the derivation is not needed. ! ! if Present (Partial_View) then ! Elmt := ! First_Elmt (Primitive_Operations (Partial_View)); ! while Present (Elmt) loop ! Ent := Node (Elmt); ! ! if Present (Alias (Ent)) ! and then Ultimate_Alias (Ent) = Alias (Subp) ! then ! Append_Elmt ! (Ent, Primitive_Operations (Derived_Type)); ! exit; ! end if; ! ! Next_Elmt (Elmt); ! end loop; ! ! -- If the interface primitive was not found in the ! -- partial view then this interface primitive was ! -- overridden. We add a derivation to activate in ! -- Derive_Progenitor_Subprograms the machinery to ! -- search for it. ! ! if No (Elmt) then ! Derive_Interface_Subprogram ! (New_Subp => New_Subp, ! Subp => Subp, ! Actual_Subp => Act_Subp); ! end if; ! end if; ! end; ! else ! Derive_Interface_Subprogram ! (New_Subp => New_Subp, ! Subp => Subp, ! Actual_Subp => Act_Subp); end if; -- Case 3: Common derivation *************** package body Sem_Ch3 is *** 12905,12910 **** --- 13542,13548 ---- Act_Subp := Node (Act_Elmt); end if; + <> Next_Elmt (Elmt); end loop; *************** package body Sem_Ch3 is *** 12921,12927 **** end if; -- Final check: Direct descendants must have their primitives in the ! -- same order. We exclude from this test non-tagged types and instances -- of formal derived types. We skip this test if we have already -- reported serious errors in the sources. --- 13559,13565 ---- end if; -- Final check: Direct descendants must have their primitives in the ! -- same order. We exclude from this test untagged types and instances -- of formal derived types. We skip this test if we have already -- reported serious errors in the sources. *************** package body Sem_Ch3 is *** 13203,13210 **** Set_Etype (T, Any_Type); Set_Scalar_Range (T, Scalar_Range (Any_Type)); ! if Is_Tagged_Type (T) then ! Set_Primitive_Operations (T, New_Elmt_List); end if; return; --- 13841,13850 ---- Set_Etype (T, Any_Type); Set_Scalar_Range (T, Scalar_Range (Any_Type)); ! if Is_Tagged_Type (T) ! and then Is_Record_Type (T) ! then ! Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; return; *************** package body Sem_Ch3 is *** 13287,13294 **** New_Copy (Subtype_Indication (Parent (Partial_View)))); ! New_Iface := Make_Identifier (Sloc (N), ! Chars (Parent_Type)); Append (New_Iface, Interface_List (Def)); -- Analyze the transformed code --- 13927,13934 ---- New_Copy (Subtype_Indication (Parent (Partial_View)))); ! New_Iface := ! Make_Identifier (Sloc (N), Chars (Parent_Type)); Append (New_Iface, Interface_List (Def)); -- Analyze the transformed code *************** package body Sem_Ch3 is *** 13334,13342 **** -- Check for early use of incomplete or private type ! if Ekind (Parent_Type) = E_Void ! or else Ekind (Parent_Type) = E_Incomplete_Type ! then Error_Msg_N ("premature derivation of incomplete type", Indic); return; --- 13974,13980 ---- -- Check for early use of incomplete or private type ! if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then Error_Msg_N ("premature derivation of incomplete type", Indic); return; *************** package body Sem_Ch3 is *** 13421,13428 **** if not Is_Generic_Actual_Type (Parent_Type) or else In_Visible_Part (Scope (Parent_Type)) then ! Error_Msg_N ! ("type derived from tagged type must have extension", Indic); end if; end if; --- 14059,14076 ---- if not Is_Generic_Actual_Type (Parent_Type) or else In_Visible_Part (Scope (Parent_Type)) then ! if Is_Class_Wide_Type (Parent_Type) then ! Error_Msg_N ! ("parent type must not be a class-wide type", Indic); ! ! -- Use specific type to prevent cascaded errors. ! ! Parent_Type := Etype (Parent_Type); ! ! else ! Error_Msg_N ! ("type derived from tagged type must have extension", Indic); ! end if; end if; end if; *************** package body Sem_Ch3 is *** 13430,13436 **** -- extension. There is no point in checking the ancestor type or -- the progenitors since the construct is wrong to begin with. ! if Ada_Version >= Ada_05 and then Is_Generic_Type (T) and then Present (Original_Node (N)) then --- 14078,14084 ---- -- extension. There is no point in checking the ancestor type or -- the progenitors since the construct is wrong to begin with. ! if Ada_Version >= Ada_2005 and then Is_Generic_Type (T) and then Present (Original_Node (N)) then *************** package body Sem_Ch3 is *** 13480,13487 **** (not Is_Interface (Parent_Type) or else not Is_Limited_Interface (Parent_Type)) then ! Error_Msg_NE ("parent type& of limited type must be limited", ! N, Parent_Type); end if; end if; end Derived_Type_Declaration; --- 14128,14150 ---- (not Is_Interface (Parent_Type) or else not Is_Limited_Interface (Parent_Type)) then ! -- AI05-0096: a derivation in the private part of an instance is ! -- legal if the generic formal is untagged limited, and the actual ! -- is non-limited. ! ! if Is_Generic_Actual_Type (Parent_Type) ! and then In_Private_Part (Current_Scope) ! and then ! not Is_Tagged_Type ! (Generic_Parent_Type (Parent (Parent_Type))) ! then ! null; ! ! else ! Error_Msg_NE ! ("parent type& of limited type must be limited", ! N, Parent_Type); ! end if; end if; end if; end Derived_Type_Declaration; *************** package body Sem_Ch3 is *** 13547,13554 **** --- 14210,14229 ---- Generate_Definition (L); Set_Convention (L, Convention_Intrinsic); + -- Case of character literal + if Nkind (L) = N_Defining_Character_Literal then Set_Is_Character_Type (T, True); + + -- Check violation of No_Wide_Characters + + if Restriction_Check_Required (No_Wide_Characters) then + Get_Name_String (Chars (L)); + + if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then + Check_Restriction (No_Wide_Characters, L); + end if; + end if; end if; Ev := Ev + 1; *************** package body Sem_Ch3 is *** 13718,13728 **** procedure Tag_Mismatch is begin if Sloc (Prev) < Sloc (Id) then ! Error_Msg_NE ! ("full declaration of } must be a tagged type ", Id, Prev); else ! Error_Msg_NE ! ("full declaration of } must be a tagged type ", Prev, Id); end if; end Tag_Mismatch; --- 14393,14417 ---- procedure Tag_Mismatch is begin if Sloc (Prev) < Sloc (Id) then ! if Ada_Version >= Ada_2012 ! and then Nkind (N) = N_Private_Type_Declaration ! then ! Error_Msg_NE ! ("declaration of private } must be a tagged type ", Id, Prev); ! else ! Error_Msg_NE ! ("full declaration of } must be a tagged type ", Id, Prev); ! end if; else ! if Ada_Version >= Ada_2012 ! and then Nkind (N) = N_Private_Type_Declaration ! then ! Error_Msg_NE ! ("declaration of private } must be a tagged type ", Prev, Id); ! else ! Error_Msg_NE ! ("full declaration of } must be a tagged type ", Prev, Id); ! end if; end if; end Tag_Mismatch; *************** package body Sem_Ch3 is *** 13733,13753 **** Prev := Current_Entity_In_Scope (Id); ! if Present (Prev) then ! -- Previous declaration exists. Error if not incomplete/private case ! -- except if previous declaration is implicit, etc. Enter_Name will ! -- emit error if appropriate. Prev_Par := Parent (Prev); if not Is_Incomplete_Or_Private_Type (Prev) then Enter_Name (Id); New_Id := Id; elsif not Nkind_In (N, N_Full_Type_Declaration, N_Task_Type_Declaration, N_Protected_Type_Declaration) then -- Completion must be a full type declarations (RM 7.3(4)) --- 14422,14456 ---- Prev := Current_Entity_In_Scope (Id); ! -- New type declaration ! if No (Prev) then ! Enter_Name (Id); ! return Id; + -- Previous declaration exists + + else Prev_Par := Parent (Prev); + -- Error if not incomplete/private case except if previous + -- declaration is implicit, etc. Enter_Name will emit error if + -- appropriate. + if not Is_Incomplete_Or_Private_Type (Prev) then Enter_Name (Id); New_Id := Id; + -- Check invalid completion of private or incomplete type + elsif not Nkind_In (N, N_Full_Type_Declaration, N_Task_Type_Declaration, N_Protected_Type_Declaration) + and then + (Ada_Version < Ada_2012 + or else not Is_Incomplete_Type (Prev) + or else not Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration)) then -- Completion must be a full type declarations (RM 7.3(4)) *************** package body Sem_Ch3 is *** 13769,13775 **** -- Case of full declaration of incomplete type ! elsif Ekind (Prev) = E_Incomplete_Type then -- Indicate that the incomplete declaration has a matching full -- declaration. The defining occurrence of the incomplete --- 14472,14482 ---- -- Case of full declaration of incomplete type ! elsif Ekind (Prev) = E_Incomplete_Type ! and then (Ada_Version < Ada_2012 ! or else No (Full_View (Prev)) ! or else not Is_Private_Type (Full_View (Prev))) ! then -- Indicate that the incomplete declaration has a matching full -- declaration. The defining occurrence of the incomplete *************** package body Sem_Ch3 is *** 13786,13794 **** --- 14493,14526 ---- Set_Is_Internal (Id); New_Id := Prev; + -- If the incomplete view is tagged, a class_wide type has been + -- created already. Use it for the private type as well, in order + -- to prevent multiple incompatible class-wide types that may be + -- created for self-referential anonymous access components. + + if Is_Tagged_Type (Prev) + and then Present (Class_Wide_Type (Prev)) + then + Set_Ekind (Id, Ekind (Prev)); -- will be reset later + Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (Id), Id); + end if; + -- Case of full declaration of private type else + -- If the private type was a completion of an incomplete type then + -- update Prev to reference the private type + + if Ada_Version >= Ada_2012 + and then Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Is_Private_Type (Full_View (Prev)) + then + Prev := Full_View (Prev); + Prev_Par := Parent (Prev); + end if; + if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then if Etype (Prev) /= Prev then *************** package body Sem_Ch3 is *** 13906,13919 **** if Is_Type (Prev) and then (Is_Tagged_Type (Prev) ! or else Present (Class_Wide_Type (Prev))) then -- The full declaration is either a tagged type (including -- a synchronized type that implements interfaces) or a -- type extension, otherwise this is an error. ! if Nkind_In (N, N_Task_Type_Declaration, ! N_Protected_Type_Declaration) then if No (Interface_List (N)) and then not Error_Posted (N) --- 14638,14667 ---- if Is_Type (Prev) and then (Is_Tagged_Type (Prev) ! or else Present (Class_Wide_Type (Prev))) then + -- Ada 2012 (AI05-0162): A private type may be the completion of + -- an incomplete type + + if Ada_Version >= Ada_2012 + and then Is_Incomplete_Type (Prev) + and then Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration) + then + -- No need to check private extensions since they are tagged + + if Nkind (N) = N_Private_Type_Declaration + and then not Tagged_Present (N) + then + Tag_Mismatch; + end if; + -- The full declaration is either a tagged type (including -- a synchronized type that implements interfaces) or a -- type extension, otherwise this is an error. ! elsif Nkind_In (N, N_Task_Type_Declaration, ! N_Protected_Type_Declaration) then if No (Interface_List (N)) and then not Error_Posted (N) *************** package body Sem_Ch3 is *** 13929,13947 **** if not Tagged_Present (Type_Definition (N)) then Tag_Mismatch; Set_Is_Tagged_Type (Id); - Set_Primitive_Operations (Id, New_Elmt_List); end if; elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then if No (Record_Extension_Part (Type_Definition (N))) then ! Error_Msg_NE ( ! "full declaration of } must be a record extension", ! Prev, Id); -- Set some attributes to produce a usable full view Set_Is_Tagged_Type (Id); - Set_Primitive_Operations (Id, New_Elmt_List); end if; else --- 14677,14693 ---- if not Tagged_Present (Type_Definition (N)) then Tag_Mismatch; Set_Is_Tagged_Type (Id); end if; elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then if No (Record_Extension_Part (Type_Definition (N))) then ! Error_Msg_NE ! ("full declaration of } must be a record extension", ! Prev, Id); -- Set some attributes to produce a usable full view Set_Is_Tagged_Type (Id); end if; else *************** package body Sem_Ch3 is *** 13950,13961 **** end if; return New_Id; - - else - -- New type declaration - - Enter_Name (Id); - return Id; end if; end Find_Type_Name; --- 14696,14701 ---- *************** package body Sem_Ch3 is *** 14027,14033 **** then null; else ! Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P))); end if; -- Ada 2005 AI-406: the object definition in an object declaration --- 14767,14773 ---- then null; else ! Insert_Actions (Obj_Def, Freeze_Entity (T, P)); end if; -- Ada 2005 AI-406: the object definition in an object declaration *************** package body Sem_Ch3 is *** 14081,14093 **** -- Check No_Wide_Characters restriction ! if Typ = Standard_Wide_Character ! or else Typ = Standard_Wide_Wide_Character ! or else Typ = Standard_Wide_String ! or else Typ = Standard_Wide_Wide_String ! then ! Check_Restriction (No_Wide_Characters, S); ! end if; return Typ; end Find_Type_Of_Subtype_Indic; --- 14821,14827 ---- -- Check No_Wide_Characters restriction ! Check_Wide_Character_Restriction (Typ, S); return Typ; end Find_Type_Of_Subtype_Indic; *************** package body Sem_Ch3 is *** 14221,14227 **** Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); ! Set_Vax_Float (Implicit_Base, Vax_Float (Base_Typ)); Set_Ekind (T, E_Floating_Point_Subtype); Set_Etype (T, Implicit_Base); --- 14955,14961 ---- Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); ! Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); Set_Ekind (T, E_Floating_Point_Subtype); Set_Etype (T, Implicit_Base); *************** package body Sem_Ch3 is *** 14757,14764 **** then null; ! elsif Ekind (Derived_Base) = E_Private_Type ! or else Ekind (Derived_Base) = E_Limited_Private_Type then null; --- 15491,15498 ---- then null; ! elsif Ekind_In (Derived_Base, E_Private_Type, ! E_Limited_Private_Type) then null; *************** package body Sem_Ch3 is *** 14833,14851 **** end if; end Is_Null_Extension; - -------------------- - -- Is_Progenitor -- - -------------------- - - function Is_Progenitor - (Iface : Entity_Id; - Typ : Entity_Id) return Boolean - is - begin - return Implements_Interface (Typ, Iface, - Exclude_Parents => True); - end Is_Progenitor; - ------------------------------ -- Is_Valid_Constraint_Kind -- ------------------------------ --- 15567,15572 ---- *************** package body Sem_Ch3 is *** 14926,14934 **** -- Start of processing for Is_Visible_Component begin ! if Ekind (C) = E_Component ! or else Ekind (C) = E_Discriminant ! then Original_Comp := Original_Record_Component (C); end if; --- 15647,15653 ---- -- Start of processing for Is_Visible_Component begin ! if Ekind_In (C, E_Component, E_Discriminant) then Original_Comp := Original_Record_Component (C); end if; *************** package body Sem_Ch3 is *** 15081,15092 **** -- Customize the class-wide type: It has no prim. op., it cannot be -- abstract and its Etype points back to the specific root type. ! Set_Ekind (CW_Type, E_Class_Wide_Type); ! Set_Is_Tagged_Type (CW_Type, True); ! Set_Primitive_Operations (CW_Type, New_Elmt_List); ! Set_Is_Abstract_Type (CW_Type, False); ! Set_Is_Constrained (CW_Type, False); ! Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); --- 15800,15811 ---- -- Customize the class-wide type: It has no prim. op., it cannot be -- abstract and its Etype points back to the specific root type. ! Set_Ekind (CW_Type, E_Class_Wide_Type); ! Set_Is_Tagged_Type (CW_Type, True); ! Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); ! Set_Is_Abstract_Type (CW_Type, False); ! Set_Is_Constrained (CW_Type, False); ! Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); *************** package body Sem_Ch3 is *** 15458,15467 **** Set_Scalar_Range (T, Make_Range (Sloc (Mod_Expr), ! Low_Bound => ! Make_Integer_Literal (Sloc (Mod_Expr), 0), ! High_Bound => ! Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); -- Properly analyze the literals for the range. We do this manually -- because we can't go calling Resolve, since we are resolving these --- 16177,16184 ---- Set_Scalar_Range (T, Make_Range (Sloc (Mod_Expr), ! Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), ! High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); -- Properly analyze the literals for the range. We do this manually -- because we can't go calling Resolve, since we are resolving these *************** package body Sem_Ch3 is *** 15574,15580 **** is begin return Is_CPP_Constructor_Call (Exp) ! or else (Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L and then OK_For_Limited_Init_In_05 (Typ, Exp)); end OK_For_Limited_Init; --- 16291,16297 ---- is begin return Is_CPP_Constructor_Call (Exp) ! or else (Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L and then OK_For_Limited_Init_In_05 (Typ, Exp)); end OK_For_Limited_Init; *************** package body Sem_Ch3 is *** 15600,15607 **** -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in -- case of limited aggregates (including extension aggregates), and ! -- function calls. The function call may have been give in prefixed -- notation, in which case the original node is an indexed component. case Nkind (Original_Node (Exp)) is when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => --- 16317,16326 ---- -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in -- case of limited aggregates (including extension aggregates), and ! -- function calls. The function call may have been given in prefixed -- notation, in which case the original node is an indexed component. + -- If the function is parameterless, the original node was an explicit + -- dereference. case Nkind (Original_Node (Exp)) is when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => *************** package body Sem_Ch3 is *** 15620,15632 **** -- A return statement for a build-in-place function returning a -- synchronized type also introduces an unchecked conversion. ! when N_Type_Conversion | N_Unchecked_Type_Conversion => return not Comes_From_Source (Exp) and then OK_For_Limited_Init_In_05 (Typ, Expression (Original_Node (Exp))); ! when N_Indexed_Component | N_Selected_Component => return Nkind (Exp) = N_Function_Call; -- A use of 'Input is a function call, hence allowed. Normally the --- 16339,16354 ---- -- A return statement for a build-in-place function returning a -- synchronized type also introduces an unchecked conversion. ! when N_Type_Conversion | ! N_Unchecked_Type_Conversion => return not Comes_From_Source (Exp) and then OK_For_Limited_Init_In_05 (Typ, Expression (Original_Node (Exp))); ! when N_Indexed_Component | ! N_Selected_Component | ! N_Explicit_Dereference => return Nkind (Exp) = N_Function_Call; -- A use of 'Input is a function call, hence allowed. Normally the *************** package body Sem_Ch3 is *** 15875,15881 **** -- Ada 2005 (AI-230): Access discriminant allowed in non-limited -- record types ! if Ada_Version < Ada_05 then Check_Access_Discriminant_Requires_Limited (Discr, Discriminant_Type (Discr)); end if; --- 16597,16603 ---- -- Ada 2005 (AI-230): Access discriminant allowed in non-limited -- record types ! if Ada_Version < Ada_2005 then Check_Access_Discriminant_Requires_Limited (Discr, Discriminant_Type (Discr)); end if; *************** package body Sem_Ch3 is *** 15908,15923 **** ("discriminant defaults not allowed for formal type", Expression (Discr)); ! -- Tagged types cannot have defaulted discriminants, but a ! -- non-tagged private type with defaulted discriminants ! -- can have a tagged completion. elsif Is_Tagged_Type (Current_Scope) and then Comes_From_Source (N) then ! Error_Msg_N ! ("discriminants of tagged type cannot have defaults", ! Expression (Discr)); else Default_Present := True; --- 16630,16662 ---- ("discriminant defaults not allowed for formal type", Expression (Discr)); ! -- Flag an error for a tagged type with defaulted discriminants, ! -- excluding limited tagged types when compiling for Ada 2012 ! -- (see AI05-0214). elsif Is_Tagged_Type (Current_Scope) + and then (not Is_Limited_Type (Current_Scope) + or else Ada_Version < Ada_2012) and then Comes_From_Source (N) then ! -- Note: see similar test in Check_Or_Process_Discriminants, to ! -- handle the (illegal) case of the completion of an untagged ! -- view with discriminants with defaults by a tagged full view. ! -- We skip the check if Discr does not come from source, to ! -- account for the case of an untagged derived type providing ! -- defaults for a renamed discriminant from a private untagged ! -- ancestor with a tagged full view (ACATS B460006). ! ! if Ada_Version >= Ada_2012 then ! Error_Msg_N ! ("discriminants of nonlimited tagged type cannot have" ! & " defaults", ! Expression (Discr)); ! else ! Error_Msg_N ! ("discriminants of tagged type cannot have defaults", ! Expression (Discr)); ! end if; else Default_Present := True; *************** package body Sem_Ch3 is *** 15937,15943 **** -- Ada 2005 (AI-231): Create an Itype that is a duplicate of -- Discr_Type but with the null-exclusion attribute ! if Ada_Version >= Ada_05 then -- Ada 2005 (AI-231): Static checks --- 16676,16682 ---- -- Ada 2005 (AI-231): Create an Itype that is a duplicate of -- Discr_Type but with the null-exclusion attribute ! if Ada_Version >= Ada_2005 then -- Ada 2005 (AI-231): Static checks *************** package body Sem_Ch3 is *** 16130,16136 **** if Ekind (Typ) = E_Record_Type_With_Private then ! -- Handle the following erronous case: -- type Private_Type is tagged private; -- private -- type Private_Type is new Type_Implementing_Iface; --- 16869,16875 ---- if Ekind (Typ) = E_Record_Type_With_Private then ! -- Handle the following erroneous case: -- type Private_Type is tagged private; -- private -- type Private_Type is new Type_Implementing_Iface; *************** package body Sem_Ch3 is *** 16225,16231 **** -- consistent. We omit this check for synchronized types because -- they are performed on the corresponding record type when frozen. ! if Ada_Version >= Ada_05 and then Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) and then not Is_Concurrent_Type (Full_T) --- 16964,16970 ---- -- consistent. We omit this check for synchronized types because -- they are performed on the corresponding record type when frozen. ! if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) and then not Is_Concurrent_Type (Full_T) *************** package body Sem_Ch3 is *** 16246,16260 **** Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ("interface & not implemented by full type " & ! "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ("interface & not implemented by partial view " & ! "(RM-2005 7.3 (7.3/2))", Full_T, Iface); end if; end; end if; --- 16985,17001 ---- Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ! ("interface & not implemented by full type " & ! "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ! ("interface & not implemented by partial view " & ! "(RM-2005 7.3 (7.3/2))", Full_T, Iface); end if; end; end if; *************** package body Sem_Ch3 is *** 16423,16429 **** -- Ada 2005 (AI-443): A synchronized private extension must be -- completed by a task or protected type. ! if Ada_Version >= Ada_05 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration and then Synchronized_Present (Parent (Priv_T)) and then not Is_Concurrent_Type (Full_T) --- 17164,17170 ---- -- Ada 2005 (AI-443): A synchronized private extension must be -- completed by a task or protected type. ! if Ada_Version >= Ada_2005 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration and then Synchronized_Present (Parent (Priv_T)) and then not Is_Concurrent_Type (Full_T) *************** package body Sem_Ch3 is *** 16463,16471 **** while Present (Priv_Elmt) loop Priv := Node (Priv_Elmt); ! if Ekind (Priv) = E_Private_Subtype ! or else Ekind (Priv) = E_Limited_Private_Subtype ! or else Ekind (Priv) = E_Record_Subtype_With_Private then Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); Set_Is_Itype (Full); --- 17204,17212 ---- while Present (Priv_Elmt) loop Priv := Node (Priv_Elmt); ! if Ekind_In (Priv, E_Private_Subtype, ! E_Limited_Private_Subtype, ! E_Record_Subtype_With_Private) then Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); Set_Is_Itype (Full); *************** package body Sem_Ch3 is *** 16613,16622 **** Prim := Next_Entity (Full_T); while Present (Prim) and then Prim /= Priv_T loop ! if Ekind (Prim) = E_Procedure ! or else ! Ekind (Prim) = E_Function ! then Disp_Typ := Find_Dispatching_Type (Prim); if Disp_Typ = Full_T --- 17354,17360 ---- Prim := Next_Entity (Full_T); while Present (Prim) and then Prim /= Priv_T loop ! if Ekind_In (Prim, E_Procedure, E_Function) then Disp_Typ := Find_Dispatching_Type (Prim); if Disp_Typ = Full_T *************** package body Sem_Ch3 is *** 16646,16658 **** end loop; end if; ! -- For the tagged case, the two views can share the same ! -- Primitive Operation list and the same class wide type. ! -- Update attributes of the class-wide type which depend on ! -- the full declaration. if Is_Tagged_Type (Priv_T) then ! Set_Primitive_Operations (Priv_T, Full_List); Set_Class_Wide_Type (Base_Type (Full_T), Class_Wide_Type (Priv_T)); --- 17384,17395 ---- end loop; end if; ! -- For the tagged case, the two views can share the same primitive ! -- operations list and the same class-wide type. Update attributes ! -- of the class-wide type which depend on the full declaration. if Is_Tagged_Type (Priv_T) then ! Set_Direct_Primitive_Operations (Priv_T, Full_List); Set_Class_Wide_Type (Base_Type (Full_T), Class_Wide_Type (Priv_T)); *************** package body Sem_Ch3 is *** 16670,16677 **** -- but it means we don't have to struggle to meet the requirements in -- the RM for having Preelaborable Initialization. Otherwise we -- require that the type meets the RM rules. But we can't check that ! -- yet, because of the rule about overriding Ininitialize, so we ! -- simply set a flag that will be checked at freeze time. if not In_Predefined_Unit (Full_T) then Set_Must_Have_Preelab_Init (Full_T); --- 17407,17414 ---- -- but it means we don't have to struggle to meet the requirements in -- the RM for having Preelaborable Initialization. Otherwise we -- require that the type meets the RM rules. But we can't check that ! -- yet, because of the rule about overriding Initialize, so we simply ! -- set a flag that will be checked at freeze time. if not In_Predefined_Unit (Full_T) then Set_Must_Have_Preelab_Init (Full_T); *************** package body Sem_Ch3 is *** 16689,16706 **** --- 17426,17466 ---- -- If the private view has user specified stream attributes, then so has -- the full view. + -- Why the test, how could these flags be already set in Full_T ??? + if Has_Specified_Stream_Read (Priv_T) then Set_Has_Specified_Stream_Read (Full_T); end if; + if Has_Specified_Stream_Write (Priv_T) then Set_Has_Specified_Stream_Write (Full_T); end if; + if Has_Specified_Stream_Input (Priv_T) then Set_Has_Specified_Stream_Input (Full_T); end if; + if Has_Specified_Stream_Output (Priv_T) then Set_Has_Specified_Stream_Output (Full_T); end if; + + -- Propagate invariants to full type + + if Has_Invariants (Priv_T) then + Set_Has_Invariants (Full_T); + Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); + end if; + + if Has_Inheritable_Invariants (Priv_T) then + Set_Has_Inheritable_Invariants (Full_T); + end if; + + -- Propagate predicates to full type + + if Has_Predicates (Priv_T) then + Set_Predicate_Function (Priv_T, Predicate_Function (Full_T)); + Set_Has_Predicates (Priv_T); + end if; end Process_Full_View; ----------------------------------- *************** package body Sem_Ch3 is *** 16829,16838 **** Check_List : List_Id := Empty_List; R_Check_Off : Boolean := False) is ! Lo, Hi : Node_Id; ! R_Checks : Check_Result; ! Type_Decl : Node_Id; ! Def_Id : Entity_Id; begin Analyze_And_Resolve (R, Base_Type (T)); --- 17589,17598 ---- Check_List : List_Id := Empty_List; R_Check_Off : Boolean := False) is ! Lo, Hi : Node_Id; ! R_Checks : Check_Result; ! Insert_Node : Node_Id; ! Def_Id : Entity_Id; begin Analyze_And_Resolve (R, Base_Type (T)); *************** package body Sem_Ch3 is *** 16940,16971 **** if not R_Check_Off then R_Checks := Get_Range_Checks (R, T); ! -- Look up tree to find an appropriate insertion point. ! -- This seems really junk code, and very brittle, couldn't ! -- we just use an insert actions call of some kind ??? ! Type_Decl := Parent (R); ! while Present (Type_Decl) and then not ! (Nkind_In (Type_Decl, N_Full_Type_Declaration, ! N_Subtype_Declaration, ! N_Loop_Statement, ! N_Task_Type_Declaration) ! or else ! Nkind_In (Type_Decl, N_Single_Task_Declaration, ! N_Protected_Type_Declaration, ! N_Single_Protected_Declaration)) ! loop ! Type_Decl := Parent (Type_Decl); end loop; -- Why would Type_Decl not be present??? Without this test, -- short regression tests fail. ! if Present (Type_Decl) then ! -- Case of loop statement (more comments ???) ! if Nkind (Type_Decl) = N_Loop_Statement then declare Indic : Node_Id; --- 17700,17742 ---- if not R_Check_Off then R_Checks := Get_Range_Checks (R, T); ! -- Look up tree to find an appropriate insertion point. We ! -- can't just use insert_actions because later processing ! -- depends on the insertion node. Prior to Ada2012 the ! -- insertion point could only be a declaration or a loop, but ! -- quantified expressions can appear within any context in an ! -- expression, and the insertion point can be any statement, ! -- pragma, or declaration. ! Insert_Node := Parent (R); ! while Present (Insert_Node) loop ! exit when ! Nkind (Insert_Node) in N_Declaration ! and then ! not Nkind_In ! (Insert_Node, N_Component_Declaration, ! N_Loop_Parameter_Specification, ! N_Function_Specification, ! N_Procedure_Specification); ! ! exit when Nkind (Insert_Node) in N_Later_Decl_Item ! or else Nkind (Insert_Node) in ! N_Statement_Other_Than_Procedure_Call ! or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, ! N_Pragma); ! ! Insert_Node := Parent (Insert_Node); end loop; -- Why would Type_Decl not be present??? Without this test, -- short regression tests fail. ! if Present (Insert_Node) then ! -- Case of loop statement. Verify that the range is part ! -- of the subtype indication of the iteration scheme. ! if Nkind (Insert_Node) = N_Loop_Statement then declare Indic : Node_Id; *************** package body Sem_Ch3 is *** 16982,16999 **** Insert_Range_Checks (R_Checks, ! Type_Decl, Def_Id, ! Sloc (Type_Decl), R, Do_Before => True); end if; end; ! -- All other cases (more comments ???) ! else ! Def_Id := Defining_Identifier (Type_Decl); if (Ekind (Def_Id) = E_Record_Type and then Depends_On_Discriminant (R)) --- 17753,17772 ---- Insert_Range_Checks (R_Checks, ! Insert_Node, Def_Id, ! Sloc (Insert_Node), R, Do_Before => True); end if; end; ! -- Insertion before a declaration. If the declaration ! -- includes discriminants, the list of applicable checks ! -- is given by the caller. ! elsif Nkind (Insert_Node) in N_Declaration then ! Def_Id := Defining_Identifier (Insert_Node); if (Ekind (Def_Id) = E_Record_Type and then Depends_On_Discriminant (R)) *************** package body Sem_Ch3 is *** 17002,17019 **** and then Has_Discriminants (Def_Id)) then Append_Range_Checks ! (R_Checks, Check_List, Def_Id, Sloc (Type_Decl), R); else Insert_Range_Checks ! (R_Checks, Type_Decl, Def_Id, Sloc (Type_Decl), R); end if; end if; end if; end if; end if; elsif Expander_Active then Get_Index_Bounds (R, Lo, Hi); Force_Evaluation (Lo); --- 17775,17803 ---- and then Has_Discriminants (Def_Id)) then Append_Range_Checks ! (R_Checks, ! Check_List, Def_Id, Sloc (Insert_Node), R); else Insert_Range_Checks ! (R_Checks, ! Insert_Node, Def_Id, Sloc (Insert_Node), R); end if; + + -- Insertion before a statement. Range appears in the + -- context of a quantified expression. Insertion will + -- take place when expression is expanded. + + else + null; end if; end if; end if; end if; + -- Case of other than an explicit N_Range node + elsif Expander_Active then Get_Index_Bounds (R, Lo, Hi); Force_Evaluation (Lo); *************** package body Sem_Ch3 is *** 17097,17103 **** if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type and then ! not (Ada_Version >= Ada_05 and then (Nkind (Parent (T)) = N_Subtype_Declaration or else --- 17881,17887 ---- if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type and then ! not (Ada_Version >= Ada_2005 and then (Nkind (Parent (T)) = N_Subtype_Declaration or else *************** package body Sem_Ch3 is *** 17121,17127 **** -- Ada 2005 (AI-231): Static check ! if Ada_Version >= Ada_05 and then Present (P) and then Null_Exclusion_Present (P) and then Nkind (P) /= N_Access_To_Object_Definition --- 17905,17911 ---- -- Ada 2005 (AI-231): Static check ! if Ada_Version >= Ada_2005 and then Present (P) and then Null_Exclusion_Present (P) and then Nkind (P) /= N_Access_To_Object_Definition *************** package body Sem_Ch3 is *** 17149,17155 **** N_Subtype_Declaration); -- Create an Itype that is a duplicate of Entity (S) but with the ! -- null-exclusion attribute if May_Have_Null_Exclusion and then Is_Access_Type (Entity (S)) --- 17933,17939 ---- N_Subtype_Declaration); -- Create an Itype that is a duplicate of Entity (S) but with the ! -- null-exclusion attribute. if May_Have_Null_Exclusion and then Is_Access_Type (Entity (S)) *************** package body Sem_Ch3 is *** 17480,17498 **** and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type and then Full_View (Current_Entity (Typ)) = Typ then return; else Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); ! -- Type has already been inserted into the current scope. ! -- Remove it, and add incomplete declaration for type, so ! -- that subsequent anonymous access types can use it. ! -- The entity is unchained from the homonym list and from ! -- immediate visibility. After analysis, the entity in the ! -- incomplete declaration becomes immediately visible in the ! -- record declaration that follows. H := Current_Entity (Typ); --- 18264,18290 ---- and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type and then Full_View (Current_Entity (Typ)) = Typ then + if Is_Tagged + and then Comes_From_Source (Current_Entity (Typ)) + and then not Is_Tagged_Type (Current_Entity (Typ)) + then + Make_Class_Wide_Type (Typ); + Error_Msg_N + ("incomplete view of tagged type should be declared tagged?", + Parent (Current_Entity (Typ))); + end if; return; else Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); ! -- Type has already been inserted into the current scope. Remove ! -- it, and add incomplete declaration for type, so that subsequent ! -- anonymous access types can use it. The entity is unchained from ! -- the homonym list and from immediate visibility. After analysis, ! -- the entity in the incomplete declaration becomes immediately ! -- visible in the record declaration that follows. H := Current_Entity (Typ); *************** package body Sem_Ch3 is *** 17513,17520 **** Set_Full_View (Inc_T, Typ); if Is_Tagged then ! -- Create a common class-wide type for both views, and set ! -- the Etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); --- 18305,18313 ---- Set_Full_View (Inc_T, Typ); if Is_Tagged then ! ! -- Create a common class-wide type for both views, and set the ! -- Etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); *************** package body Sem_Ch3 is *** 17676,17684 **** (Access_Definition (Comp_Def)); Build_Incomplete_Type_Declaration; ! Anon_Access := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); -- Create a declaration for the anonymous access type: either -- an access_to_object or an access_to_subprogram. --- 18469,18475 ---- (Access_Definition (Comp_Def)); Build_Incomplete_Type_Declaration; ! Anon_Access := Make_Temporary (Loc, 'S'); -- Create a declaration for the anonymous access type: either -- an access_to_object or an access_to_subprogram. *************** package body Sem_Ch3 is *** 17814,17820 **** -- Normal case ! if Ada_Version < Ada_05 or else not Interface_Present (Def) then -- The flag Is_Tagged_Type might have already been set by --- 18605,18611 ---- -- Normal case ! if Ada_Version < Ada_2005 or else not Interface_Present (Def) then -- The flag Is_Tagged_Type might have already been set by *************** package body Sem_Ch3 is *** 17853,17859 **** Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); ! if Ada_Version >= Ada_05 and then Present (Interface_List (Def)) then Check_Interfaces (N, Def); --- 18644,18650 ---- Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); ! if Ada_Version >= Ada_2005 and then Present (Interface_List (Def)) then Check_Interfaces (N, Def); *************** package body Sem_Ch3 is *** 17923,17936 **** end if; Make_Class_Wide_Type (T); ! Set_Primitive_Operations (T, New_Elmt_List); end if; ! -- We must suppress range checks when processing the components ! -- of a record in the presence of discriminants, since we don't ! -- want spurious checks to be generated during their analysis, but ! -- must reset the Suppress_Range_Checks flags after having processed ! -- the record definition. -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, -- couldn't we just use the normal range check suppression method here. --- 18714,18726 ---- end if; Make_Class_Wide_Type (T); ! Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; ! -- We must suppress range checks when processing record components in ! -- the presence of discriminants, since we don't want spurious checks to ! -- be generated during their analysis, but Suppress_Range_Checks flags ! -- must be reset the after processing the record definition. -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, -- couldn't we just use the normal range check suppression method here. *************** package body Sem_Ch3 is *** 18181,18186 **** --- 18971,18982 ---- Kind : constant Entity_Kind := Ekind (Def_Id); begin + -- Defend against previous error + + if Nkind (R) = N_Error then + return; + end if; + Set_Scalar_Range (Def_Id, R); -- We need to link the range into the tree before resolving it so diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch3.ads gcc-4.6.0/gcc/ada/sem_ch3.ads *** gcc-4.5.2/gcc/ada/sem_ch3.ads Thu Jul 30 09:23:06 2009 --- gcc-4.6.0/gcc/ada/sem_ch3.ads Thu Oct 21 10:19:58 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Types; use Types; *** 28,33 **** --- 28,34 ---- package Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id); + procedure Analyze_Full_Type_Declaration (N : Node_Id); procedure Analyze_Incomplete_Type_Decl (N : Node_Id); procedure Analyze_Itype_Reference (N : Node_Id); procedure Analyze_Number_Declaration (N : Node_Id); *************** package Sem_Ch3 is *** 35,41 **** procedure Analyze_Others_Choice (N : Node_Id); procedure Analyze_Private_Extension_Declaration (N : Node_Id); procedure Analyze_Subtype_Indication (N : Node_Id); - procedure Analyze_Type_Declaration (N : Node_Id); procedure Analyze_Variant_Part (N : Node_Id); procedure Analyze_Subtype_Declaration --- 36,41 ---- *************** package Sem_Ch3 is *** 84,96 **** procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Process an access type declaration ! procedure Build_Itype_Reference ! (Ityp : Entity_Id; ! Nod : Node_Id); -- Create a reference to an internal type, for use by Gigi. The back-end ! -- elaborates itypes on demand, i.e. when their first use is seen. This ! -- can lead to scope anomalies if the first use is within a scope that is ! -- nested within the scope that contains the point of definition of the -- itype. The Itype_Reference node forces the elaboration of the itype -- in the proper scope. The node is inserted after Nod, which is the -- enclosing declaration that generated Ityp. --- 84,94 ---- procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Process an access type declaration ! procedure Build_Itype_Reference (Ityp : Entity_Id; Nod : Node_Id); -- Create a reference to an internal type, for use by Gigi. The back-end ! -- elaborates itypes on demand, i.e. when their first use is seen. This can ! -- lead to scope anomalies if the first use is within a scope that is ! -- nested within the scope that contains the point of definition of the -- itype. The Itype_Reference node forces the elaboration of the itype -- in the proper scope. The node is inserted after Nod, which is the -- enclosing declaration that generated Ityp. *************** package Sem_Ch3 is *** 159,165 **** function Find_Type_Name (N : Node_Id) return Entity_Id; -- Enter the identifier in a type definition, or find the entity already -- declared, in the case of the full declaration of an incomplete or ! -- private type. function Get_Discriminant_Value (Discriminant : Entity_Id; --- 157,166 ---- function Find_Type_Name (N : Node_Id) return Entity_Id; -- Enter the identifier in a type definition, or find the entity already -- declared, in the case of the full declaration of an incomplete or ! -- private type. If the previous declaration is tagged then the class-wide ! -- entity is propagated to the identifier to prevent multiple incompatible ! -- class-wide types that may be created for self-referential anonymous ! -- access components. function Get_Discriminant_Value (Discriminant : Entity_Id; *************** package Sem_Ch3 is *** 229,234 **** --- 230,237 ---- -- In_Default_Expression flag. See the documentation section entitled -- "Handling of Default and Per-Object Expressions" in sem.ads for full -- details. N is the expression to be analyzed, T is the expected type. + -- This mechanism is also used for aspect specifications that have an + -- expression parameter that needs similar preanalysis. procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is *************** package Sem_Ch3 is *** 274,279 **** --- 277,286 ---- -- Process the discriminants contained in an N_Full_Type_Declaration or -- N_Incomplete_Type_Decl node N. If the declaration is a completion, -- Prev is entity on the partial view, on which references are posted. + -- However, note that Process_Discriminants is called for a completion only + -- if partial view had no discriminants (else we just check conformance + -- between the two views and do not call Process_Discriminants again for + -- the completion). function Replace_Anonymous_Access_To_Protected_Subprogram (N : Node_Id) return Entity_Id; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch4.adb gcc-4.6.0/gcc/ada/sem_ch4.adb *** gcc-4.5.2/gcc/ada/sem_ch4.adb Mon Nov 30 09:46:15 2009 --- gcc-4.6.0/gcc/ada/sem_ch4.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Restrict; use Restrict; *** 43,59 **** with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; - with Sem_SCIL; use Sem_SCIL; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; - with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; --- 43,61 ---- with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; + with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; + with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; + with Sem_Util; use Sem_Util; + with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; *************** package body Sem_Ch4 is *** 98,104 **** -- the operand of the operator node. procedure Ambiguous_Operands (N : Node_Id); ! -- for equality, membership, and comparison operators with overloaded -- arguments, list possible interpretations. procedure Analyze_One_Call --- 100,106 ---- -- the operand of the operator node. procedure Ambiguous_Operands (N : Node_Id); ! -- For equality, membership, and comparison operators with overloaded -- arguments, list possible interpretations. procedure Analyze_One_Call *************** package body Sem_Ch4 is *** 268,274 **** -- the call may be overloaded with both interpretations. function Try_Object_Operation (N : Node_Id) return Boolean; ! -- Ada 2005 (AI-252): Support the object.operation notation procedure wpo (T : Entity_Id); pragma Warnings (Off, wpo); --- 270,279 ---- -- the call may be overloaded with both interpretations. function Try_Object_Operation (N : Node_Id) return Boolean; ! -- Ada 2005 (AI-252): Support the object.operation notation. If node N ! -- is a call in this notation, it is transformed into a normal subprogram ! -- call where the prefix is a parameter, and True is returned. If node ! -- N is not of this form, it is unchanged, and False is returned. procedure wpo (T : Entity_Id); pragma Warnings (Off, wpo); *************** package body Sem_Ch4 is *** 305,312 **** end if; if Opnd = Left_Opnd (N) then ! Error_Msg_N ! ("\left operand has the following interpretations", N); else Error_Msg_N ("\right operand has the following interpretations", N); --- 310,316 ---- end if; if Opnd = Left_Opnd (N) then ! Error_Msg_N ("\left operand has the following interpretations", N); else Error_Msg_N ("\right operand has the following interpretations", N); *************** package body Sem_Ch4 is *** 361,375 **** E : Node_Id := Expression (N); Acc_Type : Entity_Id; Type_Id : Entity_Id; begin -- In accordance with H.4(7), the No_Allocators restriction only applies ! -- to user-written allocators. if Comes_From_Source (N) then Check_Restriction (No_Allocators, N); end if; if Nkind (E) = N_Qualified_Expression then Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); --- 365,424 ---- E : Node_Id := Expression (N); Acc_Type : Entity_Id; Type_Id : Entity_Id; + P : Node_Id; + C : Node_Id; begin + -- Deal with allocator restrictions + -- In accordance with H.4(7), the No_Allocators restriction only applies ! -- to user-written allocators. The same consideration applies to the ! -- No_Allocators_Before_Elaboration restriction. if Comes_From_Source (N) then Check_Restriction (No_Allocators, N); + + -- Processing for No_Allocators_After_Elaboration, loop to look at + -- enclosing context, checking task case and main subprogram case. + + C := N; + P := Parent (C); + while Present (P) loop + + -- In both cases we need a handled sequence of statements, where + -- the occurrence of the allocator is within the statements. + + if Nkind (P) = N_Handled_Sequence_Of_Statements + and then Is_List_Member (C) + and then List_Containing (C) = Statements (P) + then + -- Check for allocator within task body, this is a definite + -- violation of No_Allocators_After_Elaboration we can detect. + + if Nkind (Original_Node (Parent (P))) = N_Task_Body then + Check_Restriction (No_Allocators_After_Elaboration, N); + exit; + end if; + + -- The other case is appearance in a subprogram body. This may + -- be a violation if this is a library level subprogram, and it + -- turns out to be used as the main program, but only the + -- binder knows that, so just record the occurrence. + + if Nkind (Original_Node (Parent (P))) = N_Subprogram_Body + and then Nkind (Parent (Parent (P))) = N_Compilation_Unit + then + Set_Has_Allocator (Current_Sem_Unit); + end if; + end if; + + C := P; + P := Parent (C); + end loop; end if; + -- Analyze the allocator + if Nkind (E) = N_Qualified_Expression then Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); *************** package body Sem_Ch4 is *** 463,469 **** -- partial view, it cannot receive a discriminant constraint, -- and the allocated object is unconstrained. ! elsif Ada_Version >= Ada_05 and then Has_Constrained_Partial_View (Base_Typ) then Error_Msg_N --- 512,518 ---- -- partial view, it cannot receive a discriminant constraint, -- and the allocated object is unconstrained. ! elsif Ada_Version >= Ada_2005 and then Has_Constrained_Partial_View (Base_Typ) then Error_Msg_N *************** package body Sem_Ch4 is *** 472,479 **** end if; if Expander_Active then ! Def_Id := ! Make_Defining_Identifier (Loc, New_Internal_Name ('S')); Insert_Action (E, Make_Subtype_Declaration (Loc, --- 521,527 ---- end if; if Expander_Active then ! Def_Id := Make_Temporary (Loc, 'S'); Insert_Action (E, Make_Subtype_Declaration (Loc, *************** package body Sem_Ch4 is *** 505,519 **** -- be a null object, and we can insert an unconditional raise -- before the allocator. if Can_Never_Be_Null (Type_Id) then declare Not_Null_Check : constant Node_Id := Make_Raise_Constraint_Error (Sloc (E), Reason => CE_Null_Not_Allowed); begin ! if Expander_Active then Insert_Action (N, Not_Null_Check); Analyze (Not_Null_Check); else Error_Msg_N ("null value not allowed here?", E); end if; --- 553,577 ---- -- be a null object, and we can insert an unconditional raise -- before the allocator. + -- Ada 2012 (AI-104): A not null indication here is altogether + -- illegal. + if Can_Never_Be_Null (Type_Id) then declare Not_Null_Check : constant Node_Id := Make_Raise_Constraint_Error (Sloc (E), Reason => CE_Null_Not_Allowed); + begin ! if Ada_Version >= Ada_2012 then ! Error_Msg_N ! ("an uninitialized allocator cannot have" ! & " a null exclusion", N); ! ! elsif Expander_Active then Insert_Action (N, Not_Null_Check); Analyze (Not_Null_Check); + else Error_Msg_N ("null value not allowed here?", E); end if; *************** package body Sem_Ch4 is *** 540,546 **** Error_Msg_N ("initialization required in class-wide allocation", N); else ! if Ada_Version < Ada_05 and then Is_Limited_Type (Type_Id) then Error_Msg_N ("unconstrained allocation not allowed", N); --- 598,604 ---- Error_Msg_N ("initialization required in class-wide allocation", N); else ! if Ada_Version < Ada_2005 and then Is_Limited_Type (Type_Id) then Error_Msg_N ("unconstrained allocation not allowed", N); *************** package body Sem_Ch4 is *** 591,596 **** --- 649,673 ---- Check_Restriction (No_Tasking, N); Check_Restriction (Max_Tasks, N); Check_Restriction (No_Task_Allocators, N); + + -- Check that an allocator with task parts isn't for a nested access + -- type when restriction No_Task_Hierarchy applies. + + if not Is_Library_Level_Entity (Acc_Type) then + Check_Restriction (No_Task_Hierarchy, N); + end if; + end if; + + -- Check that an allocator of a nested access type doesn't create a + -- protected object when restriction No_Local_Protected_Objects applies. + -- We don't have an equivalent to Has_Task for protected types, so only + -- cases where the designated type itself is a protected type are + -- currently checked. ??? + + if Is_Protected_Type (Designated_Type (Acc_Type)) + and then not Is_Library_Level_Entity (Acc_Type) + then + Check_Restriction (No_Local_Protected_Objects, N); end if; -- If the No_Streams restriction is set, check that the type of the *************** package body Sem_Ch4 is *** 599,605 **** -- Has_Stream just for efficiency reasons. There is no point in -- spending time on a Has_Stream check if the restriction is not set. ! if Restrictions.Set (No_Streams) then if Has_Stream (Designated_Type (Acc_Type)) then Check_Restriction (No_Streams, N); end if; --- 676,682 ---- -- Has_Stream just for efficiency reasons. There is no point in -- spending time on a Has_Stream check if the restriction is not set. ! if Restriction_Check_Required (No_Streams) then if Has_Stream (Designated_Type (Acc_Type)) then Check_Restriction (No_Streams, N); end if; *************** package body Sem_Ch4 is *** 818,827 **** elsif Nkind (Nam) = N_Selected_Component then Nam_Ent := Entity (Selector_Name (Nam)); ! if Ekind (Nam_Ent) /= E_Entry ! and then Ekind (Nam_Ent) /= E_Entry_Family ! and then Ekind (Nam_Ent) /= E_Function ! and then Ekind (Nam_Ent) /= E_Procedure then Error_Msg_N ("name in call is not a callable entity", Nam); Set_Etype (N, Any_Type); --- 895,904 ---- elsif Nkind (Nam) = N_Selected_Component then Nam_Ent := Entity (Selector_Name (Nam)); ! if not Ekind_In (Nam_Ent, E_Entry, ! E_Entry_Family, ! E_Function, ! E_Procedure) then Error_Msg_N ("name in call is not a callable entity", Nam); Set_Etype (N, Any_Type); *************** package body Sem_Ch4 is *** 870,877 **** -- If this is an indirect call, the return type of the access_to -- subprogram may be an incomplete type. At the point of the call, ! -- use the full type if available, and at the same time update ! -- the return type of the access_to_subprogram. if Success and then Nkind (Nam) = N_Explicit_Dereference --- 947,954 ---- -- If this is an indirect call, the return type of the access_to -- subprogram may be an incomplete type. At the point of the call, ! -- use the full type if available, and at the same time update the ! -- return type of the access_to_subprogram. if Success and then Nkind (Nam) = N_Explicit_Dereference *************** package body Sem_Ch4 is *** 899,910 **** -- Name may be call that returns an access to subprogram, or more -- generally an overloaded expression one of whose interpretations ! -- yields an access to subprogram. If the name is an entity, we ! -- do not dereference, because the node is a call that returns ! -- the access type: note difference between f(x), where the call ! -- may return an access subprogram type, and f(x)(y), where the ! -- type returned by the call to f is implicitly dereferenced to ! -- analyze the outer call. if Is_Access_Type (Nam_Ent) then Nam_Ent := Designated_Type (Nam_Ent); --- 976,987 ---- -- Name may be call that returns an access to subprogram, or more -- generally an overloaded expression one of whose interpretations ! -- yields an access to subprogram. If the name is an entity, we do ! -- not dereference, because the node is a call that returns the ! -- access type: note difference between f(x), where the call may ! -- return an access subprogram type, and f(x)(y), where the type ! -- returned by the call to f is implicitly dereferenced to analyze ! -- the outer call. if Is_Access_Type (Nam_Ent) then Nam_Ent := Designated_Type (Nam_Ent); *************** package body Sem_Ch4 is *** 923,929 **** end if; end if; ! Analyze_One_Call (N, Nam_Ent, False, Success); -- If the interpretation succeeds, mark the proper type of the -- prefix (any valid candidate will do). If not, remove the --- 1000,1020 ---- end if; end if; ! -- If the call has been rewritten from a prefixed call, the first ! -- parameter has been analyzed, but may need a subsequent ! -- dereference, so skip its analysis now. ! ! if N /= Original_Node (N) ! and then Nkind (Original_Node (N)) = Nkind (N) ! and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N))) ! and then Present (Parameter_Associations (N)) ! and then Present (Etype (First (Parameter_Associations (N)))) ! then ! Analyze_One_Call ! (N, Nam_Ent, False, Success, Skip_First => True); ! else ! Analyze_One_Call (N, Nam_Ent, False, Success); ! end if; -- If the interpretation succeeds, mark the proper type of the -- prefix (any valid candidate will do). If not, remove the *************** package body Sem_Ch4 is *** 1035,1040 **** --- 1126,1262 ---- end if; end Analyze_Call; + ----------------------------- + -- Analyze_Case_Expression -- + ----------------------------- + + procedure Analyze_Case_Expression (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + FirstX : constant Node_Id := Expression (First (Alternatives (N))); + Alt : Node_Id; + Exp_Type : Entity_Id; + Exp_Btype : Entity_Id; + + Dont_Care : Boolean; + Others_Present : Boolean; + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the case expression has a non static choice. + + package Case_Choices_Processing is new + Generic_Choices_Processing + (Get_Alternatives => Alternatives, + Get_Choices => Discrete_Choices, + Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => No_OP); + use Case_Choices_Processing; + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in case expression is not static!", Choice); + end Non_Static_Choice_Error; + + -- Start of processing for Analyze_Case_Expression + + begin + if Comes_From_Source (N) then + Check_Compiler_Unit (N); + end if; + + Analyze_And_Resolve (Expr, Any_Discrete); + Check_Unset_Reference (Expr); + Exp_Type := Etype (Expr); + Exp_Btype := Base_Type (Exp_Type); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Expression (Alt)); + Next (Alt); + end loop; + + if not Is_Overloaded (FirstX) then + Set_Etype (N, Etype (FirstX)); + + else + declare + I : Interp_Index; + It : Interp; + + begin + Set_Etype (N, Any_Type); + + Get_First_Interp (FirstX, I, It); + while Present (It.Nam) loop + + -- For each interpretation of the first expression, we only + -- add the interpretation if every other expression in the + -- case expression alternatives has a compatible type. + + Alt := Next (First (Alternatives (N))); + while Present (Alt) loop + exit when not Has_Compatible_Type (Expression (Alt), It.Typ); + Next (Alt); + end loop; + + if No (Alt) then + Add_One_Interp (N, It.Typ, It.Typ); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Exp_Btype := Base_Type (Exp_Type); + + -- The expression must be of a discrete type which must be determinable + -- independently of the context in which the expression occurs, but + -- using the fact that the expression must be of a discrete type. + -- Moreover, the type this expression must not be a character literal + -- (which is always ambiguous). + + -- If error already reported by Resolve, nothing more to do + + if Exp_Btype = Any_Discrete + or else Exp_Btype = Any_Type + then + return; + + elsif Exp_Btype = Any_Character then + Error_Msg_N + ("character literal as case expression is ambiguous", Expr); + return; + end if; + + -- If the case expression is a formal object of mode in out, then + -- treat it as having a nonstatic subtype by forcing use of the base + -- type (which has to get passed to Check_Case_Choices below). Also + -- use base type when the case expression is parenthesized. + + if Paren_Count (Expr) > 0 + or else (Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter) + then + Exp_Type := Exp_Btype; + end if; + + -- Call instantiated Analyze_Choices which does the rest of the work + + Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + + if Exp_Type = Universal_Integer and then not Others_Present then + Error_Msg_N + ("case on universal integer requires OTHERS choice", Expr); + end if; + end Analyze_Case_Expression; + --------------------------- -- Analyze_Comparison_Op -- --------------------------- *************** package body Sem_Ch4 is *** 1160,1166 **** if Present (Op_Id) then if Ekind (Op_Id) = E_Operator then - LT := Base_Type (Etype (L)); RT := Base_Type (Etype (R)); --- 1382,1387 ---- *************** package body Sem_Ch4 is *** 1237,1245 **** procedure Analyze_Conditional_Expression (N : Node_Id) is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); ! Else_Expr : constant Node_Id := Next (Then_Expr); begin if Comes_From_Source (N) then Check_Compiler_Unit (N); end if; --- 1458,1474 ---- procedure Analyze_Conditional_Expression (N : Node_Id) is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); ! Else_Expr : Node_Id; begin + -- Defend against error of missing expressions from previous error + + if No (Then_Expr) then + return; + end if; + + Else_Expr := Next (Then_Expr); + if Comes_From_Source (N) then Check_Compiler_Unit (N); end if; *************** package body Sem_Ch4 is *** 1251,1258 **** --- 1480,1492 ---- Analyze_Expression (Else_Expr); end if; + -- If then expression not overloaded, then that decides the type + if not Is_Overloaded (Then_Expr) then Set_Etype (N, Etype (Then_Expr)); + + -- Case where then expression is overloaded + else declare I : Interp_Index; *************** package body Sem_Ch4 is *** 1262,1267 **** --- 1496,1507 ---- Set_Etype (N, Any_Type); Get_First_Interp (Then_Expr, I, It); while Present (It.Nam) loop + + -- For each possible interpretation of the Then Expression, + -- add it only if the else expression has a compatible type. + + -- Is this right if Else_Expr is empty? + if Has_Compatible_Type (Else_Expr, It.Typ) then Add_One_Interp (N, It.Typ, It.Typ); end if; *************** package body Sem_Ch4 is *** 1577,1582 **** --- 1817,1841 ---- Check_Parameterless_Call (N); end Analyze_Expression; + ------------------------------------- + -- Analyze_Expression_With_Actions -- + ------------------------------------- + + procedure Analyze_Expression_With_Actions (N : Node_Id) is + A : Node_Id; + + begin + A := First (Actions (N)); + loop + Analyze (A); + Next (A); + exit when No (A); + end loop; + + Analyze_Expression (Expression (N)); + Set_Etype (N, Etype (Expression (N))); + end Analyze_Expression_With_Actions; + ------------------------------------ -- Analyze_Indexed_Component_Form -- ------------------------------------ *************** package body Sem_Ch4 is *** 1896,1904 **** P_T := Base_Type (Etype (P)); ! if Is_Entity_Name (P) ! or else Nkind (P) = N_Operator_Symbol ! then U_N := Entity (P); if Is_Type (U_N) then --- 2155,2161 ---- P_T := Base_Type (Etype (P)); ! if Is_Entity_Name (P) and then Present (Entity (P)) then U_N := Entity (P); if Is_Type (U_N) then *************** package body Sem_Ch4 is *** 1930,1936 **** elsif Ekind (Etype (P)) = E_Subprogram_Type or else (Is_Access_Type (Etype (P)) and then ! Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type) then -- Call to access_to-subprogram with possible implicit dereference --- 2187,2194 ---- elsif Ekind (Etype (P)) = E_Subprogram_Type or else (Is_Access_Type (Etype (P)) and then ! Ekind (Designated_Type (Etype (P))) = ! E_Subprogram_Type) then -- Call to access_to-subprogram with possible implicit dereference *************** package body Sem_Ch4 is *** 1955,1961 **** if Ekind (P_T) = E_Subprogram_Type or else (Is_Access_Type (P_T) and then ! Ekind (Designated_Type (P_T)) = E_Subprogram_Type) then Process_Function_Call; --- 2213,2219 ---- if Ekind (P_T) = E_Subprogram_Type or else (Is_Access_Type (P_T) and then ! Ekind (Designated_Type (P_T)) = E_Subprogram_Type) then Process_Function_Call; *************** package body Sem_Ch4 is *** 2018,2025 **** --------------------------- procedure Analyze_Membership_Op (N : Node_Id) is ! L : constant Node_Id := Left_Opnd (N); ! R : constant Node_Id := Right_Opnd (N); Index : Interp_Index; It : Interp; --- 2276,2284 ---- --------------------------- procedure Analyze_Membership_Op (N : Node_Id) is ! Loc : constant Source_Ptr := Sloc (N); ! L : constant Node_Id := Left_Opnd (N); ! R : constant Node_Id := Right_Opnd (N); Index : Interp_Index; It : Interp; *************** package body Sem_Ch4 is *** 2158,2164 **** Analyze_Expression (L); if No (R) ! and then Extensions_Allowed then Analyze_Set_Membership; return; --- 2417,2423 ---- Analyze_Expression (L); if No (R) ! and then Ada_Version >= Ada_2012 then Analyze_Set_Membership; return; *************** package body Sem_Ch4 is *** 2181,2194 **** end loop; end if; ! -- If not a range, it can only be a subtype mark, or else there ! -- is a more basic error, to be diagnosed in Find_Type. else ! Find_Type (R); ! ! if Is_Entity_Name (R) then Check_Fully_Declared (Entity (R), R); end if; end if; --- 2440,2477 ---- end loop; end if; ! -- If not a range, it can be a subtype mark, or else it is a degenerate ! -- membership test with a singleton value, i.e. a test for equality. else ! Analyze (R); ! if Is_Entity_Name (R) ! and then Is_Type (Entity (R)) ! then ! Find_Type (R); Check_Fully_Declared (Entity (R), R); + + elsif Ada_Version >= Ada_2012 then + if Nkind (N) = N_In then + Rewrite (N, + Make_Op_Eq (Loc, + Left_Opnd => L, + Right_Opnd => R)); + else + Rewrite (N, + Make_Op_Ne (Loc, + Left_Opnd => L, + Right_Opnd => R)); + end if; + + Analyze (N); + return; + + else + -- In previous version of the language this is an error that will + -- be diagnosed below. + + Find_Type (R); end if; end if; *************** package body Sem_Ch4 is *** 2318,2326 **** -- being called is noted on the selector. if not Is_Type (Nam) then ! if Is_Entity_Name (Name (N)) ! or else Nkind (Name (N)) = N_Operator_Symbol ! then Set_Entity (Name (N), Nam); elsif Nkind (Name (N)) = N_Selected_Component then --- 2601,2607 ---- -- being called is noted on the selector. if not Is_Type (Nam) then ! if Is_Entity_Name (Name (N)) then Set_Entity (Name (N), Nam); elsif Nkind (Name (N)) = N_Selected_Component then *************** package body Sem_Ch4 is *** 2617,2622 **** --- 2898,2908 ---- if All_Errors_Mode then Error_Msg_Sloc := Sloc (Nam); + if Etype (Formal) = Any_Type then + Error_Msg_N + ("there is no legal actual parameter", Actual); + end if; + if Is_Overloadable (Nam) and then Present (Alias (Nam)) and then not Comes_From_Source (Nam) *************** package body Sem_Ch4 is *** 2917,2922 **** --- 3203,3256 ---- Set_Etype (N, T); end Analyze_Qualified_Expression; + ----------------------------------- + -- Analyze_Quantified_Expression -- + ----------------------------------- + + procedure Analyze_Quantified_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (N), 'L'); + + Iterator : Node_Id; + + begin + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, N); + + if Present (Loop_Parameter_Specification (N)) then + Iterator := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Loop_Parameter_Specification (N)); + else + Iterator := + Make_Iteration_Scheme (Loc, + Iterator_Specification => + Iterator_Specification (N)); + end if; + + Push_Scope (Ent); + Set_Parent (Iterator, N); + Analyze_Iteration_Scheme (Iterator); + + -- The loop specification may have been converted into an + -- iterator specification during its analysis. Update the + -- quantified node accordingly. + + if Present (Iterator_Specification (Iterator)) then + Set_Iterator_Specification + (N, Iterator_Specification (Iterator)); + Set_Loop_Parameter_Specification (N, Empty); + end if; + + Analyze (Condition (N)); + End_Scope; + + Set_Etype (N, Standard_Boolean); + end Analyze_Quantified_Expression; + ------------------- -- Analyze_Range -- ------------------- *************** package body Sem_Ch4 is *** 3058,3069 **** -- It is not clear if that can ever occur, but in case it does, we will -- generate an error message. Not clear if this message can ever be -- generated, and pretty clear that it represents a bug if it is, still ! -- seems worth checking! T := Etype (P); if Is_Entity_Name (P) and then Is_Object_Reference (P) then E := Entity (P); T := Etype (P); --- 3392,3405 ---- -- It is not clear if that can ever occur, but in case it does, we will -- generate an error message. Not clear if this message can ever be -- generated, and pretty clear that it represents a bug if it is, still ! -- seems worth checking, except in CodePeer mode where we do not really ! -- care and don't want to bother the user. T := Etype (P); if Is_Entity_Name (P) and then Is_Object_Reference (P) + and then not CodePeer_Mode then E := Entity (P); T := Etype (P); *************** package body Sem_Ch4 is *** 3092,3099 **** -- Analyze_Selected_Component -- -------------------------------- ! -- Prefix is a record type or a task or protected type. In the ! -- later case, the selector must denote a visible entry. procedure Analyze_Selected_Component (N : Node_Id) is Name : constant Node_Id := Prefix (N); --- 3428,3435 ---- -- Analyze_Selected_Component -- -------------------------------- ! -- Prefix is a record type or a task or protected type. In the latter case, ! -- the selector must denote a visible entry. procedure Analyze_Selected_Component (N : Node_Id) is Name : constant Node_Id := Prefix (N); *************** package body Sem_Ch4 is *** 3111,3116 **** --- 3447,3463 ---- -- a class-wide type, we use its root type, whose components are -- present in the class-wide type. + Is_Single_Concurrent_Object : Boolean; + -- Set True if the prefix is a single task or a single protected object + + procedure Find_Component_In_Instance (Rec : Entity_Id); + -- In an instance, a component of a private extension may not be visible + -- while it was visible in the generic. Search candidate scope for a + -- component with the proper identifier. This is only done if all other + -- searches have failed. When the match is found (it always will be), + -- the Etype of both N and Sel are set from this component, and the + -- entity of Sel is set to reference this component. + function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean; -- It is known that the parent of N denotes a subprogram call. Comp -- is an overloadable component of the concurrent type of the prefix. *************** package body Sem_Ch4 is *** 3118,3123 **** --- 3465,3495 ---- -- conformant. If the parent node is not analyzed yet it may be an -- indexed component rather than a function call. + -------------------------------- + -- Find_Component_In_Instance -- + -------------------------------- + + procedure Find_Component_In_Instance (Rec : Entity_Id) is + Comp : Entity_Id; + + begin + Comp := First_Component (Rec); + while Present (Comp) loop + if Chars (Comp) = Chars (Sel) then + Set_Entity_With_Style_Check (Sel, Comp); + Set_Etype (Sel, Etype (Comp)); + Set_Etype (N, Etype (Comp)); + return; + end if; + + Next_Component (Comp); + end loop; + + -- This must succeed because code was legal in the generic + + raise Program_Error; + end Find_Component_In_Instance; + ------------------------------ -- Has_Mode_Conformant_Spec -- ------------------------------ *************** package body Sem_Ch4 is *** 3182,3192 **** if Is_Access_Type (Prefix_Type) then ! -- A RACW object can never be used as prefix of a selected ! -- component since that means it is dereferenced without ! -- being a controlling operand of a dispatching operation ! -- (RM E.2.2(16/1)). Before reporting an error, we must check ! -- whether this is actually a dispatching call in prefix form. if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) and then Comes_From_Source (N) --- 3554,3564 ---- if Is_Access_Type (Prefix_Type) then ! -- A RACW object can never be used as prefix of a selected component ! -- since that means it is dereferenced without being a controlling ! -- operand of a dispatching operation (RM E.2.2(16/1)). Before ! -- reporting an error, we must check whether this is actually a ! -- dispatching call in prefix form. if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) and then Comes_From_Source (N) *************** package body Sem_Ch4 is *** 3281,3286 **** --- 3653,3667 ---- Type_To_Use := Root_Type (Prefix_Type); end if; + -- If the prefix is a single concurrent object, use its name in error + -- messages, rather than that of its anonymous type. + + Is_Single_Concurrent_Object := + Is_Concurrent_Type (Prefix_Type) + and then Is_Internal_Name (Chars (Prefix_Type)) + and then not Is_Derived_Type (Prefix_Type) + and then Is_Entity_Name (Name); + Comp := First_Entity (Type_To_Use); -- If the selector has an original discriminant, the node appears in *************** package body Sem_Ch4 is *** 3367,3374 **** -- this case gigi generates all the checks and can find the -- necessary bounds information. ! -- We also do not need an actual subtype for the case of ! -- a first, last, length, or range attribute applied to a -- non-packed array, since gigi can again get the bounds in -- these cases (gigi cannot handle the packed case, since it -- has the bounds of the packed array type, not the original --- 3748,3755 ---- -- this case gigi generates all the checks and can find the -- necessary bounds information. ! -- We also do not need an actual subtype for the case of a ! -- first, last, length, or range attribute applied to a -- non-packed array, since gigi can again get the bounds in -- these cases (gigi cannot handle the packed case, since it -- has the bounds of the packed array type, not the original *************** package body Sem_Ch4 is *** 3461,3467 **** -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the -- selected component should resolve to a name. ! if Ada_Version >= Ada_05 and then Is_Tagged_Type (Prefix_Type) and then not Is_Concurrent_Type (Prefix_Type) then --- 3842,3848 ---- -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the -- selected component should resolve to a name. ! if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) and then not Is_Concurrent_Type (Prefix_Type) then *************** package body Sem_Ch4 is *** 3512,3527 **** -- Before declaring an error, check whether this is tagged -- private type and a call to a primitive operation. ! elsif Ada_Version >= Ada_05 and then Is_Tagged_Type (Prefix_Type) and then Try_Object_Operation (N) then return; else ! Error_Msg_NE ! ("invisible selector for }", ! N, First_Subtype (Prefix_Type)); Set_Entity (Sel, Any_Id); Set_Etype (N, Any_Type); end if; --- 3893,3907 ---- -- Before declaring an error, check whether this is tagged -- private type and a call to a primitive operation. ! elsif Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) and then Try_Object_Operation (N) then return; else ! Error_Msg_Node_2 := First_Subtype (Prefix_Type); ! Error_Msg_NE ("invisible selector& for }", N, Sel); Set_Entity (Sel, Any_Id); Set_Etype (N, Any_Type); end if; *************** package body Sem_Ch4 is *** 3566,3575 **** Has_Candidate := True; end if; ! elsif Ekind (Comp) = E_Discriminant ! or else Ekind (Comp) = E_Entry_Family or else (In_Scope ! and then Is_Entity_Name (Name)) then Set_Entity_With_Style_Check (Sel, Comp); Generate_Reference (Comp, Sel); --- 3946,3958 ---- Has_Candidate := True; end if; ! -- Note: a selected component may not denote a component of a ! -- protected type (4.1.3(7)). ! ! elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family) or else (In_Scope ! and then not Is_Protected_Type (Prefix_Type) ! and then Is_Entity_Name (Name)) then Set_Entity_With_Style_Check (Sel, Comp); Generate_Reference (Comp, Sel); *************** package body Sem_Ch4 is *** 3606,3612 **** -- visible entities are plausible interpretations, check whether -- there is some other primitive operation with that name. ! if Ada_Version >= Ada_05 and then Is_Tagged_Type (Prefix_Type) then if (Etype (N) = Any_Type --- 3989,3995 ---- -- visible entities are plausible interpretations, check whether -- there is some other primitive operation with that name. ! if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) then if (Etype (N) = Any_Type *************** package body Sem_Ch4 is *** 3633,3638 **** --- 4016,4043 ---- end if; end if; + if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then + -- Case of a prefix of a protected type: selector might denote + -- an invisible private component. + + Comp := First_Private_Entity (Base_Type (Prefix_Type)); + while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop + Next_Entity (Comp); + end loop; + + if Present (Comp) then + if Is_Single_Concurrent_Object then + Error_Msg_Node_2 := Entity (Name); + Error_Msg_NE ("invisible selector& for &", N, Sel); + + else + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("invisible selector& for }", N, Sel); + end if; + return; + end if; + end if; + Set_Is_Overloaded (N, Is_Overloaded (Sel)); else *************** package body Sem_Ch4 is *** 3645,3659 **** if Etype (N) = Any_Type then ! -- If the prefix is a single concurrent object, use its name in the ! -- error message, rather than that of its anonymous type. ! ! if Is_Concurrent_Type (Prefix_Type) ! and then Is_Internal_Name (Chars (Prefix_Type)) ! and then not Is_Derived_Type (Prefix_Type) ! and then Is_Entity_Name (Name) ! then ! Error_Msg_Node_2 := Entity (Name); Error_Msg_NE ("no selector& for&", N, Sel); --- 4050,4056 ---- if Etype (N) = Any_Type then ! if Is_Single_Concurrent_Object then Error_Msg_Node_2 := Entity (Name); Error_Msg_NE ("no selector& for&", N, Sel); *************** package body Sem_Ch4 is *** 3672,3714 **** Analyze_Selected_Component (N); return; elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private and then Is_Generic_Actual_Type (Prefix_Type) and then Present (Full_View (Prefix_Type)) then - -- Similarly, if this the actual for a formal derived type, the - -- component inherited from the generic parent may not be visible - -- in the actual, but the selected component is legal. ! declare ! Comp : Entity_Id; ! begin ! Comp := ! First_Component (Generic_Parent_Type (Parent (Prefix_Type))); ! while Present (Comp) loop ! if Chars (Comp) = Chars (Sel) then ! Set_Entity_With_Style_Check (Sel, Comp); ! Set_Etype (Sel, Etype (Comp)); ! Set_Etype (N, Etype (Comp)); ! return; ! end if; ! Next_Component (Comp); ! end loop; ! pragma Assert (Etype (N) /= Any_Type); ! end; else if Ekind (Prefix_Type) = E_Record_Subtype then ! -- Check whether this is a component of the base type ! -- which is absent from a statically constrained subtype. ! -- This will raise constraint error at run-time, but is ! -- not a compile-time error. When the selector is illegal ! -- for base type as well fall through and generate a ! -- compilation error anyway. Comp := First_Component (Base_Type (Prefix_Type)); while Present (Comp) loop --- 4069,4108 ---- Analyze_Selected_Component (N); return; + -- Similarly, if this is the actual for a formal derived type, the + -- component inherited from the generic parent may not be visible + -- in the actual, but the selected component is legal. + elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private and then Is_Generic_Actual_Type (Prefix_Type) and then Present (Full_View (Prefix_Type)) then ! Find_Component_In_Instance ! (Generic_Parent_Type (Parent (Prefix_Type))); ! return; ! -- Finally, the formal and the actual may be private extensions, ! -- but the generic is declared in a child unit of the parent, and ! -- an additional step is needed to retrieve the proper scope. ! elsif In_Instance ! and then Present (Parent_Subtype (Etype (Base_Type (Prefix_Type)))) ! then ! Find_Component_In_Instance ! (Parent_Subtype (Etype (Base_Type (Prefix_Type)))); ! return; ! -- Component not found, specialize error message when appropriate else if Ekind (Prefix_Type) = E_Record_Subtype then ! -- Check whether this is a component of the base type which ! -- is absent from a statically constrained subtype. This will ! -- raise constraint error at run time, but is not a compile- ! -- time error. When the selector is illegal for base type as ! -- well fall through and generate a compilation error anyway. Comp := First_Component (Base_Type (Prefix_Type)); while Present (Comp) loop *************** package body Sem_Ch4 is *** 3890,3904 **** T : Entity_Id; begin - -- Check if the expression is a function call for which we need to - -- adjust a SCIL dispatching node. - - if Generate_SCIL - and then Nkind (Expr) = N_Function_Call - then - Adjust_SCIL_Node (N, Expr); - end if; - -- If Conversion_OK is set, then the Etype is already set, and the -- only processing required is to analyze the expression. This is -- used to construct certain "illegal" conversions which are not --- 4284,4289 ---- *************** package body Sem_Ch4 is *** 4431,4437 **** pragma Warnings (Off, Boolean); begin ! if Ada_Version >= Ada_05 then Actual := First_Actual (N); while Present (Actual) loop --- 4816,4822 ---- pragma Warnings (Off, Boolean); begin ! if Ada_Version >= Ada_2005 then Actual := First_Actual (N); while Present (Actual) loop *************** package body Sem_Ch4 is *** 4488,4496 **** if Nkind (N) = N_Function_Call then Get_First_Interp (Nam, X, It); while Present (It.Nam) loop ! if Ekind (It.Nam) = E_Function ! or else Ekind (It.Nam) = E_Operator ! then return; else Get_Next_Interp (X, It); --- 4873,4879 ---- if Nkind (N) = N_Function_Call then Get_First_Interp (Nam, X, It); while Present (It.Nam) loop ! if Ekind_In (It.Nam, E_Function, E_Operator) then return; else Get_Next_Interp (X, It); *************** package body Sem_Ch4 is *** 4920,4926 **** null; else ! -- Save candidate type for subsquent error message, if any if not Is_Limited_Type (T1) then Candidate_Type := T1; --- 5303,5309 ---- null; else ! -- Save candidate type for subsequent error message, if any if not Is_Limited_Type (T1) then Candidate_Type := T1; *************** package body Sem_Ch4 is *** 4932,4938 **** -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: -- Do not allow anonymous access types in equality operators. ! if Ada_Version < Ada_05 and then Ekind (T1) = E_Anonymous_Access_Type then return; --- 5315,5321 ---- -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: -- Do not allow anonymous access types in equality operators. ! if Ada_Version < Ada_2005 and then Ekind (T1) = E_Anonymous_Access_Type then return; *************** package body Sem_Ch4 is *** 5288,5294 **** or else Is_Array_Type (Etype (L)) or else Is_Array_Type (Etype (R))) then - if Nkind (N) = N_Op_Concat then if Etype (L) /= Any_Composite and then Is_Array_Type (Etype (L)) --- 5671,5676 ---- *************** package body Sem_Ch4 is *** 5302,5311 **** end if; end if; ! Error_Msg_NE ("operator for} is not directly visible!", N, First_Subtype (Candidate_Type)); ! Error_Msg_N ("use clause would make operation legal!", N); return; -- If either operand is a junk operand (e.g. package name), then --- 5684,5694 ---- end if; end if; ! Error_Msg_NE -- CODEFIX ("operator for} is not directly visible!", N, First_Subtype (Candidate_Type)); ! Error_Msg_N -- CODEFIX ! ("use clause would make operation legal!", N); return; -- If either operand is a junk operand (e.g. package name), then *************** package body Sem_Ch4 is *** 5611,5617 **** -- unit, it is one of the operations declared abstract in some -- variants of System, and it must be removed as well. ! elsif Ada_Version >= Ada_05 or else Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (It.Nam))) then --- 5994,6000 ---- -- unit, it is one of the operations declared abstract in some -- variants of System, and it must be removed as well. ! elsif Ada_Version >= Ada_2005 or else Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (It.Nam))) then *************** package body Sem_Ch4 is *** 5771,5777 **** -- predefined operators when addresses are involved since this -- case is handled separately. ! elsif Ada_Version >= Ada_05 and then not Address_Kludge then while Present (It.Nam) loop --- 6154,6160 ---- -- predefined operators when addresses are involved since this -- case is handled separately. ! elsif Ada_Version >= Ada_2005 and then not Address_Kludge then while Present (It.Nam) loop *************** package body Sem_Ch4 is *** 5874,5887 **** and then Is_Type (Entity (Actual)) and then No (Next (Actual)) then ! Rewrite (N, ! Make_Slice (Loc, ! Prefix => Make_Function_Call (Loc, ! Name => Relocate_Node (Name (N))), ! Discrete_Range => ! New_Occurrence_Of (Entity (Actual), Sloc (Actual)))); - Analyze (N); return True; elsif not Has_Compatible_Type (Actual, Etype (Index)) then --- 6257,6281 ---- and then Is_Type (Entity (Actual)) and then No (Next (Actual)) then ! -- A single actual that is a type name indicates a slice if the ! -- type is discrete, and an error otherwise. ! ! if Is_Discrete_Type (Entity (Actual)) then ! Rewrite (N, ! Make_Slice (Loc, ! Prefix => ! Make_Function_Call (Loc, ! Name => Relocate_Node (Name (N))), ! Discrete_Range => ! New_Occurrence_Of (Entity (Actual), Sloc (Actual)))); ! ! Analyze (N); ! ! else ! Error_Msg_N ("invalid use of type in expression", Actual); ! Set_Etype (N, Any_Type); ! end if; return True; elsif not Has_Compatible_Type (Actual, Etype (Index)) then *************** package body Sem_Ch4 is *** 5921,5929 **** N_Function_Call); Loc : constant Source_Ptr := Sloc (N); Obj : constant Node_Id := Prefix (N); ! Subprog : constant Node_Id := ! Make_Identifier (Sloc (Selector_Name (N)), ! Chars => Chars (Selector_Name (N))); -- Identifier on which possible interpretations will be collected Report_Error : Boolean := False; --- 6315,6324 ---- N_Function_Call); Loc : constant Source_Ptr := Sloc (N); Obj : constant Node_Id := Prefix (N); ! ! Subprog : constant Node_Id := ! Make_Identifier (Sloc (Selector_Name (N)), ! Chars => Chars (Selector_Name (N))); -- Identifier on which possible interpretations will be collected Report_Error : Boolean := False; *************** package body Sem_Ch4 is *** 6025,6032 **** if Present (Arr_Type) then ! -- Verify that the actuals (excluding the object) ! -- match the types of the indices. declare Actual : Node_Id; --- 6420,6427 ---- if Present (Arr_Type) then ! -- Verify that the actuals (excluding the object) match the types ! -- of the indexes. declare Actual : Node_Id; *************** package body Sem_Ch4 is *** 6180,6187 **** --- 6575,6594 ---- if Is_Overloaded (Subprog) then Save_Interps (Subprog, Node_To_Replace); + else Analyze (Node_To_Replace); + + -- If the operation has been rewritten into a call, which may get + -- subsequently an explicit dereference, preserve the type on the + -- original node (selected component or indexed component) for + -- subsequent legality tests, e.g. Is_Variable. which examines + -- the original node. + + if Nkind (Node_To_Replace) = N_Function_Call then + Set_Etype + (Original_Node (Node_To_Replace), Etype (Node_To_Replace)); + end if; end if; end Complete_Object_Operation; *************** package body Sem_Ch4 is *** 6293,6299 **** and then N = Prefix (Parent_Node) then Node_To_Replace := Parent_Node; - Actuals := Expressions (Parent_Node); Actual := First (Actuals); --- 6700,6705 ---- *************** package body Sem_Ch4 is *** 6649,6677 **** if Is_Derived_Type (T) then return Primitive_Operations (T); ! elsif Ekind (Scope (T)) = E_Procedure ! or else Ekind (Scope (T)) = E_Function ! then -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. ! declare ! Decl : Node_Id; ! ! begin ! Decl := ! First (Generic_Formal_Declarations ! (Unit_Declaration_Node (Scope (T)))); ! while Present (Decl) loop ! if Nkind (Decl) in N_Formal_Subprogram_Declaration then ! Subp := Defining_Entity (Decl); ! Check_Candidate; ! end if; ! Next (Decl); ! end loop; ! end; return Candidates; else --- 7055,7085 ---- if Is_Derived_Type (T) then return Primitive_Operations (T); ! elsif Ekind_In (Scope (T), E_Procedure, E_Function) then ! -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. ! if Nkind (Unit_Declaration_Node (Scope (T))) ! = N_Generic_Subprogram_Declaration ! then ! declare ! Decl : Node_Id; ! begin ! Decl := ! First (Generic_Formal_Declarations ! (Unit_Declaration_Node (Scope (T)))); ! while Present (Decl) loop ! if Nkind (Decl) in N_Formal_Subprogram_Declaration then ! Subp := Defining_Entity (Decl); ! Check_Candidate; ! end if; + Next (Decl); + end loop; + end; + end if; return Candidates; else *************** package body Sem_Ch4 is *** 6681,6687 **** -- declaration or body (either the one that declares T, or a -- child unit). ! Subp := First_Entity (Scope (T)); while Present (Subp) loop if Is_Overloadable (Subp) then Check_Candidate; --- 7089,7103 ---- -- declaration or body (either the one that declares T, or a -- child unit). ! -- For a subtype representing a generic actual type, go to the ! -- base type. ! ! if Is_Generic_Actual_Type (T) then ! Subp := First_Entity (Scope (Base_Type (T))); ! else ! Subp := First_Entity (Scope (T)); ! end if; ! while Present (Subp) loop if Is_Overloadable (Subp) then Check_Candidate; *************** package body Sem_Ch4 is *** 6754,6766 **** -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then ! if not Present (Corresponding_Record_Type (Obj_Type)) then ! return False; end if; - Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); - Elmt := First_Elmt (Primitive_Operations (Corr_Type)); - elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; Elmt := First_Elmt (Primitive_Operations (Obj_Type)); --- 7170,7183 ---- -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then ! if Present (Corresponding_Record_Type (Obj_Type)) then ! Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); ! Elmt := First_Elmt (Primitive_Operations (Corr_Type)); ! else ! Corr_Type := Obj_Type; ! Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); end if; elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; Elmt := First_Elmt (Primitive_Operations (Obj_Type)); *************** package body Sem_Ch4 is *** 6777,6783 **** and then Present (First_Formal (Prim_Op)) and then Valid_First_Argument_Of (Prim_Op) and then ! (Nkind (Call_Node) = N_Function_Call) = (Ekind (Prim_Op) = E_Function) then -- Ada 2005 (AI-251): If this primitive operation corresponds --- 7194,7200 ---- and then Present (First_Formal (Prim_Op)) and then Valid_First_Argument_Of (Prim_Op) and then ! (Nkind (Call_Node) = N_Function_Call) = (Ekind (Prim_Op) = E_Function) then -- Ada 2005 (AI-251): If this primitive operation corresponds diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch4.ads gcc-4.6.0/gcc/ada/sem_ch4.ads *** gcc-4.5.2/gcc/ada/sem_ch4.ads Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/sem_ch4.ads Thu Oct 21 10:14:06 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Ch4 is *** 30,45 **** --- 30,48 ---- procedure Analyze_Allocator (N : Node_Id); procedure Analyze_Arithmetic_Op (N : Node_Id); procedure Analyze_Call (N : Node_Id); + procedure Analyze_Case_Expression (N : Node_Id); procedure Analyze_Comparison_Op (N : Node_Id); procedure Analyze_Concatenation (N : Node_Id); procedure Analyze_Conditional_Expression (N : Node_Id); procedure Analyze_Equality_Op (N : Node_Id); procedure Analyze_Explicit_Dereference (N : Node_Id); + procedure Analyze_Expression_With_Actions (N : Node_Id); procedure Analyze_Logical_Op (N : Node_Id); procedure Analyze_Membership_Op (N : Node_Id); procedure Analyze_Negation (N : Node_Id); procedure Analyze_Null (N : Node_Id); procedure Analyze_Qualified_Expression (N : Node_Id); + procedure Analyze_Quantified_Expression (N : Node_Id); procedure Analyze_Range (N : Node_Id); procedure Analyze_Reference (N : Node_Id); procedure Analyze_Selected_Component (N : Node_Id); *************** package Sem_Ch4 is *** 58,63 **** -- c) A conversion -- d) A slice -- The resolution of the construct requires some semantic information ! -- on the prefix and the indices. end Sem_Ch4; --- 61,66 ---- -- c) A conversion -- d) A slice -- The resolution of the construct requires some semantic information ! -- on the prefix and the indexes. end Sem_Ch4; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch5.adb gcc-4.6.0/gcc/ada/sem_ch5.adb *** gcc-4.5.2/gcc/ada/sem_ch5.adb Wed Jul 29 08:43:58 2009 --- gcc-4.6.0/gcc/ada/sem_ch5.adb Tue Oct 26 13:05:30 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Sem_Disp; use Sem_Disp; *** 46,52 **** with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; - with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; --- 46,51 ---- *************** package body Sem_Ch5 is *** 71,82 **** -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Analyze_Iteration_Scheme (N : Node_Id); - ------------------------ -- Analyze_Assignment -- ------------------------ --- 70,75 ---- *************** package body Sem_Ch5 is *** 367,373 **** S : Entity_Id; begin ! if Ada_Version >= Ada_05 then -- Handle chains of renamings --- 360,366 ---- S : Entity_Id; begin ! if Ada_Version >= Ada_2005 then -- Handle chains of renamings *************** package body Sem_Ch5 is *** 448,461 **** end if; return; ! -- Enforce RM 3.9.3 (8): left-hand side cannot be abstract ! elsif Is_Interface (T1) ! and then not Is_Class_Wide_Type (T1) ! then Error_Msg_N ! ("target of assignment operation may not be abstract", Lhs); ! return; end if; -- Resolution may have updated the subtype, in case the left-hand --- 441,454 ---- end if; return; ! -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be ! -- abstract. This is only checked when the assignment Comes_From_Source, ! -- because in some cases the expander generates such assignments (such ! -- in the _assign operation for an abstract type). ! elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then Error_Msg_N ! ("target of assignment operation must not be abstract", Lhs); end if; -- Resolution may have updated the subtype, in case the left-hand *************** package body Sem_Ch5 is *** 593,599 **** -- as well to anonymous access-to-subprogram types that are component -- subtypes or formal parameters. ! if Ada_Version >= Ada_05 and then Is_Access_Type (T1) then if Is_Local_Anonymous_Access (T1) --- 586,592 ---- -- as well to anonymous access-to-subprogram types that are component -- subtypes or formal parameters. ! if Ada_Version >= Ada_2005 and then Is_Access_Type (T1) then if Is_Local_Anonymous_Access (T1) *************** package body Sem_Ch5 is *** 606,612 **** -- Ada 2005 (AI-231): Assignment to not null variable ! if Ada_Version >= Ada_05 and then Can_Never_Be_Null (T1) and then not Assignment_OK (Lhs) then --- 599,605 ---- -- Ada 2005 (AI-231): Assignment to not null variable ! if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T1) and then not Assignment_OK (Lhs) then *************** package body Sem_Ch5 is *** 650,656 **** or else Nkind (N) /= N_Block_Statement) then -- Assignment verifies that the length of the Lsh and Rhs are equal, ! -- but of course the indices do not have to match. If the right-hand -- side is a type conversion to an unconstrained type, a length check -- is performed on the expression itself during expansion. In rare -- cases, the redundant length check is computed on an index type --- 643,649 ---- or else Nkind (N) /= N_Block_Statement) then -- Assignment verifies that the length of the Lsh and Rhs are equal, ! -- but of course the indexes do not have to match. If the right-hand -- side is a type conversion to an unconstrained type, a length check -- is performed on the expression itself during expansion. In rare -- cases, the redundant length check is computed on an index type *************** package body Sem_Ch5 is *** 669,674 **** --- 662,668 ---- -- checks have been applied. Note_Possible_Modification (Lhs, Sure => True); + Check_Order_Dependence; -- ??? a real accessibility check is needed when ??? *************** package body Sem_Ch5 is *** 693,702 **** and then Nkind (Original_Node (Rhs)) not in N_Op then if Nkind (Lhs) in N_Has_Entity then ! Error_Msg_NE ("?useless assignment of & to itself!", N, Entity (Lhs)); else ! Error_Msg_N ("?useless assignment of object to itself!", N); end if; end if; --- 687,696 ---- and then Nkind (Original_Node (Rhs)) not in N_Op then if Nkind (Lhs) in N_Has_Entity then ! Error_Msg_NE -- CODEFIX ("?useless assignment of & to itself!", N, Entity (Lhs)); else ! Error_Msg_N -- CODEFIX ("?useless assignment of object to itself!", N); end if; end if; *************** package body Sem_Ch5 is *** 948,954 **** -- the case statement has a non static choice. procedure Process_Statements (Alternative : Node_Id); ! -- Analyzes all the statements associated to a case alternative. -- Needed by the generic instantiation below. package Case_Choices_Processing is new --- 942,948 ---- -- the case statement has a non static choice. procedure Process_Statements (Alternative : Node_Id); ! -- Analyzes all the statements associated with a case alternative. -- Needed by the generic instantiation below. package Case_Choices_Processing is new *************** package body Sem_Ch5 is *** 998,1008 **** if Is_Entity_Name (Exp) then Ent := Entity (Exp); ! if Ekind (Ent) = E_Variable ! or else ! Ekind (Ent) = E_In_Out_Parameter ! or else ! Ekind (Ent) = E_Out_Parameter then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr --- 992,1000 ---- if Is_Entity_Name (Exp) then Ent := Entity (Exp); ! if Ekind_In (Ent, E_Variable, ! E_In_Out_Parameter, ! E_Out_Parameter) then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr *************** package body Sem_Ch5 is *** 1027,1038 **** Analyze_Statements (Statements (Alternative)); end Process_Statements; - -- Table to record choices. Put after subprograms since we make - -- a call to Number_Of_Choices to get the right number of entries. - - Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); - pragma Warnings (Off, Case_Table); - -- Start of processing for Analyze_Case_Statement begin --- 1019,1024 ---- *************** package body Sem_Ch5 is *** 1105,1112 **** -- Call instantiated Analyze_Choices which does the rest of the work ! Analyze_Choices ! (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); --- 1091,1097 ---- -- Call instantiated Analyze_Choices which does the rest of the work ! Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); *************** package body Sem_Ch5 is *** 1198,1204 **** else Error_Msg_N ("cannot exit from program unit or accept statement", N); ! exit; end if; end loop; --- 1183,1189 ---- else Error_Msg_N ("cannot exit from program unit or accept statement", N); ! return; end if; end loop; *************** package body Sem_Ch5 is *** 1209,1214 **** --- 1194,1204 ---- Check_Unset_Reference (Cond); end if; + -- Chain exit statement to associated loop entity + + Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); + Set_First_Exit_Statement (Scope_Id, N); + -- Since the exit may take us out of a loop, any previous assignment -- statement is not useless, so clear last assignment indications. It -- is OK to keep other current values, since if the exit statement *************** package body Sem_Ch5 is *** 1472,1479 **** R_Copy : constant Node_Id := New_Copy_Tree (R); Lo : constant Node_Id := Low_Bound (R); Hi : constant Node_Id := High_Bound (R); ! New_Lo_Bound : Node_Id := Empty; ! New_Hi_Bound : Node_Id := Empty; Typ : Entity_Id; Save_Analysis : Boolean; --- 1462,1469 ---- R_Copy : constant Node_Id := New_Copy_Tree (R); Lo : constant Node_Id := Low_Bound (R); Hi : constant Node_Id := High_Bound (R); ! New_Lo_Bound : Node_Id; ! New_Hi_Bound : Node_Id; Typ : Entity_Id; Save_Analysis : Boolean; *************** package body Sem_Ch5 is *** 1517,1525 **** Analyze_And_Resolve (Original_Bound, Typ); ! Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); -- Normally, the best approach is simply to generate a constant -- declaration that captures the bound. However, there is a nasty --- 1507,1513 ---- Analyze_And_Resolve (Original_Bound, Typ); ! Id := Make_Temporary (Loc, 'S', Original_Bound); -- Normally, the best approach is simply to generate a constant -- declaration that captures the bound. However, there is a nasty *************** package body Sem_Ch5 is *** 1550,1587 **** Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Original_Bound)); ! Insert_Before (Parent (N), Decl); ! Analyze (Decl); Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); return Expression (Decl); end if; ! -- Here we make a declaration with a separate assignment statement Decl := Make_Object_Declaration (Loc, Defining_Identifier => Id, Object_Definition => New_Occurrence_Of (Typ, Loc)); - Insert_Before (Parent (N), Decl); - Analyze (Decl); - Assign := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Id, Loc), Expression => Relocate_Node (Original_Bound)); ! -- If the relocated node is a function call then check if some ! -- SCIL node references it and needs readjustment. ! ! if Generate_SCIL ! and then Nkind (Original_Bound) = N_Function_Call ! then ! Adjust_SCIL_Node (Original_Bound, Expression (Assign)); ! end if; ! ! Insert_Before (Parent (N), Assign); ! Analyze (Assign); Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); --- 1538,1566 ---- Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Original_Bound)); ! -- Insert declaration at proper place. If loop comes from an ! -- enclosing quantified expression, the insertion point is ! -- arbitrarily far up in the tree. ! ! Insert_Action (Parent (N), Decl); Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); return Expression (Decl); end if; ! -- Here we make a declaration with a separate assignment ! -- statement, and insert before loop header. Decl := Make_Object_Declaration (Loc, Defining_Identifier => Id, Object_Definition => New_Occurrence_Of (Typ, Loc)); Assign := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Id, Loc), Expression => Relocate_Node (Original_Bound)); ! Insert_Actions (Parent (N), New_List (Decl, Assign)); Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); *************** package body Sem_Ch5 is *** 1718,1730 **** then declare Loc : constant Source_Ptr := Sloc (N); ! Arr : constant Entity_Id := ! Etype (Entity (Prefix (DS))); Indx : constant Entity_Id := Base_Type (Etype (First_Index (Arr))); ! Subt : constant Entity_Id := ! Make_Defining_Identifier ! (Loc, New_Internal_Name ('S')); Decl : Node_Id; begin --- 1697,1706 ---- then declare Loc : constant Source_Ptr := Sloc (N); ! Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); Indx : constant Entity_Id := Base_Type (Etype (First_Index (Arr))); ! Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); Decl : Node_Id; begin *************** package body Sem_Ch5 is *** 1752,1961 **** -- Start of processing for Analyze_Iteration_Scheme begin -- For an infinite loop, there is no iteration scheme if No (N) then return; ! else ! declare ! Cond : constant Node_Id := Condition (N); ! begin ! -- For WHILE loop, verify that the condition is a Boolean ! -- expression and resolve and check it. ! if Present (Cond) then ! Analyze_And_Resolve (Cond, Any_Boolean); ! Check_Unset_Reference (Cond); ! Set_Current_Value_Condition (N); ! return; ! -- Else we have a FOR loop ! else ! declare ! LP : constant Node_Id := Loop_Parameter_Specification (N); ! Id : constant Entity_Id := Defining_Identifier (LP); ! DS : constant Node_Id := Discrete_Subtype_Definition (LP); ! begin ! Enter_Name (Id); ! -- We always consider the loop variable to be referenced, ! -- since the loop may be used just for counting purposes. ! Generate_Reference (Id, N, ' '); ! -- Check for case of loop variable hiding a local ! -- variable (used later on to give a nice warning ! -- if the hidden variable is never assigned). ! declare ! H : constant Entity_Id := Homonym (Id); ! begin ! if Present (H) ! and then Enclosing_Dynamic_Scope (H) = ! Enclosing_Dynamic_Scope (Id) ! and then Ekind (H) = E_Variable ! and then Is_Discrete_Type (Etype (H)) ! then ! Set_Hiding_Loop_Variable (H, Id); ! end if; ! end; ! -- Now analyze the subtype definition. If it is ! -- a range, create temporaries for bounds. ! if Nkind (DS) = N_Range ! and then Expander_Active then ! Process_Bounds (DS); ! else ! Analyze (DS); end if; ! if DS = Error then ! return; ! end if; ! -- The subtype indication may denote the completion ! -- of an incomplete type declaration. ! if Is_Entity_Name (DS) ! and then Present (Entity (DS)) ! and then Is_Type (Entity (DS)) ! and then Ekind (Entity (DS)) = E_Incomplete_Type then Set_Entity (DS, Get_Full_View (Entity (DS))); Set_Etype (DS, Entity (DS)); end if; ! if not Is_Discrete_Type (Etype (DS)) then ! Wrong_Type (DS, Any_Discrete); ! Set_Etype (DS, Any_Type); end if; ! Check_Controlled_Array_Attribute (DS); ! Make_Index (DS, LP); ! Set_Ekind (Id, E_Loop_Parameter); ! Set_Etype (Id, Etype (DS)); ! -- Treat a range as an implicit reference to the type, to ! -- inhibit spurious warnings. ! Generate_Reference (Base_Type (Etype (DS)), N, ' '); ! Set_Is_Known_Valid (Id, True); ! -- The loop is not a declarative part, so the only entity ! -- declared "within" must be frozen explicitly. ! declare ! Flist : constant List_Id := Freeze_Entity (Id, Sloc (N)); ! begin ! if Is_Non_Empty_List (Flist) then ! Insert_Actions (N, Flist); ! end if; ! end; ! -- Check for null or possibly null range and issue warning. ! -- We suppress such messages in generic templates and ! -- instances, because in practice they tend to be dubious ! -- in these cases. ! if Nkind (DS) = N_Range ! and then Comes_From_Source (N) ! then ! declare ! L : constant Node_Id := Low_Bound (DS); ! H : constant Node_Id := High_Bound (DS); ! begin ! -- If range of loop is null, issue warning ! if Compile_Time_Compare ! (L, H, Assume_Valid => True) = GT then ! -- Suppress the warning if inside a generic ! -- template or instance, since in practice ! -- they tend to be dubious in these cases since ! -- they can result from intended parametrization. ! if not Inside_A_Generic ! and then not In_Instance then ! -- Specialize msg if invalid values could make ! -- the loop non-null after all. ! ! if Compile_Time_Compare ! (L, H, Assume_Valid => False) = GT ! then ! Error_Msg_N ! ("?loop range is null, " ! & "loop will not execute", ! DS); ! -- Since we know the range of the loop is ! -- null, set the appropriate flag to remove ! -- the loop entirely during expansion. ! Set_Is_Null_Loop (Parent (N)); -- Here is where the loop could execute because -- of invalid values, so issue appropriate -- message and in this case we do not set the -- Is_Null_Loop flag since the loop may execute. ! else ! Error_Msg_N ! ("?loop range may be null, " ! & "loop may not execute", ! DS); ! Error_Msg_N ! ("?can only execute if invalid values " ! & "are present", ! DS); ! end if; end if; ! -- In either case, suppress warnings in the body of ! -- the loop, since it is likely that these warnings ! -- will be inappropriate if the loop never actually ! -- executes, which is unlikely. ! Set_Suppress_Loop_Warnings (Parent (N)); -- The other case for a warning is a reverse loop ! -- where the upper bound is the integer literal ! -- zero or one, and the lower bound can be positive. -- For example, we have -- for J in reverse N .. 1 loop ! -- In practice, this is very likely to be a case ! -- of reversing the bounds incorrectly in the range. ! elsif Reverse_Present (LP) ! and then Nkind (Original_Node (H)) = ! N_Integer_Literal ! and then (Intval (Original_Node (H)) = Uint_0 ! or else Intval (Original_Node (H)) = Uint_1) ! then ! Error_Msg_N ("?loop range may be null", DS); ! Error_Msg_N ("\?bounds may be wrong way round", DS); ! end if; ! end; ! end if; ! end; ! end if; ! end; ! end if; end Analyze_Iteration_Scheme; ------------------- -- Analyze_Label -- ------------------- --- 1728,2059 ---- -- Start of processing for Analyze_Iteration_Scheme begin + -- If this is a rewritten quantified expression, the iteration + -- scheme has been analyzed already. Do no repeat analysis because + -- the loop variable is already declared. + + if Analyzed (N) then + return; + end if; + -- For an infinite loop, there is no iteration scheme if No (N) then return; + end if; ! -- Iteration scheme is present ! declare ! Cond : constant Node_Id := Condition (N); ! begin ! -- For WHILE loop, verify that the condition is a Boolean ! -- expression and resolve and check it. ! if Present (Cond) then ! Analyze_And_Resolve (Cond, Any_Boolean); ! Check_Unset_Reference (Cond); ! Set_Current_Value_Condition (N); ! return; ! elsif Present (Iterator_Specification (N)) then ! Analyze_Iterator_Specification (Iterator_Specification (N)); ! -- Else we have a FOR loop ! else ! declare ! LP : constant Node_Id := Loop_Parameter_Specification (N); ! Id : constant Entity_Id := Defining_Identifier (LP); ! DS : constant Node_Id := Discrete_Subtype_Definition (LP); ! begin ! Enter_Name (Id); ! -- We always consider the loop variable to be referenced, ! -- since the loop may be used just for counting purposes. ! Generate_Reference (Id, N, ' '); ! -- Check for the case of loop variable hiding a local variable ! -- (used later on to give a nice warning if the hidden variable ! -- is never assigned). ! declare ! H : constant Entity_Id := Homonym (Id); ! begin ! if Present (H) ! and then Enclosing_Dynamic_Scope (H) = ! Enclosing_Dynamic_Scope (Id) ! and then Ekind (H) = E_Variable ! and then Is_Discrete_Type (Etype (H)) then ! Set_Hiding_Loop_Variable (H, Id); end if; + end; ! -- Now analyze the subtype definition. If it is a range, create ! -- temporaries for bounds. ! if Nkind (DS) = N_Range ! and then Expander_Active ! then ! Process_Bounds (DS); ! -- Not a range or expander not active (is that right???) ! ! else ! Analyze (DS); ! ! if Nkind (DS) = N_Function_Call ! or else ! (Is_Entity_Name (DS) ! and then not Is_Type (Entity (DS))) then + -- This is an iterator specification. Rewrite as such + -- and analyze. + + declare + I_Spec : constant Node_Id := + Make_Iterator_Specification (Sloc (LP), + Defining_Identifier => + Relocate_Node (Id), + Name => + Relocate_Node (DS), + Subtype_Indication => + Empty, + Reverse_Present => + Reverse_Present (LP)); + begin + Set_Iterator_Specification (N, I_Spec); + Set_Loop_Parameter_Specification (N, Empty); + Analyze_Iterator_Specification (I_Spec); + return; + end; + end if; + end if; + + if DS = Error then + return; + end if; + + -- Some additional checks if we are iterating through a type + + if Is_Entity_Name (DS) + and then Present (Entity (DS)) + and then Is_Type (Entity (DS)) + then + -- The subtype indication may denote the completion of an + -- incomplete type declaration. + + if Ekind (Entity (DS)) = E_Incomplete_Type then Set_Entity (DS, Get_Full_View (Entity (DS))); Set_Etype (DS, Entity (DS)); end if; ! -- Attempt to iterate through non-static predicate ! ! if Is_Discrete_Type (Entity (DS)) ! and then Present (Predicate_Function (Entity (DS))) ! and then No (Static_Predicate (Entity (DS))) ! then ! Bad_Predicated_Subtype_Use ! ("cannot use subtype& with non-static " ! & "predicate for loop iteration", DS, Entity (DS)); end if; + end if; ! -- Error if not discrete type ! if not Is_Discrete_Type (Etype (DS)) then ! Wrong_Type (DS, Any_Discrete); ! Set_Etype (DS, Any_Type); ! end if; ! Check_Controlled_Array_Attribute (DS); ! Make_Index (DS, LP); ! Set_Ekind (Id, E_Loop_Parameter); ! Set_Etype (Id, Etype (DS)); ! -- Treat a range as an implicit reference to the type, to ! -- inhibit spurious warnings. ! Generate_Reference (Base_Type (Etype (DS)), N, ' '); ! Set_Is_Known_Valid (Id, True); ! -- The loop is not a declarative part, so the only entity ! -- declared "within" must be frozen explicitly. ! declare ! Flist : constant List_Id := Freeze_Entity (Id, N); ! begin ! if Is_Non_Empty_List (Flist) then ! Insert_Actions (N, Flist); ! end if; ! end; ! -- Check for null or possibly null range and issue warning. We ! -- suppress such messages in generic templates and instances, ! -- because in practice they tend to be dubious in these cases. ! if Nkind (DS) = N_Range and then Comes_From_Source (N) then ! declare ! L : constant Node_Id := Low_Bound (DS); ! H : constant Node_Id := High_Bound (DS); ! ! begin ! -- If range of loop is null, issue warning ! ! if Compile_Time_Compare ! (L, H, Assume_Valid => True) = GT ! then ! -- Suppress the warning if inside a generic template ! -- or instance, since in practice they tend to be ! -- dubious in these cases since they can result from ! -- intended parametrization. ! ! if not Inside_A_Generic ! and then not In_Instance then ! -- Specialize msg if invalid values could make ! -- the loop non-null after all. ! if Compile_Time_Compare ! (L, H, Assume_Valid => False) = GT then ! Error_Msg_N ! ("?loop range is null, loop will not execute", ! DS); ! -- Since we know the range of the loop is ! -- null, set the appropriate flag to remove ! -- the loop entirely during expansion. ! Set_Is_Null_Loop (Parent (N)); -- Here is where the loop could execute because -- of invalid values, so issue appropriate -- message and in this case we do not set the -- Is_Null_Loop flag since the loop may execute. ! else ! Error_Msg_N ! ("?loop range may be null, " ! & "loop may not execute", ! DS); ! Error_Msg_N ! ("?can only execute if invalid values " ! & "are present", ! DS); end if; + end if; ! -- In either case, suppress warnings in the body of ! -- the loop, since it is likely that these warnings ! -- will be inappropriate if the loop never actually ! -- executes, which is likely. ! Set_Suppress_Loop_Warnings (Parent (N)); -- The other case for a warning is a reverse loop ! -- where the upper bound is the integer literal zero ! -- or one, and the lower bound can be positive. -- For example, we have -- for J in reverse N .. 1 loop ! -- In practice, this is very likely to be a case of ! -- reversing the bounds incorrectly in the range. ! elsif Reverse_Present (LP) ! and then Nkind (Original_Node (H)) = ! N_Integer_Literal ! and then (Intval (Original_Node (H)) = Uint_0 ! or else Intval (Original_Node (H)) = Uint_1) ! then ! Error_Msg_N ("?loop range may be null", DS); ! Error_Msg_N ("\?bounds may be wrong way round", DS); ! end if; ! end; ! end if; ! end; ! end if; ! end; end Analyze_Iteration_Scheme; + ------------------------------------- + -- Analyze_Iterator_Specification -- + ------------------------------------- + + procedure Analyze_Iterator_Specification (N : Node_Id) is + Def_Id : constant Node_Id := Defining_Identifier (N); + Subt : constant Node_Id := Subtype_Indication (N); + Container : constant Node_Id := Name (N); + + Ent : Entity_Id; + Typ : Entity_Id; + + begin + Enter_Name (Def_Id); + Set_Ekind (Def_Id, E_Variable); + + if Present (Subt) then + Analyze (Subt); + end if; + + Analyze_And_Resolve (Container); + Typ := Etype (Container); + + if Is_Array_Type (Typ) then + if Of_Present (N) then + Set_Etype (Def_Id, Component_Type (Typ)); + else + Error_Msg_N + ("to iterate over the elements of an array, use OF", N); + Set_Etype (Def_Id, Etype (First_Index (Typ))); + end if; + + -- Iteration over a container + + else + Set_Ekind (Def_Id, E_Loop_Parameter); + + if Of_Present (N) then + + -- Find the Element_Type in the package instance that defines the + -- container type. + + Ent := First_Entity (Scope (Typ)); + while Present (Ent) loop + if Chars (Ent) = Name_Element_Type then + Set_Etype (Def_Id, Ent); + exit; + end if; + + Next_Entity (Ent); + end loop; + + else + -- Find the Cursor type in similar fashion + + Ent := First_Entity (Scope (Typ)); + while Present (Ent) loop + if Chars (Ent) = Name_Cursor then + Set_Etype (Def_Id, Ent); + exit; + end if; + + Next_Entity (Ent); + end loop; + end if; + end if; + end Analyze_Iterator_Specification; + ------------------- -- Analyze_Label -- ------------------- *************** package body Sem_Ch5 is *** 2060,2067 **** End_Scope; Kill_Current_Values; ! -- Check for infinite loop. We skip this check for generated code, since ! -- it justs waste time and makes debugging the routine called harder. if Comes_From_Source (N) then Check_Infinite_Loop_Warning (N); --- 2158,2169 ---- End_Scope; Kill_Current_Values; ! -- Check for infinite loop. Skip check for generated code, since it ! -- justs waste time and makes debugging the routine called harder. ! ! -- Note that we have to wait till the body of the loop is fully analyzed ! -- before making this call, since Check_Infinite_Loop_Warning relies on ! -- being able to use semantic visibility information to find references. if Comes_From_Source (N) then Check_Infinite_Loop_Warning (N); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch5.ads gcc-4.6.0/gcc/ada/sem_ch5.ads *** gcc-4.5.2/gcc/ada/sem_ch5.ads Tue Apr 8 06:50:04 2008 --- gcc-4.6.0/gcc/ada/sem_ch5.ads Fri Oct 22 09:36:41 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Ch5 is *** 34,39 **** --- 34,41 ---- procedure Analyze_Goto_Statement (N : Node_Id); procedure Analyze_If_Statement (N : Node_Id); procedure Analyze_Implicit_Label_Declaration (N : Node_Id); + procedure Analyze_Iterator_Specification (N : Node_Id); + procedure Analyze_Iteration_Scheme (N : Node_Id); procedure Analyze_Label (N : Node_Id); procedure Analyze_Loop_Statement (N : Node_Id); procedure Analyze_Null_Statement (N : Node_Id); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch6.adb gcc-4.6.0/gcc/ada/sem_ch6.adb *** gcc-4.5.2/gcc/ada/sem_ch6.adb Tue Jan 26 13:49:56 2010 --- gcc-4.6.0/gcc/ada/sem_ch6.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; *************** with Sem_Ch5; use Sem_Ch5; *** 59,64 **** --- 60,66 ---- with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; + with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; *************** package body Sem_Ch6 is *** 98,104 **** ----------------------- procedure Analyze_Return_Statement (N : Node_Id); ! -- Common processing for simple_ and extended_return_statements procedure Analyze_Function_Return (N : Node_Id); -- Subsidiary to Analyze_Return_Statement. Called when the return statement --- 100,106 ---- ----------------------- procedure Analyze_Return_Statement (N : Node_Id); ! -- Common processing for simple and extended return statements procedure Analyze_Function_Return (N : Node_Id); -- Subsidiary to Analyze_Return_Statement. Called when the return statement *************** package body Sem_Ch6 is *** 106,116 **** procedure Analyze_Return_Type (N : Node_Id); -- Subsidiary to Process_Formals: analyze subtype mark in function ! -- specification, in a context where the formals are visible and hide -- outer homographs. procedure Analyze_Subprogram_Body_Helper (N : Node_Id); ! -- Does all the real work of Analyze_Subprogram_Body procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); -- Analyze a generic subprogram body. N is the body to be analyzed, and --- 108,119 ---- procedure Analyze_Return_Type (N : Node_Id); -- Subsidiary to Process_Formals: analyze subtype mark in function ! -- specification in a context where the formals are visible and hide -- outer homographs. procedure Analyze_Subprogram_Body_Helper (N : Node_Id); ! -- Does all the real work of Analyze_Subprogram_Body. This is split out so ! -- that we can use RETURN but not skip the debug output at the end. procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); -- Analyze a generic subprogram body. N is the body to be analyzed, and *************** package body Sem_Ch6 is *** 165,176 **** -- True otherwise. Proc is the entity for the procedure case and is used -- in posting the warning message. procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first visible -- entity with that name. procedure Install_Entity (E : Entity_Id); ! -- Make single entity visible. Used for generic formals as well function Is_Non_Overriding_Operation (Prev_E : Entity_Id; --- 168,186 ---- -- True otherwise. Proc is the entity for the procedure case and is used -- in posting the warning message. + procedure Check_Untagged_Equality (Eq_Op : Entity_Id); + -- In Ada 2012, a primitive equality operator on an untagged record type + -- must appear before the type is frozen, and have the same visibility as + -- that of the type. This procedure checks that this rule is met, and + -- otherwise emits an error on the subprogram declaration and a warning + -- on the earlier freeze point if it is easy to locate. + procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first visible -- entity with that name. procedure Install_Entity (E : Entity_Id); ! -- Make single entity visible (used for generic formals as well) function Is_Non_Overriding_Operation (Prev_E : Entity_Id; *************** package body Sem_Ch6 is *** 197,203 **** -- conditions for the body and assembling and inserting the _postconditions -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are -- the entities for the body and separate spec (if there is no separate ! -- spec, Spec_Id is Empty). procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with --- 207,214 ---- -- conditions for the body and assembling and inserting the _postconditions -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are -- the entities for the body and separate spec (if there is no separate ! -- spec, Spec_Id is Empty). Note that invariants and predicates may also ! -- provide postconditions, and are also handled in this procedure. procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with *************** package body Sem_Ch6 is *** 363,369 **** elsif Warn_On_Redundant_Constructs and then not Is_Dispatching_Operation (Designator) ! and then not Is_Overriding_Operation (Designator) and then (not Is_Operator_Symbol_Name (Chars (Designator)) or else Scop /= Scope (Etype (First_Formal (Designator)))) then --- 374,380 ---- elsif Warn_On_Redundant_Constructs and then not Is_Dispatching_Operation (Designator) ! and then not Present (Overridden_Operation (Designator)) and then (not Is_Operator_Symbol_Name (Chars (Designator)) or else Scop /= Scope (Etype (First_Formal (Designator)))) then *************** package body Sem_Ch6 is *** 373,378 **** --- 384,390 ---- Generate_Reference_To_Formals (Designator); Check_Eliminated (Designator); + Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N)); end Analyze_Abstract_Subprogram_Declaration; ---------------------------------------- *************** package body Sem_Ch6 is *** 468,481 **** then -- Error in Ada 2005 ! if Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L and then not GNAT_Mode then Error_Msg_N ("(Ada 2005) cannot copy object of a limited type " & "(RM-2005 6.5(5.5/2))", Expr); ! if Is_Inherently_Limited_Type (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; --- 480,494 ---- then -- Error in Ada 2005 ! if Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L and then not GNAT_Mode then Error_Msg_N ("(Ada 2005) cannot copy object of a limited type " & "(RM-2005 6.5(5.5/2))", Expr); ! ! if Is_Immutably_Limited_Type (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; *************** package body Sem_Ch6 is *** 486,500 **** -- In GNAT mode, this is just a warning, to allow it to be -- evilly turned off. Otherwise it is a real error. elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then ! if Is_Inherently_Limited_Type (R_Type) then Error_Msg_N ! ("return by reference not permitted in Ada 2005 " & ! "(RM-2005 6.5(5.5/2))?", Expr); else Error_Msg_N ! ("cannot copy object of a limited type in Ada 2005 " & ! "(RM-2005 6.5(5.5/2))?", Expr); end if; -- Ada 95 mode, compatibility warnings disabled --- 499,521 ---- -- In GNAT mode, this is just a warning, to allow it to be -- evilly turned off. Otherwise it is a real error. + -- In a generic context, simplify the warning because it makes + -- no sense to discuss pass-by-reference or copy. + elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then ! if Inside_A_Generic then Error_Msg_N ! ("return of limited object not permitted in Ada2005 " ! & "(RM-2005 6.5(5.5/2))?", Expr); ! ! elsif Is_Immutably_Limited_Type (R_Type) then ! Error_Msg_N ! ("return by reference not permitted in Ada 2005 " ! & "(RM-2005 6.5(5.5/2))?", Expr); else Error_Msg_N ! ("cannot copy object of a limited type in Ada 2005 " ! & "(RM-2005 6.5(5.5/2))?", Expr); end if; -- Ada 95 mode, compatibility warnings disabled *************** package body Sem_Ch6 is *** 503,511 **** return; -- skip continuation messages below end if; ! Error_Msg_N ! ("\consider switching to return of access type", Expr); ! Explain_Limited_Type (R_Type, Expr); end if; end Check_Limited_Return; --- 524,534 ---- return; -- skip continuation messages below end if; ! if not Inside_A_Generic then ! Error_Msg_N ! ("\consider switching to return of access type", Expr); ! Explain_Limited_Type (R_Type, Expr); ! end if; end if; end Check_Limited_Return; *************** package body Sem_Ch6 is *** 514,523 **** ------------------------------------- procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is ! Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); ! R_Stm_Type : constant Entity_Id := Etype (Return_Obj); ! -- Subtype given in the extended return statement; ! -- this must match R_Type. Subtype_Ind : constant Node_Id := Object_Definition (Original_Node (Obj_Decl)); --- 537,546 ---- ------------------------------------- procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is ! Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); ! ! R_Stm_Type : constant Entity_Id := Etype (Return_Obj); ! -- Subtype given in the extended return statement (must match R_Type) Subtype_Ind : constant Node_Id := Object_Definition (Original_Node (Obj_Decl)); *************** package body Sem_Ch6 is *** 542,548 **** -- True if type of the return object is an anonymous access type begin ! -- First, avoid cascade errors: if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then return; --- 565,571 ---- -- True if type of the return object is an anonymous access type begin ! -- First, avoid cascaded errors if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then return; *************** package body Sem_Ch6 is *** 612,618 **** Subtype_Ind); end if; ! if Is_Constrained (R_Type) then if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then Error_Msg_N ("subtype must statically match function result subtype", --- 635,645 ---- Subtype_Ind); end if; ! -- AI05-103: for elementary types, subtypes must statically match ! ! if Is_Constrained (R_Type) ! or else Is_Access_Type (R_Type) ! then if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then Error_Msg_N ("subtype must statically match function result subtype", *************** package body Sem_Ch6 is *** 710,716 **** -- type, apply an implicit conversion of the expression to that type -- to force appropriate static and run-time accessibility checks. ! if Ada_Version >= Ada_05 and then Ekind (R_Type) = E_Anonymous_Access_Type then Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); --- 737,743 ---- -- type, apply an implicit conversion of the expression to that type -- to force appropriate static and run-time accessibility checks. ! if Ada_Version >= Ada_2005 and then Ekind (R_Type) = E_Anonymous_Access_Type then Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); *************** package body Sem_Ch6 is *** 721,727 **** -- expression's type is not declared at a deeper level than the -- function (RM05-6.5(5.6/2)). ! if Ada_Version >= Ada_05 and then Is_Class_Wide_Type (R_Type) then if Type_Access_Level (Etype (Expr)) > --- 748,754 ---- -- expression's type is not declared at a deeper level than the -- function (RM05-6.5(5.6/2)). ! if Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (R_Type) then if Type_Access_Level (Etype (Expr)) > *************** package body Sem_Ch6 is *** 746,766 **** -- involving dereferences of access parameters. For now we just -- check the static cases. ! if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L) ! and then Is_Inherently_Limited_Type (Etype (Scope_Id)) and then Object_Access_Level (Expr) > Subprogram_Access_Level (Scope_Id) then - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - Analyze (N); ! Error_Msg_N ! ("cannot return a local value by reference?", N); ! Error_Msg_NE ! ("\& will be raised at run time?", ! N, Standard_Program_Error); end if; if Known_Null (Expr) --- 773,802 ---- -- involving dereferences of access parameters. For now we just -- check the static cases. ! if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) ! and then Is_Immutably_Limited_Type (Etype (Scope_Id)) and then Object_Access_Level (Expr) > Subprogram_Access_Level (Scope_Id) then ! -- Suppress the message in a generic, where the rewriting ! -- is irrelevant. ! ! if Inside_A_Generic then ! null; ! ! else ! Rewrite (N, ! Make_Raise_Program_Error (Loc, ! Reason => PE_Accessibility_Check_Failed)); ! Analyze (N); ! ! Error_Msg_N ! ("cannot return a local value by reference?", N); ! Error_Msg_NE ! ("\& will be raised at run time?", ! N, Standard_Program_Error); ! end if; end if; if Known_Null (Expr) *************** package body Sem_Ch6 is *** 773,778 **** --- 809,818 ---- & "null-excluding return?", Reason => CE_Null_Not_Allowed); end if; + + -- Apply checks suggested by AI05-0144 (dangerous order dependence) + + Check_Order_Dependence; end if; end Analyze_Function_Return; *************** package body Sem_Ch6 is *** 978,983 **** --- 1018,1024 ---- if Style_Check then Style.Check_Identifier (Body_Id, Gen_Id); end if; + End_Generic; end Analyze_Generic_Subprogram_Body; *************** package body Sem_Ch6 is *** 1024,1029 **** --- 1065,1095 ---- Analyze (Explicit_Actual_Parameter (N)); end Analyze_Parameter_Association; + -------------------------------------- + -- Analyze_Parameterized_Expression -- + -------------------------------------- + + procedure Analyze_Parameterized_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + LocX : constant Source_Ptr := Sloc (Expression (N)); + + begin + -- This is one of the occasions on which we write things during semantic + -- analysis. Transform the parameterized expression into an equivalent + -- subprogram body, and then analyze that. + + Rewrite (N, + Make_Subprogram_Body (Loc, + Specification => Specification (N), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (LocX, + Statements => New_List ( + Make_Simple_Return_Statement (LocX, + Expression => Expression (N)))))); + Analyze (N); + end Analyze_Parameterized_Expression; + ---------------------------- -- Analyze_Procedure_Call -- ---------------------------- *************** package body Sem_Ch6 is *** 1037,1042 **** --- 1103,1109 ---- procedure Analyze_Call_And_Resolve; -- Do Analyze and Resolve calls for procedure call + -- At end, check illegal order dependence. ------------------------------ -- Analyze_Call_And_Resolve -- *************** package body Sem_Ch6 is *** 1047,1052 **** --- 1114,1124 ---- if Nkind (N) = N_Procedure_Call_Statement then Analyze_Call (N); Resolve (N, Standard_Void_Type); + + -- Apply checks suggested by AI05-0144 + + Check_Order_Dependence; + else Analyze (N); end if; *************** package body Sem_Ch6 is *** 1074,1082 **** return; end if; ! -- If error analyzing prefix, then set Any_Type as result and return ! if Etype (P) = Any_Type then Set_Etype (N, Any_Type); return; end if; --- 1146,1158 ---- return; end if; ! -- If there is an error analyzing the name (which may have been ! -- rewritten if the original call was in prefix notation) then error ! -- has been emitted already, mark node and return. ! if Error_Posted (N) ! or else Etype (Name (N)) = Any_Type ! then Set_Etype (N, Any_Type); return; end if; *************** package body Sem_Ch6 is *** 1359,1366 **** and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) then ! Error_Msg_NE ! ("invalid use of incomplete type&", Designator, Typ); end if; end if; --- 1435,1461 ---- and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) then ! -- AI05-0151: Tagged incomplete types are allowed in all formal ! -- parts. Untagged incomplete types are not allowed in bodies. ! ! if Ada_Version >= Ada_2012 then ! if Is_Tagged_Type (Typ) then ! null; ! ! elsif Nkind_In (Parent (Parent (N)), ! N_Accept_Statement, ! N_Entry_Body, ! N_Subprogram_Body) ! then ! Error_Msg_NE ! ("invalid use of untagged incomplete type&", ! Designator, Typ); ! end if; ! ! else ! Error_Msg_NE ! ("invalid use of incomplete type&", Designator, Typ); ! end if; end if; end if; *************** package body Sem_Ch6 is *** 1424,1430 **** Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); Conformant : Boolean; HSS : Node_Id; - Missing_Ret : Boolean; P_Ent : Entity_Id; Prot_Typ : Entity_Id := Empty; Spec_Id : Entity_Id; --- 1519,1524 ---- *************** package body Sem_Ch6 is *** 1466,1471 **** --- 1560,1569 ---- -- If pragma does not appear after the body, check whether there is -- an inline pragma before any local declarations. + procedure Check_Missing_Return; + -- Checks for a function with a no return statements, and also performs + -- the warning checks implemented by Check_Returns. + function Disambiguate_Spec return Entity_Id; -- When a primitive is declared between the private view and the full -- view of a concurrent type which implements an interface, a special *************** package body Sem_Ch6 is *** 1618,1626 **** if Present (Prag) then if Present (Spec_Id) then ! if List_Containing (N) = ! List_Containing (Unit_Declaration_Node (Spec_Id)) ! then Analyze (Prag); end if; --- 1716,1722 ---- if Present (Prag) then if Present (Spec_Id) then ! if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then Analyze (Prag); end if; *************** package body Sem_Ch6 is *** 1629,1638 **** declare Subp : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Body_Id)); Decl : constant Node_Id := ! Make_Subprogram_Declaration (Loc, ! Specification => New_Copy_Tree (Specification (N))); begin Set_Defining_Unit_Name (Specification (Decl), Subp); --- 1725,1736 ---- declare Subp : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Body_Id)); Decl : constant Node_Id := ! Make_Subprogram_Declaration (Loc, ! Specification => ! New_Copy_Tree (Specification (N))); ! begin Set_Defining_Unit_Name (Specification (Decl), Subp); *************** package body Sem_Ch6 is *** 1658,1663 **** --- 1756,1801 ---- end if; end Check_Inline_Pragma; + -------------------------- + -- Check_Missing_Return -- + -------------------------- + + procedure Check_Missing_Return is + Id : Entity_Id; + Missing_Ret : Boolean; + + begin + if Nkind (Body_Spec) = N_Function_Specification then + if Present (Spec_Id) then + Id := Spec_Id; + else + Id := Body_Id; + end if; + + if Return_Present (Id) then + Check_Returns (HSS, 'F', Missing_Ret); + + if Missing_Ret then + Set_Has_Missing_Return (Id); + end if; + + elsif (Is_Generic_Subprogram (Id) + or else not Is_Machine_Code_Subprogram (Id)) + and then not Body_Deleted + then + Error_Msg_N ("missing RETURN statement in function body", N); + end if; + + -- If procedure with No_Return, check returns + + elsif Nkind (Body_Spec) = N_Procedure_Specification + and then Present (Spec_Id) + and then No_Return (Spec_Id) + then + Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); + end if; + end Check_Missing_Return; + ----------------------- -- Disambiguate_Spec -- ----------------------- *************** package body Sem_Ch6 is *** 1822,1834 **** then null; ! elsif not Is_Overriding_Operation (Spec_Id) then Error_Msg_NE ("subprogram& is not overriding", Body_Spec, Spec_Id); end if; elsif Must_Not_Override (Body_Spec) then ! if Is_Overriding_Operation (Spec_Id) then Error_Msg_NE ("subprogram& overrides inherited operation", Body_Spec, Spec_Id); --- 1960,1972 ---- then null; ! elsif not Present (Overridden_Operation (Spec_Id)) then Error_Msg_NE ("subprogram& is not overriding", Body_Spec, Spec_Id); end if; elsif Must_Not_Override (Body_Spec) then ! if Present (Overridden_Operation (Spec_Id)) then Error_Msg_NE ("subprogram& overrides inherited operation", Body_Spec, Spec_Id); *************** package body Sem_Ch6 is *** 1846,1858 **** elsif not Is_Primitive (Spec_Id) and then Ekind (Scope (Spec_Id)) /= E_Protected_Type then ! Error_Msg_N ("overriding indicator only allowed " & ! "if subprogram is primitive", ! Body_Spec); end if; elsif Style_Check -- ??? incorrect use of Style_Check! ! and then Is_Overriding_Operation (Spec_Id) then pragma Assert (Unit_Declaration_Node (Body_Id) = N); Style.Missing_Overriding (N, Body_Id); --- 1984,1997 ---- elsif not Is_Primitive (Spec_Id) and then Ekind (Scope (Spec_Id)) /= E_Protected_Type then ! Error_Msg_N ! ("overriding indicator only allowed " & ! "if subprogram is primitive", ! Body_Spec); end if; elsif Style_Check -- ??? incorrect use of Style_Check! ! and then Present (Overridden_Operation (Spec_Id)) then pragma Assert (Unit_Declaration_Node (Body_Id) = N); Style.Missing_Overriding (N, Body_Id); *************** package body Sem_Ch6 is *** 1881,1886 **** --- 2020,2031 ---- Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); Analyze_Generic_Subprogram_Body (N, Spec_Id); + + if Nkind (N) = N_Subprogram_Body then + HSS := Handled_Statement_Sequence (N); + Check_Missing_Return; + end if; + return; else *************** package body Sem_Ch6 is *** 2022,2035 **** -- why, to be investigated further??? Set_Has_Delayed_Freeze (Spec_Id); ! Insert_Actions (N, Freeze_Entity (Spec_Id, Loc)); end if; end if; ! -- Mark presence of postcondition proc in current scope if Chars (Body_Id) = Name_uPostconditions then Set_Has_Postconditions (Current_Scope); end if; -- Place subprogram on scope stack, and make formals visible. If there --- 2167,2183 ---- -- why, to be investigated further??? Set_Has_Delayed_Freeze (Spec_Id); ! Freeze_Before (N, Spec_Id); end if; end if; ! -- Mark presence of postcondition procedure in current scope and mark ! -- the procedure itself as needing debug info. The latter is important ! -- when analyzing decision coverage (for example, for MC/DC coverage). if Chars (Body_Id) = Name_uPostconditions then Set_Has_Postconditions (Current_Scope); + Set_Debug_Info_Needed (Body_Id); end if; -- Place subprogram on scope stack, and make formals visible. If there *************** package body Sem_Ch6 is *** 2079,2084 **** --- 2227,2241 ---- then Conformant := True; + -- Conversely, the spec may have been generated for specless body + -- with an inline pragma. + + elsif Comes_From_Source (N) + and then not Comes_From_Source (Spec_Id) + and then Has_Pragma_Inline (Spec_Id) + then + Conformant := True; + else Check_Conformance (Body_Id, Spec_Id, *************** package body Sem_Ch6 is *** 2169,2178 **** --- 2326,2348 ---- -- Case of subprogram body with no previous spec else + -- Check for style warning required + if Style_Check + + -- Only apply check for source level subprograms for which checks + -- have not been suppressed. + and then Comes_From_Source (Body_Id) and then not Suppress_Style_Checks (Body_Id) + + -- No warnings within an instance + and then not In_Instance + + -- No warnings for parameterized expressions + + and then Nkind (Original_Node (N)) /= N_Parameterized_Expression then Style.Body_With_No_Spec (N); end if; *************** package body Sem_Ch6 is *** 2194,2200 **** -- is the limited view of a class-wide type and the non-limited view is -- available, update the return type accordingly. ! if Ada_Version >= Ada_05 and then Comes_From_Source (N) then declare --- 2364,2370 ---- -- is the limited view of a class-wide type and the non-limited view is -- available, update the return type accordingly. ! if Ada_Version >= Ada_2005 and then Comes_From_Source (N) then declare *************** package body Sem_Ch6 is *** 2407,2447 **** end if; end if; ! -- If function, check return statements ! ! if Nkind (Body_Spec) = N_Function_Specification then ! declare ! Id : Entity_Id; ! ! begin ! if Present (Spec_Id) then ! Id := Spec_Id; ! else ! Id := Body_Id; ! end if; ! ! if Return_Present (Id) then ! Check_Returns (HSS, 'F', Missing_Ret); ! ! if Missing_Ret then ! Set_Has_Missing_Return (Id); ! end if; ! ! elsif not Is_Machine_Code_Subprogram (Id) ! and then not Body_Deleted ! then ! Error_Msg_N ("missing RETURN statement in function body", N); ! end if; ! end; ! ! -- If procedure with No_Return, check returns ! ! elsif Nkind (Body_Spec) = N_Procedure_Specification ! and then Present (Spec_Id) ! and then No_Return (Spec_Id) ! then ! Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); ! end if; -- Now we are going to check for variables that are never modified in -- the body of the procedure. But first we deal with a special case --- 2577,2583 ---- end if; end if; ! Check_Missing_Return; -- Now we are going to check for variables that are never modified in -- the body of the procedure. But first we deal with a special case *************** package body Sem_Ch6 is *** 2576,2593 **** procedure Analyze_Subprogram_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Designator : Entity_Id; Form : Node_Id; - Scop : constant Entity_Id := Current_Scope; Null_Body : Node_Id := Empty; -- Start of processing for Analyze_Subprogram_Declaration begin -- For a null procedure, capture the profile before analysis, for ! -- expansion at the freeze point and at each point of call. ! -- The body will only be used if the procedure has preconditions. ! -- In that case the body is analyzed at the freeze point. if Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) --- 2712,2729 ---- procedure Analyze_Subprogram_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Scop : constant Entity_Id := Current_Scope; Designator : Entity_Id; Form : Node_Id; Null_Body : Node_Id := Empty; -- Start of processing for Analyze_Subprogram_Declaration begin -- For a null procedure, capture the profile before analysis, for ! -- expansion at the freeze point and at each point of call. The body ! -- will only be used if the procedure has preconditions. In that case ! -- the body is analyzed at the freeze point. if Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) *************** package body Sem_Ch6 is *** 2614,2629 **** Set_Defining_Identifier (Form, Make_Defining_Identifier (Loc, Chars (Defining_Identifier (Form)))); Next (Form); end loop; if Is_Protected_Type (Current_Scope) then ! Error_Msg_N ! ("protected operation cannot be a null procedure", N); end if; end if; ! Designator := Analyze_Subprogram_Specification (Specification (N)); Generate_Definition (Designator); if Debug_Flag_C then --- 2750,2785 ---- Set_Defining_Identifier (Form, Make_Defining_Identifier (Loc, Chars (Defining_Identifier (Form)))); + + -- Resolve the types of the formals now, because the freeze point + -- may appear in a different context, e.g. an instantiation. + + if Nkind (Parameter_Type (Form)) /= N_Access_Definition then + Find_Type (Parameter_Type (Form)); + + elsif + No (Access_To_Subprogram_Definition (Parameter_Type (Form))) + then + Find_Type (Subtype_Mark (Parameter_Type (Form))); + + else + + -- the case of a null procedure with a formal that is an + -- access_to_subprogram type, and that is used as an actual + -- in an instantiation is left to the enthusiastic reader. + + null; + end if; + Next (Form); end loop; if Is_Protected_Type (Current_Scope) then ! Error_Msg_N ("protected operation cannot be a null procedure", N); end if; end if; ! Designator := Analyze_Subprogram_Specification (Specification (N)); Generate_Definition (Designator); if Debug_Flag_C then *************** package body Sem_Ch6 is *** 2681,2687 **** -- Ada 2005 (AI-251): Abstract interface primitives must be abstract -- or null. ! if Ada_Version >= Ada_05 and then Comes_From_Source (N) and then Is_Dispatching_Operation (Designator) then --- 2837,2843 ---- -- Ada 2005 (AI-251): Abstract interface primitives must be abstract -- or null. ! if Ada_Version >= Ada_2005 and then Comes_From_Source (N) and then Is_Dispatching_Operation (Designator) then *************** package body Sem_Ch6 is *** 2752,2758 **** if Nkind (Parent (N)) = N_Compilation_Unit then Set_Body_Required (Parent (N), True); ! if Ada_Version >= Ada_05 and then Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) then --- 2908,2914 ---- if Nkind (Parent (N)) = N_Compilation_Unit then Set_Body_Required (Parent (N), True); ! if Ada_Version >= Ada_2005 and then Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) then *************** package body Sem_Ch6 is *** 2772,2777 **** --- 2928,2936 ---- Write_Location (Sloc (N)); Write_Eol; end if; + + List_Inherited_Pre_Post_Aspects (Designator); + Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N)); end Analyze_Subprogram_Declaration; -------------------------------------- *************** package body Sem_Ch6 is *** 2794,2800 **** if Nkind (N) = N_Function_Specification then Set_Ekind (Designator, E_Function); Set_Mechanism (Designator, Default_Mechanism); - else Set_Ekind (Designator, E_Procedure); Set_Etype (Designator, Standard_Void_Type); --- 2953,2958 ---- *************** package body Sem_Ch6 is *** 2815,2821 **** -- Same processing for an access parameter whose designated type is -- derived from a synchronized interface. ! if Ada_Version >= Ada_05 then declare Formal : Entity_Id; Formal_Typ : Entity_Id; --- 2973,2979 ---- -- Same processing for an access parameter whose designated type is -- derived from a synchronized interface. ! if Ada_Version >= Ada_2005 then declare Formal : Entity_Id; Formal_Typ : Entity_Id; *************** package body Sem_Ch6 is *** 2865,2877 **** elsif Nkind (N) = N_Function_Specification then Push_Scope (Designator); - Analyze_Return_Type (N); - End_Scope; end if; if Nkind (N) = N_Function_Specification then if Nkind (Designator) = N_Defining_Operator_Symbol then Valid_Operator_Definition (Designator); end if; --- 3023,3038 ---- elsif Nkind (N) = N_Function_Specification then Push_Scope (Designator); Analyze_Return_Type (N); End_Scope; end if; + -- Function case + if Nkind (N) = N_Function_Specification then + + -- Deal with operator symbol case + if Nkind (Designator) = N_Defining_Operator_Symbol then Valid_Operator_Definition (Designator); end if; *************** package body Sem_Ch6 is *** 2881,2899 **** -- Ada 2005 (AI-251): If the return type is abstract, verify that -- the subprogram is abstract also. This does not apply to renaming -- declarations, where abstractness is inherited. -- In case of primitives associated with abstract interface types -- the check is applied later (see Analyze_Subprogram_Declaration). ! if Is_Abstract_Type (Etype (Designator)) ! and then not Is_Interface (Etype (Designator)) ! and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration ! and then Nkind (Parent (N)) /= ! N_Abstract_Subprogram_Declaration ! and then ! (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration then ! Error_Msg_N ! ("function that returns abstract type must be abstract", N); end if; end if; --- 3042,3073 ---- -- Ada 2005 (AI-251): If the return type is abstract, verify that -- the subprogram is abstract also. This does not apply to renaming -- declarations, where abstractness is inherited. + -- In case of primitives associated with abstract interface types -- the check is applied later (see Analyze_Subprogram_Declaration). ! if not Nkind_In (Parent (N), N_Subprogram_Renaming_Declaration, ! N_Abstract_Subprogram_Declaration, ! N_Formal_Abstract_Subprogram_Declaration) then ! if Is_Abstract_Type (Etype (Designator)) ! and then not Is_Interface (Etype (Designator)) ! then ! Error_Msg_N ! ("function that returns abstract type must be abstract", N); ! ! -- Ada 2012 (AI-0073): Extend this test to subprograms with an ! -- access result whose designated type is abstract. ! ! elsif Nkind (Result_Definition (N)) = N_Access_Definition ! and then ! not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) ! and then Is_Abstract_Type (Designated_Type (Etype (Designator))) ! and then Ada_Version >= Ada_2012 ! then ! Error_Msg_N ("function whose access result designates " ! & "abstract type must be abstract", N); ! end if; end if; end if; *************** package body Sem_Ch6 is *** 3087,3092 **** --- 3261,3275 ---- and then Has_Excluded_Statement (Statements (S)) then return True; + + elsif Nkind (S) = N_Extended_Return_Statement then + if Has_Excluded_Statement + (Statements (Handled_Statement_Sequence (S))) + or else Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + then + return True; + end if; end if; Next (S); *************** package body Sem_Ch6 is *** 3109,3114 **** --- 3292,3298 ---- or else Is_Child_Unit (S) then return False; + elsif Ekind (S) = E_Package and then Has_Forward_Instantiation (S) then *************** package body Sem_Ch6 is *** 3153,3164 **** --- 3337,3369 ---- return Abandon; end if; + -- A return statement within an extended return is a noop + -- after inlining. + + elsif No (Expression (N)) + and then Nkind (Parent (Parent (N))) = + N_Extended_Return_Statement + then + return OK; + else -- Expression has wrong form return Abandon; end if; + -- We can only inline a build-in-place function if + -- it has a single extended return. + + elsif Nkind (N) = N_Extended_Return_Statement then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + else + return Abandon; + end if; + else return OK; end if; *************** package body Sem_Ch6 is *** 3169,3179 **** -- Start of processing for Has_Single_Return begin ! return Check_All_Returns (N) = OK ! and then Present (Declarations (N)) ! and then Present (First (Declarations (N))) ! and then Chars (Expression (Return_Statement)) = ! Chars (Defining_Identifier (First (Declarations (N)))); end Has_Single_Return; -------------------- --- 3374,3391 ---- -- Start of processing for Has_Single_Return begin ! if Check_All_Returns (N) /= OK then ! return False; ! ! elsif Nkind (Return_Statement) = N_Extended_Return_Statement then ! return True; ! ! else ! return Present (Declarations (N)) ! and then Present (First (Declarations (N))) ! and then Chars (Expression (Return_Statement)) = ! Chars (Defining_Identifier (First (Declarations (N)))); ! end if; end Has_Single_Return; -------------------- *************** package body Sem_Ch6 is *** 3390,3399 **** procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is begin ! -- Do not emit warning if this is a predefined unit which is not ! -- the main unit. With validity checks enabled, some predefined ! -- subprograms may contain nested subprograms and become ineligible ! -- for inlining. if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) and then not In_Extended_Main_Source_Unit (Subp) --- 3602,3610 ---- procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is begin ! -- Do not emit warning if this is a predefined unit which is not the ! -- main unit. With validity checks enabled, some predefined subprograms ! -- may contain nested subprograms and become ineligible for inlining. if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) and then not In_Extended_Main_Source_Unit (Subp) *************** package body Sem_Ch6 is *** 3462,3482 **** when Mode_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then ! Error_Msg_N -- CODEFIX??? ("not mode conformant with operation inherited#!", Enode); else ! Error_Msg_N -- CODEFIX??? ("not mode conformant with declaration#!", Enode); end if; when Subtype_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then ! Error_Msg_N -- CODEFIX??? ("not subtype conformant with operation inherited#!", Enode); else ! Error_Msg_N -- CODEFIX??? ("not subtype conformant with declaration#!", Enode); end if; --- 3673,3693 ---- when Mode_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then ! Error_Msg_N ("not mode conformant with operation inherited#!", Enode); else ! Error_Msg_N ("not mode conformant with declaration#!", Enode); end if; when Subtype_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then ! Error_Msg_N ("not subtype conformant with operation inherited#!", Enode); else ! Error_Msg_N ("not subtype conformant with declaration#!", Enode); end if; *************** package body Sem_Ch6 is *** 3545,3551 **** -- Ada 2005 (AI-231): In case of anonymous access types check the -- null-exclusion and access-to-constant attributes match. ! if Ada_Version >= Ada_05 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type and then (Can_Never_Be_Null (Old_Type) --- 3756,3762 ---- -- Ada 2005 (AI-231): In case of anonymous access types check the -- null-exclusion and access-to-constant attributes match. ! if Ada_Version >= Ada_2005 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type and then (Can_Never_Be_Null (Old_Type) *************** package body Sem_Ch6 is *** 3585,3591 **** Error_Msg_Name_1 := Chars (New_Id); Error_Msg_Name_2 := Name_Ada + Convention_Id'Pos (Convention (New_Id)); - Conformance_Error ("\prior declaration for% has convention %!"); else --- 3796,3801 ---- *************** package body Sem_Ch6 is *** 3645,3650 **** --- 3855,3883 ---- Set_Error_Posted (New_Formal); return; end if; + + -- Null exclusion must match + + if Null_Exclusion_Present (Parent (Old_Formal)) + /= + Null_Exclusion_Present (Parent (New_Formal)) + then + -- Only give error if both come from source. This should be + -- investigated some time, since it should not be needed ??? + + if Comes_From_Source (Old_Formal) + and then + Comes_From_Source (New_Formal) + then + Conformance_Error + ("\null exclusion for & does not match", New_Formal); + + -- Mark error posted on the new formal to avoid duplicated + -- complaint about types not matching. + + Set_Error_Posted (New_Formal); + end if; + end if; end if; -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This *************** package body Sem_Ch6 is *** 3667,3673 **** New_Formal_Base := Get_Instance_Of (New_Formal_Base); end if; ! Access_Types_Match := Ada_Version >= Ada_05 -- Ensure that this rule is only applied when New_Id is a -- renaming of Old_Id. --- 3900,3906 ---- New_Formal_Base := Get_Instance_Of (New_Formal_Base); end if; ! Access_Types_Match := Ada_Version >= Ada_2005 -- Ensure that this rule is only applied when New_Id is a -- renaming of Old_Id. *************** package body Sem_Ch6 is *** 3777,3783 **** -- the null-exclusion and access-to-constant attributes must -- match. ! if Ada_Version >= Ada_05 and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type and then --- 4010,4016 ---- -- the null-exclusion and access-to-constant attributes must -- match. ! if Ada_Version >= Ada_2005 and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type and then *************** package body Sem_Ch6 is *** 3786,3791 **** --- 4019,4029 ---- or else Is_Access_Constant (Etype (Old_Formal)) /= Is_Access_Constant (Etype (New_Formal))) + + -- Do not complain if error already posted on New_Formal. This + -- avoids some redundant error messages. + + and then not Error_Posted (New_Formal) then -- It is allowed to omit the null-exclusion in case of stream -- attribute subprograms. We recognize stream subprograms *************** package body Sem_Ch6 is *** 3956,3981 **** Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); Error_Msg_Sloc := Sloc (Op); ! if Comes_From_Source (Op) then ! if not Is_Overriding_Operation (Op) then Error_Msg_N ("\\primitive % defined #", Typ); else ! Error_Msg_N ("\\overriding operation % with " & ! "convention % defined #", Typ); end if; else pragma Assert (Present (Alias (Op))); Error_Msg_Sloc := Sloc (Alias (Op)); ! Error_Msg_N ("\\inherited operation % with " & ! "convention % defined #", Typ); end if; Error_Msg_Name_1 := Chars (Op); Error_Msg_Name_2 := Get_Convention_Name (Convention (Iface_Prim)); Error_Msg_Sloc := Sloc (Iface_Prim); ! Error_Msg_N ("\\overridden operation % with " & ! "convention % defined #", Typ); -- Avoid cascading errors --- 4194,4222 ---- Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); Error_Msg_Sloc := Sloc (Op); ! if Comes_From_Source (Op) or else No (Alias (Op)) then ! if not Present (Overridden_Operation (Op)) then Error_Msg_N ("\\primitive % defined #", Typ); else ! Error_Msg_N ! ("\\overriding operation % with " & ! "convention % defined #", Typ); end if; else pragma Assert (Present (Alias (Op))); Error_Msg_Sloc := Sloc (Alias (Op)); ! Error_Msg_N ! ("\\inherited operation % with " & ! "convention % defined #", Typ); end if; Error_Msg_Name_1 := Chars (Op); Error_Msg_Name_2 := Get_Convention_Name (Convention (Iface_Prim)); Error_Msg_Sloc := Sloc (Iface_Prim); ! Error_Msg_N ! ("\\overridden operation % with " & ! "convention % defined #", Typ); -- Avoid cascading errors *************** package body Sem_Ch6 is *** 4060,4088 **** -- Start of processing for Check_Delayed_Subprogram begin ! -- Never need to freeze abstract subprogram ! ! if Ekind (Designator) /= E_Subprogram_Type ! and then Is_Abstract_Subprogram (Designator) ! then ! null; ! else ! -- Need delayed freeze if return type itself needs a delayed ! -- freeze and is not yet frozen. ! Possible_Freeze (Etype (Designator)); ! Possible_Freeze (Base_Type (Etype (Designator))); -- needed ??? ! -- Need delayed freeze if any of the formal types themselves need ! -- a delayed freeze and are not yet frozen. ! F := First_Formal (Designator); ! while Present (F) loop ! Possible_Freeze (Etype (F)); ! Possible_Freeze (Base_Type (Etype (F))); -- needed ??? ! Next_Formal (F); ! end loop; ! end if; -- Mark functions that return by reference. Note that it cannot be -- done for delayed_freeze subprograms because the underlying --- 4301,4321 ---- -- Start of processing for Check_Delayed_Subprogram begin ! -- All subprograms, including abstract subprograms, may need a freeze ! -- node if some formal type or the return type needs one. ! Possible_Freeze (Etype (Designator)); ! Possible_Freeze (Base_Type (Etype (Designator))); -- needed ??? ! -- Need delayed freeze if any of the formal types themselves need ! -- a delayed freeze and are not yet frozen. ! F := First_Formal (Designator); ! while Present (F) loop ! Possible_Freeze (Etype (F)); ! Possible_Freeze (Base_Type (Etype (F))); -- needed ??? ! Next_Formal (F); ! end loop; -- Mark functions that return by reference. Note that it cannot be -- done for delayed_freeze subprograms because the underlying *************** package body Sem_Ch6 is *** 4096,4102 **** Utyp : constant Entity_Id := Underlying_Type (Typ); begin ! if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then --- 4329,4335 ---- Utyp : constant Entity_Id := Underlying_Type (Typ); begin ! if Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then *************** package body Sem_Ch6 is *** 4393,4399 **** then Error_Msg_Node_2 := Alias (Overridden_Subp); Error_Msg_Sloc := Sloc (Error_Msg_Node_2); ! Error_Msg_NE ("& does not match corresponding formal of&#", Form1, Form1); exit; end if; --- 4626,4633 ---- then Error_Msg_Node_2 := Alias (Overridden_Subp); Error_Msg_Sloc := Sloc (Error_Msg_Node_2); ! Error_Msg_NE ! ("& does not match corresponding formal of&#", Form1, Form1); exit; end if; *************** package body Sem_Ch6 is *** 4404,4411 **** end; end if; if Present (Overridden_Subp) ! and then not Is_Hidden (Overridden_Subp) then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); --- 4638,4663 ---- end; end if; + -- If there is an overridden subprogram, then check that there is no + -- "not overriding" indicator, and mark the subprogram as overriding. + -- This is not done if the overridden subprogram is marked as hidden, + -- which can occur for the case of inherited controlled operations + -- (see Derive_Subprogram), unless the inherited subprogram's parent + -- subprogram is not itself hidden. (Note: This condition could probably + -- be simplified, leaving out the testing for the specific controlled + -- cases, but it seems safer and clearer this way, and echoes similar + -- special-case tests of this kind in other places.) + if Present (Overridden_Subp) ! and then (not Is_Hidden (Overridden_Subp) ! or else ! ((Chars (Overridden_Subp) = Name_Initialize ! or else ! Chars (Overridden_Subp) = Name_Adjust ! or else ! Chars (Overridden_Subp) = Name_Finalize) ! and then Present (Alias (Overridden_Subp)) ! and then not Is_Hidden (Alias (Overridden_Subp)))) then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); *************** package body Sem_Ch6 is *** 4419,4425 **** end if; elsif Is_Subprogram (Subp) then ! Set_Is_Overriding_Operation (Subp); end if; -- If primitive flag is set or this is a protected operation, then --- 4671,4695 ---- end if; elsif Is_Subprogram (Subp) then ! if No (Overridden_Operation (Subp)) then ! ! -- For entities generated by Derive_Subprograms the overridden ! -- operation is the inherited primitive (which is available ! -- through the attribute alias) ! ! if (Is_Dispatching_Operation (Subp) ! or else Is_Dispatching_Operation (Overridden_Subp)) ! and then not Comes_From_Source (Overridden_Subp) ! and then Find_Dispatching_Type (Overridden_Subp) = ! Find_Dispatching_Type (Subp) ! and then Present (Alias (Overridden_Subp)) ! and then Comes_From_Source (Alias (Overridden_Subp)) ! then ! Set_Overridden_Operation (Subp, Alias (Overridden_Subp)); ! else ! Set_Overridden_Operation (Subp, Overridden_Subp); ! end if; ! end if; end if; -- If primitive flag is set or this is a protected operation, then *************** package body Sem_Ch6 is *** 4437,4443 **** -- If Subp is an operator, it may override a predefined operation, if -- it is defined in the same scope as the type to which it applies. ! -- In that case overridden_subp is empty because of our implicit -- representation for predefined operators. We have to check whether the -- signature of Subp matches that of a predefined operator. Note that -- first argument provides the name of the operator, and the second --- 4707,4713 ---- -- If Subp is an operator, it may override a predefined operation, if -- it is defined in the same scope as the type to which it applies. ! -- In that case Overridden_Subp is empty because of our implicit -- representation for predefined operators. We have to check whether the -- signature of Subp matches that of a predefined operator. Note that -- first argument provides the name of the operator, and the second *************** package body Sem_Ch6 is *** 4449,4455 **** elsif Nkind (Subp) = N_Defining_Operator_Symbol then declare Typ : constant Entity_Id := ! Base_Type (Etype (First_Formal (Subp))); Can_Override : constant Boolean := Operator_Matches_Spec (Subp, Subp) --- 4719,4725 ---- elsif Nkind (Subp) = N_Defining_Operator_Symbol then declare Typ : constant Entity_Id := ! Base_Type (Etype (First_Formal (Subp))); Can_Override : constant Boolean := Operator_Matches_Spec (Subp, Subp) *************** package body Sem_Ch6 is *** 4471,4485 **** elsif Can_Override then Error_Msg_NE ! ("subprogram & overrides predefined operator ", ! Spec, Subp); end if; elsif Must_Override (Spec) then ! if Is_Overriding_Operation (Subp) then ! Set_Is_Overriding_Operation (Subp); ! ! elsif not Can_Override then Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); end if; --- 4741,4753 ---- elsif Can_Override then Error_Msg_NE ! ("subprogram& overrides predefined operator ", Spec, Subp); end if; elsif Must_Override (Spec) then ! if No (Overridden_Operation (Subp)) ! and then not Can_Override ! then Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); end if; *************** package body Sem_Ch6 is *** 4490,4497 **** not Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) then - Set_Is_Overriding_Operation (Subp); - -- If style checks are enabled, indicate that the indicator is -- missing. However, at the point of declaration, the type of -- which this is a primitive operation may be private, in which --- 4758,4763 ---- *************** package body Sem_Ch6 is *** 5227,5233 **** -- In Ada2005, access constant indicators must match for -- subtype conformance. ! if Ada_Version >= Ada_05 and then Ctype >= Subtype_Conformant and then Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2) --- 5493,5499 ---- -- In Ada2005, access constant indicators must match for -- subtype conformance. ! if Ada_Version >= Ada_2005 and then Ctype >= Subtype_Conformant and then Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2) *************** package body Sem_Ch6 is *** 5236,5242 **** end if; Desig_1 := Find_Designated_Type (Type_1); - Desig_2 := Find_Designated_Type (Type_2); -- If the context is an instance association for a formal --- 5502,5507 ---- *************** package body Sem_Ch6 is *** 5257,5263 **** -- of an incomplete Class_Wide_Type are illegal. if Is_Class_Wide_Type (Desig_1) ! and then Is_Class_Wide_Type (Desig_2) then return Conforming_Types --- 5522,5529 ---- -- of an incomplete Class_Wide_Type are illegal. if Is_Class_Wide_Type (Desig_1) ! and then ! Is_Class_Wide_Type (Desig_2) then return Conforming_Types *************** package body Sem_Ch6 is *** 5265,5271 **** Etype (Base_Type (Desig_2)), Ctype); elsif Are_Anonymous_Access_To_Subprogram_Types then ! if Ada_Version < Ada_05 then return Ctype = Type_Conformant or else Subtypes_Statically_Match (Desig_1, Desig_2); --- 5531,5537 ---- Etype (Base_Type (Desig_2)), Ctype); elsif Are_Anonymous_Access_To_Subprogram_Types then ! if Ada_Version < Ada_2005 then return Ctype = Type_Conformant or else Subtypes_Statically_Match (Desig_1, Desig_2); *************** package body Sem_Ch6 is *** 5329,5334 **** --- 5595,5608 ---- -- and also returned as the result. These formals are always of mode IN. -- The new formal has the type Typ, is declared in Scope, and its name -- is given by a concatenation of the name of Assoc_Entity and Suffix. + -- The following suffixes are currently used. They should not be changed + -- without coordinating with CodePeer, which makes use of these to + -- provide better messages. + + -- O denotes the Constrained bit. + -- L denotes the accessibility level. + -- BIP_xxx denotes an extra formal for a build-in-place function. See + -- the full list in exp_ch6.BIP_Formal_Kind. ---------------------- -- Add_Extra_Formal -- *************** package body Sem_Ch6 is *** 5450,5461 **** Formal_Type := Underlying_Type (Formal_Type); end if; if Has_Discriminants (Formal_Type) and then not Is_Constrained (Formal_Type) and then not Is_Indefinite_Subtype (Formal_Type) then Set_Extra_Constrained ! (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "F")); end if; end if; --- 5724,5749 ---- Formal_Type := Underlying_Type (Formal_Type); end if; + -- Suppress the extra formal if formal's subtype is constrained or + -- indefinite, or we're compiling for Ada 2012 and the underlying + -- type is tagged and limited. In Ada 2012, a limited tagged type + -- can have defaulted discriminants, but 'Constrained is required + -- to return True, so the formal is never needed (see AI05-0214). + -- Note that this ensures consistency of calling sequences for + -- dispatching operations when some types in a class have defaults + -- on discriminants and others do not (and requiring the extra + -- formal would introduce distributed overhead). + if Has_Discriminants (Formal_Type) and then not Is_Constrained (Formal_Type) and then not Is_Indefinite_Subtype (Formal_Type) + and then (Ada_Version < Ada_2012 + or else + not (Is_Tagged_Type (Underlying_Type (Formal_Type)) + and then Is_Limited_Type (Formal_Type))) then Set_Extra_Constrained ! (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); end if; end if; *************** package body Sem_Ch6 is *** 5488,5494 **** or else Present (Extra_Accessibility (P_Formal))) then Set_Extra_Accessibility ! (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F")); end if; -- This label is required when skipping extra formal generation for --- 5776,5782 ---- or else Present (Extra_Accessibility (P_Formal))) then Set_Extra_Accessibility ! (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L")); end if; -- This label is required when skipping extra formal generation for *************** package body Sem_Ch6 is *** 5508,5514 **** -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. ! if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function (E) then declare Result_Subt : constant Entity_Id := Etype (E); --- 5796,5802 ---- -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. ! if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then declare Result_Subt : constant Entity_Id := Etype (E); *************** package body Sem_Ch6 is *** 5517,5531 **** begin -- In the case of functions with unconstrained result subtypes, ! -- add a 3-state formal indicating whether the return object is ! -- allocated by the caller (0), or should be allocated by the ! -- callee on the secondary stack (1) or in the global heap (2). ! -- For the moment we just use Natural for the type of this formal. ! -- Note that this formal isn't usually needed in the case where ! -- the result subtype is constrained, but it is needed when the ! -- function has a tagged result, because generally such functions ! -- can be called in a dispatching context and such calls must be ! -- handled like calls to a class-wide function. if not Is_Constrained (Underlying_Type (Result_Subt)) or else Is_Tagged_Type (Underlying_Type (Result_Subt)) --- 5805,5820 ---- begin -- In the case of functions with unconstrained result subtypes, ! -- add a 4-state formal indicating whether the return object is ! -- allocated by the caller (1), or should be allocated by the ! -- callee on the secondary stack (2), in the global heap (3), or ! -- in a user-defined storage pool (4). For the moment we just use ! -- Natural for the type of this formal. Note that this formal ! -- isn't usually needed in the case where the result subtype is ! -- constrained, but it is needed when the function has a tagged ! -- result, because generally such functions can be called in a ! -- dispatching context and such calls must be handled like calls ! -- to a class-wide function. if not Is_Constrained (Underlying_Type (Result_Subt)) or else Is_Tagged_Type (Underlying_Type (Result_Subt)) *************** package body Sem_Ch6 is *** 5536,5554 **** E, BIP_Formal_Suffix (BIP_Alloc_Form)); end if; ! -- In the case of functions whose result type has controlled ! -- parts, we have an extra formal of type ! -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That ! -- is, we are passing a pointer to a finalization list (which is ! -- itself a pointer). This extra formal is then passed along to ! -- Move_Final_List in case of successful completion of a return ! -- statement. We cannot pass an 'in out' parameter, because we ! -- need to update the finalization list during an abort-deferred ! -- region, rather than using copy-back after the function ! -- returns. This is true even if we are able to get away with ! -- having 'in out' parameters, which are normally illegal for ! -- functions. This formal is also needed when the function has ! -- a tagged result. if Needs_BIP_Final_List (E) then Discard := --- 5825,5842 ---- E, BIP_Formal_Suffix (BIP_Alloc_Form)); end if; ! -- For functions whose result type has controlled parts, we have ! -- an extra formal of type System.Finalization_Implementation. ! -- Finalizable_Ptr_Ptr. That is, we are passing a pointer to a ! -- finalization list (which is itself a pointer). This extra ! -- formal is then passed along to Move_Final_List in case of ! -- successful completion of a return statement. We cannot pass an ! -- 'in out' parameter, because we need to update the finalization ! -- list during an abort-deferred region, rather than using ! -- copy-back after the function returns. This is true even if we ! -- are able to get away with having 'in out' parameters, which are ! -- normally illegal for functions. This formal is also needed when ! -- the function has a tagged result. if Needs_BIP_Final_List (E) then Discard := *************** package body Sem_Ch6 is *** 5667,5687 **** E := Homonym (E); exit when No (E); ! -- Warn unless genuine overloading if (not Is_Overloadable (E) or else Subtype_Conformant (E, S)) and then (Is_Immediately_Visible (E) or else Is_Potentially_Use_Visible (S)) then ! Error_Msg_Sloc := Sloc (E); ! Error_Msg_N ("declaration of & hides one#?", S); end if; end loop; end if; end Enter_Overloaded_Entity; ----------------------------- -- Find_Corresponding_Spec -- ----------------------------- --- 5955,6062 ---- E := Homonym (E); exit when No (E); ! -- Warn unless genuine overloading. Do not emit warning on ! -- hiding predefined operators in Standard (these are either an ! -- (artifact of our implicit declarations, or simple noise) but ! -- keep warning on a operator defined on a local subtype, because ! -- of the real danger that different operators may be applied in ! -- various parts of the program. if (not Is_Overloadable (E) or else Subtype_Conformant (E, S)) and then (Is_Immediately_Visible (E) or else Is_Potentially_Use_Visible (S)) then ! if Scope (E) /= Standard_Standard then ! Error_Msg_Sloc := Sloc (E); ! Error_Msg_N ("declaration of & hides one#?", S); ! ! elsif Nkind (S) = N_Defining_Operator_Symbol ! and then ! Scope ( ! Base_Type (Etype (First_Formal (S)))) /= Scope (S) ! then ! Error_Msg_N ! ("declaration of & hides predefined operator?", S); ! end if; end if; end loop; end if; end Enter_Overloaded_Entity; ----------------------------- + -- Check_Untagged_Equality -- + ----------------------------- + + procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is + Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); + Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); + Obj_Decl : Node_Id; + + begin + if Nkind (Decl) = N_Subprogram_Declaration + and then Is_Record_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + -- If the type is not declared in a package, or if we are in the + -- body of the package or in some other scope, the new operation is + -- not primitive, and therefore legal, though suspicious. If the + -- type is a generic actual (sub)type, the operation is not primitive + -- either because the base type is declared elsewhere. + + if Is_Frozen (Typ) then + if Ekind (Scope (Typ)) /= E_Package + or else Scope (Typ) /= Current_Scope + then + null; + + elsif Is_Generic_Actual_Type (Typ) then + null; + + elsif In_Package_Body (Scope (Typ)) then + Error_Msg_NE + ("equality operator must be declared " + & "before type& is frozen", Eq_Op, Typ); + Error_Msg_N + ("\move declaration to package spec", Eq_Op); + + else + Error_Msg_NE + ("equality operator must be declared " + & "before type& is frozen", Eq_Op, Typ); + + Obj_Decl := Next (Parent (Typ)); + while Present (Obj_Decl) + and then Obj_Decl /= Decl + loop + if Nkind (Obj_Decl) = N_Object_Declaration + and then Etype (Defining_Identifier (Obj_Decl)) = Typ + then + Error_Msg_NE ("type& is frozen by declaration?", + Obj_Decl, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this " + & "point ('R'M 4.5.2 (9.8)) (Ada 2012))?", Obj_Decl); + exit; + end if; + + Next (Obj_Decl); + end loop; + end if; + + elsif not In_Same_List (Parent (Typ), Decl) + and then not Is_Limited_Type (Typ) + then + + -- This makes it illegal to have a primitive equality declared in + -- the private part if the type is visible. + + Error_Msg_N ("equality operator appears too late", Eq_Op); + end if; + end if; + end Check_Untagged_Equality; + + ----------------------------- -- Find_Corresponding_Spec -- ----------------------------- *************** package body Sem_Ch6 is *** 5750,5760 **** -- that was created for an operation inherited by a null -- extension, it may be overridden by a body without a previous -- spec (one more reason why these should be shunned). In that ! -- case remove the generated body, because the current one is ! -- the explicit overriding. elsif Ekind (E) = E_Function ! and then Ada_Version >= Ada_05 and then not Comes_From_Source (E) and then Has_Controlling_Result (E) and then Is_Null_Extension (Etype (E)) --- 6125,6135 ---- -- that was created for an operation inherited by a null -- extension, it may be overridden by a body without a previous -- spec (one more reason why these should be shunned). In that ! -- case remove the generated body if present, because the ! -- current one is the explicit overriding. elsif Ekind (E) = E_Function ! and then Ada_Version >= Ada_2005 and then not Comes_From_Source (E) and then Has_Controlling_Result (E) and then Is_Null_Extension (Etype (E)) *************** package body Sem_Ch6 is *** 5762,5776 **** then Set_Has_Completion (E, False); ! if Expander_Active then Remove (Unit_Declaration_Node ! (Corresponding_Body (Unit_Declaration_Node (E)))); return E; ! -- If expansion is disabled, the wrapper function has not ! -- been generated, and this is the standard case of a late ! -- body overriding an inherited operation. else return Empty; --- 6137,6156 ---- then Set_Has_Completion (E, False); ! if Expander_Active ! and then Nkind (Parent (E)) = N_Function_Specification ! then Remove (Unit_Declaration_Node ! (Corresponding_Body (Unit_Declaration_Node (E)))); ! return E; ! -- If expansion is disabled, or if the wrapper function has ! -- not been generated yet, this a late body overriding an ! -- inherited operation, or it is an overriding by some other ! -- declaration before the controlling result is frozen. In ! -- either case this is a declaration of a new entity. else return Empty; *************** package body Sem_Ch6 is *** 6001,6008 **** when N_Aggregate => return FCL (Expressions (E1), Expressions (E2)) ! and then FCL (Component_Associations (E1), ! Component_Associations (E2)); when N_Allocator => if Nkind (Expression (E1)) = N_Qualified_Expression --- 6381,6389 ---- when N_Aggregate => return FCL (Expressions (E1), Expressions (E2)) ! and then ! FCL (Component_Associations (E1), ! Component_Associations (E2)); when N_Allocator => if Nkind (Expression (E1)) = N_Qualified_Expression *************** package body Sem_Ch6 is *** 6072,6077 **** --- 6453,6490 ---- and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + when N_Case_Expression => + declare + Alt1 : Node_Id; + Alt2 : Node_Id; + + begin + if not FCE (Expression (E1), Expression (E2)) then + return False; + + else + Alt1 := First (Alternatives (E1)); + Alt2 := First (Alternatives (E2)); + loop + if Present (Alt1) /= Present (Alt2) then + return False; + elsif No (Alt1) then + return True; + end if; + + if not FCE (Expression (Alt1), Expression (Alt2)) + or else not FCL (Discrete_Choices (Alt1), + Discrete_Choices (Alt2)) + then + return False; + end if; + + Next (Alt1); + Next (Alt2); + end loop; + end if; + end; + when N_Character_Literal => return Char_Literal_Value (E1) = Char_Literal_Value (E2); *************** package body Sem_Ch6 is *** 6079,6085 **** when N_Component_Association => return FCL (Choices (E1), Choices (E2)) ! and then FCE (Expression (E1), Expression (E2)); when N_Conditional_Expression => return --- 6492,6499 ---- when N_Component_Association => return FCL (Choices (E1), Choices (E2)) ! and then ! FCE (Expression (E1), Expression (E2)); when N_Conditional_Expression => return *************** package body Sem_Ch6 is *** 6100,6112 **** when N_Function_Call => return FCE (Name (E1), Name (E2)) ! and then FCL (Parameter_Associations (E1), ! Parameter_Associations (E2)); when N_Indexed_Component => return FCE (Prefix (E1), Prefix (E2)) ! and then FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => return (Intval (E1) = Intval (E2)); --- 6514,6528 ---- when N_Function_Call => return FCE (Name (E1), Name (E2)) ! and then ! FCL (Parameter_Associations (E1), ! Parameter_Associations (E2)); when N_Indexed_Component => return FCE (Prefix (E1), Prefix (E2)) ! and then ! FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => return (Intval (E1) = Intval (E2)); *************** package body Sem_Ch6 is *** 6130,6141 **** when N_Qualified_Expression => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) ! and then FCE (Expression (E1), Expression (E2)); when N_Range => return FCE (Low_Bound (E1), Low_Bound (E2)) ! and then FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => return (Realval (E1) = Realval (E2)); --- 6546,6559 ---- when N_Qualified_Expression => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) ! and then ! FCE (Expression (E1), Expression (E2)); when N_Range => return FCE (Low_Bound (E1), Low_Bound (E2)) ! and then ! FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => return (Realval (E1) = Realval (E2)); *************** package body Sem_Ch6 is *** 6143,6154 **** when N_Selected_Component => return FCE (Prefix (E1), Prefix (E2)) ! and then FCE (Selector_Name (E1), Selector_Name (E2)); when N_Slice => return FCE (Prefix (E1), Prefix (E2)) ! and then FCE (Discrete_Range (E1), Discrete_Range (E2)); when N_String_Literal => declare --- 6561,6574 ---- when N_Selected_Component => return FCE (Prefix (E1), Prefix (E2)) ! and then ! FCE (Selector_Name (E1), Selector_Name (E2)); when N_Slice => return FCE (Prefix (E1), Prefix (E2)) ! and then ! FCE (Discrete_Range (E1), Discrete_Range (E2)); when N_String_Literal => declare *************** package body Sem_Ch6 is *** 6177,6193 **** when N_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) ! and then FCE (Expression (E1), Expression (E2)); when N_Unary_Op => return Entity (E1) = Entity (E2) ! and then FCE (Right_Opnd (E1), Right_Opnd (E2)); when N_Unchecked_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) ! and then FCE (Expression (E1), Expression (E2)); -- All other node types cannot appear in this context. Strictly -- we should raise a fatal internal error. Instead we just ignore --- 6597,6616 ---- when N_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) ! and then ! FCE (Expression (E1), Expression (E2)); when N_Unary_Op => return Entity (E1) = Entity (E2) ! and then ! FCE (Right_Opnd (E1), Right_Opnd (E2)); when N_Unchecked_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) ! and then ! FCE (Expression (E1), Expression (E2)); -- All other node types cannot appear in this context. Strictly -- we should raise a fatal internal error. Instead we just ignore *************** package body Sem_Ch6 is *** 6343,6350 **** or else Etype (Prim) = Etype (Iface_Prim) or else not Has_Controlling_Result (Prim) then ! return Type_Conformant (Prim, Iface_Prim, ! Skip_Controlling_Formals => True); -- Case of a function returning an interface, or an access to one. -- Check that the return types correspond. --- 6766,6773 ---- or else Etype (Prim) = Etype (Iface_Prim) or else not Has_Controlling_Result (Prim) then ! return Type_Conformant ! (Iface_Prim, Prim, Skip_Controlling_Formals => True); -- Case of a function returning an interface, or an access to one. -- Check that the return types correspond. *************** package body Sem_Ch6 is *** 6481,6487 **** -- instance of) a generic type. Formal := First_Formal (Prev_E); - while Present (Formal) loop F_Typ := Base_Type (Etype (Formal)); --- 6904,6909 ---- *************** package body Sem_Ch6 is *** 6575,6580 **** --- 6997,7039 ---- end if; end Is_Non_Overriding_Operation; + ------------------------------------- + -- List_Inherited_Pre_Post_Aspects -- + ------------------------------------- + + procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is + begin + if Opt.List_Inherited_Aspects + and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E)) + then + declare + Inherited : constant Subprogram_List := + Inherited_Subprograms (E); + P : Node_Id; + + begin + for J in Inherited'Range loop + P := Spec_PPC_List (Inherited (J)); + while Present (P) loop + Error_Msg_Sloc := Sloc (P); + + if Class_Present (P) and then not Split_PPC (P) then + if Pragma_Name (P) = Name_Precondition then + Error_Msg_N + ("?info: & inherits `Pre''Class` aspect from #", E); + else + Error_Msg_N + ("?info: & inherits `Post''Class` aspect from #", E); + end if; + end if; + + P := Next_Pragma (P); + end loop; + end loop; + end; + end if; + end List_Inherited_Pre_Post_Aspects; + ------------------------------ -- Make_Inequality_Operator -- ------------------------------ *************** package body Sem_Ch6 is *** 6792,6811 **** and then (not Is_Overriding or else not Is_Abstract_Subprogram (E)) then ! Error_Msg_N ("abstract subprograms must be visible " ! & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function - and then Is_Tagged_Type (T) - and then T = Base_Type (Etype (S)) and then not Is_Overriding then ! Error_Msg_N ! ("private function with tagged result must" ! & " override visible-part function", S); ! Error_Msg_N ! ("\move subprogram to the visible part" ! & " (RM 3.9.3(10))", S); end if; end if; end Check_Private_Overriding; --- 7251,7289 ---- and then (not Is_Overriding or else not Is_Abstract_Subprogram (E)) then ! Error_Msg_N ! ("abstract subprograms must be visible " ! & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function and then not Is_Overriding then ! if Is_Tagged_Type (T) ! and then T = Base_Type (Etype (S)) ! then ! Error_Msg_N ! ("private function with tagged result must" ! & " override visible-part function", S); ! Error_Msg_N ! ("\move subprogram to the visible part" ! & " (RM 3.9.3(10))", S); ! ! -- AI05-0073: extend this test to the case of a function ! -- with a controlling access result. ! ! elsif Ekind (Etype (S)) = E_Anonymous_Access_Type ! and then Is_Tagged_Type (Designated_Type (Etype (S))) ! and then ! not Is_Class_Wide_Type (Designated_Type (Etype (S))) ! and then Ada_Version >= Ada_2012 ! then ! Error_Msg_N ! ("private function with controlling access result " ! & "must override visible-part function", S); ! Error_Msg_N ! ("\move subprogram to the visible part" ! & " (RM 3.9.3(10))", S); ! end if; end if; end if; end Check_Private_Overriding; *************** package body Sem_Ch6 is *** 7099,7111 **** In_Scope := True; -- The enclosing scope is not a synchronized type and the subprogram ! -- has no formals elsif No (First_Formal (Def_Id)) then return; -- The subprogram has formals and hence it may be a primitive of a ! -- concurrent type else Typ := Etype (First_Formal (Def_Id)); --- 7577,7589 ---- In_Scope := True; -- The enclosing scope is not a synchronized type and the subprogram ! -- has no formals. elsif No (First_Formal (Def_Id)) then return; -- The subprogram has formals and hence it may be a primitive of a ! -- concurrent type. else Typ := Etype (First_Formal (Def_Id)); *************** package body Sem_Ch6 is *** 7154,7160 **** Subp : Entity_Id := Empty; begin ! -- Traverse the homonym chain, looking at a potentially -- overridden subprogram that belongs to an implemented -- interface. --- 7632,7638 ---- Subp : Entity_Id := Empty; begin ! -- Traverse the homonym chain, looking for a potentially -- overridden subprogram that belongs to an implemented -- interface. *************** package body Sem_Ch6 is *** 7172,7178 **** null; -- Entries and procedures can override abstract or null ! -- interface procedures elsif (Ekind (Def_Id) = E_Procedure or else Ekind (Def_Id) = E_Entry) --- 7650,7656 ---- null; -- Entries and procedures can override abstract or null ! -- interface procedures. elsif (Ekind (Def_Id) = E_Procedure or else Ekind (Def_Id) = E_Entry) *************** package body Sem_Ch6 is *** 7233,7255 **** Hom := Homonym (Hom); end loop; ! -- After examining all candidates for overriding, we are ! -- left with the best match which is a mode incompatible ! -- interface routine. Do not emit an error if the Expander ! -- is active since this error will be detected later on ! -- after all concurrent types are expanded and all wrappers ! -- are built. This check is meant for spec-only ! -- compilations. ! if Present (Candidate) ! and then not Expander_Active ! then Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate))); ! -- Def_Id is primitive of a protected type, declared ! -- inside the type, and the candidate is primitive of a ! -- limited or synchronized interface. if In_Scope and then Is_Protected_Type (Typ) --- 7711,7730 ---- Hom := Homonym (Hom); end loop; ! -- After examining all candidates for overriding, we are left with ! -- the best match which is a mode incompatible interface routine. ! -- Do not emit an error if the Expander is active since this error ! -- will be detected later on after all concurrent types are ! -- expanded and all wrappers are built. This check is meant for ! -- spec-only compilations. ! if Present (Candidate) and then not Expander_Active then Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate))); ! -- Def_Id is primitive of a protected type, declared inside the ! -- type, and the candidate is primitive of a limited or ! -- synchronized interface. if In_Scope and then Is_Protected_Type (Typ) *************** package body Sem_Ch6 is *** 7259,7273 **** or else Is_Synchronized_Interface (Iface_Typ) or else Is_Task_Interface (Iface_Typ)) then - -- Must reword this message, comma before to in -gnatj - -- mode ??? - Error_Msg_NE ("first formal of & must be of mode `OUT`, `IN OUT`" & " or access-to-variable", Typ, Candidate); Error_Msg_N ! ("\to be overridden by protected procedure or entry " ! & "(RM 9.4(11.9/2))", Typ); end if; end if; --- 7734,7745 ---- or else Is_Synchronized_Interface (Iface_Typ) or else Is_Task_Interface (Iface_Typ)) then Error_Msg_NE ("first formal of & must be of mode `OUT`, `IN OUT`" & " or access-to-variable", Typ, Candidate); Error_Msg_N ! ("\in order to be overridden by protected procedure or " ! & "entry (RM 9.4(11.9/2))", Typ); end if; end if; *************** package body Sem_Ch6 is *** 7334,7339 **** --- 7806,7858 ---- E := Current_Entity_In_Scope (S); + -- Ada 2005 (AI-251): Derivation of abstract interface primitives. + -- They are directly added to the list of primitive operations of + -- Derived_Type, unless this is a rederivation in the private part + -- of an operation that was already derived in the visible part of + -- the current package. + + if Ada_Version >= Ada_2005 + and then Present (Derived_Type) + and then Present (Alias (S)) + and then Is_Dispatching_Operation (Alias (S)) + and then Present (Find_Dispatching_Type (Alias (S))) + and then Is_Interface (Find_Dispatching_Type (Alias (S))) + then + -- For private types, when the full-view is processed we propagate to + -- the full view the non-overridden entities whose attribute "alias" + -- references an interface primitive. These entities were added by + -- Derive_Subprograms to ensure that interface primitives are + -- covered. + + -- Inside_Freeze_Actions is non zero when S corresponds with an + -- internal entity that links an interface primitive with its + -- covering primitive through attribute Interface_Alias (see + -- Add_Internal_Interface_Entities). + + if Inside_Freezing_Actions = 0 + and then Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Nkind (Parent (E)) = N_Private_Extension_Declaration + and then Nkind (Parent (S)) = N_Full_Type_Declaration + and then Full_View (Defining_Identifier (Parent (E))) + = Defining_Identifier (Parent (S)) + and then Alias (E) = Alias (S) + then + Check_Operation_From_Private_View (S, E); + Set_Is_Dispatching_Operation (S); + + -- Common case + + else + Enter_Overloaded_Entity (S); + Check_Dispatching_Operation (S, Empty); + Check_For_Primitive_Subprogram (Is_Primitive_Subp); + end if; + + return; + end if; + -- If there is no homonym then this is definitely not overriding if No (E) then *************** package body Sem_Ch6 is *** 7346,7351 **** --- 7865,7884 ---- if Comes_From_Source (S) then Check_Synchronized_Overriding (S, Overridden_Subp); + + -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then + -- it may have overridden some hidden inherited primitive. Update + -- Overridden_Subp to avoid spurious errors when checking the + -- overriding indicator. + + if Ada_Version >= Ada_2012 + and then No (Overridden_Subp) + and then Is_Dispatching_Operation (S) + and then Present (Overridden_Operation (S)) + then + Overridden_Subp := Overridden_Operation (S); + end if; + Check_Overriding_Indicator (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); end if; *************** package body Sem_Ch6 is *** 7380,7388 **** -- dispatch table anyway, because it can be dispatched to even if it -- cannot be called directly. ! elsif Present (Alias (S)) ! and then not Comes_From_Source (S) ! then Set_Scope (S, Current_Scope); if Is_Dispatching_Operation (Alias (S)) then --- 7913,7919 ---- -- dispatch table anyway, because it can be dispatched to even if it -- cannot be called directly. ! elsif Present (Alias (S)) and then not Comes_From_Source (S) then Set_Scope (S, Current_Scope); if Is_Dispatching_Operation (Alias (S)) then *************** package body Sem_Ch6 is *** 7409,7427 **** -- E exists and is overloadable else - -- Ada 2005 (AI-251): Derivation of abstract interface primitives - -- need no check against the homonym chain. They are directly added - -- to the list of primitive operations of Derived_Type. - - if Ada_Version >= Ada_05 - and then Present (Derived_Type) - and then Is_Dispatching_Operation (Alias (S)) - and then Present (Find_Dispatching_Type (Alias (S))) - and then Is_Interface (Find_Dispatching_Type (Alias (S))) - then - goto Add_New_Entity; - end if; - Check_Synchronized_Overriding (S, Overridden_Subp); -- Loop through E and its homonyms to determine if any of them is --- 7940,7945 ---- *************** package body Sem_Ch6 is *** 7478,7499 **** Check_Operation_From_Private_View (S, E); end if; ! -- In any case the implicit operation remains hidden by ! -- the existing declaration, which is overriding. ! Set_Is_Overriding_Operation (E); if Comes_From_Source (E) then Check_Overriding_Indicator (E, S, Is_Primitive => False); - - -- Indicate that E overrides the operation from which - -- S is inherited. - - if Present (Alias (S)) then - Set_Overridden_Operation (E, Alias (S)); - else - Set_Overridden_Operation (E, S); - end if; end if; return; --- 7996,8013 ---- Check_Operation_From_Private_View (S, E); end if; ! -- In any case the implicit operation remains hidden by the ! -- existing declaration, which is overriding. Indicate that ! -- E overrides the operation from which S is inherited. ! if Present (Alias (S)) then ! Set_Overridden_Operation (E, Alias (S)); ! else ! Set_Overridden_Operation (E, S); ! end if; if Comes_From_Source (E) then Check_Overriding_Indicator (E, S, Is_Primitive => False); end if; return; *************** package body Sem_Ch6 is *** 7641,7661 **** if No (Next_Entity (Prev)) then Set_Last_Entity (Current_Scope, Prev); end if; - end if; end if; Enter_Overloaded_Entity (S); ! Set_Is_Overriding_Operation (S); Check_Overriding_Indicator (S, E, Is_Primitive => True); -- If S is a user-defined subprogram or a null procedure ! -- expanded to override an inherited null procedure, then ! -- indicate that E overrides the operation from which S ! -- is inherited. It seems odd that Overridden_Operation ! -- isn't set in all cases where Is_Overriding_Operation ! -- is true, but doing so causes infinite loops in the ! -- compiler for implicit overriding subprograms. ??? if Comes_From_Source (S) or else --- 8155,8187 ---- if No (Next_Entity (Prev)) then Set_Last_Entity (Current_Scope, Prev); end if; end if; end if; Enter_Overloaded_Entity (S); ! ! -- For entities generated by Derive_Subprograms the ! -- overridden operation is the inherited primitive ! -- (which is available through the attribute alias). ! ! if not (Comes_From_Source (E)) ! and then Is_Dispatching_Operation (E) ! and then Find_Dispatching_Type (E) = ! Find_Dispatching_Type (S) ! and then Present (Alias (E)) ! and then Comes_From_Source (Alias (E)) ! then ! Set_Overridden_Operation (S, Alias (E)); ! else ! Set_Overridden_Operation (S, E); ! end if; ! Check_Overriding_Indicator (S, E, Is_Primitive => True); -- If S is a user-defined subprogram or a null procedure ! -- expanded to override an inherited null procedure, or a ! -- predefined dispatching primitive then indicate that E ! -- overrides the operation from which S is inherited. if Comes_From_Source (S) or else *************** package body Sem_Ch6 is *** 7664,7682 **** Nkind (Parent (S)) = N_Procedure_Specification and then Null_Present (Parent (S))) then if Present (Alias (E)) then Set_Overridden_Operation (S, Alias (E)); - else - Set_Overridden_Operation (S, E); end if; end if; if Is_Dispatching_Operation (E) then -- An overriding dispatching subprogram inherits the ! -- convention of the overridden subprogram (by ! -- AI-117). Set_Convention (S, Convention (E)); Check_Dispatching_Operation (S, E); --- 8190,8209 ---- Nkind (Parent (S)) = N_Procedure_Specification and then Null_Present (Parent (S))) + or else + (Present (Alias (E)) + and then + Is_Predefined_Dispatching_Operation (Alias (E))) then if Present (Alias (E)) then Set_Overridden_Operation (S, Alias (E)); end if; end if; if Is_Dispatching_Operation (E) then -- An overriding dispatching subprogram inherits the ! -- convention of the overridden subprogram (AI-117). Set_Convention (S, Convention (E)); Check_Dispatching_Operation (S, E); *************** package body Sem_Ch6 is *** 7779,7786 **** E := Homonym (E); end loop; - <> - -- On exit, we know that S is a new entity Enter_Overloaded_Entity (S); --- 8306,8311 ---- *************** package body Sem_Ch6 is *** 7812,7817 **** --- 8337,8346 ---- and then not Is_Dispatching_Operation (S) then Make_Inequality_Operator (S); + + if Ada_Version >= Ada_2012 then + Check_Untagged_Equality (S); + end if; end if; end New_Overloaded_Entity; *************** package body Sem_Ch6 is *** 7936,7953 **** elsif not Nkind_In (Parent (T), N_Access_Function_Definition, N_Access_Procedure_Definition) then - Error_Msg_NE - ("invalid use of incomplete type&", - Param_Spec, Formal_Type); ! -- Further checks on the legality of incomplete types ! -- in formal parts must be delayed until the freeze point ! -- of the enclosing subprogram or access to subprogram. end if; elsif Ekind (Formal_Type) = E_Void then ! Error_Msg_NE ("premature use of&", ! Parameter_Type (Param_Spec), Formal_Type); end if; -- Ada 2005 (AI-231): Create and decorate an internal subtype --- 8465,8503 ---- elsif not Nkind_In (Parent (T), N_Access_Function_Definition, N_Access_Procedure_Definition) then ! -- AI05-0151: Tagged incomplete types are allowed in all ! -- formal parts. Untagged incomplete types are not allowed ! -- in bodies. ! ! if Ada_Version >= Ada_2012 then ! if Is_Tagged_Type (Formal_Type) then ! null; ! ! elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement, ! N_Entry_Body, ! N_Subprogram_Body) ! then ! Error_Msg_NE ! ("invalid use of untagged incomplete type&", ! Ptype, Formal_Type); ! end if; ! ! else ! Error_Msg_NE ! ("invalid use of incomplete type&", ! Param_Spec, Formal_Type); ! ! -- Further checks on the legality of incomplete types ! -- in formal parts are delayed until the freeze point ! -- of the enclosing subprogram or access to subprogram. ! end if; end if; elsif Ekind (Formal_Type) = E_Void then ! Error_Msg_NE ! ("premature use of&", ! Parameter_Type (Param_Spec), Formal_Type); end if; -- Ada 2005 (AI-231): Create and decorate an internal subtype *************** package body Sem_Ch6 is *** 7955,7961 **** -- formal in the enclosing scope. Finally, replace the parameter -- type of the formal with the internal subtype. ! if Ada_Version >= Ada_05 and then Null_Exclusion_Present (Param_Spec) then if not Is_Access_Type (Formal_Type) then --- 8505,8511 ---- -- formal in the enclosing scope. Finally, replace the parameter -- type of the formal with the internal subtype. ! if Ada_Version >= Ada_2005 and then Null_Exclusion_Present (Param_Spec) then if not Is_Access_Type (Formal_Type) then *************** package body Sem_Ch6 is *** 7968,7975 **** then Error_Msg_NE ("`NOT NULL` not allowed (& already excludes null)", ! Param_Spec, ! Formal_Type); end if; Formal_Type := --- 8518,8524 ---- then Error_Msg_NE ("`NOT NULL` not allowed (& already excludes null)", ! Param_Spec, Formal_Type); end if; Formal_Type := *************** package body Sem_Ch6 is *** 8072,8078 **** -- Ada 2005 (AI-231): Static checks ! if Ada_Version >= Ada_05 and then Is_Access_Type (Etype (Formal)) and then Can_Never_Be_Null (Etype (Formal)) then --- 8621,8627 ---- -- Ada 2005 (AI-231): Static checks ! if Ada_Version >= Ada_2005 and then Is_Access_Type (Etype (Formal)) and then Can_Never_Be_Null (Etype (Formal)) then *************** package body Sem_Ch6 is *** 8094,8100 **** -- Now set the kind (mode) of each formal Param_Spec := First (T); - while Present (Param_Spec) loop Formal := Defining_Identifier (Param_Spec); Set_Formal_Mode (Formal); --- 8643,8648 ---- *************** package body Sem_Ch6 is *** 8150,8210 **** is Loc : constant Source_Ptr := Sloc (N); Prag : Node_Id; - Plist : List_Id := No_List; - Subp : Entity_Id; Parms : List_Id; ! function Grab_PPC (Nam : Name_Id) return Node_Id; ! -- Prag contains an analyzed precondition or postcondition pragma. ! -- This function copies the pragma, changes it to the corresponding ! -- Check pragma and returns the Check pragma as the result. The ! -- argument Nam is either Name_Precondition or Name_Postcondition. -------------- -- Grab_PPC -- -------------- ! function Grab_PPC (Nam : Name_Id) return Node_Id is ! CP : constant Node_Id := New_Copy_Tree (Prag); begin -- Set Analyzed to false, since we want to reanalyze the check -- procedure. Note that it is only at the outer level that we -- do this fiddling, for the spec cases, the already preanalyzed -- parameters are not affected. -- For a postcondition pragma within a generic, preserve the pragma -- for later expansion. - Set_Analyzed (CP, False); - if Nam = Name_Postcondition and then not Expander_Active then return CP; end if; ! -- Change pragma into corresponding pragma Check Prepend_To (Pragma_Argument_Associations (CP), Make_Pragma_Argument_Association (Sloc (Prag), ! Expression => ! Make_Identifier (Loc, ! Chars => Nam))); ! Set_Pragma_Identifier (CP, ! Make_Identifier (Sloc (Prag), ! Chars => Name_Check)); return CP; end Grab_PPC; -- Start of processing for Process_PPCs begin ! -- Nothing to do if we are not generating code ! if Operating_Mode /= Generate_Code then ! return; end if; -- Grab preconditions from spec --- 8698,8872 ---- is Loc : constant Source_Ptr := Sloc (N); Prag : Node_Id; Parms : List_Id; ! Designator : Entity_Id; ! -- Subprogram designator, set from Spec_Id if present, else Body_Id ! ! Precond : Node_Id := Empty; ! -- Set non-Empty if we prepend precondition to the declarations. This ! -- is used to hook up inherited preconditions (adding the condition ! -- expression with OR ELSE, and adding the message). ! ! Inherited_Precond : Node_Id; ! -- Precondition inherited from parent subprogram ! ! Inherited : constant Subprogram_List := ! Inherited_Subprograms (Spec_Id); ! -- List of subprograms inherited by this subprogram ! ! Plist : List_Id := No_List; ! -- List of generated postconditions ! ! function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id; ! -- Prag contains an analyzed precondition or postcondition pragma. This ! -- function copies the pragma, changes it to the corresponding Check ! -- pragma and returns the Check pragma as the result. If Pspec is non- ! -- empty, this is the case of inheriting a PPC, where we must change ! -- references to parameters of the inherited subprogram to point to the ! -- corresponding parameters of the current subprogram. ! ! function Invariants_Or_Predicates_Present return Boolean; ! -- Determines if any invariants or predicates are present for any OUT ! -- or IN OUT parameters of the subprogram, or (for a function) if the ! -- return value has an invariant. -------------- -- Grab_PPC -- -------------- ! function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id is ! Nam : constant Name_Id := Pragma_Name (Prag); ! Map : Elist_Id; ! CP : Node_Id; begin + -- Prepare map if this is the case where we have to map entities of + -- arguments in the overridden subprogram to corresponding entities + -- of the current subprogram. + + if No (Pspec) then + Map := No_Elist; + + else + declare + PF : Entity_Id; + CF : Entity_Id; + + begin + Map := New_Elmt_List; + PF := First_Formal (Pspec); + CF := First_Formal (Designator); + while Present (PF) loop + Append_Elmt (PF, Map); + Append_Elmt (CF, Map); + Next_Formal (PF); + Next_Formal (CF); + end loop; + end; + end if; + + -- Now we can copy the tree, doing any required substitutions + + CP := New_Copy_Tree (Prag, Map => Map, New_Scope => Current_Scope); + -- Set Analyzed to false, since we want to reanalyze the check -- procedure. Note that it is only at the outer level that we -- do this fiddling, for the spec cases, the already preanalyzed -- parameters are not affected. + Set_Analyzed (CP, False); + + -- We also make sure Comes_From_Source is False for the copy + + Set_Comes_From_Source (CP, False); + -- For a postcondition pragma within a generic, preserve the pragma -- for later expansion. if Nam = Name_Postcondition and then not Expander_Active then return CP; end if; ! -- Change copy of pragma into corresponding pragma Check Prepend_To (Pragma_Argument_Associations (CP), Make_Pragma_Argument_Association (Sloc (Prag), ! Expression => Make_Identifier (Loc, Nam))); ! Set_Pragma_Identifier (CP, Make_Identifier (Sloc (Prag), Name_Check)); ! ! -- If this is inherited case and the current message starts with ! -- "failed p", we change it to "failed inherited p...". ! ! if Present (Pspec) then ! declare ! Msg : constant Node_Id := ! Last (Pragma_Argument_Associations (CP)); ! ! begin ! if Chars (Msg) = Name_Message then ! String_To_Name_Buffer (Strval (Expression (Msg))); ! ! if Name_Buffer (1 .. 8) = "failed p" then ! Insert_Str_In_Name_Buffer ("inherited ", 8); ! Set_Strval ! (Expression (Last (Pragma_Argument_Associations (CP))), ! String_From_Name_Buffer); ! end if; ! end if; ! end; ! end if; ! ! -- Return the check pragma return CP; end Grab_PPC; + -------------------------------------- + -- Invariants_Or_Predicates_Present -- + -------------------------------------- + + function Invariants_Or_Predicates_Present return Boolean is + Formal : Entity_Id; + + begin + -- Check function return result + + if Ekind (Designator) /= E_Procedure + and then Has_Invariants (Etype (Designator)) + then + return True; + end if; + + -- Check parameters + + Formal := First_Formal (Designator); + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter + and then + (Has_Invariants (Etype (Formal)) + or else Present (Predicate_Function (Etype (Formal)))) + then + return True; + end if; + + Next_Formal (Formal); + end loop; + + return False; + end Invariants_Or_Predicates_Present; + -- Start of processing for Process_PPCs begin ! -- Capture designator from spec if present, else from body ! if Present (Spec_Id) then ! Designator := Spec_Id; ! else ! Designator := Body_Id; end if; -- Grab preconditions from spec *************** package body Sem_Ch6 is *** 8217,8235 **** Prag := Spec_PPC_List (Spec_Id); while Present (Prag) loop ! if Pragma_Name (Prag) = Name_Precondition ! and then Pragma_Enabled (Prag) ! then ! -- Add pragma Check at the start of the declarations of N. ! -- Note that this processing reverses the order of the list, ! -- which is what we want since new entries were chained to ! -- the head of the list. ! Prepend (Grab_PPC (Name_Precondition), Declarations (N)); end if; Prag := Next_Pragma (Prag); end loop; end if; -- Build postconditions procedure if needed and prepend the following --- 8879,8999 ---- Prag := Spec_PPC_List (Spec_Id); while Present (Prag) loop ! if Pragma_Name (Prag) = Name_Precondition then ! -- For Pre (or Precondition pragma), we simply prepend the ! -- pragma to the list of declarations right away so that it ! -- will be executed at the start of the procedure. Note that ! -- this processing reverses the order of the list, which is ! -- what we want since new entries were chained to the head of ! -- the list. There can be more then one precondition when we ! -- use pragma Precondition ! ! if not Class_Present (Prag) then ! Prepend (Grab_PPC, Declarations (N)); ! ! -- For Pre'Class there can only be one pragma, and we save ! -- it in Precond for now. We will add inherited Pre'Class ! -- stuff before inserting this pragma in the declarations. ! else ! Precond := Grab_PPC; ! end if; end if; Prag := Next_Pragma (Prag); end loop; + + -- Now deal with inherited preconditions + + for J in Inherited'Range loop + Prag := Spec_PPC_List (Inherited (J)); + + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition + and then Class_Present (Prag) + then + Inherited_Precond := Grab_PPC (Inherited (J)); + + -- No precondition so far, so establish this as the first + + if No (Precond) then + Precond := Inherited_Precond; + + -- Here we already have a precondition, add inherited one + + else + -- Add new precondition to old one using OR ELSE + + declare + New_Expr : constant Node_Id := + Get_Pragma_Arg + (Next + (First + (Pragma_Argument_Associations + (Inherited_Precond)))); + Old_Expr : constant Node_Id := + Get_Pragma_Arg + (Next + (First + (Pragma_Argument_Associations + (Precond)))); + + begin + if Paren_Count (Old_Expr) = 0 then + Set_Paren_Count (Old_Expr, 1); + end if; + + if Paren_Count (New_Expr) = 0 then + Set_Paren_Count (New_Expr, 1); + end if; + + Rewrite (Old_Expr, + Make_Or_Else (Sloc (Old_Expr), + Left_Opnd => Relocate_Node (Old_Expr), + Right_Opnd => New_Expr)); + end; + + -- Add new message in the form: + + -- failed precondition from bla + -- also failed inherited precondition from bla + -- ... + + -- Skip this if exception locations are suppressed + + if not Exception_Locations_Suppressed then + declare + New_Msg : constant Node_Id := + Get_Pragma_Arg + (Last + (Pragma_Argument_Associations + (Inherited_Precond))); + Old_Msg : constant Node_Id := + Get_Pragma_Arg + (Last + (Pragma_Argument_Associations + (Precond))); + begin + Start_String (Strval (Old_Msg)); + Store_String_Chars (ASCII.LF & " also "); + Store_String_Chars (Strval (New_Msg)); + Set_Strval (Old_Msg, End_String); + end; + end if; + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end loop; + + -- If we have built a precondition for Pre'Class (including any + -- Pre'Class aspects inherited from parent subprograms), then we + -- insert this composite precondition at this stage. + + if Present (Precond) then + Prepend (Precond, Declarations (N)); + end if; end if; -- Build postconditions procedure if needed and prepend the following *************** package body Sem_Ch6 is *** 8240,8245 **** --- 9004,9012 ---- -- pragma Check (Postcondition, condition [,message]); -- pragma Check (Postcondition, condition [,message]); -- ... + -- Invariant_Procedure (_Result) ... + -- Invariant_Procedure (Arg1) + -- ... -- end; -- First we deal with the postconditions in the body *************** package body Sem_Ch6 is *** 8263,8275 **** Analyze (Prag); ! -- If expansion is disabled, as in a generic unit, ! -- save pragma for later expansion. if not Expander_Active then ! Prepend (Grab_PPC (Name_Postcondition), Declarations (N)); else ! Append (Grab_PPC (Name_Postcondition), Plist); end if; end if; --- 9030,9042 ---- Analyze (Prag); ! -- If expansion is disabled, as in a generic unit, save ! -- pragma for later expansion. if not Expander_Active then ! Prepend (Grab_PPC, Declarations (N)); else ! Append (Grab_PPC, Plist); end if; end if; *************** package body Sem_Ch6 is *** 8291,8343 **** -- Now deal with any postconditions from the spec if Present (Spec_Id) then ! -- Loop through PPC pragmas from spec ! Prag := Spec_PPC_List (Spec_Id); ! while Present (Prag) loop ! if Pragma_Name (Prag) = Name_Postcondition ! and then Pragma_Enabled (Prag) ! then ! if Plist = No_List then ! Plist := Empty_List; ! end if; ! if not Expander_Active then ! Prepend (Grab_PPC (Name_Postcondition), Declarations (N)); else ! Append (Grab_PPC (Name_Postcondition), Plist); end if; end if; ! Prag := Next_Pragma (Prag); ! end loop; end if; ! -- If we had any postconditions and expansion is enabled, build ! -- the _Postconditions procedure. ! if Present (Plist) and then Expander_Active then ! Subp := Defining_Entity (N); - if Etype (Subp) /= Standard_Void_Type then - Parms := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_uResult), - Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc))); else Parms := No_List; end if; declare Post_Proc : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => Name_uPostconditions); -- The entity for the _Postconditions procedure begin Prepend_To (Declarations (N), Make_Subprogram_Body (Loc, --- 9058,9217 ---- -- Now deal with any postconditions from the spec if Present (Spec_Id) then + Spec_Postconditions : declare + procedure Process_Post_Conditions + (Spec : Node_Id; + Class : Boolean); + -- This processes the Spec_PPC_List from Spec, processing any + -- postconditions from the list. If Class is True, then only + -- postconditions marked with Class_Present are considered. + -- The caller has checked that Spec_PPC_List is non-Empty. ! ----------------------------- ! -- Process_Post_Conditions -- ! ----------------------------- ! procedure Process_Post_Conditions ! (Spec : Node_Id; ! Class : Boolean) ! is ! Pspec : Node_Id; ! begin ! if Class then ! Pspec := Spec; else ! Pspec := Empty; end if; + + -- Loop through PPC pragmas from spec + + Prag := Spec_PPC_List (Spec); + loop + if Pragma_Name (Prag) = Name_Postcondition + and then (not Class or else Class_Present (Prag)) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + if not Expander_Active then + Prepend + (Grab_PPC (Pspec), Declarations (N)); + else + Append (Grab_PPC (Pspec), Plist); + end if; + end if; + + Prag := Next_Pragma (Prag); + exit when No (Prag); + end loop; + end Process_Post_Conditions; + + -- Start of processing for Spec_Postconditions + + begin + if Present (Spec_PPC_List (Spec_Id)) then + Process_Post_Conditions (Spec_Id, Class => False); end if; ! -- Process inherited postconditions ! ! for J in Inherited'Range loop ! if Present (Spec_PPC_List (Inherited (J))) then ! Process_Post_Conditions (Inherited (J), Class => True); ! end if; ! end loop; ! end Spec_Postconditions; end if; ! -- If we had any postconditions and expansion is enabled, or if the ! -- procedure has invariants, then build the _Postconditions procedure. ! if (Present (Plist) or else Invariants_Or_Predicates_Present) and then Expander_Active then ! if No (Plist) then ! Plist := Empty_List; ! end if; ! ! -- Special processing for function case ! ! if Ekind (Designator) /= E_Procedure then ! declare ! Rent : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => Name_uResult); ! Ftyp : constant Entity_Id := Etype (Designator); ! ! begin ! Set_Etype (Rent, Ftyp); ! ! -- Add argument for return ! ! Parms := ! New_List ( ! Make_Parameter_Specification (Loc, ! Parameter_Type => New_Occurrence_Of (Ftyp, Loc), ! Defining_Identifier => Rent)); ! ! -- Add invariant call if returning type with invariants ! ! if Has_Invariants (Etype (Rent)) ! and then Present (Invariant_Procedure (Etype (Rent))) ! then ! Append_To (Plist, ! Make_Invariant_Call (New_Occurrence_Of (Rent, Loc))); ! end if; ! end; ! ! -- Procedure rather than a function else Parms := No_List; end if; + -- Add invariant calls and predicate calls for parameters. Note that + -- this is done for functions as well, since in Ada 2012 they can + -- have IN OUT args. + + declare + Formal : Entity_Id; + Ftype : Entity_Id; + + begin + Formal := First_Formal (Designator); + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter then + Ftype := Etype (Formal); + + if Has_Invariants (Ftype) + and then Present (Invariant_Procedure (Ftype)) + then + Append_To (Plist, + Make_Invariant_Call + (New_Occurrence_Of (Formal, Loc))); + end if; + + if Present (Predicate_Function (Ftype)) then + Append_To (Plist, + Make_Predicate_Check + (Ftype, New_Occurrence_Of (Formal, Loc))); + end if; + end if; + + Next_Formal (Formal); + end loop; + end; + + -- Build and insert postcondition procedure + declare Post_Proc : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => Name_uPostconditions); -- The entity for the _Postconditions procedure + begin Prepend_To (Declarations (N), Make_Subprogram_Body (Loc, *************** package body Sem_Ch6 is *** 8355,8374 **** -- If this is a procedure, set the Postcondition_Proc attribute on -- the proper defining entity for the subprogram. ! if Etype (Subp) = Standard_Void_Type then ! if Present (Spec_Id) then ! Set_Postcondition_Proc (Spec_Id, Post_Proc); ! else ! Set_Postcondition_Proc (Body_Id, Post_Proc); ! end if; end if; end; ! if Present (Spec_Id) then ! Set_Has_Postconditions (Spec_Id); ! else ! Set_Has_Postconditions (Body_Id); ! end if; end if; end Process_PPCs; --- 9229,9240 ---- -- If this is a procedure, set the Postcondition_Proc attribute on -- the proper defining entity for the subprogram. ! if Ekind (Designator) = E_Procedure then ! Set_Postcondition_Proc (Designator, Post_Proc); end if; end; ! Set_Has_Postconditions (Designator); end if; end Process_PPCs; *************** package body Sem_Ch6 is *** 8409,8415 **** ------------------------- procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; Formal : Entity_Id; T : Entity_Id; --- 9275,9280 ---- *************** package body Sem_Ch6 is *** 8523,8529 **** if Present (First_Stmt) then Insert_List_Before_And_Analyze (First_Stmt, ! Freeze_Entity (Defining_Identifier (Decl), Loc)); end if; if Nkind (N) = N_Accept_Statement --- 9388,9394 ---- if Present (First_Stmt) then Insert_List_Before_And_Analyze (First_Stmt, ! Freeze_Entity (Defining_Identifier (Decl), N)); end if; if Nkind (N) = N_Accept_Statement *************** package body Sem_Ch6 is *** 8556,8563 **** if Ekind (Scope (Formal_Id)) = E_Function or else Ekind (Scope (Formal_Id)) = E_Generic_Function then ! Error_Msg_N ("functions can only have IN parameters", Spec); ! Set_Ekind (Formal_Id, E_In_Parameter); elsif In_Present (Spec) then Set_Ekind (Formal_Id, E_In_Out_Parameter); --- 9421,9441 ---- if Ekind (Scope (Formal_Id)) = E_Function or else Ekind (Scope (Formal_Id)) = E_Generic_Function then ! -- [IN] OUT parameters allowed for functions in Ada 2012 ! ! if Ada_Version >= Ada_2012 then ! if In_Present (Spec) then ! Set_Ekind (Formal_Id, E_In_Out_Parameter); ! else ! Set_Ekind (Formal_Id, E_Out_Parameter); ! end if; ! ! -- But not in earlier versions of Ada ! ! else ! Error_Msg_N ("functions can only have IN parameters", Spec); ! Set_Ekind (Formal_Id, E_In_Parameter); ! end if; elsif In_Present (Spec) then Set_Ekind (Formal_Id, E_In_Out_Parameter); *************** package body Sem_Ch6 is *** 8582,8588 **** -- Ada 2005 (AI-231): In Ada95, access parameters are always non- -- null; In Ada 2005, only if then null_exclusion is explicit. ! if Ada_Version < Ada_05 or else Can_Never_Be_Null (Etype (Formal_Id)) then Set_Is_Known_Non_Null (Formal_Id); --- 9460,9466 ---- -- Ada 2005 (AI-231): In Ada95, access parameters are always non- -- null; In Ada 2005, only if then null_exclusion is explicit. ! if Ada_Version < Ada_2005 or else Can_Never_Be_Null (Etype (Formal_Id)) then Set_Is_Known_Non_Null (Formal_Id); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch6.ads gcc-4.6.0/gcc/ada/sem_ch6.ads *** gcc-4.5.2/gcc/ada/sem_ch6.ads Mon Apr 20 08:35:16 2009 --- gcc-4.6.0/gcc/ada/sem_ch6.ads Tue Oct 26 12:45:45 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Ch6 is *** 28,42 **** type Conformance_Type is (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); -- Conformance type used in conformance checks between specs and bodies, -- and for overriding. The literals match the RM definitions of the ! -- corresponding terms. procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id); procedure Analyze_Extended_Return_Statement (N : Node_Id); procedure Analyze_Function_Call (N : Node_Id); procedure Analyze_Operator_Symbol (N : Node_Id); procedure Analyze_Parameter_Association (N : Node_Id); procedure Analyze_Procedure_Call (N : Node_Id); procedure Analyze_Simple_Return_Statement (N : Node_Id); procedure Analyze_Subprogram_Declaration (N : Node_Id); --- 28,45 ---- type Conformance_Type is (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); + pragma Ordered (Conformance_Type); -- Conformance type used in conformance checks between specs and bodies, -- and for overriding. The literals match the RM definitions of the ! -- corresponding terms. This is an ordered type, since each conformance ! -- type is stronger than the ones preceding it. procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id); procedure Analyze_Extended_Return_Statement (N : Node_Id); procedure Analyze_Function_Call (N : Node_Id); procedure Analyze_Operator_Symbol (N : Node_Id); procedure Analyze_Parameter_Association (N : Node_Id); + procedure Analyze_Parameterized_Expression (N : Node_Id); procedure Analyze_Procedure_Call (N : Node_Id); procedure Analyze_Simple_Return_Statement (N : Node_Id); procedure Analyze_Subprogram_Declaration (N : Node_Id); *************** package Sem_Ch6 is *** 183,191 **** (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean; ! -- Returns true if both primitives have a matching name and they are also ! -- type conformant. Special management is done for functions returning ! -- interfaces. function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, --- 186,199 ---- (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean; ! -- Returns true if both primitives have a matching name (including support ! -- for names of inherited private primitives --which have suffix 'P'), they ! -- are type conformant, and Prim is defined in the scope of Tagged_Type. ! -- Special management is done for functions returning interfaces. ! ! procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id); ! -- E is the entity for a subprogram or generic subprogram spec. This call ! -- lists all inherited Pre/Post aspects if List_Inherited_Pre_Post is True. function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch7.adb gcc-4.6.0/gcc/ada/sem_ch7.adb *** gcc-4.5.2/gcc/ada/sem_ch7.adb Thu Jul 30 09:23:06 2009 --- gcc-4.6.0/gcc/ada/sem_ch7.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 28,33 **** --- 28,34 ---- -- 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; *************** with Sem_Ch6; use Sem_Ch6; *** 51,58 **** with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; with Sem_Disp; use Sem_Disp; ! with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Snames; use Snames; --- 52,60 ---- with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; + with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; ! with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Snames; use Snames; *************** package body Sem_Ch7 is *** 252,268 **** end if; if Is_Package_Or_Generic_Package (Spec_Id) ! and then ! (Scope (Spec_Id) = Standard_Standard ! or else Is_Child_Unit (Spec_Id)) and then not Unit_Requires_Body (Spec_Id) then if Ada_Version = Ada_83 then Error_Msg_N ("optional package body (not allowed in Ada 95)?", N); else ! Error_Msg_N ! ("spec of this package does not allow a body", N); end if; end if; end if; --- 254,268 ---- end if; if Is_Package_Or_Generic_Package (Spec_Id) ! and then (Scope (Spec_Id) = Standard_Standard ! or else Is_Child_Unit (Spec_Id)) and then not Unit_Requires_Body (Spec_Id) then if Ada_Version = Ada_83 then Error_Msg_N ("optional package body (not allowed in Ada 95)?", N); else ! Error_Msg_N ("spec of this package does not allow a body", N); end if; end if; end if; *************** package body Sem_Ch7 is *** 474,482 **** -- is conservative and definitely correct. -- We only do this at the outer (library) level non-generic packages. ! -- The reason is simply to cut down on the number of external symbols ! -- generated, so this is simply an optimization of the efficiency ! -- of the compilation process. It has no other effect. if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) and then not Is_Generic_Unit (Spec_Id) --- 474,483 ---- -- is conservative and definitely correct. -- We only do this at the outer (library) level non-generic packages. ! -- The reason is simply to cut down on the number of global symbols ! -- generated, which has a double effect: (1) to make the compilation ! -- process more efficient and (2) to give the code generator more ! -- freedom to optimize within each unit, especially subprograms. if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) and then not Is_Generic_Unit (Spec_Id) *************** package body Sem_Ch7 is *** 486,504 **** function Has_Referencer (L : List_Id; ! Outer : Boolean) ! return Boolean; -- Traverse the given list of declarations in reverse order. ! -- Return True as soon as a referencer is reached. Return False if ! -- none is found. The Outer parameter is True for the outer level ! -- call, and False for inner level calls for nested packages. If ! -- Outer is True, then any entities up to the point of hitting a ! -- referencer get their Is_Public flag cleared, so that the ! -- entities will be treated as static entities in the C sense, and ! -- need not have fully qualified names. For inner levels, we need ! -- all names to be fully qualified to deal with the same name ! -- appearing in parallel packages (right now this is tied to their ! -- being external). -------------------- -- Has_Referencer -- --- 487,506 ---- function Has_Referencer (L : List_Id; ! Outer : Boolean) return Boolean; -- Traverse the given list of declarations in reverse order. ! -- Return True if a referencer is present. Return False if none is ! -- found. The Outer parameter is True for the outer level call and ! -- False for inner level calls for nested packages. If Outer is ! -- True, then any entities up to the point of hitting a referencer ! -- get their Is_Public flag cleared, so that the entities will be ! -- treated as static entities in the C sense, and need not have ! -- fully qualified names. Furthermore, if the referencer is an ! -- inlined subprogram that doesn't reference other subprograms, ! -- we keep clearing the Is_Public flag on subprograms. For inner ! -- levels, we need all names to be fully qualified to deal with ! -- the same name appearing in parallel packages (right now this ! -- is tied to their being external). -------------------- -- Has_Referencer -- *************** package body Sem_Ch7 is *** 506,519 **** function Has_Referencer (L : List_Id; ! Outer : Boolean) ! return Boolean is D : Node_Id; E : Entity_Id; K : Node_Kind; S : Entity_Id; begin if No (L) then return False; --- 508,576 ---- function Has_Referencer (L : List_Id; ! Outer : Boolean) return Boolean is + Has_Referencer_Except_For_Subprograms : Boolean := False; + D : Node_Id; E : Entity_Id; K : Node_Kind; S : Entity_Id; + function Check_Subprogram_Ref (N : Node_Id) + return Traverse_Result; + -- Look for references to subprograms + + -------------------------- + -- Check_Subprogram_Ref -- + -------------------------- + + function Check_Subprogram_Ref (N : Node_Id) + return Traverse_Result + is + V : Node_Id; + + begin + -- Check name of procedure or function calls + + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) + and then Is_Entity_Name (Name (N)) + then + return Abandon; + end if; + + -- Check prefix of attribute references + + if Nkind (N) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (N)) + and then Present (Entity (Prefix (N))) + and then Ekind (Entity (Prefix (N))) in Subprogram_Kind + then + return Abandon; + end if; + + -- Check value of constants + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Constant + then + V := Constant_Value (Entity (N)); + if Present (V) + and then not Compile_Time_Known_Value_Or_Aggr (V) + then + return Abandon; + end if; + end if; + + return OK; + end Check_Subprogram_Ref; + + function Check_Subprogram_Refs is + new Traverse_Func (Check_Subprogram_Ref); + + -- Start of processing for Has_Referencer + begin if No (L) then return False; *************** package body Sem_Ch7 is *** 526,531 **** --- 583,590 ---- if K in N_Body_Stub then return True; + -- Processing for subprogram bodies + elsif K = N_Subprogram_Body then if Acts_As_Spec (D) then E := Defining_Entity (D); *************** package body Sem_Ch7 is *** 542,548 **** -- of accessing global entities. if Has_Pragma_Inline (E) then ! return True; else Set_Is_Public (E, False); end if; --- 601,613 ---- -- of accessing global entities. if Has_Pragma_Inline (E) then ! if Outer ! and then Check_Subprogram_Refs (D) = OK ! then ! Has_Referencer_Except_For_Subprograms := True; ! else ! return True; ! end if; else Set_Is_Public (E, False); end if; *************** package body Sem_Ch7 is *** 550,567 **** else E := Corresponding_Spec (D); ! if Present (E) ! and then (Is_Generic_Unit (E) ! or else Has_Pragma_Inline (E) ! or else Is_Inlined (E)) ! then ! return True; end if; end if; -- Processing for package bodies elsif K = N_Package_Body and then Present (Corresponding_Spec (D)) then E := Corresponding_Spec (D); --- 615,644 ---- else E := Corresponding_Spec (D); ! if Present (E) then ! ! -- A generic subprogram body acts as a referencer ! ! if Is_Generic_Unit (E) then ! return True; ! end if; ! ! if Has_Pragma_Inline (E) or else Is_Inlined (E) then ! if Outer ! and then Check_Subprogram_Refs (D) = OK ! then ! Has_Referencer_Except_For_Subprograms := True; ! else ! return True; ! end if; ! end if; end if; end if; -- Processing for package bodies elsif K = N_Package_Body + and then not Has_Referencer_Except_For_Subprograms and then Present (Corresponding_Spec (D)) then E := Corresponding_Spec (D); *************** package body Sem_Ch7 is *** 591,597 **** -- Processing for package specs, recurse into declarations. -- Again we skip this for the case of generic instances. ! elsif K = N_Package_Declaration then S := Specification (D); if not Is_Generic_Unit (Defining_Entity (S)) then --- 668,676 ---- -- Processing for package specs, recurse into declarations. -- Again we skip this for the case of generic instances. ! elsif K = N_Package_Declaration ! and then not Has_Referencer_Except_For_Subprograms ! then S := Specification (D); if not Is_Generic_Unit (Defining_Entity (S)) then *************** package body Sem_Ch7 is *** 618,623 **** --- 697,704 ---- E := Defining_Entity (D); if Outer + and then (not Has_Referencer_Except_For_Subprograms + or else K = N_Subprogram_Declaration) and then not Is_Imported (E) and then not Is_Exported (E) and then No (Interface_Name (E)) *************** package body Sem_Ch7 is *** 629,635 **** Prev (D); end loop; ! return False; end Has_Referencer; -- Start of processing for Make_Non_Public_Where_Possible --- 710,716 ---- Prev (D); end loop; ! return Has_Referencer_Except_For_Subprograms; end Has_Referencer; -- Start of processing for Make_Non_Public_Where_Possible *************** package body Sem_Ch7 is *** 687,693 **** -- package Pkg is ... if From_With_Type (Id) then ! return; end if; if Debug_Flag_C then --- 768,774 ---- -- package Pkg is ... if From_With_Type (Id) then ! goto Leave; end if; if Debug_Flag_C then *************** package body Sem_Ch7 is *** 761,766 **** --- 842,850 ---- Write_Location (Sloc (N)); Write_Eol; end if; + + <> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Package_Declaration; ----------------------------------- *************** package body Sem_Ch7 is *** 786,797 **** -- private_with_clauses, and remove them at the end of the nested -- package. - procedure Analyze_PPCs (Decls : List_Id); - -- Given a list of declarations, go through looking for subprogram - -- specs, and for each one found, analyze any pre/postconditions that - -- are chained to the spec. This is the implementation of the late - -- visibility analysis for preconditions and postconditions in specs. - procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); -- Clears constant indications (Never_Set_In_Source, Constant_Value, and -- Is_True_Constant) on all variables that are entities of Id, and on --- 870,875 ---- *************** package body Sem_Ch7 is *** 820,852 **** -- private part rather than being done in Sem_Ch12.Install_Parent -- (which is where the parents' visible declarations are installed). - ------------------ - -- Analyze_PPCs -- - ------------------ - - procedure Analyze_PPCs (Decls : List_Id) is - Decl : Node_Id; - Spec : Node_Id; - Sent : Entity_Id; - Prag : Node_Id; - - begin - Decl := First (Decls); - while Present (Decl) loop - if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then - Spec := Specification (Original_Node (Decl)); - Sent := Defining_Unit_Name (Spec); - Prag := Spec_PPC_List (Sent); - while Present (Prag) loop - Analyze_PPC_In_Decl_Part (Prag, Sent); - Prag := Next_Pragma (Prag); - end loop; - end if; - - Next (Decl); - end loop; - end Analyze_PPCs; - --------------------- -- Clear_Constants -- --------------------- --- 898,903 ---- *************** package body Sem_Ch7 is *** 1075,1093 **** begin if Present (Vis_Decls) then Analyze_Declarations (Vis_Decls); - Analyze_PPCs (Vis_Decls); end if; ! -- Verify that incomplete types have received full declarations E := First_Entity (Id); while Present (E) loop if Ekind (E) = E_Incomplete_Type and then No (Full_View (E)) then Error_Msg_N ("no declaration in visible part for incomplete}", E); end if; Next_Entity (E); end loop; --- 1126,1153 ---- begin if Present (Vis_Decls) then Analyze_Declarations (Vis_Decls); end if; ! -- Verify that incomplete types have received full declarations and ! -- also build invariant procedures for any types with invariants. E := First_Entity (Id); while Present (E) loop + + -- Check on incomplete types + if Ekind (E) = E_Incomplete_Type and then No (Full_View (E)) then Error_Msg_N ("no declaration in visible part for incomplete}", E); end if; + -- Build invariant procedures + + if Is_Type (E) and then Has_Invariants (E) then + Build_Invariant_Procedure (E, N); + end if; + Next_Entity (E); end loop; *************** package body Sem_Ch7 is *** 1109,1115 **** declare Orig_Spec : constant Node_Id := Specification (Orig_Decl); Save_Priv : constant List_Id := Private_Declarations (Orig_Spec); - begin Set_Private_Declarations (Orig_Spec, Empty_List); Save_Global_References (Orig_Decl); --- 1169,1174 ---- *************** package body Sem_Ch7 is *** 1210,1216 **** end if; Analyze_Declarations (Priv_Decls); - Analyze_PPCs (Priv_Decls); -- Check the private declarations for incomplete deferred constants --- 1269,1274 ---- *************** package body Sem_Ch7 is *** 1345,1350 **** --- 1403,1409 ---- New_Private_Type (N, Id, N); Set_Depends_On_Private (Id); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Private_Type_Declaration; ---------------------------------- *************** package body Sem_Ch7 is *** 1451,1457 **** (Nkind (Parent (E)) = N_Private_Extension_Declaration and then Is_Generic_Type (E))) and then In_Open_Scopes (Scope (Etype (E))) ! and then E = Base_Type (E) then if Is_Tagged_Type (E) then Op_List := Primitive_Operations (E); --- 1510,1516 ---- (Nkind (Parent (E)) = N_Private_Extension_Declaration and then Is_Generic_Type (E))) and then In_Open_Scopes (Scope (Etype (E))) ! and then Is_Base_Type (E) then if Is_Tagged_Type (E) then Op_List := Primitive_Operations (E); *************** package body Sem_Ch7 is *** 1478,1485 **** --- 1537,1551 ---- Op_Elmt_2 := Next_Elmt (Op_Elmt); while Present (Op_Elmt_2) loop + + -- Skip entities with attribute Interface_Alias since + -- they are not overriding primitives (these entities + -- link an interface primitive with their covering + -- primitive) + if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) + and then No (Interface_Alias (Node (Op_Elmt_2))) then -- The private inherited operation has been -- overridden by an explicit subprogram: replace *************** package body Sem_Ch7 is *** 1488,1494 **** New_Op := Node (Op_Elmt_2); Replace_Elmt (Op_Elmt, New_Op); Remove_Elmt (Op_List, Op_Elmt_2); - Set_Is_Overriding_Operation (New_Op); Set_Overridden_Operation (New_Op, Parent_Subp); -- We don't need to inherit its dispatching slot. --- 1554,1559 ---- *************** package body Sem_Ch7 is *** 1869,1875 **** procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is begin ! Enter_Name (Id); if Limited_Present (Def) then Set_Ekind (Id, E_Limited_Private_Type); --- 1934,1958 ---- procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is begin ! -- For other than Ada 2012, enter the name in the current scope ! ! if Ada_Version < Ada_2012 then ! Enter_Name (Id); ! ! -- Ada 2012 (AI05-0162): Enter the name in the current scope handling ! -- private type that completes an incomplete type. ! ! else ! declare ! Prev : Entity_Id; ! begin ! Prev := Find_Type_Name (N); ! pragma Assert (Prev = Id ! or else (Ekind (Prev) = E_Incomplete_Type ! and then Present (Full_View (Prev)) ! and then Full_View (Prev) = Id)); ! end; ! end if; if Limited_Present (Def) then Set_Ekind (Id, E_Limited_Private_Type); *************** package body Sem_Ch7 is *** 1906,1916 **** Set_Private_Dependents (Id, New_Elmt_List); if Tagged_Present (Def) then ! Set_Ekind (Id, E_Record_Type_With_Private); ! Set_Primitive_Operations (Id, New_Elmt_List); ! Set_Is_Abstract_Type (Id, Abstract_Present (Def)); ! Set_Is_Limited_Record (Id, Limited_Present (Def)); ! Set_Has_Delayed_Freeze (Id, True); -- Create a class-wide type with the same attributes --- 1989,1999 ---- Set_Private_Dependents (Id, New_Elmt_List); if Tagged_Present (Def) then ! Set_Ekind (Id, E_Record_Type_With_Private); ! Set_Direct_Primitive_Operations (Id, New_Elmt_List); ! Set_Is_Abstract_Type (Id, Abstract_Present (Def)); ! Set_Is_Limited_Record (Id, Limited_Present (Def)); ! Set_Has_Delayed_Freeze (Id, True); -- Create a class-wide type with the same attributes *************** package body Sem_Ch7 is *** 1944,1950 **** ------------------------------ procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is ! Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv); begin Set_Size_Info (Priv, (Full)); --- 2027,2033 ---- ------------------------------ procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is ! Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv); begin Set_Size_Info (Priv, (Full)); *************** package body Sem_Ch7 is *** 1954,1959 **** --- 2037,2044 ---- Set_Is_Volatile (Priv, Is_Volatile (Full)); Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full)); + Set_Is_Ada_2012_Only (Priv, Is_Ada_2012_Only (Full)); + Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full)); Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full)); Set_Has_Pragma_Unreferenced_Objects (Priv, Has_Pragma_Unreferenced_Objects *************** package body Sem_Ch7 is *** 2032,2037 **** --- 2117,2127 ---- end if; Set_Has_Discriminants (Priv, Has_Discriminants (Full)); + + if Has_Discriminants (Full) then + Set_Discriminant_Constraint (Priv, + Discriminant_Constraint (Full)); + end if; end if; end Preserve_Full_Attributes; *************** package body Sem_Ch7 is *** 2068,2074 **** -- but the formals are private and remain so. if Ekind (Id) = E_Function ! and then Is_Operator_Symbol_Name (Chars (Id)) and then not Is_Hidden (Id) and then not Error_Posted (Id) then --- 2158,2164 ---- -- but the formals are private and remain so. if Ekind (Id) = E_Function ! and then Is_Operator_Symbol_Name (Chars (Id)) and then not Is_Hidden (Id) and then not Error_Posted (Id) then diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch8.adb gcc-4.6.0/gcc/ada/sem_ch8.adb *** gcc-4.5.2/gcc/ada/sem_ch8.adb Tue Jan 26 14:02:25 2010 --- gcc-4.6.0/gcc/ada/sem_ch8.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Sinfo.CN; use Sinfo.CN; *** 64,69 **** --- 64,70 ---- with Snames; use Snames; with Style; use Style; with Table; + with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; *************** package body Sem_Ch8 is *** 398,412 **** -- must be added to the list of actuals in any subsequent call. function Applicable_Use (Pack_Name : Node_Id) return Boolean; ! -- Common code to Use_One_Package and Set_Use, to determine whether ! -- use clause must be processed. Pack_Name is an entity name that ! -- references the package in question. procedure Attribute_Renaming (N : Node_Id); -- Analyze renaming of attribute as subprogram. The renaming declaration N -- is rewritten as a subprogram body that returns the attribute reference -- applied to the formals of the function. procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); -- A renaming_as_body may occur after the entity of the original decla- -- ration has been frozen. In that case, the body of the new entity must --- 399,418 ---- -- must be added to the list of actuals in any subsequent call. function Applicable_Use (Pack_Name : Node_Id) return Boolean; ! -- Common code to Use_One_Package and Set_Use, to determine whether use ! -- clause must be processed. Pack_Name is an entity name that references ! -- the package in question. procedure Attribute_Renaming (N : Node_Id); -- Analyze renaming of attribute as subprogram. The renaming declaration N -- is rewritten as a subprogram body that returns the attribute reference -- applied to the formals of the function. + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id); + -- Set Entity, with style check if need be. For a discriminant reference, + -- replace by the corresponding discriminal, i.e. the parameter of the + -- initialization procedure that corresponds to the discriminant. + procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); -- A renaming_as_body may occur after the entity of the original decla- -- ration has been frozen. In that case, the body of the new entity must *************** package body Sem_Ch8 is *** 449,456 **** -- private with on E. procedure Find_Expanded_Name (N : Node_Id); ! -- Selected component is known to be expanded name. Verify legality of ! -- selector given the scope denoted by prefix. function Find_Renamed_Entity (N : Node_Id; --- 455,463 ---- -- private with on E. procedure Find_Expanded_Name (N : Node_Id); ! -- The input is a selected component is known to be expanded name. Verify ! -- legality of selector given the scope denoted by prefix, and change node ! -- N into a expanded name with a properly set Entity field. function Find_Renamed_Entity (N : Node_Id; *************** package body Sem_Ch8 is *** 506,515 **** procedure Write_Info; -- Write debugging information on entities declared in current scope - procedure Write_Scopes; - pragma Warnings (Off, Write_Scopes); - -- Debugging information: dump all entities on scope stack - -------------------------------- -- Analyze_Exception_Renaming -- -------------------------------- --- 513,518 ---- *************** package body Sem_Ch8 is *** 893,899 **** Error_Msg_NE ("\?function & will be called only once", Nam, Entity (Name (Nam))); ! Error_Msg_N ("\?suggest using an initialized constant object instead", Nam); end if; --- 896,902 ---- Error_Msg_NE ("\?function & will be called only once", Nam, Entity (Name (Nam))); ! Error_Msg_N -- CODEFIX ("\?suggest using an initialized constant object instead", Nam); end if; *************** package body Sem_Ch8 is *** 910,918 **** then declare Loc : constant Source_Ptr := Sloc (N); ! Subt : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('T')); begin Remove_Side_Effects (Nam); Insert_Action (N, --- 913,919 ---- then declare Loc : constant Source_Ptr := Sloc (N); ! Subt : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Remove_Side_Effects (Nam); Insert_Action (N, *************** package body Sem_Ch8 is *** 953,965 **** -- Ada 2005 (AI-327) ! if Ada_Version >= Ada_05 and then Nkind (Nam) = N_Attribute_Reference and then Attribute_Name (Nam) = Name_Priority then null; ! elsif Ada_Version >= Ada_05 and then Nkind (Nam) in N_Has_Entity then declare --- 954,966 ---- -- Ada 2005 (AI-327) ! if Ada_Version >= Ada_2005 and then Nkind (Nam) = N_Attribute_Reference and then Attribute_Name (Nam) = Name_Priority then null; ! elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then declare *************** package body Sem_Ch8 is *** 1102,1108 **** -- Ada 2005 (AI-327) ! elsif Ada_Version >= Ada_05 and then Nkind (Nam) = N_Attribute_Reference and then Attribute_Name (Nam) = Name_Priority then --- 1103,1109 ---- -- Ada 2005 (AI-327) ! elsif Ada_Version >= Ada_2005 and then Nkind (Nam) = N_Attribute_Reference and then Attribute_Name (Nam) = Name_Priority then *************** package body Sem_Ch8 is *** 1315,1321 **** begin if not Is_Overloaded (P) then if Ekind (Etype (Nam)) /= E_Subprogram_Type ! or else not Type_Conformant (Etype (Nam), New_S) then Error_Msg_N ("designated type does not match specification", P); else Resolve (P); --- 1316,1323 ---- begin if not Is_Overloaded (P) then if Ekind (Etype (Nam)) /= E_Subprogram_Type ! or else not Type_Conformant (Etype (Nam), New_S) ! then Error_Msg_N ("designated type does not match specification", P); else Resolve (P); *************** package body Sem_Ch8 is *** 1330,1337 **** while Present (It.Nam) loop if Ekind (It.Nam) = E_Subprogram_Type ! and then Type_Conformant (It.Nam, New_S) then ! if Typ /= Any_Id then Error_Msg_N ("ambiguous renaming", P); return; --- 1332,1339 ---- while Present (It.Nam) loop if Ekind (It.Nam) = E_Subprogram_Type ! and then Type_Conformant (It.Nam, New_S) ! then if Typ /= Any_Id then Error_Msg_N ("ambiguous renaming", P); return; *************** package body Sem_Ch8 is *** 1966,1972 **** -- Ada 2005: check overriding indicator ! if Is_Overriding_Operation (Rename_Spec) then if Must_Not_Override (Specification (N)) then Error_Msg_NE ("subprogram& overrides inherited operation", --- 1968,1974 ---- -- Ada 2005: check overriding indicator ! if Present (Overridden_Operation (Rename_Spec)) then if Must_Not_Override (Specification (N)) then Error_Msg_NE ("subprogram& overrides inherited operation", *************** package body Sem_Ch8 is *** 2077,2084 **** Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); return; ! elsif (not Is_Entity_Name (Nam) ! and then Nkind (Nam) /= N_Operator_Symbol) or else not Is_Overloadable (Entity (Nam)) then Error_Msg_N ("expect valid subprogram name in renaming", N); --- 2079,2085 ---- Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); return; ! elsif not Is_Entity_Name (Nam) or else not Is_Overloadable (Entity (Nam)) then Error_Msg_N ("expect valid subprogram name in renaming", N); *************** package body Sem_Ch8 is *** 2099,2104 **** --- 2100,2120 ---- if No (Old_S) then Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); + -- The visible operation may be an inherited abstract operation that + -- was overridden in the private part, in which case a call will + -- dispatch to the overriding operation. Use the overriding one in + -- the renaming declaration, to prevent spurious errors below. + + if Is_Overloadable (Old_S) + and then Is_Abstract_Subprogram (Old_S) + and then No (DTC_Entity (Old_S)) + and then Present (Alias (Old_S)) + and then not Is_Abstract_Subprogram (Alias (Old_S)) + and then Present (Overridden_Operation (Alias (Old_S))) + then + Old_S := Alias (Old_S); + end if; + -- When the renamed subprogram is overloaded and used as an actual -- of a generic, its entity is set to the first available homonym. -- We must first disambiguate the name, then set the proper entity. *************** package body Sem_Ch8 is *** 2127,2133 **** -- when performing a null exclusion check between a renaming and a -- renamed subprogram that has been found to be illegal. ! if Ada_Version >= Ada_05 and then Entity (Nam) /= Any_Id then Check_Null_Exclusion --- 2143,2149 ---- -- when performing a null exclusion check between a renaming and a -- renamed subprogram that has been found to be illegal. ! if Ada_Version >= Ada_2005 and then Entity (Nam) /= Any_Id then Check_Null_Exclusion *************** package body Sem_Ch8 is *** 2149,2157 **** -- Guard against previous errors, and omit renamings of predefined -- operators. ! elsif Ekind (Old_S) /= E_Function ! and then Ekind (Old_S) /= E_Procedure ! then null; elsif Requires_Overriding (Old_S) --- 2165,2171 ---- -- Guard against previous errors, and omit renamings of predefined -- operators. ! elsif not Ekind_In (Old_S, E_Function, E_Procedure) then null; elsif Requires_Overriding (Old_S) *************** package body Sem_Ch8 is *** 2435,2441 **** -- is dispatching. Test is skipped if some previous error was detected -- that set Old_S to Any_Id. ! if Ada_Version >= Ada_05 and then Old_S /= Any_Id and then not Is_Dispatching_Operation (Old_S) and then Is_Dispatching_Operation (New_S) --- 2449,2455 ---- -- is dispatching. Test is skipped if some previous error was detected -- that set Old_S to Any_Id. ! if Ada_Version >= Ada_2005 and then Old_S /= Any_Id and then not Is_Dispatching_Operation (Old_S) and then Is_Dispatching_Operation (New_S) *************** package body Sem_Ch8 is *** 2465,2482 **** end if; -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005) if Comes_From_Source (N) and then Present (Old_S) ! and then Nkind (Old_S) = N_Defining_Operator_Symbol and then Nkind (New_S) = N_Defining_Operator_Symbol and then Chars (Old_S) /= Chars (New_S) then Error_Msg_NE ! ("?& is being renamed as a different operator", ! New_S, Old_S); end if; -- Another warning or some utility: if the new subprogram as the same -- name as the old one, the old one is not hidden by an outer homograph, -- the new one is not a public symbol, and the old one is otherwise --- 2479,2504 ---- end if; -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005) + -- is to warn if an operator is being renamed as a different operator. + -- If the operator is predefined, examine the kind of the entity, not + -- the abbreviated declaration in Standard. if Comes_From_Source (N) and then Present (Old_S) ! and then ! (Nkind (Old_S) = N_Defining_Operator_Symbol ! or else Ekind (Old_S) = E_Operator) and then Nkind (New_S) = N_Defining_Operator_Symbol and then Chars (Old_S) /= Chars (New_S) then Error_Msg_NE ! ("?& is being renamed as a different operator", N, Old_S); end if; + -- Check for renaming of obsolescent subprogram + + Check_Obsolescent_2005_Entity (Entity (Nam), Nam); + -- Another warning or some utility: if the new subprogram as the same -- name as the old one, the old one is not hidden by an outer homograph, -- the new one is not a public symbol, and the old one is otherwise *************** package body Sem_Ch8 is *** 2584,2591 **** ("a generic package is not allowed in a use clause", Pack_Name); else ! Error_Msg_N -- CODEFIX??? ! ("& is not a usable package", Pack_Name); end if; else --- 2606,2612 ---- ("a generic package is not allowed in a use clause", Pack_Name); else ! Error_Msg_N ("& is not a usable package", Pack_Name); end if; else *************** package body Sem_Ch8 is *** 2706,2712 **** if Warn_On_Redundant_Constructs and then Pack = Current_Scope then ! Error_Msg_NE ("& is already use-visible within itself?", Pack_Name, Pack); end if; --- 2727,2733 ---- if Warn_On_Redundant_Constructs and then Pack = Current_Scope then ! Error_Msg_NE -- CODEFIX ("& is already use-visible within itself?", Pack_Name, Pack); end if; *************** package body Sem_Ch8 is *** 2838,2856 **** if Aname = Name_AST_Entry then declare ! Ent : Entity_Id; Decl : Node_Id; begin - Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Decl := Make_Object_Declaration (Loc, Defining_Identifier => Ent, ! Object_Definition => New_Occurrence_Of (RTE (RE_AST_Handler), Loc), ! Expression => Nam, ! Constant_Present => True); Set_Assignment_OK (Decl, True); Insert_Action (N, Decl); --- 2859,2875 ---- if Aname = Name_AST_Entry then declare ! Ent : constant Entity_Id := Make_Temporary (Loc, 'R', Nam); Decl : Node_Id; begin Decl := Make_Object_Declaration (Loc, Defining_Identifier => Ent, ! Object_Definition => New_Occurrence_Of (RTE (RE_AST_Handler), Loc), ! Expression => Nam, ! Constant_Present => True); Set_Assignment_OK (Decl, True); Insert_Action (N, Decl); *************** package body Sem_Ch8 is *** 2918,2924 **** -- type is still not frozen). We exclude from this processing generic -- formal subprograms found in instantiations and AST_Entry renamings. ! if not Present (Corresponding_Formal_Spec (N)) and then Etype (Nam) /= RTE (RE_AST_Handler) then declare --- 2937,2947 ---- -- type is still not frozen). We exclude from this processing generic -- formal subprograms found in instantiations and AST_Entry renamings. ! -- We must exclude VM targets because entity AST_Handler is defined in ! -- package System.Aux_Dec which is not available in those platforms. ! ! if VM_Target = No_VM ! and then not Present (Corresponding_Formal_Spec (N)) and then Etype (Nam) /= RTE (RE_AST_Handler) then declare *************** package body Sem_Ch8 is *** 3042,3047 **** --- 3065,3120 ---- end if; end Check_Frozen_Renaming; + ------------------------------- + -- Set_Entity_Or_Discriminal -- + ------------------------------- + + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id) is + P : Node_Id; + + begin + -- If the entity is not a discriminant, or else expansion is disabled, + -- simply set the entity. + + if not In_Spec_Expression + or else Ekind (E) /= E_Discriminant + or else Inside_A_Generic + then + Set_Entity_With_Style_Check (N, E); + + -- The replacement of a discriminant by the corresponding discriminal + -- is not done for a task discriminant that appears in a default + -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant + -- for details on their handling. + + elsif Is_Concurrent_Type (Scope (E)) then + + P := Parent (N); + while Present (P) + and then not Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + loop + P := Parent (P); + end loop; + + if Present (P) + and then Nkind (P) = N_Parameter_Specification + then + null; + + else + Set_Entity (N, Discriminal (E)); + end if; + + -- Otherwise, this is a discriminant in a context in which + -- it is a reference to the corresponding parameter of the + -- init proc for the enclosing type. + + else + Set_Entity (N, Discriminal (E)); + end if; + end Set_Entity_Or_Discriminal; + ----------------------------------- -- Check_In_Previous_With_Clause -- ----------------------------------- *************** package body Sem_Ch8 is *** 3076,3083 **** end loop; if Is_Child_Unit (Entity (Original_Node (Par))) then ! Error_Msg_NE ! ("& is not directly visible", Par, Entity (Par)); else return; end if; --- 3149,3155 ---- end loop; if Is_Child_Unit (Entity (Original_Node (Par))) then ! Error_Msg_NE ("& is not directly visible", Par, Entity (Par)); else return; end if; *************** package body Sem_Ch8 is *** 3292,3315 **** Id : Entity_Id; Elmt : Elmt_Id; ! function Is_Primitive_Operator (Op : Entity_Id; F : Entity_Id) return Boolean; -- Check whether Op is a primitive operator of a use-visible type ! --------------------------- ! -- Is_Primitive_Operator -- ! --------------------------- ! function Is_Primitive_Operator (Op : Entity_Id; F : Entity_Id) return Boolean is T : constant Entity_Id := Etype (F); begin ! return In_Use (T) and then Scope (T) = Scope (Op); ! end Is_Primitive_Operator; -- Start of processing for End_Use_Package --- 3364,3388 ---- Id : Entity_Id; Elmt : Elmt_Id; ! function Is_Primitive_Operator_In_Use (Op : Entity_Id; F : Entity_Id) return Boolean; -- Check whether Op is a primitive operator of a use-visible type ! ---------------------------------- ! -- Is_Primitive_Operator_In_Use -- ! ---------------------------------- ! function Is_Primitive_Operator_In_Use (Op : Entity_Id; F : Entity_Id) return Boolean is T : constant Entity_Id := Etype (F); begin ! return (In_Use (T) ! or else Present (Current_Use_Clause (Base_Type (T)))) and then Scope (T) = Scope (Op); ! end Is_Primitive_Operator_In_Use; -- Start of processing for End_Use_Package *************** package body Sem_Ch8 is *** 3340,3350 **** if Nkind (Id) = N_Defining_Operator_Symbol and then ! (Is_Primitive_Operator (Id, First_Formal (Id)) or else (Present (Next_Formal (First_Formal (Id))) and then ! Is_Primitive_Operator (Id, Next_Formal (First_Formal (Id))))) then null; --- 3413,3424 ---- if Nkind (Id) = N_Defining_Operator_Symbol and then ! (Is_Primitive_Operator_In_Use ! (Id, First_Formal (Id)) or else (Present (Next_Formal (First_Formal (Id))) and then ! Is_Primitive_Operator_In_Use (Id, Next_Formal (First_Formal (Id))))) then null; *************** package body Sem_Ch8 is *** 3426,3458 **** ------------------ procedure End_Use_Type (N : Node_Id) is Id : Entity_Id; Op_List : Elist_Id; ! Elmt : Elmt_Id; T : Entity_Id; begin Id := First (Subtype_Marks (N)); while Present (Id) loop ! -- A call to rtsfind may occur while analyzing a use_type clause, -- in which case the type marks are not resolved yet, and there is -- nothing to remove. ! if not Is_Entity_Name (Id) ! or else No (Entity (Id)) ! then goto Continue; end if; T := Entity (Id); ! if T = Any_Type ! or else From_With_Type (T) ! then null; ! -- Note that the use_Type clause may mention a subtype of the type -- whose primitive operations have been made visible. Here as -- elsewhere, it is the base type that matters for visibility. --- 3500,3546 ---- ------------------ procedure End_Use_Type (N : Node_Id) is + Elmt : Elmt_Id; Id : Entity_Id; Op_List : Elist_Id; ! Op : Entity_Id; T : Entity_Id; + function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean; + -- An operator may be primitive in several types, if they are declared + -- in the same scope as the operator. To determine the use-visibility of + -- the operator in such cases we must examine all types in the profile. + + ------------------------------ + -- May_Be_Used_Primitive_Of -- + ------------------------------ + + function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean is + begin + return Scope (Op) = Scope (T) + and then (In_Use (T) or else Is_Potentially_Use_Visible (T)); + end May_Be_Used_Primitive_Of; + + -- Start of processing for End_Use_Type + begin Id := First (Subtype_Marks (N)); while Present (Id) loop ! -- A call to Rtsfind may occur while analyzing a use_type clause, -- in which case the type marks are not resolved yet, and there is -- nothing to remove. ! if not Is_Entity_Name (Id) or else No (Entity (Id)) then goto Continue; end if; T := Entity (Id); ! if T = Any_Type or else From_With_Type (T) then null; ! -- Note that the use_type clause may mention a subtype of the type -- whose primitive operations have been made visible. Here as -- elsewhere, it is the base type that matters for visibility. *************** package body Sem_Ch8 is *** 3468,3475 **** Elmt := First_Elmt (Op_List); while Present (Elmt) loop ! if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then ! Set_Is_Potentially_Use_Visible (Node (Elmt), False); end if; Next_Elmt (Elmt); --- 3556,3585 ---- Elmt := First_Elmt (Op_List); while Present (Elmt) loop ! Op := Node (Elmt); ! ! if Nkind (Op) = N_Defining_Operator_Symbol then ! declare ! T_First : constant Entity_Id := ! Base_Type (Etype (First_Formal (Op))); ! T_Res : constant Entity_Id := Base_Type (Etype (Op)); ! T_Next : Entity_Id; ! ! begin ! if Present (Next_Formal (First_Formal (Op))) then ! T_Next := ! Base_Type (Etype (Next_Formal (First_Formal (Op)))); ! else ! T_Next := T_First; ! end if; ! ! if not May_Be_Used_Primitive_Of (T_First) ! and then not May_Be_Used_Primitive_Of (T_Next) ! and then not May_Be_Used_Primitive_Of (T_Res) ! then ! Set_Is_Potentially_Use_Visible (Op, False); ! end if; ! end; end if; Next_Elmt (Elmt); *************** package body Sem_Ch8 is *** 3805,3813 **** Nkind (Parent (Parent (N))) = N_Use_Package_Clause then Error_Msg_Qual_Level := 99; ! Error_Msg_NE ("\\missing `WITH &;`", N, Ent); Error_Msg_Qual_Level := 0; end if; end if; -- Set entity and its containing package as referenced. We --- 3915,3934 ---- Nkind (Parent (Parent (N))) = N_Use_Package_Clause then Error_Msg_Qual_Level := 99; ! Error_Msg_NE -- CODEFIX ! ("\\missing `WITH &;`", N, Ent); Error_Msg_Qual_Level := 0; end if; + + if Ekind (Ent) = E_Discriminant + and then Present (Corresponding_Discriminant (Ent)) + and then Scope (Corresponding_Discriminant (Ent)) = + Etype (Scope (Ent)) + then + Error_Msg_N + ("inherited discriminant not allowed here" & + " (RM 3.8 (12), 3.8.1 (6))!", N); + end if; end if; -- Set entity and its containing package as referenced. We *************** package body Sem_Ch8 is *** 3873,3879 **** if Chars (Lit) /= Chars (N) and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then Error_Msg_Node_2 := Lit; ! Error_Msg_N ("& is undefined, assume misspelling of &", N); Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); return; --- 3994,4000 ---- if Chars (Lit) /= Chars (N) and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then Error_Msg_Node_2 := Lit; ! Error_Msg_N -- CODEFIX ("& is undefined, assume misspelling of &", N); Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); return; *************** package body Sem_Ch8 is *** 3937,3943 **** -- this is a very common error for beginners to make). if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then ! Error_Msg_N ("\\possible missing `WITH Ada.Text_'I'O; " & "USE Ada.Text_'I'O`!", N); --- 4058,4064 ---- -- this is a very common error for beginners to make). if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then ! Error_Msg_N -- CODEFIX ("\\possible missing `WITH Ada.Text_'I'O; " & "USE Ada.Text_'I'O`!", N); *************** package body Sem_Ch8 is *** 3950,3956 **** and then Is_Known_Unit (Parent (N)) then Error_Msg_Node_2 := Selector_Name (Parent (N)); ! Error_Msg_N ("\\missing `WITH &.&;`", Prefix (Parent (N))); end if; -- Now check for possible misspellings --- 4071,4078 ---- and then Is_Known_Unit (Parent (N)) then Error_Msg_Node_2 := Selector_Name (Parent (N)); ! Error_Msg_N -- CODEFIX ! ("\\missing `WITH &.&;`", Prefix (Parent (N))); end if; -- Now check for possible misspellings *************** package body Sem_Ch8 is *** 4314,4319 **** --- 4436,4445 ---- <> begin + -- Check violation of No_Wide_Characters restriction + + Check_Wide_Character_Restriction (E, N); + -- When distribution features are available (Get_PCS_Name /= -- Name_No_DSA), a remote access-to-subprogram type is converted -- into a record type holding whatever information is needed to *************** package body Sem_Ch8 is *** 4336,4343 **** return; end if; ! Set_Entity (N, E); ! -- Why no Style_Check here??? if Is_Type (E) then Set_Etype (N, E); --- 4462,4479 ---- return; end if; ! -- Set the entity. Note that the reason we call Set_Entity for the ! -- overloadable case, as opposed to Set_Entity_With_Style_Check is ! -- that in the overloaded case, the initial call can set the wrong ! -- homonym. The call that sets the right homonym is in Sem_Res and ! -- that call does use Set_Entity_With_Style_Check, so we don't miss ! -- a style check. ! ! if Is_Overloadable (E) then ! Set_Entity (N, E); ! else ! Set_Entity_With_Style_Check (N, E); ! end if; if Is_Type (E) then Set_Etype (N, E); *************** package body Sem_Ch8 is *** 4447,4504 **** Check_Nested_Access (E); end if; ! -- Set Entity, with style check if need be. For a discriminant ! -- reference, replace by the corresponding discriminal, i.e. the ! -- parameter of the initialization procedure that corresponds to ! -- the discriminant. If this replacement is being performed, there ! -- is no style check to perform. ! ! -- This replacement must not be done if we are currently ! -- processing a generic spec or body, because the discriminal ! -- has not been not generated in this case. ! ! -- The replacement is also skipped if we are in special ! -- spec-expression mode. Why is this skipped in this case ??? ! ! if not In_Spec_Expression ! or else Ekind (E) /= E_Discriminant ! or else Inside_A_Generic ! then ! Set_Entity_With_Style_Check (N, E); ! ! -- The replacement is not done either for a task discriminant that ! -- appears in a default expression of an entry parameter. See ! -- Expand_Discriminant in exp_ch2 for details on their handling. ! ! elsif Is_Concurrent_Type (Scope (E)) then ! declare ! P : Node_Id; ! ! begin ! P := Parent (N); ! while Present (P) ! and then not Nkind_In (P, N_Parameter_Specification, ! N_Component_Declaration) ! loop ! P := Parent (P); ! end loop; ! ! if Present (P) ! and then Nkind (P) = N_Parameter_Specification ! then ! null; ! else ! Set_Entity (N, Discriminal (E)); ! end if; ! end; ! ! -- Otherwise, this is a discriminant in a context in which ! -- it is a reference to the corresponding parameter of the ! -- init proc for the enclosing type. ! ! else ! Set_Entity (N, Discriminal (E)); ! end if; end if; end; end Find_Direct_Name; --- 4583,4589 ---- Check_Nested_Access (E); end if; ! Set_Entity_Or_Discriminal (N, E); end if; end; end Find_Direct_Name; *************** package body Sem_Ch8 is *** 4688,4694 **** else Error_Msg_Qual_Level := 99; ! Error_Msg_NE ("missing `WITH &;`", Selector, Candidate); Error_Msg_Qual_Level := 0; end if; --- 4773,4780 ---- else Error_Msg_Qual_Level := 99; ! Error_Msg_NE -- CODEFIX ! ("missing `WITH &;`", Selector, Candidate); Error_Msg_Qual_Level := 0; end if; *************** package body Sem_Ch8 is *** 4719,4727 **** exit when S = Standard_Standard; ! if Ekind (S) = E_Function ! or else Ekind (S) = E_Package ! or else Ekind (S) = E_Procedure then P := Generic_Parent (Specification (Unit_Declaration_Node (S))); --- 4805,4813 ---- exit when S = Standard_Standard; ! if Ekind_In (S, E_Function, ! E_Package, ! E_Procedure) then P := Generic_Parent (Specification (Unit_Declaration_Node (S))); *************** package body Sem_Ch8 is *** 4745,4751 **** if Is_Known_Unit (N) then if not Error_Posted (N) then Error_Msg_Node_2 := Selector; ! Error_Msg_N ("missing `WITH &.&;`", Prefix (N)); end if; -- If this is a selection from a dummy package, then suppress --- 4831,4838 ---- if Is_Known_Unit (N) then if not Error_Posted (N) then Error_Msg_Node_2 := Selector; ! Error_Msg_N -- CODEFIX ! ("missing `WITH &.&;`", Prefix (N)); end if; -- If this is a selection from a dummy package, then suppress *************** package body Sem_Ch8 is *** 4785,4795 **** ("\use fully qualified name starting with" & " Standard to make& visible", N, H); Error_Msg_Qual_Level := 0; ! exit; end if; Next_Entity (Id); end loop; end; else --- 4872,4888 ---- ("\use fully qualified name starting with" & " Standard to make& visible", N, H); Error_Msg_Qual_Level := 0; ! goto Done; end if; Next_Entity (Id); end loop; + + -- If not found, standard error message. + + Error_Msg_NE ("& not declared in&", N, Selector); + + <> null; end; else *************** package body Sem_Ch8 is *** 4820,4826 **** (Generic_Parent (Parent (Entity (Prefix (N))))) then Error_Msg_Node_2 := Selector; ! Error_Msg_N ("\missing `WITH &.&;`", Prefix (N)); end if; end if; end if; --- 4913,4920 ---- (Generic_Parent (Parent (Entity (Prefix (N))))) then Error_Msg_Node_2 := Selector; ! Error_Msg_N -- CODEFIX ! ("\missing `WITH &.&;`", Prefix (N)); end if; end if; end if; *************** package body Sem_Ch8 is *** 4885,4891 **** if Has_Homonym (Id) then Set_Entity (N, Id); else ! Set_Entity_With_Style_Check (N, Id); Generate_Reference (Id, N); end if; --- 4979,4985 ---- if Has_Homonym (Id) then Set_Entity (N, Id); else ! Set_Entity_Or_Discriminal (N, Id); Generate_Reference (Id, N); end if; *************** package body Sem_Ch8 is *** 4895,4900 **** --- 4989,4998 ---- Set_Etype (N, Get_Full_View (Etype (Id))); end if; + -- Check for violation of No_Wide_Characters + + Check_Wide_Character_Restriction (Id, N); + -- If the Ekind of the entity is Void, it means that all homonyms are -- hidden from all visibility (RM 8.3(5,14-20)). *************** package body Sem_Ch8 is *** 5112,5122 **** function Report_Overload return Entity_Id is begin if Is_Actual then ! Error_Msg_NE ("ambiguous actual subprogram&, " & "possible interpretations:", N, Nam); else ! Error_Msg_N ("ambiguous subprogram, " & "possible interpretations:", N); end if; --- 5210,5220 ---- function Report_Overload return Entity_Id is begin if Is_Actual then ! Error_Msg_NE -- CODEFIX ("ambiguous actual subprogram&, " & "possible interpretations:", N, Nam); else ! Error_Msg_N -- CODEFIX ("ambiguous subprogram, " & "possible interpretations:", N); end if; *************** package body Sem_Ch8 is *** 5273,5281 **** and then (not Is_Entity_Name (P) or else Chars (Entity (P)) /= Name_uInit) then ! C_Etype := ! Build_Actual_Subtype_Of_Component ( ! Etype (Selector), N); else C_Etype := Empty; end if; --- 5371,5399 ---- and then (not Is_Entity_Name (P) or else Chars (Entity (P)) /= Name_uInit) then ! -- Do not build the subtype when referencing components of ! -- dispatch table wrappers. Required to avoid generating ! -- elaboration code with HI runtimes. ! ! if RTU_Loaded (Ada_Tags) ! and then RTE_Available (RE_Dispatch_Table_Wrapper) ! and then Scope (Selector) = RTE (RE_Dispatch_Table_Wrapper) ! then ! C_Etype := Empty; ! ! elsif RTU_Loaded (Ada_Tags) ! and then RTE_Available (RE_No_Dispatch_Table_Wrapper) ! and then Scope (Selector) ! = RTE (RE_No_Dispatch_Table_Wrapper) ! then ! C_Etype := Empty; ! ! else ! C_Etype := ! Build_Actual_Subtype_Of_Component ( ! Etype (Selector), N); ! end if; ! else C_Etype := Empty; end if; *************** package body Sem_Ch8 is *** 5364,5369 **** --- 5482,5489 ---- Analyze_Selected_Component (N); + -- Reference to type name in predicate/invariant expression + elsif Is_Appropriate_For_Entry_Prefix (P_Type) and then not In_Open_Scopes (P_Name) and then (not Is_Concurrent_Type (Etype (P_Name)) *************** package body Sem_Ch8 is *** 5375,5384 **** Analyze_Selected_Component (N); elsif (In_Open_Scopes (P_Name) ! and then Ekind (P_Name) /= E_Void ! and then not Is_Overloadable (P_Name)) or else (Is_Concurrent_Type (Etype (P_Name)) ! and then In_Open_Scopes (Etype (P_Name))) then -- Prefix denotes an enclosing loop, block, or task, i.e. an -- enclosing construct that is not a subprogram or accept. --- 5495,5504 ---- Analyze_Selected_Component (N); elsif (In_Open_Scopes (P_Name) ! and then Ekind (P_Name) /= E_Void ! and then not Is_Overloadable (P_Name)) or else (Is_Concurrent_Type (Etype (P_Name)) ! and then In_Open_Scopes (Etype (P_Name))) then -- Prefix denotes an enclosing loop, block, or task, i.e. an -- enclosing construct that is not a subprogram or accept. *************** package body Sem_Ch8 is *** 5393,5400 **** -- The subprogram may be a renaming (of an enclosing scope) as -- in the case of the name of the generic within an instantiation. ! if (Ekind (P_Name) = E_Procedure ! or else Ekind (P_Name) = E_Function) and then Present (Alias (P_Name)) and then Is_Generic_Instance (Alias (P_Name)) then --- 5513,5519 ---- -- The subprogram may be a renaming (of an enclosing scope) as -- in the case of the name of the generic within an instantiation. ! if Ekind_In (P_Name, E_Procedure, E_Function) and then Present (Alias (P_Name)) and then Is_Generic_Instance (Alias (P_Name)) then *************** package body Sem_Ch8 is *** 5582,5588 **** -- It is legal to denote the class type of an incomplete -- type. The full type will have to be tagged, of course. -- In Ada 2005 this usage is declared obsolescent, so we ! -- warn accordingly. -- ??? This test is temporarily disabled (always False) -- because it causes an unwanted warning on GNAT sources --- 5701,5719 ---- -- It is legal to denote the class type of an incomplete -- type. The full type will have to be tagged, of course. -- In Ada 2005 this usage is declared obsolescent, so we ! -- warn accordingly. This usage is only legal if the type ! -- is completed in the current scope, and not for a limited ! -- view of a type. ! ! if not Is_Tagged_Type (T) ! and then Ada_Version >= Ada_2005 ! then ! if From_With_Type (T) then ! Error_Msg_N ! ("prefix of Class attribute must be tagged", N); ! Set_Etype (N, Any_Type); ! Set_Entity (N, Any_Type); ! return; -- ??? This test is temporarily disabled (always False) -- because it causes an unwanted warning on GNAT sources *************** package body Sem_Ch8 is *** 5590,5607 **** -- Feature). Once this issue is cleared in the sources, it -- can be enabled. ! if not Is_Tagged_Type (T) ! and then Ada_Version >= Ada_05 ! and then Warn_On_Obsolescent_Feature ! and then False ! then ! Error_Msg_N ! ("applying 'Class to an untagged incomplete type" ! & " is an obsolescent feature (RM J.11)", N); end if; Set_Is_Tagged_Type (T); ! Set_Primitive_Operations (T, New_Elmt_List); Make_Class_Wide_Type (T); Set_Entity (N, Class_Wide_Type (T)); Set_Etype (N, Class_Wide_Type (T)); --- 5721,5737 ---- -- Feature). Once this issue is cleared in the sources, it -- can be enabled. ! elsif Warn_On_Obsolescent_Feature ! and then False ! then ! Error_Msg_N ! ("applying 'Class to an untagged incomplete type" ! & " is an obsolescent feature (RM J.11)", N); ! end if; end if; Set_Is_Tagged_Type (T); ! Set_Direct_Primitive_Operations (T, New_Elmt_List); Make_Class_Wide_Type (T); Set_Entity (N, Class_Wide_Type (T)); Set_Etype (N, Class_Wide_Type (T)); *************** package body Sem_Ch8 is *** 5681,5699 **** ("prefix of Base attribute must be scalar type", Prefix (N)); ! elsif Sloc (Typ) = Standard_Location and then Base_Type (Typ) = Typ - and then Warn_On_Redundant_Constructs then ! Error_Msg_NE ("?redundant attribute, & is its own base type", N, Typ); end if; T := Base_Type (Typ); -- Rewrite attribute reference with type itself (see similar ! -- processing in Analyze_Attribute, case Base). Preserve ! -- prefix if present, for other legality checks. if Nkind (Prefix (N)) = N_Expanded_Name then Rewrite (N, --- 5811,5828 ---- ("prefix of Base attribute must be scalar type", Prefix (N)); ! elsif Warn_On_Redundant_Constructs and then Base_Type (Typ) = Typ then ! Error_Msg_NE -- CODEFIX ("?redundant attribute, & is its own base type", N, Typ); end if; T := Base_Type (Typ); -- Rewrite attribute reference with type itself (see similar ! -- processing in Analyze_Attribute, case Base). Preserve prefix ! -- if present, for other legality checks. if Nkind (Prefix (N)) = N_Expanded_Name then Rewrite (N, *************** package body Sem_Ch8 is *** 5783,5789 **** -- nor anywhere else in the declaration because entries -- cannot have access parameters. ! if Ada_Version >= Ada_05 and then Nkind (Parent (N)) = N_Access_Definition then Set_Entity (N, T_Name); --- 5912,5918 ---- -- nor anywhere else in the declaration because entries -- cannot have access parameters. ! if Ada_Version >= Ada_2005 and then Nkind (Parent (N)) = N_Access_Definition then Set_Entity (N, T_Name); *************** package body Sem_Ch8 is *** 5809,5815 **** -- In Ada 2005, a protected name can be used in an access -- definition within its own body. ! if Ada_Version >= Ada_05 and then Nkind (Parent (N)) = N_Access_Definition then Set_Entity (N, T_Name); --- 5938,5944 ---- -- In Ada 2005, a protected name can be used in an access -- definition within its own body. ! if Ada_Version >= Ada_2005 and then Nkind (Parent (N)) = N_Access_Definition then Set_Entity (N, T_Name); *************** package body Sem_Ch8 is *** 5875,5883 **** while Present (Id) and then Id /= Priv_Id loop ! if Is_Standard_Character_Type (Id) ! and then Id = Base_Type (Id) ! then -- We replace the node with the literal itself, resolve as a -- character, and set the type correctly. --- 6004,6011 ---- while Present (Id) and then Id /= Priv_Id loop ! if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then ! -- We replace the node with the literal itself, resolve as a -- character, and set the type correctly. *************** package body Sem_Ch8 is *** 5968,5979 **** Change_Selected_Component_To_Expanded_Name (N); end if; ! Add_One_Interp (N, Predef_Op, T); ! -- For operators with unary and binary interpretations, add both ! if Present (Homonym (Predef_Op)) then ! Add_One_Interp (N, Homonym (Predef_Op), T); end if; -- The node is a reference to a predefined operator, and --- 6096,6140 ---- Change_Selected_Component_To_Expanded_Name (N); end if; ! -- If the context is an unanalyzed function call, determine whether ! -- a binary or unary interpretation is required. ! if Nkind (Parent (N)) = N_Indexed_Component then ! declare ! Is_Binary_Call : constant Boolean := ! Present ! (Next (First (Expressions (Parent (N))))); ! Is_Binary_Op : constant Boolean := ! First_Entity ! (Predef_Op) /= Last_Entity (Predef_Op); ! Predef_Op2 : constant Entity_Id := Homonym (Predef_Op); ! begin ! if Is_Binary_Call then ! if Is_Binary_Op then ! Add_One_Interp (N, Predef_Op, T); ! else ! Add_One_Interp (N, Predef_Op2, T); ! end if; ! ! else ! if not Is_Binary_Op then ! Add_One_Interp (N, Predef_Op, T); ! else ! Add_One_Interp (N, Predef_Op2, T); ! end if; ! end if; ! end; ! ! else ! Add_One_Interp (N, Predef_Op, T); ! ! -- For operators with unary and binary interpretations, if ! -- context is not a call, add both ! ! if Present (Homonym (Predef_Op)) then ! Add_One_Interp (N, Homonym (Predef_Op), T); ! end if; end if; -- The node is a reference to a predefined operator, and *************** package body Sem_Ch8 is *** 6005,6013 **** when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor => while Id /= Priv_Id loop ! if Valid_Boolean_Arg (Id) ! and then Id = Base_Type (Id) ! then Add_Implicit_Operator (Id); return True; end if; --- 6166,6172 ---- when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor => while Id /= Priv_Id loop ! if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); return True; end if; *************** package body Sem_Ch8 is *** 6021,6027 **** while Id /= Priv_Id loop if Is_Type (Id) and then not Is_Limited_Type (Id) ! and then Id = Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); return True; --- 6180,6186 ---- while Id /= Priv_Id loop if Is_Type (Id) and then not Is_Limited_Type (Id) ! and then Is_Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); return True; *************** package body Sem_Ch8 is *** 6035,6043 **** when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge => while Id /= Priv_Id loop if (Is_Scalar_Type (Id) ! or else (Is_Array_Type (Id) ! and then Is_Scalar_Type (Component_Type (Id)))) ! and then Id = Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); return True; --- 6194,6202 ---- when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge => while Id /= Priv_Id loop if (Is_Scalar_Type (Id) ! or else (Is_Array_Type (Id) ! and then Is_Scalar_Type (Component_Type (Id)))) ! and then Is_Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); return True; *************** package body Sem_Ch8 is *** 6057,6065 **** Name_Op_Divide | Name_Op_Expon => while Id /= Priv_Id loop ! if Is_Numeric_Type (Id) ! and then Id = Base_Type (Id) ! then Add_Implicit_Operator (Id); return True; end if; --- 6216,6222 ---- Name_Op_Divide | Name_Op_Expon => while Id /= Priv_Id loop ! if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); return True; end if; *************** package body Sem_Ch8 is *** 6071,6078 **** when Name_Op_Concat => while Id /= Priv_Id loop ! if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1 ! and then Id = Base_Type (Id) then Add_Implicit_Operator (Id); return True; --- 6228,6236 ---- when Name_Op_Concat => while Id /= Priv_Id loop ! if Is_Array_Type (Id) ! and then Number_Dimensions (Id) = 1 ! and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); return True; *************** package body Sem_Ch8 is *** 6170,6178 **** Next_Formal (Old_F); end loop; ! if Ekind (Old_S) = E_Function ! or else Ekind (Old_S) = E_Enumeration_Literal ! then Set_Etype (New_S, Etype (Old_S)); end if; end if; --- 6328,6334 ---- Next_Formal (Old_F); end loop; ! if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then Set_Etype (New_S, Etype (Old_S)); end if; end if; *************** package body Sem_Ch8 is *** 6488,6494 **** if Present (Redundant) then Error_Msg_Sloc := Sloc (Prev_Use); ! Error_Msg_NE ("& is already use-visible through previous use clause #?", Redundant, Pack_Name); end if; --- 6644,6650 ---- if Present (Redundant) then Error_Msg_Sloc := Sloc (Prev_Use); ! Error_Msg_NE -- CODEFIX ("& is already use-visible through previous use clause #?", Redundant, Pack_Name); end if; *************** package body Sem_Ch8 is *** 6500,6517 **** procedure Pop_Scope is SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); begin if Debug_Flag_E then Write_Info; end if; Scope_Suppress := SST.Save_Scope_Suppress; Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; Check_Policy_List := SST.Save_Check_Policy_List; if Debug_Flag_W then ! Write_Str ("--> exiting scope: "); Write_Name (Chars (Current_Scope)); Write_Str (", Depth="); Write_Int (Int (Scope_Stack.Last)); --- 6656,6691 ---- procedure Pop_Scope is SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + S : constant Entity_Id := SST.Entity; begin if Debug_Flag_E then Write_Info; end if; + -- Set Default_Storage_Pool field of the library unit if necessary + + if Ekind_In (S, E_Package, E_Generic_Package) + and then + Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit + then + declare + Aux : constant Node_Id := + Aux_Decls_Node (Parent (Unit_Declaration_Node (S))); + begin + if No (Default_Storage_Pool (Aux)) then + Set_Default_Storage_Pool (Aux, Default_Pool); + end if; + end; + end if; + Scope_Suppress := SST.Save_Scope_Suppress; Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; Check_Policy_List := SST.Save_Check_Policy_List; + Default_Pool := SST.Save_Default_Storage_Pool; if Debug_Flag_W then ! Write_Str ("<-- exiting scope: "); Write_Name (Chars (Current_Scope)); Write_Str (", Depth="); Write_Int (Int (Scope_Stack.Last)); *************** package body Sem_Ch8 is *** 6529,6535 **** or else SST.Actions_To_Be_Wrapped_After /= No_List then ! return; end if; -- Free last subprogram name if allocated, and pop scope --- 6703,6709 ---- or else SST.Actions_To_Be_Wrapped_After /= No_List then ! raise Program_Error; end if; -- Free last subprogram name if allocated, and pop scope *************** package body Sem_Ch8 is *** 6543,6549 **** --------------- procedure Push_Scope (S : Entity_Id) is ! E : Entity_Id; begin if Ekind (S) = E_Void then --- 6717,6723 ---- --------------- procedure Push_Scope (S : Entity_Id) is ! E : constant Entity_Id := Scope (S); begin if Ekind (S) = E_Void then *************** package body Sem_Ch8 is *** 6581,6586 **** --- 6755,6761 ---- SST.Save_Scope_Suppress := Scope_Suppress; SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top; SST.Save_Check_Policy_List := Check_Policy_List; + SST.Save_Default_Storage_Pool := Default_Pool; if Scope_Stack.Last > Scope_Stack.First then SST.Component_Alignment_Default := Scope_Stack.Table *************** package body Sem_Ch8 is *** 6617,6624 **** and then Scope (S) /= Standard_Standard and then not Is_Child_Unit (S) then - E := Scope (S); - if Nkind (E) not in N_Entity then return; end if; --- 6792,6797 ---- *************** package body Sem_Ch8 is *** 6640,6645 **** --- 6813,6834 ---- Set_Categorization_From_Scope (E => S, Scop => E); end if; end if; + + if Is_Child_Unit (S) + and then Present (E) + and then Ekind_In (E, E_Package, E_Generic_Package) + and then + Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit + then + declare + Aux : constant Node_Id := + Aux_Decls_Node (Parent (Unit_Declaration_Node (E))); + begin + if Present (Default_Storage_Pool (Aux)) then + Default_Pool := Default_Storage_Pool (Aux); + end if; + end; + end if; end Push_Scope; --------------------- *************** package body Sem_Ch8 is *** 7162,7172 **** -- we compare the scope depth of its scope with that of the -- current instance. However, a generic actual of a subprogram -- instance is declared in the wrapper package but will not be ! -- hidden by a use-visible entity. Similarly, a generic actual ! -- will not be hidden by an entity declared in another generic ! -- actual, which can only have been use-visible in the generic. ! -- Is this condition complete, and can the following complex ! -- test be simplified ??? -- If Id is called Standard, the predefined package with the -- same name is in the homonym chain. It has to be ignored --- 7351,7361 ---- -- we compare the scope depth of its scope with that of the -- current instance. However, a generic actual of a subprogram -- instance is declared in the wrapper package but will not be ! -- hidden by a use-visible entity. similarly, an entity that is ! -- declared in an enclosing instance will not be hidden by an ! -- an entity declared in a generic actual, which can only have ! -- been use-visible in the generic and will not have hidden the ! -- entity in the generic parent. -- If Id is called Standard, the predefined package with the -- same name is in the homonym chain. It has to be ignored *************** package body Sem_Ch8 is *** 7181,7188 **** and then (Scope (Prev) /= Standard_Standard or else Sloc (Prev) > Standard_Location) then ! if Ekind (Prev) = E_Package ! and then Present (Associated_Formal_Package (Prev)) and then Present (Associated_Formal_Package (P)) then null; --- 7370,7377 ---- and then (Scope (Prev) /= Standard_Standard or else Sloc (Prev) > Standard_Location) then ! if In_Open_Scopes (Scope (Prev)) ! and then Is_Generic_Instance (Scope (Prev)) and then Present (Associated_Formal_Package (P)) then null; *************** package body Sem_Ch8 is *** 7223,7230 **** and then Scope (Id) /= Scope (Prev) and then Used_As_Generic_Actual (Scope (Prev)) and then Used_As_Generic_Actual (Scope (Id)) ! and then List_Containing (Current_Use_Clause (Scope (Prev))) /= ! List_Containing (Current_Use_Clause (Scope (Id))) then Set_Is_Potentially_Use_Visible (Prev, False); Append_Elmt (Prev, Hidden_By_Use_Clause (N)); --- 7412,7419 ---- and then Scope (Id) /= Scope (Prev) and then Used_As_Generic_Actual (Scope (Prev)) and then Used_As_Generic_Actual (Scope (Id)) ! and then not In_Same_List (Current_Use_Clause (Scope (Prev)), ! Current_Use_Clause (Scope (Id))) then Set_Is_Potentially_Use_Visible (Prev, False); Append_Elmt (Prev, Hidden_By_Use_Clause (N)); *************** package body Sem_Ch8 is *** 7466,7479 **** if Unit1 = Unit2 then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); ! Error_Msg_NE ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; elsif Nkind (Unit1) = N_Subunit then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); ! Error_Msg_NE ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; --- 7655,7668 ---- if Unit1 = Unit2 then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); ! Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; elsif Nkind (Unit1) = N_Subunit then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); ! Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; *************** package body Sem_Ch8 is *** 7483,7489 **** and then Nkind (Unit1) /= N_Subunit then Error_Msg_Sloc := Sloc (Clause1); ! Error_Msg_NE ("& is already use-visible through previous " & "use_type_clause #?", Current_Use_Clause (T), T); return; --- 7672,7678 ---- and then Nkind (Unit1) /= N_Subunit then Error_Msg_Sloc := Sloc (Clause1); ! Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Current_Use_Clause (T), T); return; *************** package body Sem_Ch8 is *** 7516,7524 **** begin S1 := Scope (Ent1); S2 := Scope (Ent2); ! while S1 /= Standard_Standard ! and then ! S2 /= Standard_Standard loop S1 := Scope (S1); S2 := Scope (S2); --- 7705,7714 ---- begin S1 := Scope (Ent1); S2 := Scope (Ent2); ! while Present (S1) ! and then Present (S2) ! and then S1 /= Standard_Standard ! and then S2 /= Standard_Standard loop S1 := Scope (S1); S2 := Scope (S2); *************** package body Sem_Ch8 is *** 7534,7540 **** end; end if; ! Error_Msg_NE ("& is already use-visible through previous " & "use_type_clause #?", Err_No, Id); --- 7724,7730 ---- end; end if; ! Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Err_No, Id); *************** package body Sem_Ch8 is *** 7543,7549 **** -- level. In this case we don't have location information. else ! Error_Msg_NE ("& is already use-visible through previous " & "use type clause?", Id, T); end if; --- 7733,7739 ---- -- level. In this case we don't have location information. else ! Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use type clause?", Id, T); end if; *************** package body Sem_Ch8 is *** 7553,7559 **** -- where we do not have the location information available. else ! Error_Msg_NE ("& is already use-visible through previous " & "use type clause?", Id, T); end if; --- 7743,7749 ---- -- where we do not have the location information available. else ! Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use type clause?", Id, T); end if; *************** package body Sem_Ch8 is *** 7562,7568 **** elsif In_Use (Scope (T)) then Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T))); ! Error_Msg_NE ("& is already use-visible through package use clause #?", Id, T); --- 7752,7758 ---- elsif In_Use (Scope (T)) then Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T))); ! Error_Msg_NE -- CODEFIX ("& is already use-visible through package use clause #?", Id, T); *************** package body Sem_Ch8 is *** 7570,7576 **** else Error_Msg_Node_2 := Scope (T); ! Error_Msg_NE ("& is already use-visible inside package &?", Id, T); end if; end if; --- 7760,7766 ---- else Error_Msg_Node_2 := Scope (T); ! Error_Msg_NE -- CODEFIX ("& is already use-visible inside package &?", Id, T); end if; end if; *************** package body Sem_Ch8 is *** 7619,7629 **** Write_Eol; end Write_Info; ! ----------------- ! -- Write_Scopes -- ! ----------------- ! procedure Write_Scopes is S : Entity_Id; begin for J in reverse 1 .. Scope_Stack.Last loop --- 7809,7819 ---- Write_Eol; end Write_Info; ! -------- ! -- ws -- ! -------- ! procedure ws is S : Entity_Id; begin for J in reverse 1 .. Scope_Stack.Last loop *************** package body Sem_Ch8 is *** 7633,7638 **** Write_Name (Chars (S)); Write_Eol; end loop; ! end Write_Scopes; end Sem_Ch8; --- 7823,7828 ---- Write_Name (Chars (S)); Write_Eol; end loop; ! end ws; end Sem_Ch8; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch8.ads gcc-4.6.0/gcc/ada/sem_ch8.ads *** gcc-4.5.2/gcc/ada/sem_ch8.ads Tue May 20 13:00:35 2008 --- gcc-4.6.0/gcc/ada/sem_ch8.ads Tue Aug 10 14:34:24 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Ch8 is *** 131,157 **** function Present_System_Aux (N : Node_Id := Empty) return Boolean; -- Return True if the auxiliary system file has been successfully loaded. -- Otherwise attempt to load it, using the name supplied by a previous ! -- Extend_System pragma, and report on the success of the load. ! -- If N is present, it is a selected component whose prefix is System, ! -- or else a with-clause on system. N is absent when the function is ! -- called to find the visibility of implicit operators. procedure Restore_Scope_Stack (Handle_Use : Boolean := True); procedure Save_Scope_Stack (Handle_Use : Boolean := True); ! -- These two procedures are called from Semantics, when a unit U1 is ! -- to be compiled in the course of the compilation of another unit U2. ! -- This happens whenever Rtsfind is called. U1, the unit retrieved by ! -- Rtsfind, must be compiled in its own context, and the current scope ! -- stack containing U2 and local scopes must be made unreachable. On ! -- return, the contents of the scope stack must be made accessible again. ! -- The flag Handle_Use indicates whether local use clauses must be ! -- removed/installed. In the case of inlining of instance bodies, the ! -- visibility handling is done fully in Inline_Instance_Body, and use ! -- clauses are handled there. procedure Set_Use (L : List_Id); -- Find use clauses that are declarative items in a package declaration -- and set the potentially use-visible flags of imported entities before -- analyzing the corresponding package body. end Sem_Ch8; --- 131,160 ---- function Present_System_Aux (N : Node_Id := Empty) return Boolean; -- Return True if the auxiliary system file has been successfully loaded. -- Otherwise attempt to load it, using the name supplied by a previous ! -- Extend_System pragma, and report on the success of the load. If N is ! -- present, it is a selected component whose prefix is System, or else a ! -- with-clause on system. N is absent when the function is called to find ! -- the visibility of implicit operators. procedure Restore_Scope_Stack (Handle_Use : Boolean := True); procedure Save_Scope_Stack (Handle_Use : Boolean := True); ! -- These two procedures are called from Semantics, when a unit U1 is to ! -- be compiled in the course of the compilation of another unit U2. This ! -- happens whenever Rtsfind is called. U1, the unit retrieved by Rtsfind, ! -- must be compiled in its own context, and the current scope stack ! -- containing U2 and local scopes must be made unreachable. On return, the ! -- contents of the scope stack must be made accessible again. The flag ! -- Handle_Use indicates whether local use clauses must be removed or ! -- installed. In the case of inlining of instance bodies, the visibility ! -- handling is done fully in Inline_Instance_Body, and use clauses are ! -- handled there. procedure Set_Use (L : List_Id); -- Find use clauses that are declarative items in a package declaration -- and set the potentially use-visible flags of imported entities before -- analyzing the corresponding package body. + procedure ws; + -- Debugging routine for use in gdb: dump all entities on scope stack + end Sem_Ch8; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch9.adb gcc-4.6.0/gcc/ada/sem_ch9.adb *** gcc-4.5.2/gcc/ada/sem_ch9.adb Mon Jul 13 12:45:02 2009 --- gcc-4.6.0/gcc/ada/sem_ch9.adb Fri Oct 22 14:35:39 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; *************** with Errout; use Errout; *** 30,36 **** with Exp_Ch9; use Exp_Ch9; with Elists; use Elists; with Freeze; use Freeze; - with Itypes; use Itypes; with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; --- 31,36 ---- *************** with Sem_Ch3; use Sem_Ch3; *** 45,50 **** --- 45,51 ---- with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; + with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; *************** package body Sem_Ch9 is *** 105,118 **** Analyze (T_Name); if Is_Task_Type (Etype (T_Name)) ! or else (Ada_Version >= Ada_05 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type and then Is_Interface (Etype (T_Name)) and then Is_Task_Interface (Etype (T_Name))) then Resolve (T_Name); else ! if Ada_Version >= Ada_05 then Error_Msg_N ("expect task name or task interface class-wide " & "object for ABORT", T_Name); else --- 106,119 ---- Analyze (T_Name); if Is_Task_Type (Etype (T_Name)) ! or else (Ada_Version >= Ada_2005 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type and then Is_Interface (Etype (T_Name)) and then Is_Task_Interface (Etype (T_Name))) then Resolve (T_Name); else ! if Ada_Version >= Ada_2005 then Error_Msg_N ("expect task name or task interface class-wide " & "object for ABORT", T_Name); else *************** package body Sem_Ch9 is *** 167,239 **** Kind : Entity_Kind; Task_Nam : Entity_Id; - ----------------------- - -- Actual_Index_Type -- - ----------------------- - - function Actual_Index_Type (E : Entity_Id) return Entity_Id; - -- If the bounds of an entry family depend on task discriminants, create - -- a new index type where a discriminant is replaced by the local - -- variable that renames it in the task body. - - ----------------------- - -- Actual_Index_Type -- - ----------------------- - - function Actual_Index_Type (E : Entity_Id) return Entity_Id is - Typ : constant Entity_Id := Entry_Index_Type (E); - Lo : constant Node_Id := Type_Low_Bound (Typ); - Hi : constant Node_Id := Type_High_Bound (Typ); - New_T : Entity_Id; - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; - -- If bound is discriminant reference, replace with corresponding - -- local variable of the same name. - - ----------------------------- - -- Actual_Discriminant_Ref -- - ----------------------------- - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is - Typ : constant Entity_Id := Etype (Bound); - Ref : Node_Id; - begin - if not Is_Entity_Name (Bound) - or else Ekind (Entity (Bound)) /= E_Discriminant - then - return Bound; - else - Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound))); - Analyze (Ref); - Resolve (Ref, Typ); - return Ref; - end if; - end Actual_Discriminant_Ref; - - -- Start of processing for Actual_Index_Type - - begin - if not Has_Discriminants (Task_Nam) - or else (not Is_Entity_Name (Lo) - and then not Is_Entity_Name (Hi)) - then - return Entry_Index_Type (E); - else - New_T := Create_Itype (Ekind (Typ), N); - Set_Etype (New_T, Base_Type (Typ)); - Set_Size_Info (New_T, Typ); - Set_RM_Size (New_T, RM_Size (Typ)); - Set_Scalar_Range (New_T, - Make_Range (Sloc (N), - Low_Bound => Actual_Discriminant_Ref (Lo), - High_Bound => Actual_Discriminant_Ref (Hi))); - - return New_T; - end if; - end Actual_Index_Type; - - -- Start of processing for Analyze_Accept_Statement - begin Tasking_Used := True; --- 168,173 ---- *************** package body Sem_Ch9 is *** 260,270 **** return; end if; ! -- In order to process the parameters, we create a defining ! -- identifier that can be used as the name of the scope. The ! -- name of the accept statement itself is not a defining identifier, ! -- and we cannot use its name directly because the task may have ! -- any number of accept statements for the same entry. if Present (Index) then Accept_Id := New_Internal_Entity --- 194,204 ---- return; end if; ! -- In order to process the parameters, we create a defining identifier ! -- that can be used as the name of the scope. The name of the accept ! -- statement itself is not a defining identifier, and we cannot use ! -- its name directly because the task may have any number of accept ! -- statements for the same entry. if Present (Index) then Accept_Id := New_Internal_Entity *************** package body Sem_Ch9 is *** 343,349 **** if Entry_Nam = Scope_Stack.Table (J).Entity then Error_Msg_N ("duplicate accept statement for same entry", N); end if; - end loop; declare --- 277,282 ---- *************** package body Sem_Ch9 is *** 370,376 **** Error_Msg_N ("missing entry index in accept for entry family", N); else Analyze_And_Resolve (Index, Entry_Index_Type (E)); ! Apply_Range_Check (Index, Actual_Index_Type (E)); end if; elsif Present (Index) then --- 303,309 ---- Error_Msg_N ("missing entry index in accept for entry family", N); else Analyze_And_Resolve (Index, Entry_Index_Type (E)); ! Apply_Range_Check (Index, Entry_Index_Type (E)); end if; elsif Present (Index) then *************** package body Sem_Ch9 is *** 470,476 **** Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); ! if Ada_Version >= Ada_05 then Trigger := Triggering_Statement (Triggering_Alternative (N)); Analyze (Trigger); --- 403,409 ---- Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); ! if Ada_Version >= Ada_2005 then Trigger := Triggering_Statement (Triggering_Alternative (N)); Analyze (Trigger); *************** package body Sem_Ch9 is *** 516,522 **** -- Ada 2005 (AI-345): The trigger may be a dispatching call ! if Ada_Version >= Ada_05 then Analyze (Trigger); Check_Triggering_Statement (Trigger, N, Is_Disp_Select); end if; --- 449,455 ---- -- Ada 2005 (AI-345): The trigger may be a dispatching call ! if Ada_Version >= Ada_2005 then Analyze (Trigger); Check_Triggering_Statement (Trigger, N, Is_Disp_Select); end if; *************** package body Sem_Ch9 is *** 946,964 **** --- 879,912 ---- Generate_Definition (Def_Id); Tasking_Used := True; + -- Case of no discrete subtype definition + if No (D_Sdef) then Set_Ekind (Def_Id, E_Entry); + + -- Processing for discrete subtype definition present + else Enter_Name (Def_Id); Set_Ekind (Def_Id, E_Entry_Family); Analyze (D_Sdef); Make_Index (D_Sdef, N, Def_Id); + + -- Check subtype with predicate in entry family + + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in entry family", + D_Sdef, Etype (D_Sdef)); end if; + -- Decorate Def_Id + Set_Etype (Def_Id, Standard_Void_Type); Set_Convention (Def_Id, Convention_Entry); Set_Accept_Address (Def_Id, New_Elmt_List); + -- Process formals + if Present (Formals) then Set_Scope (Def_Id, Current_Scope); Push_Scope (Def_Id); *************** package body Sem_Ch9 is *** 972,977 **** --- 920,926 ---- end if; Generate_Reference_To_Formals (Def_Id); + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); end Analyze_Entry_Declaration; --------------------------------------- *************** package body Sem_Ch9 is *** 991,999 **** procedure Analyze_Entry_Index_Specification (N : Node_Id) is Iden : constant Node_Id := Defining_Identifier (N); Def : constant Node_Id := Discrete_Subtype_Definition (N); ! Loop_Id : constant Entity_Id := ! Make_Defining_Identifier (Sloc (N), ! Chars => New_Internal_Name ('L')); begin Tasking_Used := True; --- 940,946 ---- procedure Analyze_Entry_Index_Specification (N : Node_Id) is Iden : constant Node_Id := Defining_Identifier (N); Def : constant Node_Id := Discrete_Subtype_Definition (N); ! Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); begin Tasking_Used := True; *************** package body Sem_Ch9 is *** 1174,1182 **** E := First_Entity (Current_Scope); while Present (E) loop ! if Ekind (E) = E_Function ! or else Ekind (E) = E_Procedure ! then Set_Convention (E, Convention_Protected); elsif Is_Task_Type (Etype (E)) --- 1121,1127 ---- E := First_Entity (Current_Scope); while Present (E) loop ! if Ekind_In (E, E_Function, E_Procedure) then Set_Convention (E, Convention_Protected); elsif Is_Task_Type (Etype (E)) *************** package body Sem_Ch9 is *** 1194,1204 **** Process_End_Label (N, 'e', Current_Scope); end Analyze_Protected_Definition; ! ---------------------------- ! -- Analyze_Protected_Type -- ! ---------------------------- ! procedure Analyze_Protected_Type (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); E : Entity_Id; T : Entity_Id; --- 1139,1149 ---- Process_End_Label (N, 'e', Current_Scope); end Analyze_Protected_Definition; ! ---------------------------------------- ! -- Analyze_Protected_Type_Declaration -- ! ---------------------------------------- ! procedure Analyze_Protected_Type_Declaration (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); E : Entity_Id; T : Entity_Id; *************** package body Sem_Ch9 is *** 1206,1212 **** begin if No_Run_Time_Mode then Error_Msg_CRT ("protected type", N); ! return; end if; Tasking_Used := True; --- 1151,1157 ---- begin if No_Run_Time_Mode then Error_Msg_CRT ("protected type", N); ! goto Leave; end if; Tasking_Used := True; *************** package body Sem_Ch9 is *** 1230,1236 **** Set_Stored_Constraint (T, No_Elist); Push_Scope (T); ! if Ada_Version >= Ada_05 then Check_Interfaces (N, T); end if; --- 1175,1181 ---- Set_Stored_Constraint (T, No_Elist); Push_Scope (T); ! if Ada_Version >= Ada_2005 then Check_Interfaces (N, T); end if; *************** package body Sem_Ch9 is *** 1248,1264 **** Set_Is_Constrained (T, not Has_Discriminants (T)); ! -- Perform minimal expansion of protected type while inside a generic. ! -- The corresponding record is needed for various semantic checks. ! if Ada_Version >= Ada_05 ! and then Inside_A_Generic then ! Insert_After_And_Analyze (N, ! Build_Corresponding_Record (N, T, Sloc (T))); ! end if; ! Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the -- Protection component if nothing else), same for any protected type --- 1193,1220 ---- Set_Is_Constrained (T, not Has_Discriminants (T)); ! Analyze (Protected_Definition (N)); ! -- In the case where the protected type is declared at a nested level ! -- and the No_Local_Protected_Objects restriction applies, issue a ! -- warning that objects of the type will violate the restriction. ! ! if Restriction_Check_Required (No_Local_Protected_Objects) ! and then not Is_Library_Level_Entity (T) ! and then Comes_From_Source (T) then ! Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); ! if Error_Msg_Sloc = No_Location then ! Error_Msg_N ! ("objects of this type will violate " & ! "`No_Local_Protected_Objects`?", N); ! else ! Error_Msg_N ! ("objects of this type will violate " & ! "`No_Local_Protected_Objects`?#", N); ! end if; ! end if; -- Protected types with entries are controlled (because of the -- Protection component if nothing else), same for any protected type *************** package body Sem_Ch9 is *** 1315,1321 **** Process_Full_View (N, T, Def_Id); end if; end if; ! end Analyze_Protected_Type; --------------------- -- Analyze_Requeue -- --- 1271,1280 ---- Process_Full_View (N, T, Def_Id); end if; end if; ! ! <> ! Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); ! end Analyze_Protected_Type_Declaration; --------------------- -- Analyze_Requeue -- *************** package body Sem_Ch9 is *** 1343,1351 **** Enclosing := Scope_Stack.Table (J).Entity; exit when Is_Entry (Enclosing); ! if Ekind (Enclosing) /= E_Block ! and then Ekind (Enclosing) /= E_Loop ! then Error_Msg_N ("requeue must appear within accept or entry body", N); return; end if; --- 1302,1308 ---- Enclosing := Scope_Stack.Table (J).Entity; exit when Is_Entry (Enclosing); ! if not Ekind_In (Enclosing, E_Block, E_Loop) then Error_Msg_N ("requeue must appear within accept or entry body", N); return; end if; *************** package body Sem_Ch9 is *** 1486,1503 **** Entry_Id := Entity (Entry_Name); end if; ! -- Ada 2005 (AI05-0030): Potential dispatching requeue statement. The -- target type must be a concurrent interface class-wide type and the ! -- entry name must be a procedure, flagged by pragma Implemented_By_ ! -- Entry. Is_Disp_Req := ! Ada_Version >= Ada_05 and then Present (Target_Obj) and then Is_Class_Wide_Type (Etype (Target_Obj)) and then Is_Concurrent_Interface (Etype (Target_Obj)) and then Ekind (Entry_Id) = E_Procedure ! and then Implemented_By_Entry (Entry_Id); -- Resolve entry, and check that it is subtype conformant with the -- enclosing construct if this construct has formals (RM 9.5.4(5)). --- 1443,1459 ---- Entry_Id := Entity (Entry_Name); end if; ! -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The -- target type must be a concurrent interface class-wide type and the ! -- target must be a procedure, flagged by pragma Implemented. Is_Disp_Req := ! Ada_Version >= Ada_2012 and then Present (Target_Obj) and then Is_Class_Wide_Type (Etype (Target_Obj)) and then Is_Concurrent_Interface (Etype (Target_Obj)) and then Ekind (Entry_Id) = E_Procedure ! and then Has_Rep_Pragma (Entry_Id, Name_Implemented); -- Resolve entry, and check that it is subtype conformant with the -- enclosing construct if this construct has formals (RM 9.5.4(5)). *************** package body Sem_Ch9 is *** 1525,1535 **** return; end if; ! -- Ada 2005 (AI05-0030): Perform type conformance after skipping -- the first parameter of Entry_Id since it is the interface -- controlling formal. ! if Is_Disp_Req then declare Enclosing_Formal : Entity_Id; Target_Formal : Entity_Id; --- 1481,1493 ---- return; end if; ! -- Ada 2012 (AI05-0030): Perform type conformance after skipping -- the first parameter of Entry_Id since it is the interface -- controlling formal. ! if Ada_Version >= Ada_2012 ! and then Is_Disp_Req ! then declare Enclosing_Formal : Entity_Id; Target_Formal : Entity_Id; *************** package body Sem_Ch9 is *** 1576,1585 **** -- perform an unconditional goto so that any further -- references will not occur anyway. ! if Ekind (Ent) = E_Out_Parameter ! or else ! Ekind (Ent) = E_In_Out_Parameter ! then Set_Never_Set_In_Source (Ent, False); Set_Is_True_Constant (Ent, False); end if; --- 1534,1540 ---- -- perform an unconditional goto so that any further -- references will not occur anyway. ! if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then Set_Never_Set_In_Source (Ent, False); Set_Is_True_Constant (Ent, False); end if; *************** package body Sem_Ch9 is *** 1716,1726 **** end if; end Analyze_Selective_Accept; ! ------------------------------ ! -- Analyze_Single_Protected -- ! ------------------------------ ! procedure Analyze_Single_Protected (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; --- 1671,1681 ---- end if; end Analyze_Selective_Accept; ! ------------------------------------------ ! -- Analyze_Single_Protected_Declaration -- ! ------------------------------------------ ! procedure Analyze_Single_Protected_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; *************** package body Sem_Ch9 is *** 1750,1755 **** --- 1705,1711 ---- Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); + Move_Aspects (N, O_Decl); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); *************** package body Sem_Ch9 is *** 1769,1782 **** -- procedure directly. Otherwise the node would be expanded twice, with -- disastrous result. ! Analyze_Protected_Type (N); ! end Analyze_Single_Protected; ! ------------------------- ! -- Analyze_Single_Task -- ! ------------------------- ! procedure Analyze_Single_Task (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; --- 1725,1739 ---- -- procedure directly. Otherwise the node would be expanded twice, with -- disastrous result. ! Analyze_Protected_Type_Declaration (N); ! Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); ! end Analyze_Single_Protected_Declaration; ! ------------------------------------- ! -- Analyze_Single_Task_Declaration -- ! ------------------------------------- ! procedure Analyze_Single_Task_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; *************** package body Sem_Ch9 is *** 1807,1819 **** -- entity is the new object declaration. The single_task_declaration -- is not used further in semantics or code generation, but is scanned -- when generating debug information, and therefore needs the updated ! -- Sloc information for the entity (see Sprint). O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); --- 1764,1778 ---- -- entity is the new object declaration. The single_task_declaration -- is not used further in semantics or code generation, but is scanned -- when generating debug information, and therefore needs the updated ! -- Sloc information for the entity (see Sprint). Aspect specifications ! -- are moved from the single task node to the object declaration node. O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); + Move_Aspects (N, O_Decl); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); *************** package body Sem_Ch9 is *** 1833,1840 **** -- procedure directly. Otherwise the node would be expanded twice, with -- disastrous result. ! Analyze_Task_Type (N); ! end Analyze_Single_Task; ----------------------- -- Analyze_Task_Body -- --- 1792,1800 ---- -- procedure directly. Otherwise the node would be expanded twice, with -- disastrous result. ! Analyze_Task_Type_Declaration (N); ! Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); ! end Analyze_Single_Task_Declaration; ----------------------- -- Analyze_Task_Body -- *************** package body Sem_Ch9 is *** 2000,2010 **** Process_End_Label (N, 'e', Current_Scope); end Analyze_Task_Definition; ! ----------------------- ! -- Analyze_Task_Type -- ! ----------------------- ! procedure Analyze_Task_Type (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); T : Entity_Id; --- 1960,1970 ---- Process_End_Label (N, 'e', Current_Scope); end Analyze_Task_Definition; ! ----------------------------------- ! -- Analyze_Task_Type_Declaration -- ! ----------------------------------- ! procedure Analyze_Task_Type_Declaration (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); T : Entity_Id; *************** package body Sem_Ch9 is *** 2031,2037 **** Set_Stored_Constraint (T, No_Elist); Push_Scope (T); ! if Ada_Version >= Ada_05 then Check_Interfaces (N, T); end if; --- 1991,1997 ---- Set_Stored_Constraint (T, No_Elist); Push_Scope (T); ! if Ada_Version >= Ada_2005 then Check_Interfaces (N, T); end if; *************** package body Sem_Ch9 is *** 2053,2073 **** Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of the task type while inside a generic - -- context. The corresponding record is needed for various semantic - -- checks. - - if Inside_A_Generic then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; ! if not Is_Library_Level_Entity (T) then ! Check_Restriction (No_Task_Hierarchy, N); end if; End_Scope; --- 2013,2039 ---- Set_Is_Constrained (T, not Has_Discriminants (T)); if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; ! -- In the case where the task type is declared at a nested level and the ! -- No_Task_Hierarchy restriction applies, issue a warning that objects ! -- of the type will violate the restriction. ! ! if Restriction_Check_Required (No_Task_Hierarchy) ! and then not Is_Library_Level_Entity (T) ! and then Comes_From_Source (T) ! then ! Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); ! ! if Error_Msg_Sloc = No_Location then ! Error_Msg_N ! ("objects of this type will violate `No_Task_Hierarchy`?", N); ! else ! Error_Msg_N ! ("objects of this type will violate `No_Task_Hierarchy`?#", N); ! end if; end if; End_Scope; *************** package body Sem_Ch9 is *** 2097,2103 **** Process_Full_View (N, T, Def_Id); end if; end if; ! end Analyze_Task_Type; ----------------------------------- -- Analyze_Terminate_Alternative -- --- 2063,2071 ---- Process_Full_View (N, T, Def_Id); end if; end if; ! ! Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); ! end Analyze_Task_Type_Declaration; ----------------------------------- -- Analyze_Terminate_Alternative -- *************** package body Sem_Ch9 is *** 2131,2137 **** -- Ada 2005 (AI-345): The trigger may be a dispatching call ! if Ada_Version >= Ada_05 then Analyze (Trigger); Check_Triggering_Statement (Trigger, N, Is_Disp_Select); end if; --- 2099,2105 ---- -- Ada 2005 (AI-345): The trigger may be a dispatching call ! if Ada_Version >= Ada_2005 then Analyze (Trigger); Check_Triggering_Statement (Trigger, N, Is_Disp_Select); end if; *************** package body Sem_Ch9 is *** 2173,2179 **** and then Nkind (Trigger) not in N_Delay_Statement and then Nkind (Trigger) /= N_Entry_Call_Statement then ! if Ada_Version < Ada_05 then Error_Msg_N ("triggering statement must be delay or entry call", Trigger); --- 2141,2147 ---- and then Nkind (Trigger) not in N_Delay_Statement and then Nkind (Trigger) /= N_Entry_Call_Statement then ! if Ada_Version < Ada_2005 then Error_Msg_N ("triggering statement must be delay or entry call", Trigger); *************** package body Sem_Ch9 is *** 2253,2270 **** -- Entry family with non-static bounds else ! -- If restriction is set, then this is an error ! ! if Restrictions.Set (R) then ! Error_Msg_N ! ("static subtype required by Restriction pragma", ! DSD); ! ! -- Otherwise we record an unknown count restriction ! else ! Check_Restriction (R, D); ! end if; end if; end; end if; --- 2221,2230 ---- -- Entry family with non-static bounds else ! -- Record an unknown count restriction, and if the ! -- restriction is active, post a message or warning. ! Check_Restriction (R, D); end if; end; end if; *************** package body Sem_Ch9 is *** 2433,2447 **** Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ("interface & not implemented by full type " & ! "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ("interface & not implemented by partial " & ! "view (RM-2005 7.3 (7.3/2))", T, Iface); end if; end if; end if; --- 2393,2409 ---- Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ! ("interface & not implemented by full type " & ! "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then ! Error_Msg_NE ! ("interface & not implemented by partial " & ! "view (RM-2005 7.3 (7.3/2))", T, Iface); end if; end if; end if; *************** package body Sem_Ch9 is *** 2465,2471 **** -- It is not possible to have a dispatching trigger if we are not in -- Ada 2005 mode. ! if Ada_Version >= Ada_05 and then Nkind (Trigger) = N_Procedure_Call_Statement and then Present (Parameter_Associations (Trigger)) then --- 2427,2433 ---- -- It is not possible to have a dispatching trigger if we are not in -- Ada 2005 mode. ! if Ada_Version >= Ada_2005 and then Nkind (Trigger) = N_Procedure_Call_Statement and then Present (Parameter_Associations (Trigger)) then diff -Nrcpad gcc-4.5.2/gcc/ada/sem_ch9.ads gcc-4.6.0/gcc/ada/sem_ch9.ads *** gcc-4.5.2/gcc/ada/sem_ch9.ads Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/sem_ch9.ads Mon Oct 11 10:34:53 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Ch9 is *** 41,54 **** procedure Analyze_Entry_Index_Specification (N : Node_Id); procedure Analyze_Protected_Body (N : Node_Id); procedure Analyze_Protected_Definition (N : Node_Id); ! procedure Analyze_Protected_Type (N : Node_Id); procedure Analyze_Requeue (N : Node_Id); procedure Analyze_Selective_Accept (N : Node_Id); ! procedure Analyze_Single_Protected (N : Node_Id); ! procedure Analyze_Single_Task (N : Node_Id); procedure Analyze_Task_Body (N : Node_Id); procedure Analyze_Task_Definition (N : Node_Id); ! procedure Analyze_Task_Type (N : Node_Id); procedure Analyze_Terminate_Alternative (N : Node_Id); procedure Analyze_Timed_Entry_Call (N : Node_Id); procedure Analyze_Triggering_Alternative (N : Node_Id); --- 41,54 ---- procedure Analyze_Entry_Index_Specification (N : Node_Id); procedure Analyze_Protected_Body (N : Node_Id); procedure Analyze_Protected_Definition (N : Node_Id); ! procedure Analyze_Protected_Type_Declaration (N : Node_Id); procedure Analyze_Requeue (N : Node_Id); procedure Analyze_Selective_Accept (N : Node_Id); ! procedure Analyze_Single_Protected_Declaration (N : Node_Id); ! procedure Analyze_Single_Task_Declaration (N : Node_Id); procedure Analyze_Task_Body (N : Node_Id); procedure Analyze_Task_Definition (N : Node_Id); ! procedure Analyze_Task_Type_Declaration (N : Node_Id); procedure Analyze_Terminate_Alternative (N : Node_Id); procedure Analyze_Timed_Entry_Call (N : Node_Id); procedure Analyze_Triggering_Alternative (N : Node_Id); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_disp.adb gcc-4.6.0/gcc/ada/sem_disp.adb *** gcc-4.5.2/gcc/ada/sem_disp.adb Mon Nov 30 13:29:41 2009 --- gcc-4.6.0/gcc/ada/sem_disp.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sem_Disp is *** 72,77 **** --- 72,89 ---- -- (returning the designated tagged type in the case of an access -- parameter); otherwise returns empty. + function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id; + -- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching + -- type of S that has the same name of S, a type-conformant profile, an + -- original corresponding operation O that is a primitive of a visible + -- ancestor of the dispatching type of S and O is visible at the point of + -- of declaration of S. If the entity is found the Alias of S is set to the + -- original corresponding operation S and its Overridden_Operation is set + -- to the found entity; otherwise return Empty. + -- + -- This routine does not search for non-hidden primitives since they are + -- covered by the normal Ada 2005 rules. + ------------------------------- -- Add_Dispatching_Operation -- ------------------------------- *************** package body Sem_Disp is *** 91,96 **** --- 103,183 ---- Append_Unique_Elmt (New_Op, List); end Add_Dispatching_Operation; + --------------------------- + -- Covers_Some_Interface -- + --------------------------- + + function Covers_Some_Interface (Prim : Entity_Id) return Boolean is + Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim); + Elmt : Elmt_Id; + E : Entity_Id; + + begin + pragma Assert (Is_Dispatching_Operation (Prim)); + + -- Although this is a dispatching primitive we must check if its + -- dispatching type is available because it may be the primitive + -- of a private type not defined as tagged in its partial view. + + if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then + + -- If the tagged type is frozen then the internal entities associated + -- with interfaces are available in the list of primitives of the + -- tagged type and can be used to speed up this search. + + if Is_Frozen (Tagged_Type) then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + E := Node (Elmt); + + if Present (Interface_Alias (E)) + and then Alias (E) = Prim + then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Otherwise we must collect all the interface primitives and check + -- if the Prim will override some interface primitive. + + else + declare + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Prim : Entity_Id; + + begin + Collect_Interfaces (Tagged_Type, Ifaces_List); + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if Chars (E) = Chars (Prim) + and then Is_Interface_Conformant + (Tagged_Type, Iface_Prim, Prim) + then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + end if; + + return False; + end Covers_Some_Interface; + ------------------------------- -- Check_Controlling_Formals -- ------------------------------- *************** package body Sem_Disp is *** 153,159 **** -- In Ada 2005, access parameters can have defaults if Ekind (Etype (Formal)) = E_Anonymous_Access_Type ! and then Ada_Version < Ada_05 then Error_Msg_N ("default not allowed for controlling access parameter", --- 240,246 ---- -- In Ada 2005, access parameters can have defaults if Ekind (Etype (Formal)) = E_Anonymous_Access_Type ! and then Ada_Version < Ada_2005 then Error_Msg_N ("default not allowed for controlling access parameter", *************** package body Sem_Disp is *** 175,184 **** Next_Formal (Formal); end loop; ! if Ekind (Subp) = E_Function ! or else ! Ekind (Subp) = E_Generic_Function ! then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then --- 262,268 ---- Next_Formal (Formal); end loop; ! if Ekind_In (Subp, E_Function, E_Generic_Function) then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then *************** package body Sem_Disp is *** 643,650 **** end if; if Present (Func) and then Is_Abstract_Subprogram (Func) then ! Error_Msg_N ( ! "call to abstract function must be dispatching", N); end if; end if; --- 727,734 ---- end if; if Present (Func) and then Is_Abstract_Subprogram (Func) then ! Error_Msg_N ! ("call to abstract function must be dispatching", N); end if; end if; *************** package body Sem_Disp is *** 669,697 **** procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is Tagged_Type : Entity_Id; ! Has_Dispatching_Parent : Boolean := False; ! Body_Is_Last_Primitive : Boolean := False; begin ! if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then return; end if; Set_Is_Dispatching_Operation (Subp, False); Tagged_Type := Find_Dispatching_Type (Subp); ! -- Ada 2005 (AI-345) ! if Ada_Version = Ada_05 and then Present (Tagged_Type) and then Is_Concurrent_Type (Tagged_Type) then - -- Protect the frontend against previously detected errors - - if No (Corresponding_Record_Type (Tagged_Type)) then - return; - end if; - Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; --- 753,779 ---- procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is Tagged_Type : Entity_Id; ! Has_Dispatching_Parent : Boolean := False; ! Body_Is_Last_Primitive : Boolean := False; ! Ovr_Subp : Entity_Id := Empty; begin ! if not Ekind_In (Subp, E_Procedure, E_Function) then return; end if; Set_Is_Dispatching_Operation (Subp, False); Tagged_Type := Find_Dispatching_Type (Subp); ! -- Ada 2005 (AI-345): Use the corresponding record (if available). ! -- Required because primitives of concurrent types are be attached ! -- to the corresponding record (not to the concurrent type). ! if Ada_Version >= Ada_2005 and then Present (Tagged_Type) and then Is_Concurrent_Type (Tagged_Type) + and then Present (Corresponding_Record_Type (Tagged_Type)) then Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; *************** package body Sem_Disp is *** 749,755 **** and then not In_Instance then Error_Msg_N ("?declaration of& is too late!", Subp); ! Error_Msg_NE ("\spec should appear immediately after declaration of &!", Subp, Typ); exit; --- 831,837 ---- and then not In_Instance then Error_Msg_N ("?declaration of& is too late!", Subp); ! Error_Msg_NE -- CODEFIX?? ("\spec should appear immediately after declaration of &!", Subp, Typ); exit; *************** package body Sem_Disp is *** 790,796 **** and then not Comes_From_Source (Subp) and then not Has_Dispatching_Parent then ! -- Complete decoration if internally built subprograms that override -- a dispatching primitive. These entities correspond with the -- following cases: --- 872,878 ---- and then not Comes_From_Source (Subp) and then not Has_Dispatching_Parent then ! -- Complete decoration of internally built subprograms that override -- a dispatching primitive. These entities correspond with the -- following cases: *************** package body Sem_Disp is *** 800,819 **** -- type by Make_Controlling_Function_Wrappers. However, attribute -- Is_Dispatching_Operation must be set to true. ! -- 2. Subprograms associated with stream attributes (built by -- New_Stream_Subprogram) if Present (Old_Subp) ! and then Is_Overriding_Operation (Subp) and then Is_Dispatching_Operation (Old_Subp) then pragma Assert ((Ekind (Subp) = E_Function and then Is_Dispatching_Operation (Old_Subp) and then Is_Null_Extension (Base_Type (Etype (Subp)))) or else Get_TSS_Name (Subp) = TSS_Stream_Read or else Get_TSS_Name (Subp) = TSS_Stream_Write); Set_Is_Dispatching_Operation (Subp); end if; --- 882,912 ---- -- type by Make_Controlling_Function_Wrappers. However, attribute -- Is_Dispatching_Operation must be set to true. ! -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface ! -- primitives. ! ! -- 3. Subprograms associated with stream attributes (built by -- New_Stream_Subprogram) if Present (Old_Subp) ! and then Present (Overridden_Operation (Subp)) and then Is_Dispatching_Operation (Old_Subp) then pragma Assert ((Ekind (Subp) = E_Function and then Is_Dispatching_Operation (Old_Subp) and then Is_Null_Extension (Base_Type (Etype (Subp)))) + or else + (Ekind (Subp) = E_Procedure + and then Is_Dispatching_Operation (Old_Subp) + and then Present (Alias (Old_Subp)) + and then Is_Null_Interface_Primitive + (Ultimate_Alias (Old_Subp))) or else Get_TSS_Name (Subp) = TSS_Stream_Read or else Get_TSS_Name (Subp) = TSS_Stream_Write); + Check_Controlling_Formals (Tagged_Type, Subp); + Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); Set_Is_Dispatching_Operation (Subp); end if; *************** package body Sem_Disp is *** 942,948 **** end if; -- Indicate that this is an overriding operation, ! -- and replace the overriden entry in the list of -- primitive operations, which is used for xref -- generation subsequently. --- 1035,1041 ---- end if; -- Indicate that this is an overriding operation, ! -- and replace the overridden entry in the list of -- primitive operations, which is used for xref -- generation subsequently. *************** package body Sem_Disp is *** 964,972 **** -- If the type is not frozen yet and we are not in the overriding -- case it looks suspiciously like an attempt to define a primitive -- operation, which requires the declaration to be in a package spec ! -- (3.2.3(6)). ! elsif not Is_Frozen (Tagged_Type) then Error_Msg_N ("?not dispatching (must be defined in a package spec)", Subp); return; --- 1057,1071 ---- -- If the type is not frozen yet and we are not in the overriding -- case it looks suspiciously like an attempt to define a primitive -- operation, which requires the declaration to be in a package spec ! -- (3.2.3(6)). Only report cases where the type and subprogram are ! -- in the same declaration list (by checking the enclosing parent ! -- declarations), to avoid spurious warnings on subprograms in ! -- instance bodies when the type is declared in the instance spec but ! -- hasn't been frozen by the instance body. ! elsif not Is_Frozen (Tagged_Type) ! and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp))) ! then Error_Msg_N ("?not dispatching (must be defined in a package spec)", Subp); return; *************** package body Sem_Disp is *** 992,1005 **** Check_Controlling_Formals (Tagged_Type, Subp); -- Now it should be a correct primitive operation, put it in the list ! if Present (Old_Subp) then -- If the type has interfaces we complete this check after we set -- attribute Is_Dispatching_Operation. ! Check_Subtype_Conformant (Subp, Old_Subp); if (Chars (Subp) = Name_Initialize or else Chars (Subp) = Name_Adjust --- 1091,1115 ---- Check_Controlling_Formals (Tagged_Type, Subp); + Ovr_Subp := Old_Subp; + + -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be + -- overridden by Subp + + if No (Ovr_Subp) + and then Ada_Version >= Ada_2012 + then + Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp); + end if; + -- Now it should be a correct primitive operation, put it in the list ! if Present (Ovr_Subp) then -- If the type has interfaces we complete this check after we set -- attribute Is_Dispatching_Operation. ! Check_Subtype_Conformant (Subp, Ovr_Subp); if (Chars (Subp) = Name_Initialize or else Chars (Subp) = Name_Adjust *************** package body Sem_Disp is *** 1007,1013 **** and then Is_Controlled (Tagged_Type) and then not Is_Visibly_Controlled (Tagged_Type) then ! Set_Is_Overriding_Operation (Subp, False); -- If the subprogram specification carries an overriding -- indicator, no need for the warning: it is either redundant, --- 1117,1123 ---- and then Is_Controlled (Tagged_Type) and then not Is_Visibly_Controlled (Tagged_Type) then ! Set_Overridden_Operation (Subp, Empty); -- If the subprogram specification carries an overriding -- indicator, no need for the warning: it is either redundant, *************** package body Sem_Disp is *** 1028,1035 **** end if; else ! Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); ! Set_Is_Overriding_Operation (Subp); -- Ada 2005 (AI-251): In case of late overriding of a primitive -- that covers abstract interface subprograms we must register it --- 1138,1144 ---- end if; else ! Override_Dispatching_Operation (Tagged_Type, Ovr_Subp, Subp); -- Ada 2005 (AI-251): In case of late overriding of a primitive -- that covers abstract interface subprograms we must register it *************** package body Sem_Disp is *** 1071,1076 **** --- 1180,1197 ---- end if; end if; + -- If the tagged type is a concurrent type then we must be compiling + -- with no code generation (we are either compiling a generic unit or + -- compiling under -gnatc mode) because we have previously tested that + -- no serious errors has been reported. In this case we do not add the + -- primitive to the list of primitives of Tagged_Type but we leave the + -- primitive decorated as a dispatching operation to be able to analyze + -- and report errors associated with the Object.Operation notation. + + elsif Is_Concurrent_Type (Tagged_Type) then + pragma Assert (not Expander_Active); + null; + -- If no old subprogram, then we add this as a dispatching operation, -- but we avoid doing this if an error was posted, to prevent annoying -- cascaded errors. *************** package body Sem_Disp is *** 1085,1091 **** -- subtype conformance against all the interfaces covered by this -- primitive. ! if Present (Old_Subp) and then Has_Interfaces (Tagged_Type) then declare --- 1206,1212 ---- -- subtype conformance against all the interfaces covered by this -- primitive. ! if Present (Ovr_Subp) and then Has_Interfaces (Tagged_Type) then declare *************** package body Sem_Disp is *** 1499,1505 **** -- For subprograms internally generated by derivations of tagged types -- use the alias subprogram as a reference to locate the dispatching ! -- type of Subp elsif not Comes_From_Source (Subp) and then Present (Alias (Subp)) --- 1620,1626 ---- -- For subprograms internally generated by derivations of tagged types -- use the alias subprogram as a reference to locate the dispatching ! -- type of Subp. elsif not Comes_From_Source (Subp) and then Present (Alias (Subp)) *************** package body Sem_Disp is *** 1551,1556 **** --- 1672,1758 ---- return Empty; end Find_Dispatching_Type; + -------------------------------------- + -- Find_Hidden_Overridden_Primitive -- + -------------------------------------- + + function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id + is + Tag_Typ : constant Entity_Id := Find_Dispatching_Type (S); + Elmt : Elmt_Id; + Orig_Prim : Entity_Id; + Prim : Entity_Id; + Vis_List : Elist_Id; + + begin + -- This Ada 2012 rule is valid only for type extensions or private + -- extensions. + + if No (Tag_Typ) + or else not Is_Record_Type (Tag_Typ) + or else Etype (Tag_Typ) = Tag_Typ + then + return Empty; + end if; + + -- Collect the list of visible ancestor of the tagged type + + Vis_List := Visible_Ancestors (Tag_Typ); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- Find an inherited hidden dispatching primitive with the name of S + -- and a type-conformant profile. + + if Present (Alias (Prim)) + and then Is_Hidden (Alias (Prim)) + and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ + and then Primitive_Names_Match (S, Prim) + and then Type_Conformant (S, Prim) + then + declare + Vis_Ancestor : Elmt_Id; + Elmt : Elmt_Id; + + begin + -- The original corresponding operation of Prim must be an + -- operation of a visible ancestor of the dispatching type + -- S, and the original corresponding operation of S2 must + -- be visible. + + Orig_Prim := Original_Corresponding_Operation (Prim); + + if Orig_Prim /= Prim + and then Is_Immediately_Visible (Orig_Prim) + then + Vis_Ancestor := First_Elmt (Vis_List); + while Present (Vis_Ancestor) loop + Elmt := + First_Elmt (Primitive_Operations (Node (Vis_Ancestor))); + while Present (Elmt) loop + if Node (Elmt) = Orig_Prim then + Set_Overridden_Operation (S, Prim); + Set_Alias (Prim, Orig_Prim); + return Prim; + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Vis_Ancestor); + end loop; + end if; + end; + end if; + + Next_Elmt (Elmt); + end loop; + + return Empty; + end Find_Hidden_Overridden_Primitive; + --------------------------------------- -- Find_Primitive_Covering_Interface -- --------------------------------------- *************** package body Sem_Disp is *** 1559,1572 **** (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id) return Entity_Id is ! E : Entity_Id; begin pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) or else (Present (Alias (Iface_Prim)) ! and then ! Is_Interface ! (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); E := Current_Entity (Iface_Prim); while Present (E) loop --- 1761,1779 ---- (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id) return Entity_Id is ! E : Entity_Id; ! El : Elmt_Id; begin pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) or else (Present (Alias (Iface_Prim)) ! and then ! Is_Interface ! (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); ! ! -- Search in the homonym chain. Done to speed up locating visible ! -- entities and required to catch primitives associated with the partial ! -- view of private types when processing the corresponding full view. E := Current_Entity (Iface_Prim); while Present (E) loop *************** package body Sem_Disp is *** 1580,1589 **** --- 1787,1948 ---- E := Homonym (E); end loop; + -- Search in the list of primitives of the type. Required to locate the + -- covering primitive if the covering primitive is not visible (for + -- example, non-visible inherited primitive of private type). + + El := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (El) loop + E := Node (El); + + -- Keep separate the management of internal entities that link + -- primitives with interface primitives from tagged type primitives. + + if No (Interface_Alias (E)) then + if Present (Alias (E)) then + + -- This interface primitive has not been covered yet + + if Alias (E) = Iface_Prim then + return E; + + -- The covering primitive was inherited + + elsif Overridden_Operation (Ultimate_Alias (E)) + = Iface_Prim + then + return E; + end if; + end if; + + -- Check if E covers the interface primitive (includes case in + -- which E is an inherited private primitive). + + if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then + return E; + end if; + + -- Use the internal entity that links the interface primitive with + -- the covering primitive to locate the entity. + + elsif Interface_Alias (E) = Iface_Prim then + return Alias (E); + end if; + + Next_Elmt (El); + end loop; + + -- Not found + return Empty; end Find_Primitive_Covering_Interface; --------------------------- + -- Inherited_Subprograms -- + --------------------------- + + function Inherited_Subprograms (S : Entity_Id) return Subprogram_List is + Result : Subprogram_List (1 .. 6000); + -- 6000 here is intended to be infinity. We could use an expandable + -- table, but it would be awfully heavy, and there is no way that we + -- could reasonably exceed this value. + + N : Int := 0; + -- Number of entries in Result + + Parent_Op : Entity_Id; + -- Traverses the Overridden_Operation chain + + procedure Store_IS (E : Entity_Id); + -- Stores E in Result if not already stored + + -------------- + -- Store_IS -- + -------------- + + procedure Store_IS (E : Entity_Id) is + begin + for J in 1 .. N loop + if E = Result (J) then + return; + end if; + end loop; + + N := N + 1; + Result (N) := E; + end Store_IS; + + -- Start of processing for Inherited_Subprograms + + begin + if Present (S) and then Is_Dispatching_Operation (S) then + + -- Deal with direct inheritance + + Parent_Op := S; + loop + Parent_Op := Overridden_Operation (Parent_Op); + exit when No (Parent_Op); + + if Is_Subprogram (Parent_Op) + or else Is_Generic_Subprogram (Parent_Op) + then + Store_IS (Parent_Op); + end if; + end loop; + + -- Now deal with interfaces + + declare + Tag_Typ : Entity_Id; + Prim : Entity_Id; + Elmt : Elmt_Id; + + begin + Tag_Typ := Find_Dispatching_Type (S); + + if Is_Concurrent_Type (Tag_Typ) then + Tag_Typ := Corresponding_Record_Type (Tag_Typ); + end if; + + -- Search primitive operations of dispatching type + + if Present (Tag_Typ) + and then Present (Primitive_Operations (Tag_Typ)) + then + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- The following test eliminates some odd cases in which + -- Ekind (Prim) is Void, to be investigated further ??? + + if not (Is_Subprogram (Prim) + or else + Is_Generic_Subprogram (Prim)) + then + null; + + -- For [generic] subprogram, look at interface alias + + elsif Present (Interface_Alias (Prim)) + and then Alias (Prim) = S + then + -- We have found a primitive covered by S + + Store_IS (Interface_Alias (Prim)); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end; + end if; + + return Result (1 .. N); + end Inherited_Subprograms; + + --------------------------- -- Is_Dynamically_Tagged -- --------------------------- *************** package body Sem_Disp is *** 1596,1601 **** --- 1955,1973 ---- end if; end Is_Dynamically_Tagged; + --------------------------------- + -- Is_Null_Interface_Primitive -- + --------------------------------- + + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is + begin + return Comes_From_Source (E) + and then Is_Dispatching_Operation (E) + and then Ekind (E) = E_Procedure + and then Null_Present (Parent (E)) + and then Is_Interface (Find_Dispatching_Type (E)); + end Is_Null_Interface_Primitive; + -------------------------- -- Is_Tag_Indeterminate -- -------------------------- *************** package body Sem_Disp is *** 1659,1665 **** -- is also tag-indeterminate. elsif Nkind (Orig_Node) = N_Explicit_Dereference ! and then Ada_Version >= Ada_05 then return Is_Tag_Indeterminate (Prefix (Orig_Node)); --- 2031,2037 ---- -- is also tag-indeterminate. elsif Nkind (Orig_Node) = N_Explicit_Dereference ! and then Ada_Version >= Ada_2005 then return Is_Tag_Indeterminate (Prefix (Orig_Node)); *************** package body Sem_Disp is *** 1703,1711 **** return; end if; ! Replace_Elmt (Elmt, New_Op); ! if Ada_Version >= Ada_05 and then Has_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased --- 2075,2104 ---- return; end if; ! -- The location of entities that come from source in the list of ! -- primitives of the tagged type must follow their order of occurrence ! -- in the sources to fulfill the C++ ABI. If the overridden entity is a ! -- primitive of an interface that is not an ancestor of this tagged ! -- type (that is, it is an entity added to the list of primitives by ! -- Derive_Interface_Progenitors), then we must append the new entity ! -- at the end of the list of primitives. ! if Present (Alias (Prev_Op)) ! and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op))) ! and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)), ! Tagged_Type) ! then ! Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt); ! Append_Elmt (New_Op, Primitive_Operations (Tagged_Type)); ! ! -- The new primitive replaces the overridden entity. Required to ensure ! -- that overriding primitive is assigned the same dispatch table slot. ! ! else ! Replace_Elmt (Elmt, New_Op); ! end if; ! ! if Ada_Version >= Ada_2005 and then Has_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased *************** package body Sem_Disp is *** 1760,1770 **** -- Make the overriding operation into an alias of the implicit one. -- In this fashion a call from outside ends up calling the new body ! -- even if non-dispatching, and a call from inside calls the ! -- overriding operation because it hides the implicit one. To ! -- indicate that the body of Prev_Op is never called, set its ! -- dispatch table entity to Empty. If the overridden operation ! -- has a dispatching result, so does the overriding one. Set_Alias (Prev_Op, New_Op); Set_DTC_Entity (Prev_Op, Empty); --- 2153,2163 ---- -- Make the overriding operation into an alias of the implicit one. -- In this fashion a call from outside ends up calling the new body ! -- even if non-dispatching, and a call from inside calls the over- ! -- riding operation because it hides the implicit one. To indicate ! -- that the body of Prev_Op is never called, set its dispatch table ! -- entity to Empty. If the overridden operation has a dispatching ! -- result, so does the overriding one. Set_Alias (Prev_Op, New_Op); Set_DTC_Entity (Prev_Op, Empty); *************** package body Sem_Disp is *** 1819,1825 **** end if; Arg := First_Actual (Call_Node); - while Present (Arg) loop if Is_Tag_Indeterminate (Arg) then Propagate_Tag (Control, Arg); --- 2212,2217 ---- *************** package body Sem_Disp is *** 1833,1839 **** -- and would have to undo any expansion to an indirect call. if Tagged_Type_Expansion then ! Expand_Dispatching_Call (Call_Node); -- Expansion of a dispatching call results in an indirect call, which in -- turn causes current values to be killed (see Resolve_Call), so on VM --- 2225,2259 ---- -- and would have to undo any expansion to an indirect call. if Tagged_Type_Expansion then ! declare ! Call_Typ : constant Entity_Id := Etype (Call_Node); ! ! begin ! Expand_Dispatching_Call (Call_Node); ! ! -- If the controlling argument is an interface type and the type ! -- of Call_Node differs then we must add an implicit conversion to ! -- force displacement of the pointer to the object to reference ! -- the secondary dispatch table of the interface. ! ! if Is_Interface (Etype (Control)) ! and then Etype (Control) /= Call_Typ ! then ! -- Cannot use Convert_To because the previous call to ! -- Expand_Dispatching_Call leaves decorated the Call_Node ! -- with the type of Control. ! ! Rewrite (Call_Node, ! Make_Type_Conversion (Sloc (Call_Node), ! Subtype_Mark => ! New_Occurrence_Of (Etype (Control), Sloc (Call_Node)), ! Expression => Relocate_Node (Call_Node))); ! Set_Etype (Call_Node, Etype (Control)); ! Set_Analyzed (Call_Node); ! ! Expand_Interface_Conversion (Call_Node, Is_Static => False); ! end if; ! end; -- Expansion of a dispatching call results in an indirect call, which in -- turn causes current values to be killed (see Resolve_Call), so on VM diff -Nrcpad gcc-4.5.2/gcc/ada/sem_disp.ads gcc-4.6.0/gcc/ada/sem_disp.ads *** gcc-4.5.2/gcc/ada/sem_disp.ads Mon May 26 13:43:18 2008 --- gcc-4.6.0/gcc/ada/sem_disp.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Disp is *** 46,52 **** -- if it has a parameter of this type and is defined at a proper place for -- primitive operations (new primitives are only defined in package spec, -- overridden operation can be defined in any scope). If Old_Subp is not ! -- Empty we are in the overriding case. procedure Check_Operation_From_Incomplete_Type (Subp : Entity_Id; --- 46,57 ---- -- if it has a parameter of this type and is defined at a proper place for -- primitive operations (new primitives are only defined in package spec, -- overridden operation can be defined in any scope). If Old_Subp is not ! -- Empty we are in the overriding case. If the tagged type associated with ! -- Subp is a concurrent type (case that occurs when the type is declared in ! -- a generic because the analysis of generics disables generation of the ! -- corresponding record) then this routine does does not add "Subp" to the ! -- list of primitive operations but leaves Subp decorated as dispatching ! -- operation to enable checks associated with the Object.Operation notation procedure Check_Operation_From_Incomplete_Type (Subp : Entity_Id; *************** package Sem_Disp is *** 61,87 **** -- of "OldSubp" is adjusted to point to the inherited procedure of the -- full view because it is always this one which has to be called. function Find_Controlling_Arg (N : Node_Id) return Node_Id; -- Returns the actual controlling argument if N is dynamically tagged, -- and Empty if it is not dynamically tagged. function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id; ! -- Check whether a subprogram is dispatching, and find the tagged ! -- type of the controlling argument or arguments. function Find_Primitive_Covering_Interface (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id) return Entity_Id; ! -- Search in the homonym chain for the primitive of Tagged_Type that ! -- covers Iface_Prim. The homonym chain traversal is required to catch ! -- primitives associated with the partial view of private types when ! -- processing the corresponding full view. function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an -- an expression of a class_Wide type, or a call to a function with -- controlling result where at least one operand is dynamically tagged. function Is_Tag_Indeterminate (N : Node_Id) return Boolean; -- An expression is tag-indeterminate if it is a call that dispatches -- on result, and all controlling operands are also indeterminate. --- 66,118 ---- -- of "OldSubp" is adjusted to point to the inherited procedure of the -- full view because it is always this one which has to be called. + function Covers_Some_Interface (Prim : Entity_Id) return Boolean; + -- Returns true if Prim covers some interface primitive of its associated + -- tagged type. The tagged type of Prim must be frozen when this function + -- is invoked. + function Find_Controlling_Arg (N : Node_Id) return Node_Id; -- Returns the actual controlling argument if N is dynamically tagged, -- and Empty if it is not dynamically tagged. function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id; ! -- Check whether a subprogram is dispatching, and find the tagged type of ! -- the controlling argument or arguments. Returns Empty if Subp is not a ! -- dispatching operation. function Find_Primitive_Covering_Interface (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id) return Entity_Id; ! -- Search in the homonym chain for the primitive of Tagged_Type that covers ! -- Iface_Prim. The homonym chain traversal is required to catch primitives ! -- associated with the partial view of private types when processing the ! -- corresponding full view. If the entity is not found then search for it ! -- in the list of primitives of Tagged_Type. This latter search is needed ! -- when the interface primitive is covered by a private subprogram. If the ! -- primitive has not been covered yet then return the entity that will be ! -- overridden when the primitive is covered (that is, return the entity ! -- whose alias attribute references the interface primitive). If none of ! -- these entities is found then return Empty. ! ! type Subprogram_List is array (Nat range <>) of Entity_Id; ! -- Type returned by Inherited_Subprograms function ! ! function Inherited_Subprograms (S : Entity_Id) return Subprogram_List; ! -- Given the spec of a subprogram, this function gathers any inherited ! -- subprograms from direct inheritance or via interfaces. The list is ! -- a list of entity id's of the specs of inherited subprograms. Returns ! -- a null array if passed an Empty spec id. Note that the returned array ! -- only includes subprograms and generic subprograms (and excludes any ! -- other inherited entities, in particular enumeration literals). function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an -- an expression of a class_Wide type, or a call to a function with -- controlling result where at least one operand is dynamically tagged. + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean; + -- Returns True if E is a null procedure that is an interface primitive + function Is_Tag_Indeterminate (N : Node_Id) return Boolean; -- An expression is tag-indeterminate if it is a call that dispatches -- on result, and all controlling operands are also indeterminate. diff -Nrcpad gcc-4.5.2/gcc/ada/sem_dist.adb gcc-4.6.0/gcc/ada/sem_dist.adb *** gcc-4.5.2/gcc/ada/sem_dist.adb Mon Jul 20 13:48:01 2009 --- gcc-4.6.0/gcc/ada/sem_dist.adb Tue Oct 26 13:20:47 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sem_Dist is *** 451,459 **** -- True iff this RAS has an access formal parameter (see -- Exp_Dist.Add_RAS_Dereference_TSS for details). ! Subpkg : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! New_Internal_Name ('S')); Subpkg_Decl : Node_Id; Subpkg_Body : Node_Id; Vis_Decls : constant List_Id := New_List; --- 451,457 ---- -- True iff this RAS has an access formal parameter (see -- Exp_Dist.Add_RAS_Dereference_TSS for details). ! Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); Subpkg_Decl : Node_Id; Subpkg_Body : Node_Id; Vis_Decls : constant List_Id := New_List; *************** package body Sem_Dist is *** 464,479 **** New_External_Name (Chars (User_Type), 'R')); Full_Obj_Type : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars (Obj_Type)); RACW_Type : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (User_Type), 'P')); Fat_Type : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars (User_Type)); Fat_Type_Decl : Node_Id; --- 462,475 ---- New_External_Name (Chars (User_Type), 'R')); Full_Obj_Type : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Obj_Type)); RACW_Type : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (User_Type), 'P')); Fat_Type : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (User_Type)); Fat_Type_Decl : Node_Id; *************** package body Sem_Dist is *** 781,787 **** Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, ! Choices => New_List (Make_Identifier (Loc, Name_Ras)), Expression => Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; --- 777,783 ---- Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, ! Choices => New_List (Make_Identifier (Loc, Name_Ras)), Expression => Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_elab.adb gcc-4.6.0/gcc/ada/sem_elab.adb *** gcc-4.5.2/gcc/ada/sem_elab.adb Wed Jul 22 10:31:30 2009 --- gcc-4.6.0/gcc/ada/sem_elab.adb Thu Oct 7 10:35:03 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2010, 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- -- *************** package body Sem_Elab is *** 599,607 **** -- No checks needed for pure or preelaborated compilation units ! if Is_Pure (E_Scope) ! or else Is_Preelaborated (E_Scope) ! then return; end if; --- 599,605 ---- -- No checks needed for pure or preelaborated compilation units ! if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then return; end if; *************** package body Sem_Elab is *** 941,946 **** --- 939,954 ---- Make_Attribute_Reference (Loc, Attribute_Name => Name_Elaborated, Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); + + -- Prevent duplicate elaboration checks on the same call, + -- which can happen if the body enclosing the call appears + -- itself in a call whose elaboration check is delayed. + + if Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) + then + Set_No_Elaboration_Check (N); + end if; end if; -- Case of static elaboration model *************** package body Sem_Elab is *** 1678,1684 **** -- Here is where we give the warning ! -- All OK if warnings suppressed on the entity if not Has_Warnings_Off (Ent) then Error_Msg_Sloc := Sloc (Ent); --- 1686,1692 ---- -- Here is where we give the warning ! -- All OK if warnings suppressed on the entity if not Has_Warnings_Off (Ent) then Error_Msg_Sloc := Sloc (Ent); *************** package body Sem_Elab is *** 1891,1896 **** --- 1899,1909 ---- elsif In_Task_Activation then return; + + -- Nothing to do if call is within a generic unit + + elsif Inside_A_Generic then + return; end if; -- Delay this call if we are still delaying calls *************** package body Sem_Elab is *** 2285,2291 **** ("task will be activated before elaboration of its body?", Decl); Error_Msg_N ! ("\Program_Error will be raised at run-time?", Decl); elsif Present (Corresponding_Body (Unit_Declaration_Node (Proc))) --- 2298,2304 ---- ("task will be activated before elaboration of its body?", Decl); Error_Msg_N ! ("\Program_Error will be raised at run time?", Decl); elsif Present (Corresponding_Body (Unit_Declaration_Node (Proc))) *************** package body Sem_Elab is *** 2427,2433 **** and then not Elaboration_Checks_Suppressed (Task_Scope) then Error_Msg_Node_2 := Task_Scope; ! Error_Msg_NE ("activation of an instance of task type&" & " requires pragma Elaborate_All on &?", N, Ent); end if; --- 2440,2447 ---- and then not Elaboration_Checks_Suppressed (Task_Scope) then Error_Msg_Node_2 := Task_Scope; ! Error_Msg_NE ! ("activation of an instance of task type&" & " requires pragma Elaborate_All on &?", N, Ent); end if; *************** package body Sem_Elab is *** 2846,2853 **** Typ : constant Entity_Id := Etype (N); Chk : constant Boolean := Do_Range_Check (N); ! R : constant Node_Id := ! Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); Reloc_N : Node_Id; --- 2860,2867 ---- Typ : constant Entity_Id := Etype (N); Chk : constant Boolean := Do_Range_Check (N); ! R : constant Node_Id := ! Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); Reloc_N : Node_Id; *************** package body Sem_Elab is *** 3008,3017 **** -- Check for case of body entity -- Why is the check for E_Void needed??? ! if Ekind (E) = E_Void ! or else Ekind (E) = E_Subprogram_Body ! or else Ekind (E) = E_Package_Body ! then Decl := E; loop --- 3022,3028 ---- -- Check for case of body entity -- Why is the check for E_Void needed??? ! if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then Decl := E; loop *************** package body Sem_Elab is *** 3042,3058 **** if No (Corresponding_Body (N)) then declare ! Loc : constant Source_Ptr := Sloc (N); ! B : Node_Id; ! Formals : constant List_Id := ! Copy_Parameter_List (Ent); ! Nam : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Ent)); ! Spec : Node_Id; ! Stats : constant List_Id := ! New_List ! (Make_Raise_Program_Error (Loc, ! Reason => PE_Access_Before_Elaboration)); begin if Ekind (Ent) = E_Function then Spec := --- 3053,3069 ---- if No (Corresponding_Body (N)) then declare ! Loc : constant Source_Ptr := Sloc (N); ! B : Node_Id; ! Formals : constant List_Id := Copy_Parameter_List (Ent); ! Nam : constant Entity_Id := ! Make_Defining_Identifier (Loc, Chars (Ent)); ! Spec : Node_Id; ! Stats : constant List_Id := ! New_List ! (Make_Raise_Program_Error (Loc, ! Reason => PE_Access_Before_Elaboration)); ! begin if Ekind (Ent) = E_Function then Spec := diff -Nrcpad gcc-4.5.2/gcc/ada/sem_elim.adb gcc-4.6.0/gcc/ada/sem_elim.adb *** gcc-4.5.2/gcc/ada/sem_elim.adb Wed Apr 29 10:19:14 2009 --- gcc-4.6.0/gcc/ada/sem_elim.adb Tue Oct 26 11:02:31 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2010, 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- -- *************** with Errout; use Errout; *** 29,35 **** --- 29,37 ---- with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; + with Opt; use Opt; with Sem; use Sem; + with Sem_Aux; use Sem_Aux; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinput; use Sinput; *************** package body Sem_Elim is *** 234,239 **** --- 236,242 ---- Elmt : Access_Elim_Data; Scop : Entity_Id; Form : Entity_Id; + Up : Nat; begin if No_Elimination then *************** package body Sem_Elim is *** 264,270 **** -- If an overriding dispatching primitive is eliminated then -- its parent must have been eliminated. ! if Is_Overriding_Operation (E) and then not Is_Eliminated (Overridden_Operation (E)) then Error_Msg_Name_1 := Chars (E); --- 267,273 ---- -- If an overriding dispatching primitive is eliminated then -- its parent must have been eliminated. ! if Present (Overridden_Operation (E)) and then not Is_Eliminated (Overridden_Operation (E)) then Error_Msg_Name_1 := Chars (E); *************** package body Sem_Elim is *** 286,306 **** goto Continue; end if; ! -- Find enclosing unit Scop := Cunit_Entity (Current_Sem_Unit); -- Now see if compilation unit matches ! for J in reverse Elmt.Unit_Name'Range loop if Elmt.Unit_Name (J) /= Chars (Scop) then goto Continue; end if; Scop := Scope (Scop); - while Ekind (Scop) = E_Block loop - Scop := Scope (Scop); - end loop; if Scop /= Standard_Standard and then J = 1 then goto Continue; --- 289,337 ---- goto Continue; end if; ! -- Find enclosing unit, and verify that its name and those of its ! -- parents match. Scop := Cunit_Entity (Current_Sem_Unit); -- Now see if compilation unit matches ! Up := Elmt.Unit_Name'Last; ! ! -- If we are within a subunit, the name in the pragma has been ! -- parsed as a child unit, but the current compilation unit is in ! -- fact the parent in which the subunit is embedded. We must skip ! -- the first name which is that of the subunit to match the pragma ! -- specification. Body may be that of a package or subprogram. ! ! declare ! Par : Node_Id; ! ! begin ! Par := Parent (E); ! while Present (Par) loop ! if Nkind (Par) = N_Subunit then ! if Chars (Defining_Entity (Proper_Body (Par))) = ! Elmt.Unit_Name (Up) ! then ! Up := Up - 1; ! exit; ! ! else ! goto Continue; ! end if; ! end if; ! ! Par := Parent (Par); ! end loop; ! end; ! ! for J in reverse Elmt.Unit_Name'First .. Up loop if Elmt.Unit_Name (J) /= Chars (Scop) then goto Continue; end if; Scop := Scope (Scop); if Scop /= Standard_Standard and then J = 1 then goto Continue; *************** package body Sem_Elim is *** 311,318 **** goto Continue; end if; ! -- Check for case of given entity is a library level subprogram ! -- and we have the single parameter Eliminate case, a match! if Is_Compilation_Unit (E) and then Is_Subprogram (E) --- 342,400 ---- goto Continue; end if; ! if Present (Elmt.Entity_Node) ! and then Elmt.Entity_Scope /= null ! then ! -- Check that names of enclosing scopes match. Skip blocks and ! -- wrapper package of subprogram instances, which do not appear ! -- in the pragma. ! ! Scop := Scope (E); ! ! for J in reverse Elmt.Entity_Scope'Range loop ! while Ekind (Scop) = E_Block ! or else ! (Ekind (Scop) = E_Package ! and then Is_Wrapper_Package (Scop)) ! loop ! Scop := Scope (Scop); ! end loop; ! ! if Elmt.Entity_Scope (J) /= Chars (Scop) then ! if Ekind (Scop) /= E_Protected_Type ! or else Comes_From_Source (Scop) ! then ! goto Continue; ! ! -- For simple protected declarations, retrieve the source ! -- name of the object, which appeared in the Eliminate ! -- pragma. ! ! else ! declare ! Decl : constant Node_Id := ! Original_Node (Parent (Scop)); ! ! begin ! if Elmt.Entity_Scope (J) /= ! Chars (Defining_Identifier (Decl)) ! then ! if J > 0 then ! null; ! end if; ! goto Continue; ! end if; ! end; ! end if; ! ! end if; ! ! Scop := Scope (Scop); ! end loop; ! end if; ! ! -- If given entity is a library level subprogram and pragma had a ! -- single parameter, a match! if Is_Compilation_Unit (E) and then Is_Subprogram (E) *************** package body Sem_Elim is *** 332,340 **** -- Check for case of subprogram ! elsif Ekind (E) = E_Function ! or else Ekind (E) = E_Procedure ! then -- If Source_Location present, then see if it matches if Elmt.Source_Location /= No_Name then --- 414,421 ---- -- Check for case of subprogram ! elsif Ekind_In (E, E_Function, E_Procedure) then ! -- If Source_Location present, then see if it matches if Elmt.Source_Location /= No_Name then *************** package body Sem_Elim is *** 642,648 **** Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); end loop; ! Eliminate_Error_Msg (N, Ultimate_Subp); end if; end Check_For_Eliminated_Subprogram; --- 723,742 ---- Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); end loop; ! -- Emit error, unless we are within an instance body and the expander ! -- is disabled, indicating an instance within an enclosing generic. ! -- In an instance, the ultimate alias is an internal entity, so place ! -- the message on the original subprogram. ! ! if In_Instance_Body and then not Expander_Active then ! null; ! ! elsif Comes_From_Source (Ultimate_Subp) then ! Eliminate_Error_Msg (N, Ultimate_Subp); ! ! else ! Eliminate_Error_Msg (N, S); ! end if; end if; end Check_For_Eliminated_Subprogram; *************** package body Sem_Elim is *** 673,679 **** -- Otherwise should not fall through, entry should be in table else ! raise Program_Error; end if; end Eliminate_Error_Msg; --- 767,775 ---- -- Otherwise should not fall through, entry should be in table else ! Error_Msg_NE ! ("subprogram& is called but its alias is eliminated", N, E); ! -- raise Program_Error; end if; end Eliminate_Error_Msg; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_eval.adb gcc-4.6.0/gcc/ada/sem_eval.adb *** gcc-4.5.2/gcc/ada/sem_eval.adb Tue Jan 26 10:30:04 2010 --- gcc-4.6.0/gcc/ada/sem_eval.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Elists; use Elists; *** 31,36 **** --- 31,37 ---- with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Util; use Exp_Util; + with Freeze; use Freeze; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; *************** package body Sem_Eval is *** 126,131 **** --- 127,136 ---- -- This is the actual cache, with entries consisting of node/value pairs, -- and the impossible value Node_High_Bound used for unset entries. + type Range_Membership is (In_Range, Out_Of_Range, Unknown); + -- Range membership may either be statically known to be in range or out + -- of range, or not statically known. Used for Test_In_Range below. + ----------------------- -- Local Subprograms -- ----------------------- *************** package body Sem_Eval is *** 176,181 **** --- 181,195 ---- -- used for producing the result of the static evaluation of the -- logical operators + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; + -- Check whether an arithmetic operation with universal operands which + -- is a rewritten function call with an explicit scope indication is + -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one + -- visible numeric type declared in P and the context does not impose a + -- type on the result (e.g. in the expression of a type conversion). + -- If ambiguous, emit an error and return Empty, else return the result + -- type of the operator. + procedure Test_Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id; *************** package body Sem_Eval is *** 197,203 **** -- -- If Stat is set True on return, then Is_Static_Expression is also set -- true in node N. There are some cases where this is over-enthusiastic, ! -- e.g. in the two operand case below, for string comaprison, the result -- is not static even though the two operands are static. In such cases, -- the caller must reset the Is_Static_Expression flag in N. --- 211,217 ---- -- -- If Stat is set True on return, then Is_Static_Expression is also set -- true in node N. There are some cases where this is over-enthusiastic, ! -- e.g. in the two operand case below, for string comparison, the result -- is not static even though the two operands are static. In such cases, -- the caller must reset the Is_Static_Expression flag in N. *************** package body Sem_Eval is *** 210,215 **** --- 224,241 ---- -- Same processing, except applies to an expression N with two operands -- Op1 and Op2. + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership; + -- Common processing for Is_In_Range and Is_Out_Of_Range: + -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time + -- that expression N is known to be in or out of range of the subtype Typ. + -- If not compile time known, Unknown is returned. + -- See documentation of Is_In_Range for complete description of parameters. + procedure To_Bits (U : Uint; B : out Bits); -- Converts a Uint value to a bit string of length B'Length *************** package body Sem_Eval is *** 616,624 **** --- 642,658 ---- -- types, since we may have two NaN values and they should never -- compare equal. + -- If the entity is a discriminant, the two expressions may be bounds + -- of components of objects of the same discriminated type. The + -- values of the discriminants are not static, and therefore the + -- result is unknown. + + -- It would be better to comment individual branches of this test ??? + if Nkind_In (Lf, N_Identifier, N_Expanded_Name) and then Nkind_In (Rf, N_Identifier, N_Expanded_Name) and then Entity (Lf) = Entity (Rf) + and then Ekind (Entity (Lf)) /= E_Discriminant and then Present (Entity (Lf)) and then not Is_Floating_Point_Type (Etype (L)) and then not Is_Volatile_Reference (L) *************** package body Sem_Eval is *** 1430,1435 **** --- 1464,1470 ---- Right : constant Node_Id := Right_Opnd (N); Ltype : constant Entity_Id := Etype (Left); Rtype : constant Entity_Id := Etype (Right); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; *************** package body Sem_Eval is *** 1442,1447 **** --- 1477,1489 ---- return; end if; + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- Fold for cases where both operands are of integer type if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then *************** package body Sem_Eval is *** 1548,1556 **** Fold_Uint (N, Result, Stat); end; ! -- Cases where at least one operand is a real. We handle the cases ! -- of both reals, or mixed/real integer cases (the latter happen ! -- only for divide and multiply, and the result is always real). elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then declare --- 1590,1598 ---- Fold_Uint (N, Result, Stat); end; ! -- Cases where at least one operand is a real. We handle the cases of ! -- both reals, or mixed/real integer cases (the latter happen only for ! -- divide and multiply, and the result is always real). elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then declare *************** package body Sem_Eval is *** 1593,1598 **** --- 1635,1648 ---- Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Arithmetic_Op; ---------------------------- *************** package body Sem_Eval is *** 1632,1641 **** and then Present (Alias (Entity (Name (N)))) and then Is_Enumeration_Type (Base_Type (Typ)) then ! Lit := Alias (Entity (Name (N))); ! while Present (Alias (Lit)) loop ! Lit := Alias (Lit); ! end loop; if Ekind (Lit) = E_Enumeration_Literal then if Base_Type (Etype (Lit)) /= Base_Type (Typ) then --- 1682,1688 ---- and then Present (Alias (Entity (Name (N)))) and then Is_Enumeration_Type (Base_Type (Typ)) then ! Lit := Ultimate_Alias (Entity (Name (N))); if Ekind (Lit) = E_Enumeration_Literal then if Base_Type (Etype (Lit)) /= Base_Type (Typ) then *************** package body Sem_Eval is *** 1650,1655 **** --- 1697,1723 ---- end if; end Eval_Call; + -------------------------- + -- Eval_Case_Expression -- + -------------------------- + + -- Right now we do not attempt folding of any case expressions, and the + -- language does not require it, so the only required processing is to + -- do the check for all expressions appearing in the case expression. + + procedure Eval_Case_Expression (N : Node_Id) is + Alt : Node_Id; + + begin + Check_Non_Static_Context (Expression (N)); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Check_Non_Static_Context (Expression (Alt)); + Next (Alt); + end loop; + end Eval_Case_Expression; + ------------------------ -- Eval_Concatenation -- ------------------------ *************** package body Sem_Eval is *** 1767,1784 **** -- Eval_Conditional_Expression -- --------------------------------- ! -- This GNAT internal construct can never be statically folded, so the ! -- only required processing is to do the check for non-static context ! -- for the two expression operands. procedure Eval_Conditional_Expression (N : Node_Id) is ! Condition : constant Node_Id := First (Expressions (N)); ! Then_Expr : constant Node_Id := Next (Condition); ! Else_Expr : constant Node_Id := Next (Then_Expr); begin ! Check_Non_Static_Context (Then_Expr); ! Check_Non_Static_Context (Else_Expr); end Eval_Conditional_Expression; ---------------------- --- 1835,1913 ---- -- Eval_Conditional_Expression -- --------------------------------- ! -- We can fold to a static expression if the condition and both constituent ! -- expressions are static. Otherwise, the only required processing is to do ! -- the check for non-static context for the then and else expressions. procedure Eval_Conditional_Expression (N : Node_Id) is ! Condition : constant Node_Id := First (Expressions (N)); ! Then_Expr : constant Node_Id := Next (Condition); ! Else_Expr : constant Node_Id := Next (Then_Expr); ! Result : Node_Id; ! Non_Result : Node_Id; ! ! Rstat : constant Boolean := ! Is_Static_Expression (Condition) ! and then ! Is_Static_Expression (Then_Expr) ! and then ! Is_Static_Expression (Else_Expr); begin ! -- If any operand is Any_Type, just propagate to result and do not try ! -- to fold, this prevents cascaded errors. ! ! if Etype (Condition) = Any_Type or else ! Etype (Then_Expr) = Any_Type or else ! Etype (Else_Expr) = Any_Type ! then ! Set_Etype (N, Any_Type); ! Set_Is_Static_Expression (N, False); ! return; ! ! -- Static case where we can fold. Note that we don't try to fold cases ! -- where the condition is known at compile time, but the result is ! -- non-static. This avoids possible cases of infinite recursion where ! -- the expander puts in a redundant test and we remove it. Instead we ! -- deal with these cases in the expander. ! ! elsif Rstat then ! ! -- Select result operand ! ! if Is_True (Expr_Value (Condition)) then ! Result := Then_Expr; ! Non_Result := Else_Expr; ! else ! Result := Else_Expr; ! Non_Result := Then_Expr; ! end if; ! ! -- Note that it does not matter if the non-result operand raises a ! -- Constraint_Error, but if the result raises constraint error then ! -- we replace the node with a raise constraint error. This will ! -- properly propagate Raises_Constraint_Error since this flag is ! -- set in Result. ! ! if Raises_Constraint_Error (Result) then ! Rewrite_In_Raise_CE (N, Result); ! Check_Non_Static_Context (Non_Result); ! ! -- Otherwise the result operand replaces the original node ! ! else ! Rewrite (N, Relocate_Node (Result)); ! end if; ! ! -- Case of condition not known at compile time ! ! else ! Check_Non_Static_Context (Condition); ! Check_Non_Static_Context (Then_Expr); ! Check_Non_Static_Context (Else_Expr); ! end if; ! ! Set_Is_Static_Expression (N, Rstat); end Eval_Conditional_Expression; ---------------------- *************** package body Sem_Eval is *** 2069,2075 **** Right_Int : constant Uint := Expr_Value (Right); begin ! if Is_Modular_Integer_Type (Etype (N)) then declare Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); --- 2198,2208 ---- Right_Int : constant Uint := Expr_Value (Right); begin ! -- VMS includes bitwise operations on signed types ! ! if Is_Modular_Integer_Type (Etype (N)) ! or else Is_VMS_Operator (Entity (N)) ! then declare Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); *************** package body Sem_Eval is *** 2144,2156 **** -- Ignore if error in either operand, except to make sure that Any_Type -- is properly propagated to avoid junk cascaded errors. ! if Etype (Left) = Any_Type ! or else Etype (Right) = Any_Type ! then Set_Etype (N, Any_Type); return; end if; -- Case of right operand is a subtype name if Is_Entity_Name (Right) then --- 2277,2296 ---- -- Ignore if error in either operand, except to make sure that Any_Type -- is properly propagated to avoid junk cascaded errors. ! if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then Set_Etype (N, Any_Type); return; end if; + -- Ignore if types involved have predicates + + if Present (Predicate_Function (Etype (Left))) + or else + Present (Predicate_Function (Etype (Right))) + then + return; + end if; + -- Case of right operand is a subtype name if Is_Entity_Name (Right) then *************** package body Sem_Eval is *** 2219,2225 **** declare Typlen : constant Uint := String_Type_Len (Etype (Right)); Strlen : constant Uint := ! UI_From_Int (String_Length (Strval (Get_String_Val (Left)))); begin Result := (Typlen = Strlen); end; --- 2359,2366 ---- declare Typlen : constant Uint := String_Type_Len (Etype (Right)); Strlen : constant Uint := ! UI_From_Int ! (String_Length (Strval (Get_String_Val (Left)))); begin Result := (Typlen = Strlen); end; *************** package body Sem_Eval is *** 2252,2257 **** --- 2393,2399 ---- end if; Fold_Uint (N, Test (Result), True); + Warn_On_Known_Condition (N); end Eval_Membership_Op; *************** package body Sem_Eval is *** 2311,2318 **** Result : Uint; begin ! -- Exponentiation of an integer raises the exception ! -- Constraint_Error for a negative exponent (RM 4.5.6) if Right_Int < 0 then Apply_Compile_Time_Constraint_Error --- 2453,2460 ---- Result : Uint; begin ! -- Exponentiation of an integer raises Constraint_Error for a ! -- negative exponent (RM 4.5.6). if Right_Int < 0 then Apply_Compile_Time_Constraint_Error *************** package body Sem_Eval is *** 2427,2435 **** begin -- Can only fold if target is string or scalar and subtype is static. ! -- Also, do not fold if our parent is an allocator (this is because ! -- the qualified expression is really part of the syntactic structure ! -- of an allocator, and we do not want to end up with something that -- corresponds to "new 1" where the 1 is the result of folding a -- qualified expression). --- 2569,2577 ---- begin -- Can only fold if target is string or scalar and subtype is static. ! -- Also, do not fold if our parent is an allocator (this is because the ! -- qualified expression is really part of the syntactic structure of an ! -- allocator, and we do not want to end up with something that -- corresponds to "new 1" where the 1 is the result of folding a -- qualified expression). *************** package body Sem_Eval is *** 2529,2542 **** -- Eval_Relational_Op -- ------------------------ ! -- Relational operations are static functions, so the result is static ! -- if both operands are static (RM 4.9(7), 4.9(20)), except that for ! -- strings, the result is never static, even if the operands are. procedure Eval_Relational_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Typ : constant Entity_Id := Etype (Left); Result : Boolean; Stat : Boolean; Fold : Boolean; --- 2671,2685 ---- -- Eval_Relational_Op -- ------------------------ ! -- Relational operations are static functions, so the result is static if ! -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings, ! -- the result is never static, even if the operands are. procedure Eval_Relational_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Typ : constant Entity_Id := Etype (Left); + Otype : Entity_Id := Empty; Result : Boolean; Stat : Boolean; Fold : Boolean; *************** package body Sem_Eval is *** 2615,2621 **** -- entity name, and the two X's are the same and K1 and K2 are -- known at compile time, in this case, the length can also be -- computed at compile time, even though the bounds are not ! -- known. A common case of this is e.g. (X'First..X'First+5). Extract_Length : declare procedure Decompose_Expr --- 2758,2764 ---- -- entity name, and the two X's are the same and K1 and K2 are -- known at compile time, in this case, the length can also be -- computed at compile time, even though the bounds are not ! -- known. A common case of this is e.g. (X'First .. X'First+5). Extract_Length : declare procedure Decompose_Expr *************** package body Sem_Eval is *** 2645,2661 **** if Nkind (Expr) = N_Op_Add and then Compile_Time_Known_Value (Right_Opnd (Expr)) then ! Exp := Left_Opnd (Expr); Cons := Expr_Value (Right_Opnd (Expr)); elsif Nkind (Expr) = N_Op_Subtract and then Compile_Time_Known_Value (Right_Opnd (Expr)) then ! Exp := Left_Opnd (Expr); Cons := -Expr_Value (Right_Opnd (Expr)); else ! Exp := Expr; Cons := Uint_0; end if; --- 2788,2824 ---- if Nkind (Expr) = N_Op_Add and then Compile_Time_Known_Value (Right_Opnd (Expr)) then ! Exp := Left_Opnd (Expr); Cons := Expr_Value (Right_Opnd (Expr)); elsif Nkind (Expr) = N_Op_Subtract and then Compile_Time_Known_Value (Right_Opnd (Expr)) then ! Exp := Left_Opnd (Expr); Cons := -Expr_Value (Right_Opnd (Expr)); + -- If the bound is a constant created to remove side + -- effects, recover original expression to see if it has + -- one of the recognizable forms. + + elsif Nkind (Expr) = N_Identifier + and then not Comes_From_Source (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Constant + and then + Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Exp := Expression (Parent (Entity (Expr))); + Decompose_Expr (Exp, Ent, Kind, Cons); + + -- If original expression includes an entity, create a + -- reference to it for use below. + + if Present (Ent) then + Exp := New_Occurrence_Of (Ent, Sloc (Ent)); + end if; + else ! Exp := Expr; Cons := Uint_0; end if; *************** package body Sem_Eval is *** 2664,2671 **** --- 2827,2836 ---- if Nkind (Exp) = N_Attribute_Reference then if Attribute_Name (Exp) = Name_First then Kind := 'F'; + elsif Attribute_Name (Exp) = Name_Last then Kind := 'L'; + else Ent := Empty; return; *************** package body Sem_Eval is *** 2746,2751 **** --- 2911,2927 ---- Set_Is_Static_Expression (N, False); end if; + -- For operators on universal numeric types called as functions with + -- an explicit scope, determine appropriate specific numeric type, and + -- diagnose possible ambiguity. + + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- For static real type expressions, we cannot use Compile_Time_Compare -- since it worries about run-time results which are not exact. *************** package body Sem_Eval is *** 2845,2850 **** --- 3021,3033 ---- Fold_Uint (N, Test (Result), Stat); end if; + -- For the case of a folded relational operator on a specific numeric + -- type, freeze operand type now. + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; + Warn_On_Known_Condition (N); end Eval_Relational_Op; *************** package body Sem_Eval is *** 2852,2860 **** -- Eval_Shift -- ---------------- ! -- Shift operations are intrinsic operations that can never be static, ! -- so the only processing required is to perform the required check for ! -- a non static context for the two operands. -- Actually we could do some compile time evaluation here some time ??? --- 3035,3043 ---- -- Eval_Shift -- ---------------- ! -- Shift operations are intrinsic operations that can never be static, so ! -- the only processing required is to perform the required check for a non ! -- static context for the two operands. -- Actually we could do some compile time evaluation here some time ??? *************** package body Sem_Eval is *** 2868,2891 **** -- Eval_Short_Circuit -- ------------------------ ! -- A short circuit operation is potentially static if both operands ! -- are potentially static (RM 4.9 (13)) procedure Eval_Short_Circuit (N : Node_Id) is Kind : constant Node_Kind := Nkind (N); Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Left_Int : Uint; ! Rstat : constant Boolean := ! Is_Static_Expression (Left) ! and then Is_Static_Expression (Right); begin -- Short circuit operations are never static in Ada 83 ! if Ada_Version = Ada_83 ! and then Comes_From_Source (N) ! then Check_Non_Static_Context (Left); Check_Non_Static_Context (Right); return; --- 3051,3074 ---- -- Eval_Short_Circuit -- ------------------------ ! -- A short circuit operation is potentially static if both operands are ! -- potentially static (RM 4.9 (13)). procedure Eval_Short_Circuit (N : Node_Id) is Kind : constant Node_Kind := Nkind (N); Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Left_Int : Uint; ! ! Rstat : constant Boolean := ! Is_Static_Expression (Left) ! and then ! Is_Static_Expression (Right); begin -- Short circuit operations are never static in Ada 83 ! if Ada_Version = Ada_83 and then Comes_From_Source (N) then Check_Non_Static_Context (Left); Check_Non_Static_Context (Right); return; *************** package body Sem_Eval is *** 2896,2903 **** -- are a special case, they can still be foldable, even if the right -- operand raises constraint error. ! -- If either operand is Any_Type, just propagate to result and ! -- do not try to fold, this prevents cascaded errors. if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then Set_Etype (N, Any_Type); --- 3079,3086 ---- -- are a special case, they can still be foldable, even if the right -- operand raises constraint error. ! -- If either operand is Any_Type, just propagate to result and do not ! -- try to fold, this prevents cascaded errors. if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then Set_Etype (N, Any_Type); *************** package body Sem_Eval is *** 2942,2948 **** if (Kind = N_And_Then and then Is_False (Left_Int)) or else ! (Kind = N_Or_Else and then Is_True (Left_Int)) then Fold_Uint (N, Left_Int, Rstat); return; --- 3125,3131 ---- if (Kind = N_And_Then and then Is_False (Left_Int)) or else ! (Kind = N_Or_Else and then Is_True (Left_Int)) then Fold_Uint (N, Left_Int, Rstat); return; *************** package body Sem_Eval is *** 2970,2977 **** -- Eval_Slice -- ---------------- ! -- Slices can never be static, so the only processing required is to ! -- check for non-static context if an explicit range is given. procedure Eval_Slice (N : Node_Id) is Drange : constant Node_Id := Discrete_Range (N); --- 3153,3160 ---- -- Eval_Slice -- ---------------- ! -- Slices can never be static, so the only processing required is to check ! -- for non-static context if an explicit range is given. procedure Eval_Slice (N : Node_Id) is Drange : constant Node_Id := Discrete_Range (N); *************** package body Sem_Eval is *** 2981,2987 **** Check_Non_Static_Context (High_Bound (Drange)); end if; ! -- A slice of the form A (subtype), when the subtype is the index of -- the type of A, is redundant, the slice can be replaced with A, and -- this is worth a warning. --- 3164,3170 ---- Check_Non_Static_Context (High_Bound (Drange)); end if; ! -- A slice of the form A (subtype), when the subtype is the index of -- the type of A, is redundant, the slice can be replaced with A, and -- this is worth a warning. *************** package body Sem_Eval is *** 3002,3008 **** Error_Msg_N ("redundant slice denotes whole array?", N); end if; ! -- The following might be a useful optimization ???? -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); end if; --- 3185,3191 ---- Error_Msg_N ("redundant slice denotes whole array?", N); end if; ! -- The following might be a useful optimization???? -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); end if; *************** package body Sem_Eval is *** 3024,3030 **** begin -- Nothing to do if error type (handles cases like default expressions ! -- or generics where we have not yet fully resolved the type) if Bas = Any_Type or else Bas = Any_String then return; --- 3207,3213 ---- begin -- Nothing to do if error type (handles cases like default expressions ! -- or generics where we have not yet fully resolved the type). if Bas = Any_Type or else Bas = Any_String then return; *************** package body Sem_Eval is *** 3042,3048 **** end if; -- Here if Etype of string literal is normal Etype (not yet possible, ! -- but may be possible in future!) elsif not Is_OK_Static_Expression (Type_Low_Bound (Etype (First_Index (Typ)))) --- 3225,3231 ---- end if; -- Here if Etype of string literal is normal Etype (not yet possible, ! -- but may be possible in future). elsif not Is_OK_Static_Expression (Type_Low_Bound (Etype (First_Index (Typ)))) *************** package body Sem_Eval is *** 3058,3069 **** return; end if; ! -- Test for illegal Ada 95 cases. A string literal is illegal in ! -- Ada 95 if its bounds are outside the index base type and this ! -- index type is static. This can happen in only two ways. Either ! -- the string literal is too long, or it is null, and the lower ! -- bound is type'First. In either case it is the upper bound that ! -- is out of range of the index type. if Ada_Version >= Ada_95 then if Root_Type (Bas) = Standard_String --- 3241,3252 ---- return; end if; ! -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95 ! -- if its bounds are outside the index base type and this index type is ! -- static. This can happen in only two ways. Either the string literal ! -- is too long, or it is null, and the lower bound is type'First. In ! -- either case it is the upper bound that is out of range of the index ! -- type. if Ada_Version >= Ada_95 then if Root_Type (Bas) = Standard_String *************** package body Sem_Eval is *** 3109,3115 **** -- A type conversion is potentially static if its subtype mark is for a -- static scalar subtype, and its operand expression is potentially static ! -- (RM 4.9 (10)) procedure Eval_Type_Conversion (N : Node_Id) is Operand : constant Node_Id := Expression (N); --- 3292,3298 ---- -- A type conversion is potentially static if its subtype mark is for a -- static scalar subtype, and its operand expression is potentially static ! -- (RM 4.9(10)). procedure Eval_Type_Conversion (N : Node_Id) is Operand : constant Node_Id := Expression (N); *************** package body Sem_Eval is *** 3120,3128 **** Fold : Boolean; function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; ! -- Returns true if type T is an integer type, or if it is a ! -- fixed-point type to be treated as an integer (i.e. the flag ! -- Conversion_OK is set on the conversion node). function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; -- Returns true if type T is a floating-point type, or if it is a --- 3303,3311 ---- Fold : Boolean; function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; ! -- Returns true if type T is an integer type, or if it is a fixed-point ! -- type to be treated as an integer (i.e. the flag Conversion_OK is set ! -- on the conversion node). function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; -- Returns true if type T is a floating-point type, or if it is a *************** package body Sem_Eval is *** 3256,3265 **** ------------------- -- Predefined unary operators are static functions (RM 4.9(20)) and thus ! -- are potentially static if the operand is potentially static (RM 4.9(7)) procedure Eval_Unary_Op (N : Node_Id) is Right : constant Node_Id := Right_Opnd (N); Stat : Boolean; Fold : Boolean; --- 3439,3449 ---- ------------------- -- Predefined unary operators are static functions (RM 4.9(20)) and thus ! -- are potentially static if the operand is potentially static (RM 4.9(7)). procedure Eval_Unary_Op (N : Node_Id) is Right : constant Node_Id := Right_Opnd (N); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; *************** package body Sem_Eval is *** 3272,3277 **** --- 3456,3468 ---- return; end if; + if Etype (Right) = Universal_Integer + or else + Etype (Right) = Universal_Real + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- Fold for integer case if Is_Integer_Type (Etype (N)) then *************** package body Sem_Eval is *** 3327,3332 **** --- 3518,3531 ---- Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Unary_Op; ------------------------------- *************** package body Sem_Eval is *** 3353,3360 **** if Is_Entity_Name (N) then Ent := Entity (N); ! -- An enumeration literal that was either in the source or ! -- created as a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then return Enumeration_Rep (Ent); --- 3552,3559 ---- if Is_Entity_Name (N) then Ent := Entity (N); ! -- An enumeration literal that was either in the source or created ! -- as a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then return Enumeration_Rep (Ent); *************** package body Sem_Eval is *** 3366,3373 **** return Expr_Rep_Value (Constant_Value (Ent)); end if; ! -- An integer literal that was either in the source or created ! -- as a result of static evaluation. elsif Kind = N_Integer_Literal then return Intval (N); --- 3565,3572 ---- return Expr_Rep_Value (Constant_Value (Ent)); end if; ! -- An integer literal that was either in the source or created as a ! -- result of static evaluation. elsif Kind = N_Integer_Literal then return Intval (N); *************** package body Sem_Eval is *** 3394,3404 **** pragma Assert (Kind = N_Character_Literal); Ent := Entity (N); ! -- Since Character literals of type Standard.Character don't ! -- have any defining character literals built for them, they ! -- do not have their Entity set, so just use their Char ! -- code. Otherwise for user-defined character literals use ! -- their Pos value as usual which is the same as the Rep value. if No (Ent) then return Char_Literal_Value (N); --- 3593,3603 ---- pragma Assert (Kind = N_Character_Literal); Ent := Entity (N); ! -- Since Character literals of type Standard.Character don't have any ! -- defining character literals built for them, they do not have their ! -- Entity set, so just use their Char code. Otherwise for user- ! -- defined character literals use their Pos value as usual which is ! -- the same as the Rep value. if No (Ent) then return Char_Literal_Value (N); *************** package body Sem_Eval is *** 3432,3439 **** if Is_Entity_Name (N) then Ent := Entity (N); ! -- An enumeration literal that was either in the source or ! -- created as a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then Val := Enumeration_Pos (Ent); --- 3631,3638 ---- if Is_Entity_Name (N) then Ent := Entity (N); ! -- An enumeration literal that was either in the source or created as ! -- a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then Val := Enumeration_Pos (Ent); *************** package body Sem_Eval is *** 3445,3452 **** Val := Expr_Value (Constant_Value (Ent)); end if; ! -- An integer literal that was either in the source or created ! -- as a result of static evaluation. elsif Kind = N_Integer_Literal then Val := Intval (N); --- 3644,3651 ---- Val := Expr_Value (Constant_Value (Ent)); end if; ! -- An integer literal that was either in the source or created as a ! -- result of static evaluation. elsif Kind = N_Integer_Literal then Val := Intval (N); *************** package body Sem_Eval is *** 3558,3565 **** return Ureal_0; end if; ! -- If we fall through, we have a node that cannot be interpreted ! -- as a compile time constant. That is definitely an error. raise Program_Error; end Expr_Value_R; --- 3757,3764 ---- return Ureal_0; end if; ! -- If we fall through, we have a node that cannot be interpreted as a ! -- compile time constant. That is definitely an error. raise Program_Error; end Expr_Value_R; *************** package body Sem_Eval is *** 3578,3583 **** --- 3777,3920 ---- end if; end Expr_Value_S; + ---------------------------------- + -- Find_Universal_Operator_Type -- + ---------------------------------- + + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is + PN : constant Node_Id := Parent (N); + Call : constant Node_Id := Original_Node (N); + Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); + + Is_Fix : constant Boolean := + Nkind (N) in N_Binary_Op + and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); + -- A mixed-mode operation in this context indicates the presence of + -- fixed-point type in the designated package. + + Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; + -- Case where N is a relational (or membership) operator (else it is an + -- arithmetic one). + + In_Membership : constant Boolean := + Nkind (PN) in N_Membership_Test + and then + Nkind (Right_Opnd (PN)) = N_Range + and then + Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) + and then + Is_Universal_Numeric_Type + (Etype (Low_Bound (Right_Opnd (PN)))) + and then + Is_Universal_Numeric_Type + (Etype (High_Bound (Right_Opnd (PN)))); + -- Case where N is part of a membership test with a universal range + + E : Entity_Id; + Pack : Entity_Id; + Typ1 : Entity_Id := Empty; + Priv_E : Entity_Id; + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; + -- Check whether one operand is a mixed-mode operation that requires the + -- presence of a fixed-point type. Given that all operands are universal + -- and have been constant-folded, retrieve the original function call. + + --------------------------- + -- Is_Mixed_Mode_Operand -- + --------------------------- + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is + Onod : constant Node_Id := Original_Node (Op); + begin + return Nkind (Onod) = N_Function_Call + and then Present (Next_Actual (First_Actual (Onod))) + and then Etype (First_Actual (Onod)) /= + Etype (Next_Actual (First_Actual (Onod))); + end Is_Mixed_Mode_Operand; + + -- Start of processing for Find_Universal_Operator_Type + + begin + if Nkind (Call) /= N_Function_Call + or else Nkind (Name (Call)) /= N_Expanded_Name + then + return Empty; + + -- There are several cases where the context does not imply the type of + -- the operands: + -- - the universal expression appears in a type conversion; + -- - the expression is a relational operator applied to universal + -- operands; + -- - the expression is a membership test with a universal operand + -- and a range with universal bounds. + + elsif Nkind (Parent (N)) = N_Type_Conversion + or else Is_Relational + or else In_Membership + then + Pack := Entity (Prefix (Name (Call))); + + -- If the prefix is a package declared elsewhere, iterate over its + -- visible entities, otherwise iterate over all declarations in the + -- designated scope. + + if Ekind (Pack) = E_Package + and then not In_Open_Scopes (Pack) + then + Priv_E := First_Private_Entity (Pack); + else + Priv_E := Empty; + end if; + + Typ1 := Empty; + E := First_Entity (Pack); + while Present (E) and then E /= Priv_E loop + if Is_Numeric_Type (E) + and then Nkind (Parent (E)) /= N_Subtype_Declaration + and then Comes_From_Source (E) + and then Is_Integer_Type (E) = Is_Int + and then + (Nkind (N) in N_Unary_Op + or else Is_Relational + or else Is_Fixed_Point_Type (E) = Is_Fix) + then + if No (Typ1) then + Typ1 := E; + + -- Before emitting an error, check for the presence of a + -- mixed-mode operation that specifies a fixed point type. + + elsif Is_Relational + and then + (Is_Mixed_Mode_Operand (Left_Opnd (N)) + or else Is_Mixed_Mode_Operand (Right_Opnd (N))) + and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) + + then + if Is_Fixed_Point_Type (E) then + Typ1 := E; + end if; + + else + -- More than one type of the proper class declared in P + + Error_Msg_N ("ambiguous operation", N); + Error_Msg_Sloc := Sloc (Typ1); + Error_Msg_N ("\possible interpretation (inherited)#", N); + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("\possible interpretation (inherited)#", N); + return Empty; + end if; + end if; + + Next_Entity (E); + end loop; + end if; + + return Typ1; + end Find_Universal_Operator_Type; + -------------------------- -- Flag_Non_Static_Expr -- -------------------------- *************** package body Sem_Eval is *** 3623,3630 **** Ent : Entity_Id; begin ! -- If we are folding a named number, retain the entity in the ! -- literal, for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer --- 3960,3967 ---- Ent : Entity_Id; begin ! -- If we are folding a named number, retain the entity in the literal, ! -- for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer *************** package body Sem_Eval is *** 3677,3684 **** Ent : Entity_Id; begin ! -- If we are folding a named number, retain the entity in the ! -- literal, for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real --- 4014,4021 ---- Ent : Entity_Id; begin ! -- If we are folding a named number, retain the entity in the literal, ! -- for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real *************** package body Sem_Eval is *** 3872,3949 **** Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is - Val : Uint; - Valr : Ureal; - - pragma Warnings (Off, Assume_Valid); - -- For now Assume_Valid is unreferenced since the current implementation - -- always returns False if N is not a compile time known value, but we - -- keep the parameter to allow for future enhancements in which we try - -- to get the information in the variable case as well. - begin ! -- Universal types have no range limits, so always in range ! ! if Typ = Universal_Integer or else Typ = Universal_Real then ! return True; ! ! -- Never in range if not scalar type. Don't know if this can ! -- actually happen, but our spec allows it, so we must check! ! ! elsif not Is_Scalar_Type (Typ) then ! return False; ! ! -- Never in range unless we have a compile time known value ! ! elsif not Compile_Time_Known_Value (N) then ! return False; ! ! -- General processing with a known compile time value ! ! else ! declare ! Lo : Node_Id; ! Hi : Node_Id; ! LB_Known : Boolean; ! UB_Known : Boolean; ! ! begin ! Lo := Type_Low_Bound (Typ); ! Hi := Type_High_Bound (Typ); ! ! LB_Known := Compile_Time_Known_Value (Lo); ! UB_Known := Compile_Time_Known_Value (Hi); ! ! -- Fixed point types should be considered as such only in ! -- flag Fixed_Int is set to False. ! ! if Is_Floating_Point_Type (Typ) ! or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) ! or else Int_Real ! then ! Valr := Expr_Value_R (N); ! ! if LB_Known and then Valr >= Expr_Value_R (Lo) ! and then UB_Known and then Valr <= Expr_Value_R (Hi) ! then ! return True; ! else ! return False; ! end if; ! ! else ! Val := Expr_Value (N); ! ! if LB_Known and then Val >= Expr_Value (Lo) ! and then UB_Known and then Val <= Expr_Value (Hi) ! then ! return True; ! else ! return False; ! end if; ! end if; ! end; ! end if; end Is_In_Range; ------------------- --- 4209,4217 ---- Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is begin ! return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) ! = In_Range; end Is_In_Range; ------------------- *************** package body Sem_Eval is *** 3998,4005 **** -- Is_OK_Static_Subtype -- -------------------------- ! -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) ! -- where neither bound raises constraint error when evaluated. function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is Base_T : constant Entity_Id := Base_Type (Typ); --- 4266,4273 ---- -- Is_OK_Static_Subtype -- -------------------------- ! -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where ! -- neither bound raises constraint error when evaluated. function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is Base_T : constant Entity_Id := Base_Type (Typ); *************** package body Sem_Eval is *** 4041,4048 **** return True; else ! -- Scalar_Range (Typ) might be an N_Subtype_Indication, so ! -- use Get_Type_Low,High_Bound. return Is_OK_Static_Subtype (Anc_Subt) and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) --- 4309,4316 ---- return True; else ! -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use ! -- Get_Type_{Low,High}_Bound. return Is_OK_Static_Subtype (Anc_Subt) and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) *************** package body Sem_Eval is *** 4067,4156 **** Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is - Val : Uint; - Valr : Ureal; - - pragma Warnings (Off, Assume_Valid); - -- For now Assume_Valid is unreferenced since the current implementation - -- always returns False if N is not a compile time known value, but we - -- keep the parameter to allow for future enhancements in which we try - -- to get the information in the variable case as well. - begin ! -- Universal types have no range limits, so always in range ! ! if Typ = Universal_Integer or else Typ = Universal_Real then ! return False; ! ! -- Never out of range if not scalar type. Don't know if this can ! -- actually happen, but our spec allows it, so we must check! ! ! elsif not Is_Scalar_Type (Typ) then ! return False; ! ! -- Never out of range if this is a generic type, since the bounds ! -- of generic types are junk. Note that if we only checked for ! -- static expressions (instead of compile time known values) below, ! -- we would not need this check, because values of a generic type ! -- can never be static, but they can be known at compile time. ! ! elsif Is_Generic_Type (Typ) then ! return False; ! ! -- Never out of range unless we have a compile time known value ! ! elsif not Compile_Time_Known_Value (N) then ! return False; ! ! else ! declare ! Lo : Node_Id; ! Hi : Node_Id; ! LB_Known : Boolean; ! UB_Known : Boolean; ! ! begin ! Lo := Type_Low_Bound (Typ); ! Hi := Type_High_Bound (Typ); ! ! LB_Known := Compile_Time_Known_Value (Lo); ! UB_Known := Compile_Time_Known_Value (Hi); ! ! -- Real types (note that fixed-point types are not treated ! -- as being of a real type if the flag Fixed_Int is set, ! -- since in that case they are regarded as integer types). ! ! if Is_Floating_Point_Type (Typ) ! or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) ! or else Int_Real ! then ! Valr := Expr_Value_R (N); ! ! if LB_Known and then Valr < Expr_Value_R (Lo) then ! return True; ! ! elsif UB_Known and then Expr_Value_R (Hi) < Valr then ! return True; ! ! else ! return False; ! end if; ! ! else ! Val := Expr_Value (N); ! ! if LB_Known and then Val < Expr_Value (Lo) then ! return True; ! ! elsif UB_Known and then Expr_Value (Hi) < Val then ! return True; ! ! else ! return False; ! end if; ! end if; ! end; ! end if; end Is_Out_Of_Range; --------------------- --- 4335,4343 ---- Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is begin ! return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) ! = Out_Of_Range; end Is_Out_Of_Range; --------------------- *************** package body Sem_Eval is *** 4275,4284 **** begin -- If we have the static expression case, then this is an illegality -- in Ada 95 mode, except that in an instance, we never generate an ! -- error (if the error is legitimate, it was already diagnosed in ! -- the template). The expression to compute the length of a packed ! -- array is attached to the array type itself, and deserves a separate ! -- message. if Is_Static_Expression (N) and then not In_Instance --- 4462,4470 ---- begin -- If we have the static expression case, then this is an illegality -- in Ada 95 mode, except that in an instance, we never generate an ! -- error (if the error is legitimate, it was already diagnosed in the ! -- template). The expression to compute the length of a packed array is ! -- attached to the array type itself, and deserves a separate message. if Is_Static_Expression (N) and then not In_Instance *************** package body Sem_Eval is *** 4300,4307 **** (N, "value not in range of}", CE_Range_Check_Failed); end if; ! -- Here we generate a warning for the Ada 83 case, or when we are ! -- in an instance, or when we have a non-static expression case. else Apply_Compile_Time_Constraint_Error --- 4486,4493 ---- (N, "value not in range of}", CE_Range_Check_Failed); end if; ! -- Here we generate a warning for the Ada 83 case, or when we are in an ! -- instance, or when we have a non-static expression case. else Apply_Compile_Time_Constraint_Error *************** package body Sem_Eval is *** 4317,4338 **** Typ : constant Entity_Id := Etype (N); begin ! -- If we want to raise CE in the condition of a raise_CE node ! -- we may as well get rid of the condition if Present (Parent (N)) and then Nkind (Parent (N)) = N_Raise_Constraint_Error then Set_Condition (Parent (N), Empty); ! -- If the expression raising CE is a N_Raise_CE node, we can use ! -- that one. We just preserve the type of the context elsif Nkind (Exp) = N_Raise_Constraint_Error then Rewrite (N, Exp); Set_Etype (N, Typ); ! -- We have to build an explicit raise_ce node else Rewrite (N, --- 4503,4524 ---- Typ : constant Entity_Id := Etype (N); begin ! -- If we want to raise CE in the condition of a N_Raise_CE node ! -- we may as well get rid of the condition. if Present (Parent (N)) and then Nkind (Parent (N)) = N_Raise_Constraint_Error then Set_Condition (Parent (N), Empty); ! -- If the expression raising CE is a N_Raise_CE node, we can use that ! -- one. We just preserve the type of the context. elsif Nkind (Exp) = N_Raise_Constraint_Error then Rewrite (N, Exp); Set_Etype (N, Typ); ! -- Else build an explcit N_Raise_CE else Rewrite (N, *************** package body Sem_Eval is *** 4371,4376 **** --- 4557,4564 ---- T2 : Entity_Id) return Boolean is begin + -- Scalar types + if Is_Scalar_Type (T1) then -- Definitely compatible if we match *************** package body Sem_Eval is *** 4393,4401 **** then return True; ! -- Base types must match, but we don't check that (should ! -- we???) but we do at least check that both types are ! -- real, or both types are not real. elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then return False; --- 4581,4589 ---- then return True; ! -- Base types must match, but we don't check that (should we???) but ! -- we do at least check that both types are real, or both types are ! -- not real. elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then return False; *************** package body Sem_Eval is *** 4429,4438 **** end; end if; elsif Is_Access_Type (T1) then ! return not Is_Constrained (T2) ! or else Subtypes_Statically_Match ! (Designated_Type (T1), Designated_Type (T2)); else return (Is_Composite_Type (T1) and then not Is_Constrained (T2)) --- 4617,4632 ---- end; end if; + -- Access types + elsif Is_Access_Type (T1) then ! return (not Is_Constrained (T2) ! or else (Subtypes_Statically_Match ! (Designated_Type (T1), Designated_Type (T2)))) ! and then not (Can_Never_Be_Null (T2) ! and then not Can_Never_Be_Null (T1)); ! ! -- All other cases else return (Is_Composite_Type (T1) and then not Is_Constrained (T2)) *************** package body Sem_Eval is *** 4470,4484 **** -- subtype, i.e. both types must be constrained or unconstrained. -- To understand the requirement for this test, see RM 4.9.1(1). ! -- As is made clear in RM 3.5.4(11), type Integer, for example ! -- is a constrained subtype with constraint bounds matching the ! -- bounds of its corresponding unconstrained base type. In this ! -- situation, Integer and Integer'Base do not statically match, ! -- even though they have the same bounds. ! -- We only apply this test to types in Standard and types that ! -- appear in user programs. That way, we do not have to be ! -- too careful about setting Is_Constrained right for itypes. if Is_Numeric_Type (T1) and then (Is_Constrained (T1) /= Is_Constrained (T2)) --- 4664,4678 ---- -- subtype, i.e. both types must be constrained or unconstrained. -- To understand the requirement for this test, see RM 4.9.1(1). ! -- As is made clear in RM 3.5.4(11), type Integer, for example is ! -- a constrained subtype with constraint bounds matching the bounds ! -- of its corresponding unconstrained base type. In this situation, ! -- Integer and Integer'Base do not statically match, even though ! -- they have the same bounds. ! -- We only apply this test to types in Standard and types that appear ! -- in user programs. That way, we do not have to be too careful about ! -- setting Is_Constrained right for Itypes. if Is_Numeric_Type (T1) and then (Is_Constrained (T1) /= Is_Constrained (T2)) *************** package body Sem_Eval is *** 4489,4497 **** then return False; ! -- A generic scalar type does not statically match its base ! -- type (AI-311). In this case we make sure that the formals, ! -- which are first subtypes of their bases, are constrained. elsif Is_Generic_Type (T1) and then Is_Generic_Type (T2) --- 4683,4691 ---- then return False; ! -- A generic scalar type does not statically match its base type ! -- (AI-311). In this case we make sure that the formals, which are ! -- first subtypes of their bases, are constrained. elsif Is_Generic_Type (T1) and then Is_Generic_Type (T2) *************** package body Sem_Eval is *** 4500,4511 **** return False; end if; ! -- If there was an error in either range, then just assume ! -- the types statically match to avoid further junk errors ! if Error_Posted (Scalar_Range (T1)) ! or else ! Error_Posted (Scalar_Range (T2)) then return True; end if; --- 4694,4705 ---- return False; end if; ! -- If there was an error in either range, then just assume the types ! -- statically match to avoid further junk errors. ! if No (Scalar_Range (T1)) or else No (Scalar_Range (T2)) ! or else Error_Posted (Scalar_Range (T1)) ! or else Error_Posted (Scalar_Range (T2)) then return True; end if; *************** package body Sem_Eval is *** 4532,4539 **** then return False; ! -- If either type has constraint error bounds, then say ! -- that they match to avoid junk cascaded errors here. elsif not Is_OK_Static_Subtype (T1) or else not Is_OK_Static_Subtype (T2) --- 4726,4733 ---- then return False; ! -- If either type has constraint error bounds, then say that ! -- they match to avoid junk cascaded errors here. elsif not Is_OK_Static_Subtype (T1) or else not Is_OK_Static_Subtype (T2) *************** package body Sem_Eval is *** 4643,4653 **** return True; ! -- A definite type does not match an indefinite or classwide type -- However, a generic type with unknown discriminants may be -- instantiated with a type with no discriminants, and conformance ! -- checking on an inherited operation may compare the actual with ! -- the subtype that renames it in the instance. elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) --- 4837,4847 ---- return True; ! -- A definite type does not match an indefinite or classwide type. -- However, a generic type with unknown discriminants may be -- instantiated with a type with no discriminants, and conformance ! -- checking on an inherited operation may compare the actual with the ! -- subtype that renames it in the instance. elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) *************** package body Sem_Eval is *** 4659,4674 **** elsif Is_Array_Type (T1) then ! -- If either subtype is unconstrained then both must be, ! -- and if both are unconstrained then no further checking ! -- is needed. if not Is_Constrained (T1) or else not Is_Constrained (T2) then return not (Is_Constrained (T1) or else Is_Constrained (T2)); end if; ! -- Both subtypes are constrained, so check that the index ! -- subtypes statically match. declare Index1 : Node_Id := First_Index (T1); --- 4853,4867 ---- elsif Is_Array_Type (T1) then ! -- If either subtype is unconstrained then both must be, and if both ! -- are unconstrained then no further checking is needed. if not Is_Constrained (T1) or else not Is_Constrained (T2) then return not (Is_Constrained (T1) or else Is_Constrained (T2)); end if; ! -- Both subtypes are constrained, so check that the index subtypes ! -- statically match. declare Index1 : Node_Id := First_Index (T1); *************** package body Sem_Eval is *** 4693,4700 **** if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then return False; ! elsif Ekind (T1) = E_Access_Subprogram_Type ! or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type then return Subtype_Conformant --- 4886,4893 ---- if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then return False; ! elsif Ekind_In (T1, E_Access_Subprogram_Type, ! E_Anonymous_Access_Subprogram_Type) then return Subtype_Conformant *************** package body Sem_Eval is *** 4819,4826 **** Set_Etype (N, Any_Type); return; ! -- If left operand raises constraint error, then replace node N with ! -- the raise constraint error node, and we are obviously not foldable. -- Is_Static_Expression is set from the two operands in the normal way, -- and we check the right operand if it is in a non-static context. --- 5012,5019 ---- Set_Etype (N, Any_Type); return; ! -- If left operand raises constraint error, then replace node N with the ! -- Raise_Constraint_Error node, and we are obviously not foldable. -- Is_Static_Expression is set from the two operands in the normal way, -- and we check the right operand if it is in a non-static context. *************** package body Sem_Eval is *** 4833,4841 **** Set_Is_Static_Expression (N, Rstat); return; ! -- Similar processing for the case of the right operand. Note that ! -- we don't use this routine for the short-circuit case, so we do ! -- not have to worry about that special case here. elsif Raises_Constraint_Error (Op2) then if not Rstat then --- 5026,5034 ---- Set_Is_Static_Expression (N, Rstat); return; ! -- Similar processing for the case of the right operand. Note that we ! -- don't use this routine for the short-circuit case, so we do not have ! -- to worry about that special case here. elsif Raises_Constraint_Error (Op2) then if not Rstat then *************** package body Sem_Eval is *** 4855,4861 **** return; -- If result is not static, then check non-static contexts on operands ! -- since one of them may be static and the other one may not be static elsif not Rstat then Check_Non_Static_Context (Op1); --- 5048,5054 ---- return; -- If result is not static, then check non-static contexts on operands ! -- since one of them may be static and the other one may not be static. elsif not Rstat then Check_Non_Static_Context (Op1); *************** package body Sem_Eval is *** 4864,4871 **** and then Compile_Time_Known_Value (Op2); return; ! -- Else result is static and foldable. Both operands are static, ! -- and neither raises constraint error, so we can definitely fold. else Set_Is_Static_Expression (N); --- 5057,5064 ---- and then Compile_Time_Known_Value (Op2); return; ! -- Else result is static and foldable. Both operands are static, and ! -- neither raises constraint error, so we can definitely fold. else Set_Is_Static_Expression (N); *************** package body Sem_Eval is *** 4875,4880 **** --- 5068,5192 ---- end if; end Test_Expression_Is_Foldable; + ------------------- + -- Test_In_Range -- + ------------------- + + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership + is + Val : Uint; + Valr : Ureal; + + pragma Warnings (Off, Assume_Valid); + -- For now Assume_Valid is unreferenced since the current implementation + -- always returns Unknown if N is not a compile time known value, but we + -- keep the parameter to allow for future enhancements in which we try + -- to get the information in the variable case as well. + + begin + -- Universal types have no range limits, so always in range + + if Typ = Universal_Integer or else Typ = Universal_Real then + return In_Range; + + -- Never known if not scalar type. Don't know if this can actually + -- happen, but our spec allows it, so we must check! + + elsif not Is_Scalar_Type (Typ) then + return Unknown; + + -- Never known if this is a generic type, since the bounds of generic + -- types are junk. Note that if we only checked for static expressions + -- (instead of compile time known values) below, we would not need this + -- check, because values of a generic type can never be static, but they + -- can be known at compile time. + + elsif Is_Generic_Type (Typ) then + return Unknown; + + -- Never known unless we have a compile time known value + + elsif not Compile_Time_Known_Value (N) then + return Unknown; + + -- General processing with a known compile time value + + else + declare + Lo : Node_Id; + Hi : Node_Id; + + LB_Known : Boolean; + HB_Known : Boolean; + + begin + Lo := Type_Low_Bound (Typ); + Hi := Type_High_Bound (Typ); + + LB_Known := Compile_Time_Known_Value (Lo); + HB_Known := Compile_Time_Known_Value (Hi); + + -- Fixed point types should be considered as such only if flag + -- Fixed_Int is set to False. + + if Is_Floating_Point_Type (Typ) + or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) + or else Int_Real + then + Valr := Expr_Value_R (N); + + if LB_Known and HB_Known then + if Valr >= Expr_Value_R (Lo) + and then + Valr <= Expr_Value_R (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Valr < Expr_Value_R (Lo)) + or else + (HB_Known and then Valr > Expr_Value_R (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + + else + Val := Expr_Value (N); + + if LB_Known and HB_Known then + if Val >= Expr_Value (Lo) + and then + Val <= Expr_Value (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Val < Expr_Value (Lo)) + or else + (HB_Known and then Val > Expr_Value (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + end if; + end; + end if; + end Test_In_Range; + -------------- -- To_Bits -- -------------- *************** package body Sem_Eval is *** 4896,4903 **** E : Entity_Id; procedure Why_Not_Static_List (L : List_Id); ! -- A version that can be called on a list of expressions. Finds ! -- all non-static violations in any element of the list. ------------------------- -- Why_Not_Static_List -- --- 5208,5215 ---- E : Entity_Id; procedure Why_Not_Static_List (L : List_Id); ! -- A version that can be called on a list of expressions. Finds all ! -- non-static violations in any element of the list. ------------------------- -- Why_Not_Static_List -- *************** package body Sem_Eval is *** 4919,4926 **** -- Start of processing for Why_Not_Static begin ! -- If in ACATS mode (debug flag 2), then suppress all these ! -- messages, this avoids massive updates to the ACATS base line. if Debug_Flag_2 then return; --- 5231,5238 ---- -- Start of processing for Why_Not_Static begin ! -- If in ACATS mode (debug flag 2), then suppress all these messages, ! -- this avoids massive updates to the ACATS base line. if Debug_Flag_2 then return; *************** package body Sem_Eval is *** 5044,5051 **** return; ! -- Special case generic types, since again this is a common ! -- source of confusion. elsif Is_Generic_Actual_Type (E) or else --- 5356,5363 ---- return; ! -- Special case generic types, since again this is a common source ! -- of confusion. elsif Is_Generic_Actual_Type (E) or else *************** package body Sem_Eval is *** 5120,5127 **** when N_Type_Conversion => Why_Not_Static (Expression (N)); ! if not Is_Scalar_Type (Etype (Prefix (N))) ! or else not Is_Static_Subtype (Etype (Prefix (N))) then Error_Msg_N ("static conversion requires static scalar subtype result " & --- 5432,5439 ---- when N_Type_Conversion => Why_Not_Static (Expression (N)); ! if not Is_Scalar_Type (Entity (Subtype_Mark (N))) ! or else not Is_Static_Subtype (Entity (Subtype_Mark (N))) then Error_Msg_N ("static conversion requires static scalar subtype result " & diff -Nrcpad gcc-4.5.2/gcc/ada/sem_eval.ads gcc-4.6.0/gcc/ada/sem_eval.ads *** gcc-4.5.2/gcc/ada/sem_eval.ads Mon Apr 20 13:28:50 2009 --- gcc-4.6.0/gcc/ada/sem_eval.ads Fri Jun 18 09:41:49 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Eval is *** 282,287 **** --- 282,288 ---- procedure Eval_Allocator (N : Node_Id); procedure Eval_Arithmetic_Op (N : Node_Id); procedure Eval_Call (N : Node_Id); + procedure Eval_Case_Expression (N : Node_Id); procedure Eval_Character_Literal (N : Node_Id); procedure Eval_Concatenation (N : Node_Id); procedure Eval_Conditional_Expression (N : Node_Id); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_intr.adb gcc-4.6.0/gcc/ada/sem_intr.adb *** gcc-4.5.2/gcc/ada/sem_intr.adb Mon Jul 20 13:06:01 2009 --- gcc-4.6.0/gcc/ada/sem_intr.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Errout; use Errout; *** 31,36 **** --- 31,37 ---- with Fname; use Fname; with Lib; use Lib; with Namet; use Namet; + with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; *************** package body Sem_Intr is *** 53,60 **** -- returns type String. procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id); ! -- Check that operator is one of the binary arithmetic operators, and ! -- that the types involved have the same size. procedure Check_Shift (E : Entity_Id; N : Node_Id); -- Check intrinsic shift subprogram, the two arguments are the same --- 54,61 ---- -- returns type String. procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id); ! -- Check that operator is one of the binary arithmetic operators, and that ! -- the types involved both have underlying integer types. procedure Check_Shift (E : Entity_Id; N : Node_Id); -- Check intrinsic shift subprogram, the two arguments are the same *************** package body Sem_Intr is *** 73,81 **** procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is begin ! if Ekind (E) /= E_Function ! and then Ekind (E) /= E_Generic_Function ! then Errint ("intrinsic exception subprogram must be a function", E, N); --- 74,80 ---- procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is begin ! if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic exception subprogram must be a function", E, N); *************** package body Sem_Intr is *** 98,107 **** procedure Check_Intrinsic_Call (N : Node_Id) is Nam : constant Entity_Id := Entity (Name (N)); - Cnam : constant Name_Id := Chars (Nam); Arg1 : constant Node_Id := First_Actual (N); begin -- For Import_xxx calls, argument must be static string. A string -- literal is legal even in Ada83 mode, where such literals are -- not static. --- 97,128 ---- procedure Check_Intrinsic_Call (N : Node_Id) is Nam : constant Entity_Id := Entity (Name (N)); Arg1 : constant Node_Id := First_Actual (N); + Typ : Entity_Id; + Rtyp : Entity_Id; + Cnam : Name_Id; + Unam : Node_Id; begin + -- Set argument type if argument present + + if Present (Arg1) then + Typ := Etype (Arg1); + Rtyp := Underlying_Type (Root_Type (Typ)); + end if; + + -- Set intrinsic name (getting original name in the generic case) + + Unam := Ultimate_Alias (Nam); + + if Present (Parent (Unam)) + and then Present (Generic_Parent (Parent (Unam))) + then + Cnam := Chars (Generic_Parent (Parent (Unam))); + else + Cnam := Chars (Nam); + end if; + -- For Import_xxx calls, argument must be static string. A string -- literal is legal even in Ada83 mode, where such literals are -- not static. *************** package body Sem_Intr is *** 138,149 **** -- Check for the case of freeing a non-null object which will raise -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. ! elsif Cnam = Name_Free and then Can_Never_Be_Null (Etype (Arg1)) then Error_Msg_N ("freeing `NOT NULL` object will raise Constraint_Error?", N); -- For now, no other special checks are required else --- 159,181 ---- -- Check for the case of freeing a non-null object which will raise -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. ! elsif Cnam = Name_Unchecked_Deallocation and then Can_Never_Be_Null (Etype (Arg1)) then Error_Msg_N ("freeing `NOT NULL` object will raise Constraint_Error?", N); + -- For unchecked deallocation, error to deallocate from empty pool. + -- Note: this test used to be in Exp_Intr as a warning, but AI 157 + -- issues a binding interpretation that this should be an error, and + -- consequently it needs to be done in the semantic analysis so that + -- the error is issued even in semantics only mode. + + elsif Cnam = Name_Unchecked_Deallocation + and then No_Pool_Assigned (Rtyp) + then + Error_Msg_N ("deallocation from empty storage pool!", N); + -- For now, no other special checks are required else *************** package body Sem_Intr is *** 190,198 **** then T2 := T1; ! else ! -- Previous error in declaration return; end if; --- 222,230 ---- then T2 := T1; ! -- Previous error in declaration + else return; end if; *************** package body Sem_Intr is *** 200,210 **** T2 := Etype (Next_Formal (First_Formal (E))); end if; ! if Root_Type (T1) /= Root_Type (T2) ! or else Root_Type (T1) /= Root_Type (Ret) then Errint ! ("types of intrinsic operator must have the same size", E, N); end if; -- Comparison operators --- 232,255 ---- T2 := Etype (Next_Formal (First_Formal (E))); end if; ! -- Same types, predefined operator will apply ! ! if Root_Type (T1) = Root_Type (T2) ! or else Root_Type (T1) = Root_Type (Ret) then + null; + + -- Expansion will introduce conversions if sizes are not equal + + elsif Is_Integer_Type (Underlying_Type (T1)) + and then Is_Integer_Type (Underlying_Type (T2)) + and then Is_Integer_Type (Underlying_Type (Ret)) + then + null; + + else Errint ! ("types of intrinsic operator operands do not match", E, N); end if; -- Comparison operators *************** package body Sem_Intr is *** 223,234 **** then T1 := Etype (First_Formal (E)); ! if No (Next_Formal (First_Formal (E))) then ! ! -- Previous error in declaration return; - else T2 := Etype (Next_Formal (First_Formal (E))); end if; --- 268,277 ---- then T1 := Etype (First_Formal (E)); ! -- Return if previous error in declaration, otherwise get T2 type + if No (Next_Formal (First_Formal (E))) then return; else T2 := Etype (Next_Formal (First_Formal (E))); end if; *************** package body Sem_Intr is *** 274,280 **** return; end if; ! if not Is_Numeric_Type (T1) then Errint ("intrinsic operator can only apply to numeric types", E, N); end if; end Check_Intrinsic_Operator; --- 317,323 ---- return; end if; ! if not Is_Numeric_Type (Underlying_Type (T1)) then Errint ("intrinsic operator can only apply to numeric types", E, N); end if; end Check_Intrinsic_Operator; *************** package body Sem_Intr is *** 374,382 **** Ptyp2 : Node_Id; begin ! if Ekind (E) /= E_Function ! and then Ekind (E) /= E_Generic_Function ! then Errint ("intrinsic shift subprogram must be a function", E, N); return; end if; --- 417,423 ---- Ptyp2 : Node_Id; begin ! if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic shift subprogram must be a function", E, N); return; end if; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_mech.adb gcc-4.6.0/gcc/ada/sem_mech.adb *** gcc-4.5.2/gcc/ada/sem_mech.adb Thu Apr 9 10:27:10 2009 --- gcc-4.6.0/gcc/ada/sem_mech.adb Fri Jun 18 12:14:52 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2010, 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- -- *************** package body Sem_Mech is *** 92,99 **** return; elsif Chars (Mech_Name) = Name_Copy then ! Error_Msg_N ! ("bad mechanism name, Value assumed", Mech_Name); Set_Mechanism (Ent, By_Copy); else --- 92,98 ---- return; elsif Chars (Mech_Name) = Name_Copy then ! Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); Set_Mechanism (Ent, By_Copy); else diff -Nrcpad gcc-4.5.2/gcc/ada/sem_prag.adb gcc-4.6.0/gcc/ada/sem_prag.adb *** gcc-4.5.2/gcc/ada/sem_prag.adb Wed Jan 27 13:29:52 2010 --- gcc-4.6.0/gcc/ada/sem_prag.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Debug; use Debug; *** 37,42 **** --- 37,43 ---- with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; + with Exp_Ch7; use Exp_Ch7; with Exp_Dist; use Exp_Dist; with Lib; use Lib; with Lib.Writ; use Lib.Writ; *************** with Nlists; use Nlists; *** 46,51 **** --- 47,53 ---- with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; + with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; *************** with Sem_Ch6; use Sem_Ch6; *** 56,61 **** --- 58,64 ---- with Sem_Ch8; use Sem_Ch8; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; + with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; with Sem_Eval; use Sem_Eval; *************** package body Sem_Prag is *** 88,97 **** -- Common Handling of Import-Export Pragmas -- ---------------------------------------------- ! -- In the following section, a number of Import_xxx and Export_xxx ! -- pragmas are defined by GNAT. These are compatible with the DEC ! -- pragmas of the same name, and all have the following common ! -- form and processing: -- pragma Export_xxx -- [Internal =>] LOCAL_NAME --- 91,99 ---- -- Common Handling of Import-Export Pragmas -- ---------------------------------------------- ! -- In the following section, a number of Import_xxx and Export_xxx pragmas ! -- are defined by GNAT. These are compatible with the DEC pragmas of the ! -- same name, and all have the following common form and processing: -- pragma Export_xxx -- [Internal =>] LOCAL_NAME *************** package body Sem_Prag is *** 176,189 **** -- original one, following the renaming chain) is returned. Otherwise the -- entity is returned unchanged. Should be in Einfo??? - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; - -- All the routines that check pragma arguments take either a pragma - -- argument association (in which case the expression of the argument - -- association is checked), or the expression directly. The function - -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg - -- is a pragma argument association node, then its expression is returned, - -- otherwise Arg is returned unchanged. - procedure rv; -- This is a dummy function called by the processing for pragma Reviewable. -- It is there for assisting front end debugging. By placing a Reviewable --- 178,183 ---- *************** package body Sem_Prag is *** 246,254 **** ------------------------------ procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is ! Arg1 : constant Node_Id := ! First (Pragma_Argument_Associations (N)); ! Arg2 : constant Node_Id := Next (Arg1); begin -- Install formals and push subprogram spec onto scope stack so that we --- 240,246 ---- ------------------------------ procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is ! Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); begin -- Install formals and push subprogram spec onto scope stack so that we *************** package body Sem_Prag is *** 263,275 **** Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); - -- If there is a message argument, analyze it the same way - - if Present (Arg2) then - Preanalyze_Spec_Expression - (Get_Pragma_Arg (Arg2), Standard_String); - end if; - -- Remove the subprogram from the scope stack now that the pre-analysis -- of the precondition/postcondition is done. --- 255,260 ---- *************** package body Sem_Prag is *** 285,290 **** --- 270,282 ---- Pname : constant Name_Id := Pragma_Name (N); Prag_Id : Pragma_Id; + Sense : constant Boolean := not Aspect_Cancel (N); + -- Sense is True if we have the normal case of a pragma that is active + -- and turns the corresponding aspect on. It is false only for the case + -- of a pragma coming from an aspect which is explicitly turned off by + -- using aspect => False. If Sense is False, the effect of the pragma + -- is to turn the corresponding aspect off. + Pragma_Exit : exception; -- This exception is used to exit pragma processing completely. It is -- used when an error is detected, and no further processing is *************** package body Sem_Prag is *** 308,314 **** procedure Ada_2005_Pragma; -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In -- Ada 95 mode, these are implementation defined pragmas, so should be ! -- caught by the No_Implementation_Pragmas restriction procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada --- 300,311 ---- procedure Ada_2005_Pragma; -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In -- Ada 95 mode, these are implementation defined pragmas, so should be ! -- caught by the No_Implementation_Pragmas restriction. ! ! procedure Ada_2012_Pragma; ! -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. ! -- In Ada 95 or 05 mode, these are implementation defined pragmas, so ! -- should be caught by the No_Implementation_Pragmas restriction. procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada *************** package body Sem_Prag is *** 376,385 **** -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If -- Typ is left Empty, then any static expression is allowed. - procedure Check_Arg_Is_String_Literal (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a string - -- literal. If not give error and raise Pragma_Exit - procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); -- Check the specified argument Arg to make sure that it is a valid task -- dispatching policy name. If not give error and raise Pragma_Exit. --- 373,378 ---- *************** package body Sem_Prag is *** 395,403 **** procedure Check_At_Most_N_Arguments (N : Nat); -- Check there are no more than N arguments present ! procedure Check_Component (Comp : Node_Id); ! -- Examine Unchecked_Union component for correct use of per-object -- constrained subtypes, and for restrictions on finalizable components. procedure Check_Duplicated_Export_Name (Nam : Node_Id); -- Nam is an N_String_Literal node containing the external name set by --- 388,407 ---- procedure Check_At_Most_N_Arguments (N : Nat); -- Check there are no more than N arguments present ! procedure Check_Component ! (Comp : Node_Id; ! UU_Typ : Entity_Id; ! In_Variant_Part : Boolean := False); ! -- Examine an Unchecked_Union component for correct use of per-object -- constrained subtypes, and for restrictions on finalizable components. + -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part + -- should be set when Comp comes from a record variant. + + procedure Check_Duplicate_Pragma (E : Entity_Id); + -- Check if a pragma of the same name as the current pragma is already + -- chained as a rep pragma to the given entity. If so give a message + -- about the duplicate, and then raise Pragma_Exit so does not return. + -- Also checks for delayed aspect specification node in the chain. procedure Check_Duplicated_Export_Name (Nam : Node_Id); -- Nam is an N_String_Literal node containing the external name set by *************** package body Sem_Prag is *** 406,417 **** -- case, and if found, issues an appropriate error message. procedure Check_First_Subtype (Arg : Node_Id); ! -- Checks that Arg, whose expression is an entity name referencing a ! -- subtype, does not reference a type that is not a first subtype. procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program ! -- (Priority, Main_Storage, Time_Slice, Relative_Deadline). procedure Check_Interrupt_Or_Attach_Handler; -- Common processing for first argument of pragma Interrupt_Handler or --- 410,421 ---- -- case, and if found, issues an appropriate error message. procedure Check_First_Subtype (Arg : Node_Id); ! -- Checks that Arg, whose expression is an entity name, references a ! -- first subtype. procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program ! -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). procedure Check_Interrupt_Or_Attach_Handler; -- Common processing for first argument of pragma Interrupt_Handler or *************** package body Sem_Prag is *** 486,494 **** -- and to library level instantiations), and they are simply ignored, -- which is implemented by rewriting them as null statements. ! procedure Check_Variant (Variant : Node_Id); ! -- Check Unchecked_Union variant for lack of nested variants and ! -- presence of at least one component. procedure Error_Pragma (Msg : String); pragma No_Return (Error_Pragma); --- 490,499 ---- -- and to library level instantiations), and they are simply ignored, -- which is implemented by rewriting them as null statements. ! procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); ! -- Check an Unchecked_Union variant for lack of nested variants and ! -- presence of at least one component. UU_Typ is the related Unchecked_ ! -- Union type. procedure Error_Pragma (Msg : String); pragma No_Return (Error_Pragma); *************** package body Sem_Prag is *** 548,553 **** --- 553,565 ---- -- procedure identified by Name, returns it if it exists, otherwise -- errors out and uses Arg as the pragma argument for the message. + procedure Fix_Error (Msg : in out String); + -- This is called prior to issuing an error message. Msg is a string + -- which typically contains the substring pragma. If the current pragma + -- comes from an aspect, each such "pragma" substring is replaced with + -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition + -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post). + procedure Gather_Associations (Names : Name_List; Args : out Args_List); *************** package body Sem_Prag is *** 729,734 **** --- 741,757 ---- end if; end Ada_2005_Pragma; + --------------------- + -- Ada_2012_Pragma -- + --------------------- + + procedure Ada_2012_Pragma is + begin + if Ada_Version <= Ada_2005 then + Check_Restriction (No_Implementation_Pragmas, N); + end if; + end Ada_2012_Pragma; + -------------------------- -- Check_Ada_83_Warning -- -------------------------- *************** package body Sem_Prag is *** 792,801 **** else Error_Msg_Name_1 := Pname; ! Flag_Non_Static_Expr ! ("argument for pragma% must be a identifier or " & ! "static string expression!", Argx); ! raise Pragma_Exit; end if; end if; end Check_Arg_Is_External_Name; --- 815,830 ---- else Error_Msg_Name_1 := Pname; ! ! declare ! Msg : String := ! "argument for pragma% must be a identifier or " ! & "static string expression!"; ! begin ! Fix_Error (Msg); ! Flag_Non_Static_Expr (Msg, Argx); ! raise Pragma_Exit; ! end; end if; end if; end Check_Arg_Is_External_Name; *************** package body Sem_Prag is *** 839,845 **** begin Check_Arg_Is_Local_Name (Arg); ! if not Is_Library_Level_Entity (Entity (Expression (Arg))) and then Comes_From_Source (N) then Error_Pragma_Arg --- 868,874 ---- begin Check_Arg_Is_Local_Name (Arg); ! if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) and then Comes_From_Source (N) then Error_Pragma_Arg *************** package body Sem_Prag is *** 872,882 **** Error_Pragma_Arg ("argument for pragma% must be local name", Argx); end if; ! if Is_Entity_Name (Argx) ! and then Scope (Entity (Argx)) /= Current_Scope ! then ! Error_Pragma_Arg ! ("pragma% argument must be in same declarative part", Arg); end if; end Check_Arg_Is_Local_Name; --- 901,967 ---- Error_Pragma_Arg ("argument for pragma% must be local name", Argx); end if; ! -- No further check required if not an entity name ! ! if not Is_Entity_Name (Argx) then ! null; ! ! else ! declare ! OK : Boolean; ! Ent : constant Entity_Id := Entity (Argx); ! Scop : constant Entity_Id := Scope (Ent); ! begin ! -- Case of a pragma applied to a compilation unit: pragma must ! -- occur immediately after the program unit in the compilation. ! ! if Is_Compilation_Unit (Ent) then ! declare ! Decl : constant Node_Id := Unit_Declaration_Node (Ent); ! begin ! -- Case of pragma placed immediately after spec ! ! if Parent (N) = Aux_Decls_Node (Parent (Decl)) then ! OK := True; ! ! -- Case of pragma placed immediately after body ! ! elsif Nkind (Decl) = N_Subprogram_Declaration ! and then Present (Corresponding_Body (Decl)) ! then ! OK := Parent (N) = ! Aux_Decls_Node ! (Parent (Unit_Declaration_Node ! (Corresponding_Body (Decl)))); ! ! -- All other cases are illegal ! ! else ! OK := False; ! end if; ! end; ! ! -- Special restricted placement rule from 10.2.1(11.8/2) ! ! elsif Is_Generic_Formal (Ent) ! and then Prag_Id = Pragma_Preelaborable_Initialization ! then ! OK := List_Containing (N) = ! Generic_Formal_Declarations ! (Unit_Declaration_Node (Scop)); ! ! -- Default case, just check that the pragma occurs in the scope ! -- of the entity denoted by the name. ! ! else ! OK := Current_Scope = Scop; ! end if; ! ! if not OK then ! Error_Pragma_Arg ! ("pragma% argument must be in same declarative part", Arg); ! end if; ! end; end if; end Check_Arg_Is_Local_Name; *************** package body Sem_Prag is *** 891,898 **** Check_Arg_Is_Identifier (Argx); if not Is_Locking_Policy_Name (Chars (Argx)) then ! Error_Pragma_Arg ! ("& is not a valid locking policy name", Argx); end if; end Check_Arg_Is_Locking_Policy; --- 976,982 ---- Check_Arg_Is_Identifier (Argx); if not Is_Locking_Policy_Name (Chars (Argx)) then ! Error_Pragma_Arg ("& is not a valid locking policy name", Argx); end if; end Check_Arg_Is_Locking_Policy; *************** package body Sem_Prag is *** 947,953 **** Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; - --------------------------------- -- Check_Arg_Is_Queuing_Policy -- --------------------------------- --- 1031,1036 ---- *************** package body Sem_Prag is *** 959,966 **** Check_Arg_Is_Identifier (Argx); if not Is_Queuing_Policy_Name (Chars (Argx)) then ! Error_Pragma_Arg ! ("& is not a valid queuing policy name", Argx); end if; end Check_Arg_Is_Queuing_Policy; --- 1042,1048 ---- Check_Arg_Is_Identifier (Argx); if not Is_Queuing_Policy_Name (Chars (Argx)) then ! Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); end if; end Check_Arg_Is_Queuing_Policy; *************** package body Sem_Prag is *** 1008,1031 **** else Error_Msg_Name_1 := Pname; - Flag_Non_Static_Expr - ("argument for pragma% must be a static expression!", Argx); - raise Pragma_Exit; - end if; - end Check_Arg_Is_Static_Expression; ! --------------------------------- ! -- Check_Arg_Is_String_Literal -- ! --------------------------------- ! procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is ! Argx : constant Node_Id := Get_Pragma_Arg (Arg); ! begin ! if Nkind (Argx) /= N_String_Literal then ! Error_Pragma_Arg ! ("argument for pragma% must be string literal", Argx); end if; ! end Check_Arg_Is_String_Literal; ------------------------------------------ -- Check_Arg_Is_Task_Dispatching_Policy -- --- 1090,1107 ---- else Error_Msg_Name_1 := Pname; ! declare ! Msg : String := ! "argument for pragma% must be a static expression!"; ! begin ! Fix_Error (Msg); ! Flag_Non_Static_Expr (Msg, Argx); ! end; ! raise Pragma_Exit; end if; ! end Check_Arg_Is_Static_Expression; ------------------------------------------ -- Check_Arg_Is_Task_Dispatching_Policy -- *************** package body Sem_Prag is *** 1110,1151 **** -- Check_Component -- --------------------- ! procedure Check_Component (Comp : Node_Id) is ! begin ! if Nkind (Comp) = N_Component_Declaration then ! declare ! Sindic : constant Node_Id := ! Subtype_Indication (Component_Definition (Comp)); ! Typ : constant Entity_Id := ! Etype (Defining_Identifier (Comp)); ! begin ! if Nkind (Sindic) = N_Subtype_Indication then ! -- Ada 2005 (AI-216): If a component subtype is subject to ! -- a per-object constraint, then the component type shall ! -- be an Unchecked_Union. ! if Has_Per_Object_Constraint (Defining_Identifier (Comp)) ! and then ! not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) ! then ! Error_Msg_N ("component subtype subject to per-object" & ! " constraint must be an Unchecked_Union", Comp); ! end if; ! end if; ! if Is_Controlled (Typ) then ! Error_Msg_N ! ("component of unchecked union cannot be controlled", Comp); ! elsif Has_Task (Typ) then ! Error_Msg_N ! ("component of unchecked union cannot have tasks", Comp); end if; ! end; end if; end Check_Component; ---------------------------------- -- Check_Duplicated_Export_Name -- ---------------------------------- --- 1186,1305 ---- -- Check_Component -- --------------------- ! procedure Check_Component ! (Comp : Node_Id; ! UU_Typ : Entity_Id; ! In_Variant_Part : Boolean := False) ! is ! Comp_Id : constant Entity_Id := Defining_Identifier (Comp); ! Sindic : constant Node_Id := ! Subtype_Indication (Component_Definition (Comp)); ! Typ : constant Entity_Id := Etype (Comp_Id); ! function Inside_Generic_Body (Id : Entity_Id) return Boolean; ! -- Determine whether entity Id appears inside a generic body. ! -- Shouldn't this be in a more general place ??? ! ------------------------- ! -- Inside_Generic_Body -- ! ------------------------- ! function Inside_Generic_Body (Id : Entity_Id) return Boolean is ! S : Entity_Id; ! begin ! S := Id; ! while Present (S) and then S /= Standard_Standard loop ! if Ekind (S) = E_Generic_Package ! and then In_Package_Body (S) ! then ! return True; end if; ! ! S := Scope (S); ! end loop; ! ! return False; ! end Inside_Generic_Body; ! ! -- Start of processing for Check_Component ! ! begin ! -- Ada 2005 (AI-216): If a component subtype is subject to a per- ! -- object constraint, then the component type shall be an Unchecked_ ! -- Union. ! ! if Nkind (Sindic) = N_Subtype_Indication ! and then Has_Per_Object_Constraint (Comp_Id) ! and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) ! then ! Error_Msg_N ! ("component subtype subject to per-object constraint " & ! "must be an Unchecked_Union", Comp); ! ! -- Ada 2012 (AI05-0026): For an unchecked union type declared within ! -- the body of a generic unit, or within the body of any of its ! -- descendant library units, no part of the type of a component ! -- declared in a variant_part of the unchecked union type shall be of ! -- a formal private type or formal private extension declared within ! -- the formal part of the generic unit. ! ! elsif Ada_Version >= Ada_2012 ! and then Inside_Generic_Body (UU_Typ) ! and then In_Variant_Part ! and then Is_Private_Type (Typ) ! and then Is_Generic_Type (Typ) ! then ! Error_Msg_N ! ("component of Unchecked_Union cannot be of generic type", Comp); ! ! elsif Needs_Finalization (Typ) then ! Error_Msg_N ! ("component of Unchecked_Union cannot be controlled", Comp); ! ! elsif Has_Task (Typ) then ! Error_Msg_N ! ("component of Unchecked_Union cannot have tasks", Comp); end if; end Check_Component; + ---------------------------- + -- Check_Duplicate_Pragma -- + ---------------------------- + + procedure Check_Duplicate_Pragma (E : Entity_Id) is + P : Node_Id; + + begin + -- Nothing to do if this pragma comes from an aspect specification, + -- since we could not be duplicating a pragma, and we dealt with the + -- case of duplicated aspects in Analyze_Aspect_Specifications. + + if From_Aspect_Specification (N) then + return; + end if; + + -- Otherwise current pragma may duplicate previous pragma or a + -- previously given aspect specification for the same pragma. + + P := Get_Rep_Item_For_Entity (E, Pragma_Name (N)); + + if Present (P) then + Error_Msg_Name_1 := Pragma_Name (N); + Error_Msg_Sloc := Sloc (P); + + if Nkind (P) = N_Aspect_Specification + or else From_Aspect_Specification (P) + then + Error_Msg_NE ("aspect% for & previously given#", N, E); + else + Error_Msg_NE ("pragma% for & duplicates pragma#", N, E); + end if; + + raise Pragma_Exit; + end if; + end Check_Duplicate_Pragma; + ---------------------------------- -- Check_Duplicated_Export_Name -- ---------------------------------- *************** package body Sem_Prag is *** 1154,1167 **** String_Val : constant String_Id := Strval (Nam); begin - -- We allow duplicated export names in CIL, as they are always - -- enclosed in a namespace that differentiates them, and overloaded - -- entities are supported by the VM. - - if VM_Target = CLI_Target then - return; - end if; - -- We are only interested in the export case, and in the case of -- generics, it is the instance, not the template, that is the -- problem (the template will generate a warning in any case). --- 1308,1313 ---- *************** package body Sem_Prag is *** 1193,1202 **** procedure Check_First_Subtype (Arg : Node_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); begin ! if not Is_First_Subtype (Entity (Argx)) then Error_Pragma_Arg ("pragma% cannot apply to subtype", Argx); end if; end Check_First_Subtype; --- 1339,1361 ---- procedure Check_First_Subtype (Arg : Node_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Ent : constant Entity_Id := Entity (Argx); + begin ! if Is_First_Subtype (Ent) then ! null; ! ! elsif Is_Type (Ent) then Error_Pragma_Arg ("pragma% cannot apply to subtype", Argx); + + elsif Is_Object (Ent) then + Error_Pragma_Arg + ("pragma% cannot apply to object, requires a type", Argx); + + else + Error_Pragma_Arg + ("pragma% cannot apply to&, requires a type", Argx); end if; end Check_First_Subtype; *************** package body Sem_Prag is *** 1229,1235 **** --------------------------------------- procedure Check_Interrupt_Or_Attach_Handler is ! Arg1_X : constant Node_Id := Expression (Arg1); Handler_Proc, Proc_Scope : Entity_Id; begin --- 1388,1394 ---- --------------------------------------- procedure Check_Interrupt_Or_Attach_Handler is ! Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); Handler_Proc, Proc_Scope : Entity_Id; begin *************** package body Sem_Prag is *** 1265,1270 **** --- 1424,1445 ---- Error_Pragma_Arg ("argument for pragma% must be library level entity", Arg1); end if; + + -- AI05-0033: A pragma cannot appear within a generic body, because + -- instance can be in a nested scope. The check that protected type + -- is itself a library-level declaration is done elsewhere. + + -- Note: we omit this check in Codepeer mode to properly handle code + -- prior to AI-0033 (pragmas don't matter to codepeer in any case). + + if Inside_A_Generic then + if Ekind (Scope (Current_Scope)) = E_Generic_Package + and then In_Package_Body (Scope (Current_Scope)) + and then not CodePeer_Mode + then + Error_Pragma ("pragma% cannot be used inside a generic"); + end if; + end if; end Check_Interrupt_Or_Attach_Handler; ------------------------------------------- *************** package body Sem_Prag is *** 1314,1320 **** procedure Check_No_Identifier (Arg : Node_Id) is begin ! if Chars (Arg) /= No_Name then Error_Pragma_Arg_Ident ("pragma% does not permit identifier& here", Arg); end if; --- 1489,1497 ---- procedure Check_No_Identifier (Arg : Node_Id) is begin ! if Nkind (Arg) = N_Pragma_Argument_Association ! and then Chars (Arg) /= No_Name ! then Error_Pragma_Arg_Ident ("pragma% does not permit identifier& here", Arg); end if; *************** package body Sem_Prag is *** 1342,1348 **** procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is begin ! if Present (Arg) and then Chars (Arg) /= No_Name then if Chars (Arg) /= Id then Error_Msg_Name_1 := Pname; Error_Msg_Name_2 := Id; --- 1519,1528 ---- procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is begin ! if Present (Arg) ! and then Nkind (Arg) = N_Pragma_Argument_Association ! and then Chars (Arg) /= No_Name ! then if Chars (Arg) /= Id then Error_Msg_Name_1 := Pname; Error_Msg_Name_2 := Id; *************** package body Sem_Prag is *** 1378,1405 **** --------------- procedure Chain_PPC (PO : Node_Id) is ! S : Node_Id; begin ! if not Nkind_In (PO, N_Subprogram_Declaration, ! N_Generic_Subprogram_Declaration) then Pragma_Misplaced; end if; ! -- Here if we have subprogram or generic subprogram declaration ! S := Defining_Unit_Name (Specification (PO)); ! -- Analyze the pragma unless it appears within a package spec, ! -- which is the case where we delay the analysis of the PPC until ! -- the end of the package declarations (for details, see ! -- Analyze_Package_Specification.Analyze_PPCs). ! if not Is_Package_Or_Generic_Package (Scope (S)) then ! Analyze_PPC_In_Decl_Part (N, S); end if; -- Chain spec PPC pragma to list for subprogram Set_Next_Pragma (N, Spec_PPC_List (S)); --- 1558,1655 ---- --------------- procedure Chain_PPC (PO : Node_Id) is ! S : Entity_Id; ! P : Node_Id; begin ! if Nkind (PO) = N_Abstract_Subprogram_Declaration then ! if not From_Aspect_Specification (N) then ! Error_Pragma ! ("pragma% cannot be applied to abstract subprogram"); ! ! elsif Class_Present (N) then ! null; ! ! else ! Error_Pragma ! ("aspect % requires ''Class for abstract subprogram"); ! end if; ! ! elsif not Nkind_In (PO, N_Subprogram_Declaration, ! N_Generic_Subprogram_Declaration, ! N_Entry_Declaration) then Pragma_Misplaced; end if; ! -- Here if we have [generic] subprogram or entry declaration ! if Nkind (PO) = N_Entry_Declaration then ! S := Defining_Entity (PO); ! else ! S := Defining_Unit_Name (Specification (PO)); ! end if; ! -- Make sure we do not have the case of a precondition pragma when ! -- the Pre'Class aspect is present. ! -- We do this by looking at pragmas already chained to the entity ! -- since the aspect derived pragma will be put on this list first. ! ! if Pragma_Name (N) = Name_Precondition then ! if not From_Aspect_Specification (N) then ! P := Spec_PPC_List (S); ! while Present (P) loop ! if Pragma_Name (P) = Name_Precondition ! and then From_Aspect_Specification (P) ! and then Class_Present (P) ! then ! Error_Msg_Sloc := Sloc (P); ! Error_Pragma ! ("pragma% not allowed, `Pre''Class` aspect given#"); ! end if; ! ! P := Next_Pragma (P); ! end loop; ! end if; end if; + -- Similarly check for Pre with inherited Pre'Class. Note that + -- we cover the aspect case as well here. + + if Pragma_Name (N) = Name_Precondition + and then not Class_Present (N) + then + declare + Inherited : constant Subprogram_List := + Inherited_Subprograms (S); + P : Node_Id; + + begin + for J in Inherited'Range loop + P := Spec_PPC_List (Inherited (J)); + while Present (P) loop + if Pragma_Name (P) = Name_Precondition + and then Class_Present (P) + then + Error_Msg_Sloc := Sloc (P); + Error_Pragma + ("pragma% not allowed, `Pre''Class` " + & "aspect inherited from#"); + end if; + + P := Next_Pragma (P); + end loop; + end loop; + end; + end if; + + -- Note: we do not analyze the pragma at this point. Instead we + -- delay this analysis until the end of the declarative part in + -- which the pragma appears. This implements the required delay + -- in this analysis, allowing forward references. The analysis + -- happens at the end of Analyze_Declarations. + -- Chain spec PPC pragma to list for subprogram Set_Next_Pragma (N, Spec_PPC_List (S)); *************** package body Sem_Prag is *** 1418,1426 **** Pragma_Misplaced; end if; ! -- Record whether pragma is enabled ! Set_Pragma_Enabled (N, Check_Enabled (Pname)); -- If we are within an inlined body, the legality of the pragma -- has been checked already. --- 1668,1688 ---- Pragma_Misplaced; end if; ! -- Preanalyze message argument if present. Visibility in this ! -- argument is established at the point of pragma occurrence. ! if Arg_Count = 2 then ! Check_Optional_Identifier (Arg2, Name_Message); ! Preanalyze_Spec_Expression ! (Get_Pragma_Arg (Arg2), Standard_String); ! end if; ! ! -- Record if pragma is enabled ! ! if Check_Enabled (Pname) then ! Set_Pragma_Enabled (N); ! Set_SCO_Pragma_Enabled (Loc); ! end if; -- If we are within an inlined body, the legality of the pragma -- has been checked already. *************** package body Sem_Prag is *** 1475,1483 **** if Operating_Mode /= Generate_Code or else Inside_A_Generic then ! ! -- Analyze expression in pragma, for correctness ! -- and for ASIS use. Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); --- 1737,1743 ---- if Operating_Mode /= Generate_Code or else Inside_A_Generic then ! -- Analyze pragma expression for correctness and for ASIS use Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); *************** package body Sem_Prag is *** 1615,1621 **** Unit_Node := Unit (Parent (Parent_Node)); Unit_Kind := Nkind (Unit_Node); ! Analyze (Expression (Arg1)); if Unit_Kind = N_Generic_Subprogram_Declaration or else Unit_Kind = N_Subprogram_Declaration --- 1875,1881 ---- Unit_Node := Unit (Parent (Parent_Node)); Unit_Kind := Nkind (Unit_Node); ! Analyze (Get_Pragma_Arg (Arg1)); if Unit_Kind = N_Generic_Subprogram_Declaration or else Unit_Kind = N_Subprogram_Declaration *************** package body Sem_Prag is *** 1630,1636 **** end if; if Chars (Unit_Name) /= ! Chars (Entity (Expression (Arg1))) then Error_Pragma_Arg ("pragma% argument is not current unit name", Arg1); --- 1890,1896 ---- end if; if Chars (Unit_Name) /= ! Chars (Entity (Get_Pragma_Arg (Arg1))) then Error_Pragma_Arg ("pragma% argument is not current unit name", Arg1); *************** package body Sem_Prag is *** 1688,1696 **** Pragma_Misplaced; elsif Arg_Count > 0 then ! Analyze (Expression (Arg1)); ! if Entity (Expression (Arg1)) /= Current_Scope then Error_Pragma_Arg ("name in pragma% must be enclosing unit", Arg1); end if; --- 1948,1956 ---- Pragma_Misplaced; elsif Arg_Count > 0 then ! Analyze (Get_Pragma_Arg (Arg1)); ! if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then Error_Pragma_Arg ("name in pragma% must be enclosing unit", Arg1); end if; *************** package body Sem_Prag is *** 1719,1725 **** -- Check_Variant -- ------------------- ! procedure Check_Variant (Variant : Node_Id) is Clist : constant Node_Id := Component_List (Variant); Comp : Node_Id; --- 1979,1985 ---- -- Check_Variant -- ------------------- ! procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is Clist : constant Node_Id := Component_List (Variant); Comp : Node_Id; *************** package body Sem_Prag is *** 1733,1739 **** Comp := First (Component_Items (Clist)); while Present (Comp) loop ! Check_Component (Comp); Next (Comp); end loop; end Check_Variant; --- 1993,1999 ---- Comp := First (Component_Items (Clist)); while Present (Comp) loop ! Check_Component (Comp, UU_Typ, In_Variant_Part => True); Next (Comp); end loop; end Check_Variant; *************** package body Sem_Prag is *** 1743,1751 **** ------------------ procedure Error_Pragma (Msg : String) is begin Error_Msg_Name_1 := Pname; ! Error_Msg_N (Msg, N); raise Pragma_Exit; end Error_Pragma; --- 2003,2013 ---- ------------------ procedure Error_Pragma (Msg : String) is + MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; ! Fix_Error (MsgF); ! Error_Msg_N (MsgF, N); raise Pragma_Exit; end Error_Pragma; *************** package body Sem_Prag is *** 1754,1769 **** ---------------------- procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is begin Error_Msg_Name_1 := Pname; ! Error_Msg_N (Msg, Get_Pragma_Arg (Arg)); raise Pragma_Exit; end Error_Pragma_Arg; procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is begin Error_Msg_Name_1 := Pname; ! Error_Msg_N (Msg1, Get_Pragma_Arg (Arg)); Error_Pragma_Arg (Msg2, Arg); end Error_Pragma_Arg; --- 2016,2035 ---- ---------------------- procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is + MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; ! Fix_Error (MsgF); ! Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); raise Pragma_Exit; end Error_Pragma_Arg; procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is + MsgF : String := Msg1; begin Error_Msg_Name_1 := Pname; ! Fix_Error (MsgF); ! Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); Error_Pragma_Arg (Msg2, Arg); end Error_Pragma_Arg; *************** package body Sem_Prag is *** 1772,1780 **** ---------------------------- procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is begin Error_Msg_Name_1 := Pname; ! Error_Msg_N (Msg, Arg); raise Pragma_Exit; end Error_Pragma_Arg_Ident; --- 2038,2048 ---- ---------------------------- procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is + MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; ! Fix_Error (MsgF); ! Error_Msg_N (MsgF, Arg); raise Pragma_Exit; end Error_Pragma_Arg_Ident; *************** package body Sem_Prag is *** 1783,1792 **** ---------------------- procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is begin Error_Msg_Name_1 := Pname; Error_Msg_Sloc := Sloc (Ref); ! Error_Msg_NE (Msg, N, Ref); raise Pragma_Exit; end Error_Pragma_Ref; --- 2051,2062 ---- ---------------------- procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is + MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); Error_Msg_Sloc := Sloc (Ref); ! Error_Msg_NE (MsgF, N, Ref); raise Pragma_Exit; end Error_Pragma_Ref; *************** package body Sem_Prag is *** 1867,1873 **** Proc := Entity (Name); if Ekind (Proc) /= E_Procedure ! or else Present (First_Formal (Proc)) then Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg); end if; --- 2137,2144 ---- Proc := Entity (Name); if Ekind (Proc) /= E_Procedure ! or else Present (First_Formal (Proc)) ! then Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg); end if; *************** package body Sem_Prag is *** 1912,1917 **** --- 2183,2209 ---- return Proc; end Find_Unique_Parameterless_Procedure; + --------------- + -- Fix_Error -- + --------------- + + procedure Fix_Error (Msg : in out String) is + begin + if From_Aspect_Specification (N) then + for J in Msg'First .. Msg'Last - 5 loop + if Msg (J .. J + 5) = "pragma" then + Msg (J .. J + 5) := "aspect"; + end if; + end loop; + + if Error_Msg_Name_1 = Name_Precondition then + Error_Msg_Name_1 := Name_Pre; + elsif Error_Msg_Name_1 = Name_Postcondition then + Error_Msg_Name_1 := Name_Post; + end if; + end if; + end Fix_Error; + ------------------------- -- Gather_Associations -- ------------------------- *************** package body Sem_Prag is *** 1940,1946 **** Arg := First (Pragma_Argument_Associations (N)); for Index in Args'Range loop exit when No (Arg) or else Chars (Arg) /= No_Name; ! Args (Index) := Expression (Arg); Next (Arg); end loop; --- 2232,2238 ---- Arg := First (Pragma_Argument_Associations (N)); for Index in Args'Range loop exit when No (Arg) or else Chars (Arg) /= No_Name; ! Args (Index) := Get_Pragma_Arg (Arg); Next (Arg); end loop; *************** package body Sem_Prag is *** 1967,1973 **** Error_Pragma_Arg ("duplicate argument association for pragma%", Arg); else ! Args (Index) := Expression (Arg); exit; end if; end if; --- 2259,2265 ---- Error_Pragma_Arg ("duplicate argument association for pragma%", Arg); else ! Args (Index) := Get_Pragma_Arg (Arg); exit; end if; end if; *************** package body Sem_Prag is *** 2148,2156 **** procedure Set_Atomic (E : Entity_Id) is begin ! Set_Is_Atomic (E); ! if not Has_Alignment_Clause (E) then Set_Alignment (E, Uint_0); end if; end Set_Atomic; --- 2440,2448 ---- procedure Set_Atomic (E : Entity_Id) is begin ! Set_Is_Atomic (E, Sense); ! if Sense and then not Has_Alignment_Clause (E) then Set_Alignment (E, Uint_0); end if; end Set_Atomic; *************** package body Sem_Prag is *** 2162,2168 **** Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then return; --- 2454,2460 ---- Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); if Etype (E_Id) = Any_Type then return; *************** package body Sem_Prag is *** 2172,2177 **** --- 2464,2475 ---- D := Declaration_Node (E); K := Nkind (D); + -- Check duplicate before we chain ourselves! + + Check_Duplicate_Pragma (E); + + -- Now check appropriateness of the entity + if Is_Type (E) then if Rep_Item_Too_Early (E, N) or else *************** package body Sem_Prag is *** 2191,2201 **** -- Attribute belongs on the base type. If the view of the type is -- currently private, it also belongs on the underlying type. ! Set_Is_Volatile (Base_Type (E)); ! Set_Is_Volatile (Underlying_Type (E)); ! Set_Treat_As_Volatile (E); ! Set_Treat_As_Volatile (Underlying_Type (E)); elsif K = N_Object_Declaration or else (K = N_Component_Declaration --- 2489,2499 ---- -- Attribute belongs on the base type. If the view of the type is -- currently private, it also belongs on the underlying type. ! Set_Is_Volatile (Base_Type (E), Sense); ! Set_Is_Volatile (Underlying_Type (E), Sense); ! Set_Treat_As_Volatile (E, Sense); ! Set_Treat_As_Volatile (Underlying_Type (E), Sense); elsif K = N_Object_Declaration or else (K = N_Component_Declaration *************** package body Sem_Prag is *** 2206,2212 **** end if; if Prag_Id /= Pragma_Volatile then ! Set_Is_Atomic (E); -- If the object declaration has an explicit initialization, a -- temporary may have to be created to hold the expression, to --- 2504,2510 ---- end if; if Prag_Id /= Pragma_Volatile then ! Set_Is_Atomic (E, Sense); -- If the object declaration has an explicit initialization, a -- temporary may have to be created to hold the expression, to *************** package body Sem_Prag is *** 2214,2219 **** --- 2512,2518 ---- if Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) + and then Sense then Set_Has_Delayed_Freeze (E); end if; *************** package body Sem_Prag is *** 2234,2240 **** Get_Source_File_Index (Sloc (E)) = Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) then ! Set_Is_Atomic (Underlying_Type (Etype (E))); end if; end if; --- 2533,2539 ---- Get_Source_File_Index (Sloc (E)) = Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) then ! Set_Is_Atomic (Underlying_Type (Etype (E)), Sense); end if; end if; *************** package body Sem_Prag is *** 2334,2340 **** -- need to force visibility for client (error will be -- output in any case, and this is the situation in which -- we do not want a client to get a warning, since the ! -- warning is in the body or the spec private part. else if Cont = False then --- 2633,2639 ---- -- need to force visibility for client (error will be -- output in any case, and this is the situation in which -- we do not want a client to get a warning, since the ! -- warning is in the body or the spec private part). else if Cont = False then *************** package body Sem_Prag is *** 2366,2377 **** --- 2665,2840 ---- Cname : Name_Id; Comp_Unit : Unit_Number_Type; + procedure Diagnose_Multiple_Pragmas (S : Entity_Id); + -- Called if we have more than one Export/Import/Convention pragma. + -- This is generally illegal, but we have a special case of allowing + -- Import and Interface to coexist if they specify the convention in + -- a consistent manner. We are allowed to do this, since Interface is + -- an implementation defined pragma, and we choose to do it since we + -- know Rational allows this combination. S is the entity id of the + -- subprogram in question. This procedure also sets the special flag + -- Import_Interface_Present in both pragmas in the case where we do + -- have matching Import and Interface pragmas. + procedure Set_Convention_From_Pragma (E : Entity_Id); -- Set convention in entity E, and also flag that the entity has a -- convention pragma. If entity is for a private or incomplete type, -- also set convention and flag on underlying type. This procedure -- also deals with the special case of C_Pass_By_Copy convention. + ------------------------------- + -- Diagnose_Multiple_Pragmas -- + ------------------------------- + + procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is + Pdec : constant Node_Id := Declaration_Node (S); + Decl : Node_Id; + Err : Boolean; + + function Same_Convention (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a first argument that is an identifier with a + -- Chars field corresponding to the Convention_Id C. + + function Same_Name (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a second argument that is an identifier with a + -- Chars field that matches the Chars of the current subprogram. + + --------------------- + -- Same_Convention -- + --------------------- + + function Same_Convention (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + + begin + if Present (Arg1) then + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Nkind (Arg) = N_Identifier + and then Is_Convention_Name (Chars (Arg)) + and then Get_Convention_Id (Chars (Arg)) = C + then + return True; + end if; + end; + end if; + + return False; + end Same_Convention; + + --------------- + -- Same_Name -- + --------------- + + function Same_Name (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + Arg2 : Node_Id; + + begin + if No (Arg1) then + return False; + end if; + + Arg2 := Next (Arg1); + + if No (Arg2) then + return False; + end if; + + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg2); + begin + if Nkind (Arg) = N_Identifier + and then Chars (Arg) = Chars (S) + then + return True; + end if; + end; + + return False; + end Same_Name; + + -- Start of processing for Diagnose_Multiple_Pragmas + + begin + Err := True; + + -- Definitely give message if we have Convention/Export here + + if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then + null; + + -- If we have an Import or Export, scan back from pragma to + -- find any previous pragma applying to the same procedure. + -- The scan will be terminated by the start of the list, or + -- hitting the subprogram declaration. This won't allow one + -- pragma to appear in the public part and one in the private + -- part, but that seems very unlikely in practice. + + else + Decl := Prev (N); + while Present (Decl) and then Decl /= Pdec loop + + -- Look for pragma with same name as us + + if Nkind (Decl) = N_Pragma + and then Same_Name (Decl) + then + -- Give error if same as our pragma or Export/Convention + + if Pragma_Name (Decl) = Name_Export + or else + Pragma_Name (Decl) = Name_Convention + or else + Pragma_Name (Decl) = Pragma_Name (N) + then + exit; + + -- Case of Import/Interface or the other way round + + elsif Pragma_Name (Decl) = Name_Interface + or else + Pragma_Name (Decl) = Name_Import + then + -- Here we know that we have Import and Interface. It + -- doesn't matter which way round they are. See if + -- they specify the same convention. If so, all OK, + -- and set special flags to stop other messages + + if Same_Convention (Decl) then + Set_Import_Interface_Present (N); + Set_Import_Interface_Present (Decl); + Err := False; + + -- If different conventions, special message + + else + Error_Msg_Sloc := Sloc (Decl); + Error_Pragma_Arg + ("convention differs from that given#", Arg1); + return; + end if; + end if; + end if; + + Next (Decl); + end loop; + end if; + + -- Give message if needed if we fall through those tests + + if Err then + Error_Pragma_Arg + ("at most one Convention/Export/Import pragma is allowed", + Arg2); + end if; + end Diagnose_Multiple_Pragmas; + -------------------------------- -- Set_Convention_From_Pragma -- -------------------------------- *************** package body Sem_Prag is *** 2453,2469 **** Check_At_Least_N_Arguments (2); Check_Optional_Identifier (Arg1, Name_Convention); Check_Arg_Is_Identifier (Arg1); ! Cname := Chars (Expression (Arg1)); -- C_Pass_By_Copy is treated as a synonym for convention C (this is -- tested again below to set the critical flag). if Cname = Name_C_Pass_By_Copy then C := Convention_C; -- Otherwise we must have something in the standard convention list elsif Is_Convention_Name (Cname) then ! C := Get_Convention_Id (Chars (Expression (Arg1))); -- In DEC VMS, it seems that there is an undocumented feature that -- any unrecognized convention is treated as the default, which for --- 2916,2933 ---- Check_At_Least_N_Arguments (2); Check_Optional_Identifier (Arg1, Name_Convention); Check_Arg_Is_Identifier (Arg1); ! Cname := Chars (Get_Pragma_Arg (Arg1)); -- C_Pass_By_Copy is treated as a synonym for convention C (this is -- tested again below to set the critical flag). + if Cname = Name_C_Pass_By_Copy then C := Convention_C; -- Otherwise we must have something in the standard convention list elsif Is_Convention_Name (Cname) then ! C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); -- In DEC VMS, it seems that there is an undocumented feature that -- any unrecognized convention is treated as the default, which for *************** package body Sem_Prag is *** 2475,2481 **** if Warn_On_Export_Import and not OpenVMS_On_Target then Error_Msg_N ("?unrecognized convention name, C assumed", ! Expression (Arg1)); end if; C := Convention_C; --- 2939,2945 ---- if Warn_On_Export_Import and not OpenVMS_On_Target then Error_Msg_N ("?unrecognized convention name, C assumed", ! Get_Pragma_Arg (Arg1)); end if; C := Convention_C; *************** package body Sem_Prag is *** 2484,2490 **** Check_Optional_Identifier (Arg2, Name_Entity); Check_Arg_Is_Local_Name (Arg2); ! Id := Expression (Arg2); Analyze (Id); if not Is_Entity_Name (Id) then --- 2948,2954 ---- Check_Optional_Identifier (Arg2, Name_Entity); Check_Arg_Is_Local_Name (Arg2); ! Id := Get_Pragma_Arg (Arg2); Analyze (Id); if not Is_Entity_Name (Id) then *************** package body Sem_Prag is *** 2537,2546 **** -- Check that we are not applying this to a named constant ! if Ekind (E) = E_Named_Integer ! or else ! Ekind (E) = E_Named_Real ! then Error_Msg_Name_1 := Pname; Error_Msg_N ("cannot apply pragma% to named constant!", --- 3001,3007 ---- -- Check that we are not applying this to a named constant ! if Ekind_In (E, E_Named_Integer, E_Named_Real) then Error_Msg_Name_1 := Pname; Error_Msg_N ("cannot apply pragma% to named constant!", *************** package body Sem_Prag is *** 2568,2575 **** end if; if Has_Convention_Pragma (E) then ! Error_Pragma_Arg ! ("at most one Convention/Export/Import pragma is allowed", Arg2); elsif Convention (E) = Convention_Protected or else Ekind (Scope (E)) = E_Protected_Type --- 3029,3035 ---- end if; if Has_Convention_Pragma (E) then ! Diagnose_Multiple_Pragmas (E); elsif Convention (E) = Convention_Protected or else Ekind (Scope (E)) = E_Protected_Type *************** package body Sem_Prag is *** 2597,2603 **** and then Ekind (E) /= E_Variable and then not (Is_Access_Type (E) ! and then Ekind (Designated_Type (E)) = E_Subprogram_Type) then Error_Pragma_Arg ("second argument of pragma% must be subprogram (type)", --- 3057,3063 ---- and then Ekind (E) /= E_Variable and then not (Is_Access_Type (E) ! and then Ekind (Designated_Type (E)) = E_Subprogram_Type) then Error_Pragma_Arg ("second argument of pragma% must be subprogram (type)", *************** package body Sem_Prag is *** 2610,2616 **** Set_Convention_From_Pragma (E); if Is_Type (E) then - Check_First_Subtype (Arg2); Set_Convention_From_Pragma (Base_Type (E)); --- 3070,3075 ---- *************** package body Sem_Prag is *** 2666,2671 **** --- 3125,3134 ---- Generate_Reference (E1, Id, 'b'); end if; end if; + + -- For aspect case, do NOT apply to homonyms + + exit when From_Aspect_Specification (N); end loop; end if; end Process_Convention; *************** package body Sem_Prag is *** 2778,2786 **** Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); ! if Ekind (Def_Id) /= E_Constant ! and then Ekind (Def_Id) /= E_Variable ! then Error_Pragma_Arg ("pragma% must designate an object", Arg_Internal); end if; --- 3241,3247 ---- Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); ! if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Arg_Internal); end if; *************** package body Sem_Prag is *** 3132,3138 **** Prag_Id = Pragma_Import_Valued_Procedure then if not Is_Imported (Ent) then ! Error_Pragma -- CODEFIX??? ("pragma Import or Interface must precede pragma%"); end if; --- 3593,3599 ---- Prag_Id = Pragma_Import_Valued_Procedure then if not Is_Imported (Ent) then ! Error_Pragma ("pragma Import or Interface must precede pragma%"); end if; *************** package body Sem_Prag is *** 3269,3275 **** Set_Mechanism_Value (Formal, Expression (Massoc)); ! -- Set entity on identifier for ASIS Set_Entity (Choice, Formal); --- 3730,3736 ---- Set_Mechanism_Value (Formal, Expression (Massoc)); ! -- Set entity on identifier (needed by ASIS) Set_Entity (Choice, Formal); *************** package body Sem_Prag is *** 3358,3364 **** Arg := Arg1; while Present (Arg) loop ! Exp := Expression (Arg); Analyze (Exp); if not Is_Entity_Name (Exp) --- 3819,3825 ---- Arg := Arg1; while Present (Arg) loop ! Exp := Get_Pragma_Arg (Arg); Analyze (Exp); if not Is_Entity_Name (Exp) *************** package body Sem_Prag is *** 3388,3399 **** begin Process_Convention (C, Def_Id); Kill_Size_Check_Code (Def_Id); ! Note_Possible_Modification (Expression (Arg2), Sure => False); - if Ekind (Def_Id) = E_Variable - or else - Ekind (Def_Id) = E_Constant - then -- We do not permit Import to apply to a renaming declaration if Present (Renamed_Object (Def_Id)) then --- 3849,3858 ---- begin Process_Convention (C, Def_Id); Kill_Size_Check_Code (Def_Id); ! Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); ! ! if Ekind_In (Def_Id, E_Variable, E_Constant) then -- We do not permit Import to apply to a renaming declaration if Present (Renamed_Object (Def_Id)) then *************** package body Sem_Prag is *** 3446,3460 **** elsif Is_Subprogram (Def_Id) or else Is_Generic_Subprogram (Def_Id) then ! -- If the name is overloaded, pragma applies to all of the ! -- denoted entities in the same declarative part. Hom_Id := Def_Id; while Present (Hom_Id) loop Def_Id := Get_Base_Subprogram (Hom_Id); ! -- Ignore inherited subprograms because the pragma will ! -- apply to the parent operation, which is the one called. if Is_Overloadable (Def_Id) and then Present (Alias (Def_Id)) --- 3905,3919 ---- elsif Is_Subprogram (Def_Id) or else Is_Generic_Subprogram (Def_Id) then ! -- If the name is overloaded, pragma applies to all of the denoted ! -- entities in the same declarative part. Hom_Id := Def_Id; while Present (Hom_Id) loop Def_Id := Get_Base_Subprogram (Hom_Id); ! -- Ignore inherited subprograms because the pragma will apply ! -- to the parent operation, which is the one called. if Is_Overloadable (Def_Id) and then Present (Alias (Def_Id)) *************** package body Sem_Prag is *** 3469,3474 **** --- 3928,3941 ---- then null; + -- The pragma does not apply to primitives of interfaces + + elsif Is_Dispatching_Operation (Def_Id) + and then Present (Find_Dispatching_Type (Def_Id)) + and then Is_Interface (Find_Dispatching_Type (Def_Id)) + then + null; + -- Verify that the homonym is in the same declarative part (not -- just the same scope). *************** package body Sem_Prag is *** 3517,3523 **** -- is present, then this is handled by the back end. if No (Arg3) then ! Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2)); end if; end if; --- 3984,3991 ---- -- is present, then this is handled by the back end. if No (Arg3) then ! Check_Intrinsic_Subprogram ! (Def_Id, Get_Pragma_Arg (Arg2)); end if; end if; *************** package body Sem_Prag is *** 3587,3596 **** and then C = Convention_CPP then -- Types treated as CPP classes are treated as limited, but we ! -- don't require them to be declared this way. A warning is ! -- issued to encourage the user to declare them as limited. ! -- This is not an error, for compatibility reasons, because ! -- these types have been supported this way for some time. if not Is_Limited_Type (Def_Id) then Error_Msg_N --- 4055,4064 ---- and then C = Convention_CPP then -- Types treated as CPP classes are treated as limited, but we ! -- don't require them to be declared this way. A warning is issued ! -- to encourage the user to declare them as limited. This is not ! -- an error, for compatibility reasons, because these types have ! -- been supported this way for some time. if not Is_Limited_Type (Def_Id) then Error_Msg_N *************** package body Sem_Prag is *** 3821,3829 **** -- entity (if declared in the same unit) is inlined. if Is_Subprogram (Subp) then ! while Present (Alias (Inner_Subp)) loop ! Inner_Subp := Alias (Inner_Subp); ! end loop; if In_Same_Source_Unit (Subp, Inner_Subp) then Set_Inline_Flags (Inner_Subp); --- 4289,4300 ---- -- entity (if declared in the same unit) is inlined. if Is_Subprogram (Subp) then ! ! if not Sense then ! return; ! end if; ! ! Inner_Subp := Ultimate_Alias (Inner_Subp); if In_Same_Source_Unit (Subp, Inner_Subp) then Set_Inline_Flags (Inner_Subp); *************** package body Sem_Prag is *** 3883,3898 **** procedure Set_Inline_Flags (Subp : Entity_Id) is begin if Active then ! Set_Is_Inlined (Subp, True); end if; if not Has_Pragma_Inline (Subp) then ! Set_Has_Pragma_Inline (Subp); Effective := True; end if; if Prag_Id = Pragma_Inline_Always then ! Set_Has_Pragma_Inline_Always (Subp); end if; end Set_Inline_Flags; --- 4354,4369 ---- procedure Set_Inline_Flags (Subp : Entity_Id) is begin if Active then ! Set_Is_Inlined (Subp, Sense); end if; if not Has_Pragma_Inline (Subp) then ! Set_Has_Pragma_Inline (Subp, Sense); Effective := True; end if; if Prag_Id = Pragma_Inline_Always then ! Set_Has_Pragma_Inline_Always (Subp, Sense); end if; end Set_Inline_Flags; *************** package body Sem_Prag is *** 3908,3914 **** Assoc := Arg1; while Present (Assoc) loop ! Subp_Id := Expression (Assoc); Analyze (Subp_Id); Applies := False; --- 4379,4385 ---- Assoc := Arg1; while Present (Assoc) loop ! Subp_Id := Get_Pragma_Arg (Assoc); Analyze (Subp_Id); Applies := False; *************** package body Sem_Prag is *** 3925,3936 **** else Make_Inline (Subp); ! while Present (Homonym (Subp)) ! and then Scope (Homonym (Subp)) = Current_Scope ! loop ! Make_Inline (Homonym (Subp)); ! Subp := Homonym (Subp); ! end loop; end if; end if; --- 4396,4409 ---- else Make_Inline (Subp); ! if not From_Aspect_Specification (N) then ! while Present (Homonym (Subp)) ! and then Scope (Homonym (Subp)) = Current_Scope ! loop ! Make_Inline (Homonym (Subp)); ! Subp := Homonym (Subp); ! end loop; ! end if; end if; end if; *************** package body Sem_Prag is *** 4140,4146 **** Set_Encoded_Interface_Name (Get_Base_Subprogram (Subprogram_Def), Link_Nam); ! Check_Duplicated_Export_Name (Link_Nam); end Process_Interface_Name; ----------------------------------------- --- 4613,4626 ---- Set_Encoded_Interface_Name (Get_Base_Subprogram (Subprogram_Def), Link_Nam); ! ! -- We allow duplicated export names in CIL, as they are always ! -- enclosed in a namespace that differentiates them, and overloaded ! -- entities are supported by the VM. ! ! if Convention (Subprogram_Def) /= Convention_CIL then ! Check_Duplicated_Export_Name (Link_Nam); ! end if; end Process_Interface_Name; ----------------------------------------- *************** package body Sem_Prag is *** 4148,4154 **** ----------------------------------------- procedure Process_Interrupt_Or_Attach_Handler is ! Arg1_X : constant Node_Id := Expression (Arg1); Handler_Proc : constant Entity_Id := Entity (Arg1_X); Proc_Scope : constant Entity_Id := Scope (Handler_Proc); --- 4628,4634 ---- ----------------------------------------- procedure Process_Interrupt_Or_Attach_Handler is ! Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); Handler_Proc : constant Entity_Id := Entity (Arg1_X); Proc_Scope : constant Entity_Id := Scope (Handler_Proc); *************** package body Sem_Prag is *** 4213,4218 **** --- 4693,4704 ---- -- Start of processing for Process_Restrictions_Or_Restriction_Warnings begin + -- Ignore all Restrictions pragma in CodePeer mode + + if CodePeer_Mode then + return; + end if; + Check_Ada_83_Warning; Check_At_Least_N_Arguments (1); Check_Valid_Configuration_Pragma; *************** package body Sem_Prag is *** 4220,4226 **** Arg := Arg1; while Present (Arg) loop Id := Chars (Arg); ! Expr := Expression (Arg); -- Case of no restriction identifier present --- 4706,4712 ---- Arg := Arg1; while Present (Arg) loop Id := Chars (Arg); ! Expr := Get_Pragma_Arg (Arg); -- Case of no restriction identifier present *************** package body Sem_Prag is *** 4290,4295 **** --- 4776,4794 ---- Restriction_Warnings (R_Id) := False; end if; + -- Check for obsolescent restrictions in Ada 2005 mode + + if not Warn + and then Ada_Version >= Ada_2005 + and then (R_Id = No_Asynchronous_Control + or else + R_Id = No_Unchecked_Deallocation + or else + R_Id = No_Unchecked_Conversion) + then + Check_Restriction (No_Obsolescent_Features, N); + end if; + -- A very special case that must be processed here: pragma -- Restrictions (No_Exceptions) turns off all run-time -- checking. This is a bit dubious in terms of the formal *************** package body Sem_Prag is *** 4418,4423 **** --- 4917,4929 ---- -- Start of processing for Process_Suppress_Unsuppress begin + -- Ignore pragma Suppress/Unsuppress in codepeer mode on user code: + -- we want to generate checks for analysis purposes, as set by -gnatC + + if CodePeer_Mode and then Comes_From_Source (N) then + return; + end if; + -- Suppress/Unsuppress can appear as a configuration pragma, or in a -- declarative part or a package spec (RM 11.5(5)). *************** package body Sem_Prag is *** 4430,4436 **** Check_No_Identifier (Arg1); Check_Arg_Is_Identifier (Arg1); ! C := Get_Check_Id (Chars (Expression (Arg1))); if C = No_Check_Id then Error_Pragma_Arg --- 4936,4942 ---- Check_No_Identifier (Arg1); Check_Arg_Is_Identifier (Arg1); ! C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); if C = No_Check_Id then Error_Pragma_Arg *************** package body Sem_Prag is *** 4481,4488 **** -- a specified entity (given as the second argument of the pragma) else Check_Optional_Identifier (Arg2, Name_On); ! E_Id := Expression (Arg2); Analyze (E_Id); if not Is_Entity_Name (E_Id) then --- 4987,5000 ---- -- a specified entity (given as the second argument of the pragma) else + -- This is obsolescent in Ada 2005 mode + + if Ada_Version >= Ada_2005 then + Check_Restriction (No_Obsolescent_Features, Arg2); + end if; + Check_Optional_Identifier (Arg2, Name_On); ! E_Id := Get_Pragma_Arg (Arg2); Analyze (E_Id); if not Is_Entity_Name (E_Id) then *************** package body Sem_Prag is *** 4524,4531 **** Suppress_Unsuppress_Echeck (Alias (E), C); end if; ! -- Move to next homonym E := Homonym (E); exit when No (E); --- 5036,5044 ---- Suppress_Unsuppress_Echeck (Alias (E), C); end if; ! -- Move to next homonym if not aspect spec case + exit when From_Aspect_Specification (N); E := Homonym (E); exit when No (E); *************** package body Sem_Prag is *** 4548,4554 **** Error_Pragma_Arg ("cannot export entity& that was previously imported", Arg); ! elsif Present (Address_Clause (E)) then Error_Pragma_Arg ("cannot export entity& that has an address clause", Arg); end if; --- 5061,5067 ---- Error_Pragma_Arg ("cannot export entity& that was previously imported", Arg); ! elsif Present (Address_Clause (E)) and then not CodePeer_Mode then Error_Pragma_Arg ("cannot export entity& that has an address clause", Arg); end if; *************** package body Sem_Prag is *** 4594,4601 **** end if; if Warn_On_Export_Import and then Is_Type (E) then ! Error_Msg_NE ! ("exporting a type has no effect?", Arg, E); end if; if Warn_On_Export_Import and Inside_A_Generic then --- 5107,5113 ---- end if; if Warn_On_Export_Import and then Is_Type (E) then ! Error_Msg_NE ("exporting a type has no effect?", Arg, E); end if; if Warn_On_Export_Import and Inside_A_Generic then *************** package body Sem_Prag is *** 4695,4702 **** --- 5207,5225 ---- -- Error message if already imported or exported if Is_Exported (E) or else Is_Imported (E) then + + -- Error if being set Exported twice + if Is_Exported (E) then Error_Msg_NE ("entity& was previously exported", N, E); + + -- OK if Import/Interface case + + elsif Import_Interface_Present (N) then + goto OK; + + -- Error if being set Imported twice + else Error_Msg_NE ("entity& was previously imported", N, E); end if; *************** package body Sem_Prag is *** 4725,4730 **** --- 5248,5255 ---- Set_Is_Statically_Allocated (E); end if; end if; + + <> null; end Set_Imported; ------------------------- *************** package body Sem_Prag is *** 4736,4743 **** -- form created by the parser. procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is ! Class : Node_Id; ! Param : Node_Id; Mech_Name_Id : Name_Id; procedure Bad_Class; --- 5261,5268 ---- -- form created by the parser. procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is ! Class : Node_Id; ! Param : Node_Id; Mech_Name_Id : Name_Id; procedure Bad_Class; *************** package body Sem_Prag is *** 4786,4792 **** elsif Chars (Mech_Name) = Name_Descriptor then Check_VMS (Mech_Name); ! Set_Mechanism (Ent, By_Descriptor); return; elsif Chars (Mech_Name) = Name_Short_Descriptor then --- 5311,5325 ---- elsif Chars (Mech_Name) = Name_Descriptor then Check_VMS (Mech_Name); ! ! -- Descriptor => Short_Descriptor if pragma was given ! ! if Short_Descriptors then ! Set_Mechanism (Ent, By_Short_Descriptor); ! else ! Set_Mechanism (Ent, By_Descriptor); ! end if; ! return; elsif Chars (Mech_Name) = Name_Short_Descriptor then *************** package body Sem_Prag is *** 4809,4815 **** -- Note: this form is parsed as an indexed component elsif Nkind (Mech_Name) = N_Indexed_Component then - Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier --- 5342,5347 ---- *************** package body Sem_Prag is *** 4820,4825 **** --- 5352,5365 ---- Bad_Mechanism; else Mech_Name_Id := Chars (Prefix (Mech_Name)); + + -- Change Descriptor => Short_Descriptor if pragma was given + + if Mech_Name_Id = Name_Descriptor + and then Short_Descriptors + then + Mech_Name_Id := Name_Short_Descriptor; + end if; end if; -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | *************** package body Sem_Prag is *** 4829,4835 **** -- Note: this form is parsed as a function call elsif Nkind (Mech_Name) = N_Function_Call then - Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier --- 5369,5374 ---- *************** package body Sem_Prag is *** 4857,4928 **** Bad_Class; elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBS then Set_Mechanism (Ent, By_Descriptor_UBS); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBSB then Set_Mechanism (Ent, By_Descriptor_UBSB); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBA then Set_Mechanism (Ent, By_Descriptor_UBA); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_S then Set_Mechanism (Ent, By_Descriptor_S); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_SB then Set_Mechanism (Ent, By_Descriptor_SB); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_A then Set_Mechanism (Ent, By_Descriptor_A); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_NCA then Set_Mechanism (Ent, By_Descriptor_NCA); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_UBS then Set_Mechanism (Ent, By_Short_Descriptor_UBS); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_UBSB then Set_Mechanism (Ent, By_Short_Descriptor_UBSB); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_UBA then Set_Mechanism (Ent, By_Short_Descriptor_UBA); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_S then Set_Mechanism (Ent, By_Short_Descriptor_S); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_SB then Set_Mechanism (Ent, By_Short_Descriptor_SB); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_A then Set_Mechanism (Ent, By_Short_Descriptor_A); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_NCA then Set_Mechanism (Ent, By_Short_Descriptor_NCA); --- 5396,5467 ---- Bad_Class; elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBS then Set_Mechanism (Ent, By_Descriptor_UBS); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBSB then Set_Mechanism (Ent, By_Descriptor_UBSB); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_UBA then Set_Mechanism (Ent, By_Descriptor_UBA); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_S then Set_Mechanism (Ent, By_Descriptor_S); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_SB then Set_Mechanism (Ent, By_Descriptor_SB); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_A then Set_Mechanism (Ent, By_Descriptor_A); elsif Mech_Name_Id = Name_Descriptor ! and then Chars (Class) = Name_NCA then Set_Mechanism (Ent, By_Descriptor_NCA); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_UBS then Set_Mechanism (Ent, By_Short_Descriptor_UBS); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_UBSB then Set_Mechanism (Ent, By_Short_Descriptor_UBSB); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_UBA then Set_Mechanism (Ent, By_Short_Descriptor_UBA); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_S then Set_Mechanism (Ent, By_Short_Descriptor_S); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_SB then Set_Mechanism (Ent, By_Short_Descriptor_SB); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_A then Set_Mechanism (Ent, By_Short_Descriptor_A); elsif Mech_Name_Id = Name_Short_Descriptor ! and then Chars (Class) = Name_NCA then Set_Mechanism (Ent, By_Short_Descriptor_NCA); *************** package body Sem_Prag is *** 4946,4952 **** --- 5485,5504 ---- -- Set required restrictions (see System.Rident for detailed list) + -- Set the No_Dependence rules + -- No_Dependence => Ada.Asynchronous_Task_Control + -- No_Dependence => Ada.Calendar + -- No_Dependence => Ada.Execution_Time.Group_Budget + -- No_Dependence => Ada.Execution_Time.Timers + -- No_Dependence => Ada.Task_Attributes + -- No_Dependence => System.Multiprocessors.Dispatching_Domains + procedure Set_Ravenscar_Profile (N : Node_Id) is + Prefix_Entity : Entity_Id; + Selector_Entity : Entity_Id; + Prefix_Node : Node_Id; + Node : Node_Id; + begin -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) *************** package body Sem_Prag is *** 4995,5000 **** --- 5547,5652 ---- Set_Profile_Restrictions (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); + + -- Set the No_Dependence restrictions + + -- The following No_Dependence restrictions: + -- No_Dependence => Ada.Asynchronous_Task_Control + -- No_Dependence => Ada.Calendar + -- No_Dependence => Ada.Task_Attributes + -- are already set by previous call to Set_Profile_Restrictions. + + -- Set the following restrictions which were added to Ada 2005: + -- No_Dependence => Ada.Execution_Time.Group_Budget + -- No_Dependence => Ada.Execution_Time.Timers + + if Ada_Version >= Ada_2005 then + Name_Buffer (1 .. 3) := "ada"; + Name_Len := 3; + + Prefix_Entity := Make_Identifier (Loc, Name_Find); + + Name_Buffer (1 .. 14) := "execution_time"; + Name_Len := 14; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Prefix_Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Entity, + Selector_Name => Selector_Entity); + + Name_Buffer (1 .. 13) := "group_budgets"; + Name_Len := 13; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); + + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + + Name_Buffer (1 .. 6) := "timers"; + Name_Len := 6; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); + + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end if; + + -- Set the following restrictions which was added to Ada 2012 (see + -- AI-0171): + -- No_Dependence => System.Multiprocessors.Dispatching_Domains + + if Ada_Version >= Ada_2012 then + Name_Buffer (1 .. 6) := "system"; + Name_Len := 6; + + Prefix_Entity := Make_Identifier (Loc, Name_Find); + + Name_Buffer (1 .. 15) := "multiprocessors"; + Name_Len := 15; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Prefix_Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Entity, + Selector_Name => Selector_Entity); + + Name_Buffer (1 .. 19) := "dispatching_domains"; + Name_Len := 19; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); + + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end if; end Set_Ravenscar_Profile; -- Start of processing for Analyze_Pragma *************** package body Sem_Prag is *** 5105,5114 **** -- said this was a configuration pragma, but we did not check and -- are hesitant to add the check now. ! -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 ! -- or Ada 95, so we must check if we are in Ada 2005 mode. ! if Ada_Version >= Ada_05 then Check_Valid_Configuration_Pragma; end if; --- 5757,5767 ---- -- said this was a configuration pragma, but we did not check and -- are hesitant to add the check now. ! -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 ! -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 ! -- or Ada 2012 mode. ! if Ada_Version >= Ada_2005 then Check_Valid_Configuration_Pragma; end if; *************** package body Sem_Prag is *** 5139,5145 **** -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 -- or Ada 95, so we must check if we are in Ada 2005 mode. ! if Ada_Version >= Ada_05 then Check_Valid_Configuration_Pragma; end if; --- 5792,5798 ---- -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 -- or Ada 95, so we must check if we are in Ada 2005 mode. ! if Ada_Version >= Ada_2005 then Check_Valid_Configuration_Pragma; end if; *************** package body Sem_Prag is *** 5158,5164 **** -- pragma Ada_2005; -- pragma Ada_2005 (LOCAL_NAME): ! -- Note: these pragma also have some specific processing in Par.Prag -- because we want to set the Ada 2005 version mode during parsing. when Pragma_Ada_05 | Pragma_Ada_2005 => declare --- 5811,5817 ---- -- pragma Ada_2005; -- pragma Ada_2005 (LOCAL_NAME): ! -- Note: these pragmas also have some specific processing in Par.Prag -- because we want to set the Ada 2005 version mode during parsing. when Pragma_Ada_05 | Pragma_Ada_2005 => declare *************** package body Sem_Prag is *** 5169,5175 **** if Arg_Count = 1 then Check_Arg_Is_Local_Name (Arg1); ! E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then return; --- 5822,5828 ---- if Arg_Count = 1 then Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); if Etype (E_Id) = Any_Type then return; *************** package body Sem_Prag is *** 5188,5197 **** Check_Valid_Configuration_Pragma; ! -- Now set Ada 2005 mode ! Ada_Version := Ada_05; ! Ada_Version_Explicit := Ada_05; end if; end; --- 5841,5908 ---- Check_Valid_Configuration_Pragma; ! -- Now set appropriate Ada mode ! if Sense then ! Ada_Version := Ada_2005; ! else ! Ada_Version := Ada_Version_Default; ! end if; ! ! Ada_Version_Explicit := Ada_2005; ! end if; ! end; ! ! --------------------- ! -- Ada_12/Ada_2012 -- ! --------------------- ! ! -- pragma Ada_12; ! -- pragma Ada_12 (LOCAL_NAME); ! ! -- pragma Ada_2012; ! -- pragma Ada_2012 (LOCAL_NAME): ! ! -- Note: these pragmas also have some specific processing in Par.Prag ! -- because we want to set the Ada 2012 version mode during parsing. ! ! when Pragma_Ada_12 | Pragma_Ada_2012 => declare ! E_Id : Node_Id; ! ! begin ! GNAT_Pragma; ! ! if Arg_Count = 1 then ! Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); ! ! if Etype (E_Id) = Any_Type then ! return; ! end if; ! ! Set_Is_Ada_2012_Only (Entity (E_Id)); ! ! else ! Check_Arg_Count (0); ! ! -- For Ada_2012 we unconditionally enforce the documented ! -- configuration pragma placement, since we do not want to ! -- tolerate mixed modes in a unit involving Ada 2012. That ! -- would cause real difficulties for those cases where there ! -- are incompatibilities between Ada 95 and Ada 2012. We could ! -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. ! ! Check_Valid_Configuration_Pragma; ! ! -- Now set appropriate Ada mode ! ! if Sense then ! Ada_Version := Ada_2012; ! else ! Ada_Version := Ada_Version_Default; ! end if; ! ! Ada_Version_Explicit := Ada_2012; end if; end; *************** package body Sem_Prag is *** 5246,5251 **** --- 5957,5964 ---- GNAT_Pragma; Check_At_Least_N_Arguments (1); Check_Arg_Is_Identifier (Arg1); + Check_No_Identifiers; + Store_Note (N); declare Arg : Node_Id; *************** package body Sem_Prag is *** 5259,5265 **** else Arg := Next (Arg2); while Present (Arg) loop ! Exp := Expression (Arg); Analyze (Exp); if Is_Entity_Name (Exp) then --- 5972,5978 ---- else Arg := Next (Arg2); while Present (Arg) loop ! Exp := Get_Pragma_Arg (Arg); Analyze (Exp); if Is_Entity_Name (Exp) then *************** package body Sem_Prag is *** 5319,5327 **** Expr := Get_Pragma_Arg (Arg1); Newa := New_List ( Make_Pragma_Argument_Association (Loc, ! Expression => ! Make_Identifier (Loc, ! Chars => Name_Assertion)), Make_Pragma_Argument_Association (Sloc (Expr), Expression => Expr)); --- 6032,6038 ---- Expr := Get_Pragma_Arg (Arg1); Newa := New_List ( Make_Pragma_Argument_Association (Loc, ! Expression => Make_Identifier (Loc, Name_Assertion)), Make_Pragma_Argument_Association (Sloc (Expr), Expression => Expr)); *************** package body Sem_Prag is *** 5370,5383 **** Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, ! Expression => ! Make_Identifier (Loc, ! Chars => Name_Assertion)), Make_Pragma_Argument_Association (Loc, Expression => ! Make_Identifier (Sloc (Policy), ! Chars => Chars (Policy)))))); Set_Analyzed (N); Set_Next_Pragma (N, Opt.Check_Policy_List); --- 6081,6091 ---- Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, ! Expression => Make_Identifier (Loc, Name_Assertion)), Make_Pragma_Argument_Association (Loc, Expression => ! Make_Identifier (Sloc (Policy), Chars (Policy)))))); Set_Analyzed (N); Set_Next_Pragma (N, Opt.Check_Policy_List); *************** package body Sem_Prag is *** 5397,5403 **** Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); ! if Chars (Expression (Arg1)) = Name_On then Assume_No_Invalid_Values := True; else Assume_No_Invalid_Values := False; --- 6105,6111 ---- Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); ! if Chars (Get_Pragma_Arg (Arg1)) = Name_On then Assume_No_Invalid_Values := True; else Assume_No_Invalid_Values := False; *************** package body Sem_Prag is *** 5418,5424 **** Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Local_Name (Arg1); ! Ent := Entity (Expression (Arg1)); -- Note: the implementation of the AST_Entry pragma could handle -- the entry family case fine, but for now we are consistent with --- 6126,6132 ---- Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Local_Name (Arg1); ! Ent := Entity (Get_Pragma_Arg (Arg1)); -- Note: the implementation of the AST_Entry pragma could handle -- the entry family case fine, but for now we are consistent with *************** package body Sem_Prag is *** 5521,5528 **** end if; C_Ent := Cunit_Entity (Current_Sem_Unit); ! Analyze (Expression (Arg1)); ! Nm := Entity (Expression (Arg1)); if not Is_Remote_Call_Interface (C_Ent) and then not Is_Remote_Types (C_Ent) --- 6229,6236 ---- end if; C_Ent := Cunit_Entity (Current_Sem_Unit); ! Analyze (Get_Pragma_Arg (Arg1)); ! Nm := Entity (Get_Pragma_Arg (Arg1)); if not Is_Remote_Call_Interface (C_Ent) and then not Is_Remote_Types (C_Ent) *************** package body Sem_Prag is *** 5634,5640 **** Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then return; --- 6342,6348 ---- Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); if Etype (E_Id) = Any_Type then return; *************** package body Sem_Prag is *** 5642,5647 **** --- 6350,6357 ---- E := Entity (E_Id); + Check_Duplicate_Pragma (E); + if Rep_Item_Too_Early (E, N) or else Rep_Item_Too_Late (E, N) *************** package body Sem_Prag is *** 5665,5682 **** E := Base_Type (E); end if; ! Set_Has_Volatile_Components (E); if Prag_Id = Pragma_Atomic_Components then ! Set_Has_Atomic_Components (E); ! ! if Is_Packed (E) then ! Set_Is_Packed (E, False); ! ! Error_Pragma_Arg ! ("?Pack canceled, cannot pack atomic components", ! Arg1); ! end if; end if; else --- 6375,6384 ---- E := Base_Type (E); end if; ! Set_Has_Volatile_Components (E, Sense); if Prag_Id = Pragma_Atomic_Components then ! Set_Has_Atomic_Components (E, Sense); end if; else *************** package body Sem_Prag is *** 5700,5723 **** else Check_Interrupt_Or_Attach_Handler; ! -- The expression that designates the attribute may ! -- depend on a discriminant, and is therefore a per- ! -- object expression, to be expanded in the init proc. ! -- If expansion is enabled, perform semantic checks ! -- on a copy only. if Expander_Active then declare Temp : constant Node_Id := ! New_Copy_Tree (Expression (Arg2)); begin Set_Parent (Temp, N); Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); end; else ! Analyze (Expression (Arg2)); ! Resolve (Expression (Arg2), RTE (RE_Interrupt_ID)); end if; Process_Interrupt_Or_Attach_Handler; --- 6402,6424 ---- else Check_Interrupt_Or_Attach_Handler; ! -- The expression that designates the attribute may depend on a ! -- discriminant, and is therefore a per- object expression, to ! -- be expanded in the init proc. If expansion is enabled, then ! -- perform semantic checks on a copy only. if Expander_Active then declare Temp : constant Node_Id := ! New_Copy_Tree (Get_Pragma_Arg (Arg2)); begin Set_Parent (Temp, N); Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); end; else ! Analyze (Get_Pragma_Arg (Arg2)); ! Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID)); end if; Process_Interrupt_Or_Attach_Handler; *************** package body Sem_Prag is *** 5739,5745 **** Check_Arg_Count (1); Check_Optional_Identifier (Arg1, "max_size"); ! Arg := Expression (Arg1); Check_Arg_Is_Static_Expression (Arg, Any_Integer); Val := Expr_Value (Arg); --- 6440,6446 ---- Check_Arg_Count (1); Check_Optional_Identifier (Arg1, "max_size"); ! Arg := Get_Pragma_Arg (Arg1); Check_Arg_Is_Static_Expression (Arg, Any_Integer); Val := Expr_Value (Arg); *************** package body Sem_Prag is *** 5788,5795 **** end if; Check_Arg_Is_Identifier (Arg1); Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); ! Set_Pragma_Enabled (N, Check_On); -- If expansion is active and the check is not enabled then we -- rewrite the Check as: --- 6489,6505 ---- end if; Check_Arg_Is_Identifier (Arg1); + + -- Indicate if pragma is enabled. The Original_Node reference here + -- is to deal with pragma Assert rewritten as a Check pragma. + Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); ! ! if Check_On then ! Set_Pragma_Enabled (N); ! Set_Pragma_Enabled (Original_Node (N)); ! Set_SCO_Pragma_Enabled (Loc); ! end if; -- If expansion is active and the check is not enabled then we -- rewrite the Check as: *************** package body Sem_Prag is *** 5810,5816 **** -- compile time, and we do not want to delete this warning when we -- delete the if statement. ! Expr := Expression (Arg2); if Expander_Active and then not Check_On then Eloc := Sloc (Expr); --- 6520,6526 ---- -- compile time, and we do not want to delete this warning when we -- delete the if statement. ! Expr := Get_Pragma_Arg (Arg2); if Expander_Active and then not Check_On then Eloc := Sloc (Expr); *************** package body Sem_Prag is *** 5847,5853 **** Check_Arg_Is_Identifier (Arg1); declare ! Nam : constant Name_Id := Chars (Expression (Arg1)); begin for J in Check_Names.First .. Check_Names.Last loop --- 6557,6563 ---- Check_Arg_Is_Identifier (Arg1); declare ! Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); begin for J in Check_Names.First .. Check_Names.Last loop *************** package body Sem_Prag is *** 5985,5991 **** Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then return; --- 6695,6701 ---- Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); if Etype (E_Id) = Any_Type then return; *************** package body Sem_Prag is *** 6133,6139 **** Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! Arg := Expression (Arg1); if not Is_Entity_Name (Arg) or else not Is_Access_Type (Entity (Arg)) --- 6843,6849 ---- Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! Arg := Get_Pragma_Arg (Arg1); if not Is_Entity_Name (Arg) or else not Is_Access_Type (Entity (Arg)) *************** package body Sem_Prag is *** 6182,6189 **** Check_Optional_Identifier (Arg2, Name_Convention); Check_Arg_Is_Identifier (Arg1); Check_Arg_Is_Identifier (Arg2); ! Idnam := Chars (Expression (Arg1)); ! Cname := Chars (Expression (Arg2)); if Is_Convention_Name (Cname) then Record_Convention_Identifier --- 6892,6899 ---- Check_Optional_Identifier (Arg2, Name_Convention); Check_Arg_Is_Identifier (Arg1); Check_Arg_Is_Identifier (Arg2); ! Idnam := Chars (Get_Pragma_Arg (Arg1)); ! Cname := Chars (Get_Pragma_Arg (Arg2)); if Is_Convention_Name (Cname) then Record_Convention_Identifier *************** package body Sem_Prag is *** 6216,6222 **** Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Arg := Expression (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then --- 6926,6932 ---- Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Arg := Get_Pragma_Arg (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then *************** package body Sem_Prag is *** 6333,6339 **** Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Id := Expression (Arg1); Find_Program_Unit_Name (Id); -- If we did not find the name, we are done --- 7043,7049 ---- Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Id := Get_Pragma_Arg (Arg1); Find_Program_Unit_Name (Id); -- If we did not find the name, we are done *************** package body Sem_Prag is *** 6344,6349 **** --- 7054,7067 ---- Def_Id := Entity (Id); + -- Check if already defined as constructor + + if Is_Constructor (Def_Id) then + Error_Msg_N + ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1); + return; + end if; + if Ekind (Def_Id) = E_Function and then (Is_CPP_Class (Etype (Def_Id)) or else (Is_Class_Wide_Type (Etype (Def_Id)) *************** package body Sem_Prag is *** 6426,6431 **** --- 7144,7235 ---- end if; end CPP_Vtable; + --------- + -- CPU -- + --------- + + -- pragma CPU (EXPRESSION); + + when Pragma_CPU => CPU : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + -- Subprogram case + + if Nkind (P) = N_Subprogram_Body then + Check_In_Main_Program; + + Arg := Get_Pragma_Arg (Arg1); + Analyze_And_Resolve (Arg, Any_Integer); + + -- Must be static + + if not Is_Static_Expression (Arg) then + Flag_Non_Static_Expr + ("main subprogram affinity is not static!", Arg); + raise Pragma_Exit; + + -- If constraint error, then we already signalled an error + + elsif Raises_Constraint_Error (Arg) then + null; + + -- Otherwise check in range + + else + declare + CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); + -- This is the entity System.Multiprocessors.CPU_Range; + + Val : constant Uint := Expr_Value (Arg); + + begin + if Val < Expr_Value (Type_Low_Bound (CPU_Id)) + or else + Val > Expr_Value (Type_High_Bound (CPU_Id)) + then + Error_Pragma_Arg + ("main subprogram CPU is out of range", Arg1); + end if; + end; + end if; + + Set_Main_CPU + (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); + + -- Task case + + elsif Nkind (P) = N_Task_Definition then + Arg := Get_Pragma_Arg (Arg1); + + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Pragma_CPU (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Pragma_CPU (P, True); + + if Nkind (P) = N_Task_Definition then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end if; + end CPU; + ----------- -- Debug -- ----------- *************** package body Sem_Prag is *** 6447,6453 **** Cond := Make_And_Then (Loc, Left_Opnd => Relocate_Node (Cond), ! Right_Opnd => Expression (Arg1)); end if; -- Rewrite into a conditional with an appropriate condition. We --- 7251,7257 ---- Cond := Make_And_Then (Loc, Left_Opnd => Relocate_Node (Cond), ! Right_Opnd => Get_Pragma_Arg (Arg1)); end if; -- Rewrite into a conditional with an appropriate condition. We *************** package body Sem_Prag is *** 6476,6482 **** GNAT_Pragma; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); ! Debug_Pragmas_Enabled := Chars (Expression (Arg1)) = Name_Check; --------------------- -- Detect_Blocking -- --- 7280,7287 ---- GNAT_Pragma; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); ! Debug_Pragmas_Enabled := ! Chars (Get_Pragma_Arg (Arg1)) = Name_Check; --------------------- -- Detect_Blocking -- *************** package body Sem_Prag is *** 6490,6495 **** --- 7295,7351 ---- Check_Valid_Configuration_Pragma; Detect_Blocking := True; + -------------------------- + -- Default_Storage_Pool -- + -------------------------- + + -- pragma Default_Storage_Pool (storage_pool_NAME | null); + + when Pragma_Default_Storage_Pool => + Ada_2012_Pragma; + Check_Arg_Count (1); + + -- Default_Storage_Pool can appear as a configuration pragma, or + -- in a declarative part or a package spec. + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + -- Case of Default_Storage_Pool (null); + + if Nkind (Expression (Arg1)) = N_Null then + Analyze (Expression (Arg1)); + + -- This is an odd case, this is not really an expression, so + -- we don't have a type for it. So just set the type to Empty. + + Set_Etype (Expression (Arg1), Empty); + + -- Case of Default_Storage_Pool (storage_pool_NAME); + + else + -- If it's a configuration pragma, then the only allowed + -- argument is "null". + + if Is_Configuration_Pragma then + Error_Pragma_Arg ("NULL expected", Arg1); + end if; + + -- The expected type for a non-"null" argument is + -- Root_Storage_Pool'Class. + + Analyze_And_Resolve + (Get_Pragma_Arg (Arg1), + Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + end if; + + -- Finally, record the pool name (or null). Freeze.Freeze_Entity + -- for an access type will use this information to set the + -- appropriate attributes of the access type. + + Default_Pool := Expression (Arg1); + --------------- -- Dimension -- --------------- *************** package body Sem_Prag is *** 6539,6545 **** -- defined in the current declarative part, and recursively -- to any nested scope. ! Set_Discard_Names (Current_Scope); return; else --- 7395,7401 ---- -- defined in the current declarative part, and recursively -- to any nested scope. ! Set_Discard_Names (Current_Scope, Sense); return; else *************** package body Sem_Prag is *** 6547,6553 **** Check_Optional_Identifier (Arg1, Name_On); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then return; --- 7403,7409 ---- Check_Optional_Identifier (Arg1, Name_On); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); if Etype (E_Id) = Any_Type then return; *************** package body Sem_Prag is *** 6560,6566 **** (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) or else Ekind (E) = E_Exception then ! Set_Discard_Names (E); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); --- 7416,7422 ---- (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) or else Ekind (E) = E_Exception then ! Set_Discard_Names (E, Sense); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); *************** package body Sem_Prag is *** 6625,6634 **** Citem := First (List_Containing (N)); Inner : while Citem /= N loop if Nkind (Citem) = N_With_Clause ! and then Same_Name (Name (Citem), Expression (Arg)) then Set_Elaborate_Present (Citem, True); ! Set_Unit_Name (Expression (Arg), Name (Citem)); -- With the pragma present, elaboration calls on -- subprograms from the named unit need no further --- 7481,7490 ---- Citem := First (List_Containing (N)); Inner : while Citem /= N loop if Nkind (Citem) = N_With_Clause ! and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) then Set_Elaborate_Present (Citem, True); ! Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); -- With the pragma present, elaboration calls on -- subprograms from the named unit need no further *************** package body Sem_Prag is *** 6707,6716 **** Citem := First (List_Containing (N)); Innr : while Citem /= N loop if Nkind (Citem) = N_With_Clause ! and then Same_Name (Name (Citem), Expression (Arg)) then Set_Elaborate_All_Present (Citem, True); ! Set_Unit_Name (Expression (Arg), Name (Citem)); -- Suppress warnings and elaboration checks on the named -- unit if the pragma is in the current compilation, as --- 7563,7572 ---- Citem := First (List_Containing (N)); Innr : while Citem /= N loop if Nkind (Citem) = N_With_Clause ! and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) then Set_Elaborate_All_Present (Citem, True); ! Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); -- Suppress warnings and elaboration checks on the named -- unit if the pragma is in the current compilation, as *************** package body Sem_Prag is *** 6909,6915 **** Process_Convention (C, Def_Id); if Ekind (Def_Id) /= E_Constant then ! Note_Possible_Modification (Expression (Arg2), Sure => False); end if; Process_Interface_Name (Def_Id, Arg3, Arg4); --- 7765,7772 ---- Process_Convention (C, Def_Id); if Ekind (Def_Id) /= E_Constant then ! Note_Possible_Modification ! (Get_Pragma_Arg (Arg2), Sure => False); end if; Process_Interface_Name (Def_Id, Arg3, Arg4); *************** package body Sem_Prag is *** 7247,7259 **** Check_Optional_Identifier (Arg1, Name_Name); Check_Arg_Is_Identifier (Arg1); ! Get_Name_String (Chars (Expression (Arg1))); if Name_Len > 4 and then Name_Buffer (1 .. 4) = "aux_" then if Present (System_Extend_Pragma_Arg) then ! if Chars (Expression (Arg1)) = Chars (Expression (System_Extend_Pragma_Arg)) then null; --- 8104,8116 ---- Check_Optional_Identifier (Arg1, Name_Name); Check_Arg_Is_Identifier (Arg1); ! Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); if Name_Len > 4 and then Name_Buffer (1 .. 4) = "aux_" then if Present (System_Extend_Pragma_Arg) then ! if Chars (Get_Pragma_Arg (Arg1)) = Chars (Expression (System_Extend_Pragma_Arg)) then null; *************** package body Sem_Prag is *** 7286,7295 **** Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); ! if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; else Extensions_Allowed := False; end if; -------------- --- 8143,8155 ---- Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); ! if Chars (Get_Pragma_Arg (Arg1)) = Name_On then Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + else Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; end if; -------------- *************** package body Sem_Prag is *** 7318,7324 **** Check_At_Least_N_Arguments (2); Check_At_Most_N_Arguments (4); Process_Convention (C, Def_Id); ! Note_Possible_Modification (Expression (Arg2), Sure => False); Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); end External; --- 8178,8185 ---- Check_At_Least_N_Arguments (2); Check_At_Most_N_Arguments (4); Process_Convention (C, Def_Id); ! Note_Possible_Modification ! (Get_Pragma_Arg (Arg2), Sure => False); Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); end External; *************** package body Sem_Prag is *** 7386,7404 **** Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! Named_Entity := Entity (Expression (Arg1)); -- If it's an access-to-subprogram type (in particular, not a -- subtype), set the flag on that type. if Is_Access_Subprogram_Type (Named_Entity) then ! Set_Can_Use_Internal_Rep (Named_Entity, False); -- Otherwise it's an error (name denotes the wrong sort of entity) else Error_Pragma_Arg ! ("access-to-subprogram type expected", Expression (Arg1)); end if; end Favor_Top_Level; --- 8247,8268 ---- Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! Named_Entity := Entity (Get_Pragma_Arg (Arg1)); -- If it's an access-to-subprogram type (in particular, not a -- subtype), set the flag on that type. if Is_Access_Subprogram_Type (Named_Entity) then ! if Sense then ! Set_Can_Use_Internal_Rep (Named_Entity, False); ! end if; -- Otherwise it's an error (name denotes the wrong sort of entity) else Error_Pragma_Arg ! ("access-to-subprogram type expected", ! Get_Pragma_Arg (Arg1)); end if; end Favor_Top_Level; *************** package body Sem_Prag is *** 7422,7428 **** when Pragma_Finalize_Storage_Only => Finalize_Storage : declare Assoc : constant Node_Id := Arg1; ! Type_Id : constant Node_Id := Expression (Assoc); Typ : Entity_Id; begin --- 8286,8292 ---- when Pragma_Finalize_Storage_Only => Finalize_Storage : declare Assoc : constant Node_Id := Arg1; ! Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); Typ : Entity_Id; begin *************** package body Sem_Prag is *** 7484,7490 **** Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); if not OpenVMS_On_Target then ! if Chars (Expression (Arg1)) = Name_VAX_Float then Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)"); end if; --- 8348,8354 ---- Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); if not OpenVMS_On_Target then ! if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)"); end if; *************** package body Sem_Prag is *** 7495,7501 **** -- One argument case if Arg_Count = 1 then ! if Chars (Expression (Arg1)) = Name_VAX_Float then if Opt.Float_Format = 'I' then Error_Pragma ("'I'E'E'E format previously specified"); end if; --- 8359,8365 ---- -- One argument case if Arg_Count = 1 then ! if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then if Opt.Float_Format = 'I' then Error_Pragma ("'I'E'E'E format previously specified"); end if; *************** package body Sem_Prag is *** 7530,7536 **** -- Two arguments, VAX_Float case ! if Chars (Expression (Arg1)) = Name_VAX_Float then case Digs is when 6 => Set_F_Float (Ent); when 9 => Set_D_Float (Ent); --- 8394,8400 ---- -- Two arguments, VAX_Float case ! if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then case Digs is when 6 => Set_F_Float (Ent); when 9 => Set_D_Float (Ent); *************** package body Sem_Prag is *** 7575,7580 **** --- 8439,8445 ---- Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Store_Note (N); -- For pragma Ident, preserve DEC compatibility by requiring the -- pragma to appear in a declarative part or package spec. *************** package body Sem_Prag is *** 7583,7589 **** Check_Is_In_Decl_Part_Or_Package_Spec; end if; ! Str := Expr_Value_S (Expression (Arg1)); declare CS : Node_Id; --- 8448,8454 ---- Check_Is_In_Decl_Part_Or_Package_Spec; end if; ! Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); declare CS : Node_Id; *************** package body Sem_Prag is *** 7623,7634 **** else -- In VMS, the effect of IDENT is achieved by passing ! -- IDENTIFICATION=name as a --for-linker switch. if OpenVMS_On_Target then Start_String; Store_String_Chars ! ("--for-linker=IDENTIFICATION="); String_To_Name_Buffer (Strval (Str)); Store_String_Chars (Name_Buffer (1 .. Name_Len)); --- 8488,8499 ---- else -- In VMS, the effect of IDENT is achieved by passing ! -- --identification=name as a --for-linker switch. if OpenVMS_On_Target then Start_String; Store_String_Chars ! ("--for-linker=--identification="); String_To_Name_Buffer (Strval (Str)); Store_String_Chars (Name_Buffer (1 .. Name_Len)); *************** package body Sem_Prag is *** 7638,7644 **** -- associated with a with'd package. Replace_Linker_Option_String ! (End_String, "--for-linker=IDENTIFICATION="); end if; Set_Ident_String (Current_Sem_Unit, Str); --- 8503,8509 ---- -- associated with a with'd package. Replace_Linker_Option_String ! (End_String, "--for-linker=--identification="); end if; Set_Ident_String (Current_Sem_Unit, Str); *************** package body Sem_Prag is *** 7663,7711 **** end; end Ident; ! -------------------------- ! -- Implemented_By_Entry -- ! -------------------------- ! -- pragma Implemented_By_Entry (DIRECT_NAME); ! when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare ! Ent : Entity_Id; begin ! Ada_2005_Pragma; ! Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Identifier (Arg1); Check_Arg_Is_Local_Name (Arg1); ! Ent := Entity (Expression (Arg1)); ! -- Pragma Implemented_By_Entry must be applied only to protected ! -- synchronized or task interface primitives. ! if (Ekind (Ent) /= E_Function ! and then Ekind (Ent) /= E_Procedure) ! or else not Present (First_Formal (Ent)) ! or else not Is_Concurrent_Interface (Etype (First_Formal (Ent))) then ! Error_Pragma_Arg ! ("pragma % must be applied to a concurrent interface " & ! "primitive", Arg1); ! else ! if Einfo.Implemented_By_Entry (Ent) ! and then Warn_On_Redundant_Constructs then ! Error_Pragma ("?duplicate pragma%!"); else ! Set_Implemented_By_Entry (Ent); end if; end if; - end Implemented_By_Entry; ! ----------------------- -- Implicit_Packing -- ! ----------------------- -- pragma Implicit_Packing; --- 8528,8632 ---- end; end Ident; ! ----------------- ! -- Implemented -- ! ----------------- ! -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind); ! -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any ! when Pragma_Implemented => Implemented : declare ! Proc_Id : Entity_Id; ! Typ : Entity_Id; begin ! Ada_2012_Pragma; ! Check_Arg_Count (2); Check_No_Identifiers; Check_Arg_Is_Identifier (Arg1); Check_Arg_Is_Local_Name (Arg1); ! Check_Arg_Is_One_Of ! (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure); ! -- Extract the name of the local procedure ! Proc_Id := Entity (Get_Pragma_Arg (Arg1)); ! ! -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a ! -- primitive procedure of a synchronized tagged type. ! ! if Ekind (Proc_Id) = E_Procedure ! and then Is_Primitive (Proc_Id) ! and then Present (First_Formal (Proc_Id)) then ! Typ := Etype (First_Formal (Proc_Id)); ! if Is_Tagged_Type (Typ) ! and then ! ! -- Check for a protected, a synchronized or a task interface ! ! ((Is_Interface (Typ) ! and then Is_Synchronized_Interface (Typ)) ! ! -- Check for a protected type or a task type that implements ! -- an interface. ! ! or else ! (Is_Concurrent_Record_Type (Typ) ! and then Present (Interfaces (Typ))) ! ! -- Check for a private record extension with keyword ! -- "synchronized". ! ! or else ! (Ekind_In (Typ, E_Record_Type_With_Private, ! E_Record_Subtype_With_Private) ! and then Synchronized_Present (Parent (Typ)))) then ! null; else ! Error_Pragma_Arg ! ("controlling formal must be of synchronized " & ! "tagged type", Arg1); ! return; end if; + + -- Procedures declared inside a protected type must be accepted + + elsif Ekind (Proc_Id) = E_Procedure + and then Is_Protected_Type (Scope (Proc_Id)) + then + null; + + -- The first argument is not a primitive procedure + + else + Error_Pragma_Arg + ("pragma % must be applied to a primitive procedure", Arg1); + return; end if; ! -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind ! -- By_Protected_Procedure to the primitive procedure of a task ! -- interface. ! ! if Chars (Arg2) = Name_By_Protected_Procedure ! and then Is_Interface (Typ) ! and then Is_Task_Interface (Typ) ! then ! Error_Pragma_Arg ! ("implementation kind By_Protected_Procedure cannot be " & ! "applied to a task interface primitive", Arg2); ! return; ! end if; ! ! Record_Rep_Item (Proc_Id, N); ! end Implemented; ! ! ---------------------- -- Implicit_Packing -- ! ---------------------- -- pragma Implicit_Packing; *************** package body Sem_Prag is *** 8009,8014 **** --- 8930,9054 ---- Arg_First_Optional_Parameter => First_Optional_Parameter); end Import_Valued_Procedure; + ----------------- + -- Independent -- + ----------------- + + -- pragma Independent (LOCAL_NAME); + + when Pragma_Independent => Independent : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + D := Declaration_Node (E); + K := Nkind (D); + + -- Check duplicate before we chain ourselves! + + Check_Duplicate_Pragma (E); + + -- Check appropriate entity + + if Is_Type (E) then + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + else + Check_First_Subtype (Arg1); + end if; + + elsif K = N_Object_Declaration + or else (K = N_Component_Declaration + and then Original_Record_Component (E) = E) + then + if Rep_Item_Too_Late (E, N) then + return; + end if; + + else + Error_Pragma_Arg + ("inappropriate entity for pragma%", Arg1); + end if; + + Independence_Checks.Append ((N, E)); + end Independent; + + ---------------------------- + -- Independent_Components -- + ---------------------------- + + -- pragma Atomic_Components (array_LOCAL_NAME); + + -- This processing is shared by Volatile_Components + + when Pragma_Independent_Components => Independent_Components : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + + -- Check duplicate before we chain ourselves! + + Check_Duplicate_Pragma (E); + + -- Check appropriate entity + + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + end if; + + D := Declaration_Node (E); + K := Nkind (D); + + if (K = N_Full_Type_Declaration + and then (Is_Array_Type (E) or else Is_Record_Type (E))) + or else + ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then Nkind (D) = N_Object_Declaration + and then Nkind (Object_Definition (D)) = + N_Constrained_Array_Definition) + then + Independence_Checks.Append ((N, E)); + + else + Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); + end if; + end Independent_Components; + ------------------------ -- Initialize_Scalars -- ------------------------ *************** package body Sem_Prag is *** 8051,8057 **** when Pragma_Inline_Always => GNAT_Pragma; ! Process_Inline (True); -------------------- -- Inline_Generic -- --- 9091,9103 ---- when Pragma_Inline_Always => GNAT_Pragma; ! ! -- Pragma always active unless in CodePeer mode, since this causes ! -- walk order issues. ! ! if not CodePeer_Mode then ! Process_Inline (True); ! end if; -------------------- -- Inline_Generic -- *************** package body Sem_Prag is *** 8077,8083 **** if Arg_Count > 0 then Arg := Arg1; loop ! Exp := Expression (Arg); Analyze (Exp); if not Is_Entity_Name (Exp) --- 9123,9129 ---- if Arg_Count > 0 then Arg := Arg1; loop ! Exp := Get_Pragma_Arg (Arg); Analyze (Exp); if not Is_Entity_Name (Exp) *************** package body Sem_Prag is *** 8113,8118 **** --- 9159,9172 ---- Check_At_Most_N_Arguments (4); Process_Import_Or_Interface; + -- In Ada 2005, the permission to use Interface (a reserved word) + -- as a pragma name is considered an obsolescent feature. + + if Ada_Version >= Ada_2005 then + Check_Restriction + (No_Obsolescent_Features, Pragma_Identifier (N)); + end if; + -------------------- -- Interface_Name -- -------------------- *************** package body Sem_Prag is *** 8134,8140 **** ((Name_Entity, Name_External_Name, Name_Link_Name)); Check_At_Least_N_Arguments (2); Check_At_Most_N_Arguments (3); ! Id := Expression (Arg1); Analyze (Id); if not Is_Entity_Name (Id) then --- 9188,9194 ---- ((Name_Entity, Name_External_Name, Name_Link_Name)); Check_At_Least_N_Arguments (2); Check_At_Most_N_Arguments (3); ! Id := Get_Pragma_Arg (Arg1); Analyze (Id); if not Is_Entity_Name (Id) then *************** package body Sem_Prag is *** 8204,8209 **** --- 9258,9264 ---- Found := True; end if; + exit when From_Aspect_Specification (N); Hom_Id := Homonym (Hom_Id); exit when No (Hom_Id) *************** package body Sem_Prag is *** 8250,8256 **** Check_Ada_83_Warning; if Arg_Count /= 0 then ! Arg := Expression (Arg1); Check_Arg_Count (1); Check_No_Identifiers; --- 9305,9311 ---- Check_Ada_83_Warning; if Arg_Count /= 0 then ! Arg := Get_Pragma_Arg (Arg1); Check_Arg_Count (1); Check_No_Identifiers; *************** package body Sem_Prag is *** 8265,8275 **** Pragma_Misplaced; return; ! elsif Has_Priority_Pragma (P) then Error_Pragma ("duplicate pragma% not allowed"); else ! Set_Has_Priority_Pragma (P, True); Record_Rep_Item (Defining_Identifier (Parent (P)), N); end if; end Interrupt_Priority; --- 9320,9330 ---- Pragma_Misplaced; return; ! elsif Has_Pragma_Priority (P) then Error_Pragma ("duplicate pragma% not allowed"); else ! Set_Has_Pragma_Priority (P, True); Record_Rep_Item (Defining_Identifier (Parent (P)), N); end if; end Interrupt_Priority; *************** package body Sem_Prag is *** 8403,8408 **** --- 9458,9524 ---- end loop; end Interrupt_State; + --------------- + -- Invariant -- + --------------- + + -- pragma Invariant + -- ([Entity =>] type_LOCAL_NAME, + -- [Check =>] EXPRESSION + -- [,[Message =>] String_Expression]); + + when Pragma_Invariant => Invariant : declare + Type_Id : Node_Id; + Typ : Entity_Id; + + Discard : Boolean; + pragma Unreferenced (Discard); + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Check); + + if Arg_Count = 3 then + Check_Optional_Identifier (Arg3, Name_Message); + Check_Arg_Is_Static_Expression (Arg3, Standard_String); + end if; + + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Arg1); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + + elsif not Ekind_In (Typ, E_Private_Type, + E_Record_Type_With_Private, + E_Limited_Private_Type) + then + Error_Pragma_Arg + ("pragma% only allowed for private type", Arg1); + end if; + + -- Note that the type has at least one invariant, and also that + -- it has inheritable invariants if we have Invariant'Class. + + Set_Has_Invariants (Typ); + + if Class_Present (N) then + Set_Has_Inheritable_Invariants (Typ); + end if; + + -- The remaining processing is simply to link the pragma on to + -- the rep item chain, for processing when the type is frozen. + -- This is accomplished by a call to Rep_Item_Too_Late. + + Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); + end Invariant; + ---------------------- -- Java_Constructor -- ---------------------- *************** package body Sem_Prag is *** 8413,8422 **** when Pragma_CIL_Constructor | Pragma_Java_Constructor => Java_Constructor : declare ! Id : Entity_Id; ! Def_Id : Entity_Id; ! Hom_Id : Entity_Id; ! Convention : Convention_Id; begin GNAT_Pragma; --- 9529,9539 ---- when Pragma_CIL_Constructor | Pragma_Java_Constructor => Java_Constructor : declare ! Convention : Convention_Id; ! Def_Id : Entity_Id; ! Hom_Id : Entity_Id; ! Id : Entity_Id; ! This_Formal : Entity_Id; begin GNAT_Pragma; *************** package body Sem_Prag is *** 8424,8430 **** Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Id := Expression (Arg1); Find_Program_Unit_Name (Id); -- If we did not find the name, we are done --- 9541,9547 ---- Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Id := Get_Pragma_Arg (Arg1); Find_Program_Unit_Name (Id); -- If we did not find the name, we are done *************** package body Sem_Prag is *** 8433,8438 **** --- 9550,9571 ---- return; end if; + -- Check wrong use of pragma in wrong VM target + + if VM_Target = No_VM then + return; + + elsif VM_Target = CLI_Target + and then Prag_Id = Pragma_Java_Constructor + then + Error_Pragma ("must use pragma 'C'I'L_'Constructor"); + + elsif VM_Target = JVM_Target + and then Prag_Id = Pragma_CIL_Constructor + then + Error_Pragma ("must use pragma 'Java_'Constructor"); + end if; + case Prag_Id is when Pragma_CIL_Constructor => Convention := Convention_CIL; when Pragma_Java_Constructor => Convention := Convention_Java; *************** package body Sem_Prag is *** 8446,8488 **** loop Def_Id := Get_Base_Subprogram (Hom_Id); ! -- The constructor is required to be a function returning an ! -- access type whose designated type has convention Java/CIL. ! ! if Ekind (Def_Id) = E_Function ! and then ! (Is_Value_Type (Etype (Def_Id)) ! or else ! (Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type ! and then ! Atree.Convention (Etype (Def_Id)) = Convention) ! or else ! (Ekind (Etype (Def_Id)) in Access_Kind ! and then ! (Atree.Convention ! (Designated_Type (Etype (Def_Id))) = Convention ! or else ! Atree.Convention ! (Root_Type (Designated_Type (Etype (Def_Id)))) = ! Convention))) ! then ! Set_Is_Constructor (Def_Id); ! Set_Convention (Def_Id, Convention); ! Set_Is_Imported (Def_Id); ! else ! if Convention = Convention_Java then Error_Pragma_Arg ("pragma% requires function returning a " & ! "'Java access type", Arg1); else - pragma Assert (Convention = Convention_CIL); Error_Pragma_Arg ("pragma% requires function returning a " & ! "'C'I'L access type", Arg1); end if; end if; Hom_Id := Homonym (Hom_Id); exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; --- 9579,9790 ---- loop Def_Id := Get_Base_Subprogram (Hom_Id); ! -- The constructor is required to be a function ! if Ekind (Def_Id) /= E_Function then ! if VM_Target = JVM_Target then Error_Pragma_Arg ("pragma% requires function returning a " & ! "'Java access type", Def_Id); else Error_Pragma_Arg ("pragma% requires function returning a " & ! "'C'I'L access type", Def_Id); end if; end if; + -- Check arguments: For tagged type the first formal must be + -- named "this" and its type must be a named access type + -- designating a class-wide tagged type that has convention + -- CIL/Java. The first formal must also have a null default + -- value. For example: + + -- type Typ is tagged ... + -- type Ref is access all Typ; + -- pragma Convention (CIL, Typ); + + -- function New_Typ (This : Ref) return Ref; + -- function New_Typ (This : Ref; I : Integer) return Ref; + -- pragma Cil_Constructor (New_Typ); + + -- Reason: The first formal must NOT be a primitive of the + -- tagged type. + + -- This rule also applies to constructors of delegates used + -- to interface with standard target libraries. For example: + + -- type Delegate is access procedure ... + -- pragma Import (CIL, Delegate, ...); + + -- function new_Delegate + -- (This : Delegate := null; ... ) return Delegate; + + -- For value-types this rule does not apply. + + if not Is_Value_Type (Etype (Def_Id)) then + if No (First_Formal (Def_Id)) then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("% function must have parameters", Def_Id); + return; + end if; + + -- In the JRE library we have several occurrences in which + -- the "this" parameter is not the first formal. + + This_Formal := First_Formal (Def_Id); + + -- In the JRE library we have several occurrences in which + -- the "this" parameter is not the first formal. Search for + -- it. + + if VM_Target = JVM_Target then + while Present (This_Formal) + and then Get_Name_String (Chars (This_Formal)) /= "this" + loop + Next_Formal (This_Formal); + end loop; + + if No (This_Formal) then + This_Formal := First_Formal (Def_Id); + end if; + end if; + + -- Warning: The first parameter should be named "this". + -- We temporarily allow it because we have the following + -- case in the Java runtime (file s-osinte.ads) ??? + + -- function new_Thread + -- (Self_Id : System.Address) return Thread_Id; + -- pragma Java_Constructor (new_Thread); + + if VM_Target = JVM_Target + and then Get_Name_String (Chars (First_Formal (Def_Id))) + = "self_id" + and then Etype (First_Formal (Def_Id)) = RTE (RE_Address) + then + null; + + elsif Get_Name_String (Chars (This_Formal)) /= "this" then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be named `this`", + Parent (This_Formal)); + + elsif not Is_Access_Type (Etype (This_Formal)) then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be an access type", + Parameter_Type (Parent (This_Formal))); + + -- For delegates the type of the first formal must be a + -- named access-to-subprogram type (see previous example) + + elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type + and then Ekind (Etype (This_Formal)) + /= E_Access_Subprogram_Type + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be a named access" & + " to subprogram type", + Parameter_Type (Parent (This_Formal))); + + -- Warning: We should reject anonymous access types because + -- the constructor must not be handled as a primitive of the + -- tagged type. We temporarily allow it because this profile + -- is currently generated by cil2ada??? + + elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type + and then not Ekind_In (Etype (This_Formal), + E_Access_Type, + E_General_Access_Type, + E_Anonymous_Access_Type) + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("first formal of % function must be a named access" & + " type", + Parameter_Type (Parent (This_Formal))); + + elsif Atree.Convention + (Designated_Type (Etype (This_Formal))) /= Convention + then + Error_Msg_Name_1 := Pname; + + if Convention = Convention_Java then + Error_Msg_N + ("pragma% requires convention 'Cil in designated" & + " type", + Parameter_Type (Parent (This_Formal))); + else + Error_Msg_N + ("pragma% requires convention 'Java in designated" & + " type", + Parameter_Type (Parent (This_Formal))); + end if; + + elsif No (Expression (Parent (This_Formal))) + or else Nkind (Expression (Parent (This_Formal))) /= N_Null + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("pragma% requires first formal with default `null`", + Parameter_Type (Parent (This_Formal))); + end if; + end if; + + -- Check result type: the constructor must be a function + -- returning: + -- * a value type (only allowed in the CIL compiler) + -- * an access-to-subprogram type with convention Java/CIL + -- * an access-type designating a type that has convention + -- Java/CIL. + + if Is_Value_Type (Etype (Def_Id)) then + null; + + -- Access-to-subprogram type with convention Java/CIL + + elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then + if Atree.Convention (Etype (Def_Id)) /= Convention then + if Convention = Convention_Java then + Error_Pragma_Arg + ("pragma% requires function returning a " & + "'Java access type", Arg1); + else + pragma Assert (Convention = Convention_CIL); + Error_Pragma_Arg + ("pragma% requires function returning a " & + "'C'I'L access type", Arg1); + end if; + end if; + + elsif Ekind (Etype (Def_Id)) in Access_Kind then + if not Ekind_In (Etype (Def_Id), E_Access_Type, + E_General_Access_Type) + or else + Atree.Convention + (Designated_Type (Etype (Def_Id))) /= Convention + then + Error_Msg_Name_1 := Pname; + + if Convention = Convention_Java then + Error_Pragma_Arg + ("pragma% requires function returning a named" & + "'Java access type", Arg1); + else + Error_Pragma_Arg + ("pragma% requires function returning a named" & + "'C'I'L access type", Arg1); + end if; + end if; + end if; + + Set_Is_Constructor (Def_Id); + Set_Convention (Def_Id, Convention); + Set_Is_Imported (Def_Id); + + exit when From_Aspect_Specification (N); Hom_Id := Homonym (Hom_Id); exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; *************** package body Sem_Prag is *** 8505,8511 **** Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Arg := Expression (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then --- 9807,9813 ---- Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Arg := Get_Pragma_Arg (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then *************** package body Sem_Prag is *** 8557,8563 **** Check_Optional_Identifier (Arg1, Name_On); Check_Arg_Is_Local_Name (Arg1); ! Arg := Expression (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then --- 9859,9865 ---- Check_Optional_Identifier (Arg1, Name_On); Check_Arg_Is_Local_Name (Arg1); ! Arg := Get_Pragma_Arg (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then *************** package body Sem_Prag is *** 8642,8648 **** Arg_Store : declare C : constant Char_Code := Get_Char_Code (' '); S : constant String_Id := ! Strval (Expr_Value_S (Expression (Arg))); L : constant Nat := String_Length (S); F : Nat := 1; --- 9944,9950 ---- Arg_Store : declare C : constant Char_Code := Get_Char_Code (' '); S : constant String_Id := ! Strval (Expr_Value_S (Get_Pragma_Arg (Arg))); L : constant Nat := String_Length (S); F : Nat := 1; *************** package body Sem_Prag is *** 8715,8724 **** -- by the call to Rep_Item_Too_Late (when no error is detected -- and False is returned). ! if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then return; else ! Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1))); end if; ------------------------ --- 10017,10026 ---- -- by the call to Rep_Item_Too_Late (when no error is detected -- and False is returned). ! if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then return; else ! Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); end if; ------------------------ *************** package body Sem_Prag is *** 8746,8752 **** Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Local_Name (Arg1); ! Arg1_X := Expression (Arg1); Analyze (Arg1_X); Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); --- 10048,10054 ---- Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Local_Name (Arg1); ! Arg1_X := Get_Pragma_Arg (Arg1); Analyze (Arg1_X); Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); *************** package body Sem_Prag is *** 8782,8794 **** Check_Arg_Count (1); Check_Is_In_Decl_Part_Or_Package_Spec; Check_Arg_Is_Static_Expression (Arg1, Standard_String); ! Start_String (Strval (Expr_Value_S (Expression (Arg1)))); Arg := Arg2; while Present (Arg) loop Check_Arg_Is_Static_Expression (Arg, Standard_String); Store_String_Char (ASCII.NUL); ! Store_String_Chars (Strval (Expr_Value_S (Expression (Arg)))); Arg := Next (Arg); end loop; --- 10084,10097 ---- Check_Arg_Count (1); Check_Is_In_Decl_Part_Or_Package_Spec; Check_Arg_Is_Static_Expression (Arg1, Standard_String); ! Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); Arg := Arg2; while Present (Arg) loop Check_Arg_Is_Static_Expression (Arg, Standard_String); Store_String_Char (ASCII.NUL); ! Store_String_Chars ! (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); Arg := Next (Arg); end loop; *************** package body Sem_Prag is *** 8818,8824 **** -- This pragma applies only to objects ! if not Is_Object (Entity (Expression (Arg1))) then Error_Pragma_Arg ("pragma% applies only to objects", Arg1); end if; --- 10121,10127 ---- -- This pragma applies only to objects ! if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then Error_Pragma_Arg ("pragma% applies only to objects", Arg1); end if; *************** package body Sem_Prag is *** 8827,8836 **** -- by the call to Rep_Item_Too_Late (when no error is detected -- and False is returned). ! if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then return; else ! Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1))); end if; ---------- --- 10130,10139 ---- -- by the call to Rep_Item_Too_Late (when no error is detected -- and False is returned). ! if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then return; else ! Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); end if; ---------- *************** package body Sem_Prag is *** 8861,8867 **** Check_No_Identifiers; Check_Arg_Is_Locking_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Expression (Arg1))); LP := Fold_Upper (Name_Buffer (1)); if Locking_Policy /= ' ' --- 10164,10170 ---- Check_No_Identifiers; Check_Arg_Is_Locking_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); LP := Fold_Upper (Name_Buffer (1)); if Locking_Policy /= ' ' *************** package body Sem_Prag is *** 8901,8907 **** -- D_Float case ! if Chars (Expression (Arg1)) = Name_D_Float then if Opt.Float_Format_Long = 'G' then Error_Pragma ("G_Float previously specified"); end if; --- 10204,10210 ---- -- D_Float case ! if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then if Opt.Float_Format_Long = 'G' then Error_Pragma ("G_Float previously specified"); end if; *************** package body Sem_Prag is *** 8947,8953 **** Check_Optional_Identifier (Arg2, Name_Attribute_Name); Check_Arg_Is_Local_Name (Arg1); Check_Arg_Is_Static_Expression (Arg2, Standard_String); ! Def_Id := Entity (Expression (Arg1)); if Is_Access_Type (Def_Id) then Def_Id := Designated_Type (Def_Id); --- 10250,10256 ---- Check_Optional_Identifier (Arg2, Name_Attribute_Name); Check_Arg_Is_Local_Name (Arg1); Check_Arg_Is_Static_Expression (Arg2, Standard_String); ! Def_Id := Entity (Get_Pragma_Arg (Arg1)); if Is_Access_Type (Def_Id) then Def_Id := Designated_Type (Def_Id); *************** package body Sem_Prag is *** 8967,8973 **** if Rep_Item_Too_Late (Def_Id, N) then return; else ! Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1))); end if; end Machine_Attribute; --- 10270,10276 ---- if Rep_Item_Too_Late (Def_Id, N) then return; else ! Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); end if; end Machine_Attribute; *************** package body Sem_Prag is *** 9116,9122 **** Arg := Arg1; while Present (Arg) loop Check_Arg_Is_Local_Name (Arg); ! Id := Expression (Arg); Analyze (Id); if not Is_Entity_Name (Id) then --- 10419,10425 ---- Arg := Arg1; while Present (Arg) loop Check_Arg_Is_Local_Name (Arg); ! Id := Get_Pragma_Arg (Arg); Analyze (Id); if not Is_Entity_Name (Id) then *************** package body Sem_Prag is *** 9134,9142 **** while Present (E) and then Scope (E) = Current_Scope loop ! if Ekind (E) = E_Procedure ! or else Ekind (E) = E_Generic_Procedure ! then Set_No_Return (E); -- Set flag on any alias as well --- 10437,10443 ---- while Present (E) and then Scope (E) = Current_Scope loop ! if Ekind_In (E, E_Procedure, E_Generic_Procedure) then Set_No_Return (E); -- Set flag on any alias as well *************** package body Sem_Prag is *** 9148,9153 **** --- 10449,10455 ---- Found := True; end if; + exit when From_Aspect_Specification (N); E := Homonym (E); end loop; *************** package body Sem_Prag is *** 9209,9215 **** else Check_Optional_Identifier (Arg2, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Entity (Expression (Arg1)); if E_Id = Any_Type then return; --- 10511,10517 ---- else Check_Optional_Identifier (Arg2, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Entity (Get_Pragma_Arg (Arg1)); if E_Id = Any_Type then return; *************** package body Sem_Prag is *** 9320,9326 **** -- Deal with static string argument Check_Arg_Is_Static_Expression (Arg1, Standard_String); ! S := Strval (Expression (Arg1)); for J in 1 .. String_Length (S) loop if not In_Character_Range (Get_String_Char (S, J)) then --- 10622,10628 ---- -- Deal with static string argument Check_Arg_Is_Static_Expression (Arg1, Standard_String); ! S := Strval (Get_Pragma_Arg (Arg1)); for J in 1 .. String_Length (S) loop if not In_Character_Range (Get_String_Char (S, J)) then *************** package body Sem_Prag is *** 9331,9337 **** end loop; Obsolescent_Warnings.Append ! ((Ent => Ent, Msg => Strval (Expression (Arg1)))); -- Check for Ada_05 parameter --- 10633,10639 ---- end loop; Obsolescent_Warnings.Append ! ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1)))); -- Check for Ada_05 parameter *************** package body Sem_Prag is *** 9350,9356 **** ("only allowed argument for pragma% is %", Argx); end if; ! if Ada_Version_Explicit < Ada_05 or else not Warn_On_Ada_2005_Compatibility then Active := False; --- 10652,10658 ---- ("only allowed argument for pragma% is %", Argx); end if; ! if Ada_Version_Explicit < Ada_2005 or else not Warn_On_Ada_2005_Compatibility then Active := False; *************** package body Sem_Prag is *** 9479,9485 **** -- pragma Optimize_Alignment (Time | Space | Off); ! when Pragma_Optimize_Alignment => GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); --- 10781,10787 ---- -- pragma Optimize_Alignment (Time | Space | Off); ! when Pragma_Optimize_Alignment => Optimize_Alignment : begin GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); *************** package body Sem_Prag is *** 9505,9510 **** --- 10807,10848 ---- -- switch will get reset anyway at the start of each unit. Optimize_Alignment_Local := True; + end Optimize_Alignment; + + ------------- + -- Ordered -- + ------------- + + -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); + + when Pragma_Ordered => Ordered : declare + Assoc : constant Node_Id := Arg1; + Type_Id : Node_Id; + Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Assoc); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + else + Typ := Underlying_Type (Typ); + end if; + + if not Is_Enumeration_Type (Typ) then + Error_Pragma ("pragma% must specify enumeration type"); + end if; + + Check_First_Subtype (Arg1); + Set_Has_Pragma_Ordered (Base_Type (Typ)); + end Ordered; ---------- -- Pack -- *************** package body Sem_Prag is *** 9516,9528 **** Assoc : constant Node_Id := Arg1; Type_Id : Node_Id; Typ : Entity_Id; begin Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! Type_Id := Expression (Assoc); Find_Type (Type_Id); Typ := Entity (Type_Id); --- 10854,10868 ---- Assoc : constant Node_Id := Arg1; Type_Id : Node_Id; Typ : Entity_Id; + Ctyp : Entity_Id; + Ignore : Boolean := False; begin Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); ! Type_Id := Get_Pragma_Arg (Assoc); Find_Type (Type_Id); Typ := Entity (Type_Id); *************** package body Sem_Prag is *** 9539,9606 **** end if; Check_First_Subtype (Arg1); ! ! if Has_Pragma_Pack (Typ) then ! Error_Pragma ("duplicate pragma%, only one allowed"); -- Array type ! elsif Is_Array_Type (Typ) then ! ! -- Pack not allowed for aliased or atomic components ! if Has_Aliased_Components (Base_Type (Typ)) then ! Error_Pragma ! ("pragma% ignored, cannot pack aliased components?"); ! elsif Has_Atomic_Components (Typ) ! or else Is_Atomic (Component_Type (Typ)) then ! Error_Pragma ! ("?pragma% ignored, cannot pack atomic components"); end if; ! -- If we had an explicit component size given, then we do not ! -- let Pack override this given size. We also give a warning ! -- that Pack is being ignored unless we can tell for sure that ! -- the Pack would not have had any effect anyway. ! if Has_Component_Size_Clause (Typ) then ! if Known_Static_RM_Size (Component_Type (Typ)) ! and then ! RM_Size (Component_Type (Typ)) = Component_Size (Typ) ! then null; - else - Error_Pragma - ("?pragma% ignored, explicit component size given"); - end if; ! -- If no prior array component size given, Pack is effective ! else ! if not Rep_Item_Too_Late (Typ, N) then ! -- In the context of static code analysis, we do not need ! -- complex front-end expansions related to pragma Pack, ! -- so disable handling of pragma Pack in this case. ! if CodePeer_Mode then ! null; ! -- For normal non-VM target, do the packing ! elsif VM_Target = No_VM then ! Set_Is_Packed (Base_Type (Typ)); ! Set_Has_Pragma_Pack (Base_Type (Typ)); ! Set_Has_Non_Standard_Rep (Base_Type (Typ)); ! -- If we ignore the pack, then warn about this, except ! -- that we suppress the warning in GNAT mode. ! elsif not GNAT_Mode then ! Error_Pragma ! ("?pragma% ignored in this configuration"); end if; end if; end if; --- 10879,10966 ---- end if; Check_First_Subtype (Arg1); ! Check_Duplicate_Pragma (Typ); -- Array type ! if Is_Array_Type (Typ) then ! Ctyp := Component_Type (Typ); ! -- Ignore pack that does nothing ! if Known_Static_Esize (Ctyp) ! and then Known_Static_RM_Size (Ctyp) ! and then Esize (Ctyp) = RM_Size (Ctyp) ! and then Addressable (Esize (Ctyp)) then ! Ignore := True; end if; ! -- Process OK pragma Pack. Note that if there is a separate ! -- component clause present, the Pack will be cancelled. This ! -- processing is in Freeze. ! if not Rep_Item_Too_Late (Typ, N) then ! ! -- In the context of static code analysis, we do not need ! -- complex front-end expansions related to pragma Pack, ! -- so disable handling of pragma Pack in this case. ! ! if CodePeer_Mode then null; ! -- Don't attempt any packing for VM targets. We possibly ! -- could deal with some cases of array bit-packing, but we ! -- don't bother, since this is not a typical kind of ! -- representation in the VM context anyway (and would not ! -- for example work nicely with the debugger). ! elsif VM_Target /= No_VM then ! if not GNAT_Mode then ! Error_Pragma ! ("?pragma% ignored in this configuration"); ! end if; ! -- Normal case where we do the pack action ! else ! if not Ignore then ! Set_Is_Packed (Base_Type (Typ), Sense); ! Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense); ! end if; ! Set_Has_Pragma_Pack (Base_Type (Typ), Sense); ! -- Complete reset action for Aspect_Cancel case ! if Sense = False then ! -- Cancel size unless explicitly set ! ! if not Has_Size_Clause (Typ) ! and then not Has_Object_Size_Clause (Typ) ! then ! Set_Esize (Typ, Uint_0); ! Set_RM_Size (Typ, Uint_0); ! Set_Alignment (Typ, Uint_0); ! Set_Packed_Array_Type (Typ, Empty); ! end if; ! ! -- Reset component size unless explicitly set ! ! if not Has_Component_Size_Clause (Typ) then ! if Known_Static_Esize (Ctyp) ! and then Known_Static_RM_Size (Ctyp) ! and then Esize (Ctyp) = RM_Size (Ctyp) ! and then Addressable (Esize (Ctyp)) ! then ! Set_Component_Size ! (Base_Type (Typ), Esize (Ctyp)); ! else ! Set_Component_Size ! (Base_Type (Typ), Uint_0); ! end if; ! end if; end if; end if; end if; *************** package body Sem_Prag is *** 9609,9621 **** else pragma Assert (Is_Record_Type (Typ)); if not Rep_Item_Too_Late (Typ, N) then - if VM_Target = No_VM then - Set_Is_Packed (Base_Type (Typ)); - Set_Has_Pragma_Pack (Base_Type (Typ)); - Set_Has_Non_Standard_Rep (Base_Type (Typ)); ! elsif not GNAT_Mode then ! Error_Pragma ("?pragma% ignored in this configuration"); end if; end if; end if; --- 10969,11004 ---- else pragma Assert (Is_Record_Type (Typ)); if not Rep_Item_Too_Late (Typ, N) then ! -- Ignore pack request with warning in VM mode (skip warning ! -- if we are compiling GNAT run time library). ! ! if VM_Target /= No_VM then ! if not GNAT_Mode then ! Error_Pragma ! ("?pragma% ignored in this configuration"); ! end if; ! ! -- Normal case of pack request active ! ! else ! Set_Is_Packed (Base_Type (Typ), Sense); ! Set_Has_Pragma_Pack (Base_Type (Typ), Sense); ! Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense); ! ! -- Complete reset action for Aspect_Cancel case ! ! if Sense = False then ! ! -- Cancel size if not explicitly given ! ! if not Has_Size_Clause (Typ) ! and then not Has_Object_Size_Clause (Typ) ! then ! Set_Esize (Typ, Uint_0); ! Set_Alignment (Typ, Uint_0); ! end if; ! end if; end if; end if; end if; *************** package body Sem_Prag is *** 9640,9646 **** -- pragma Passive [(PASSIVE_FORM)]; ! -- PASSIVE_FORM ::= Semaphore | No when Pragma_Passive => GNAT_Pragma; --- 11023,11029 ---- -- pragma Passive [(PASSIVE_FORM)]; ! -- PASSIVE_FORM ::= Semaphore | No when Pragma_Passive => GNAT_Pragma; *************** package body Sem_Prag is *** 9670,9682 **** Check_Arg_Is_Identifier (Arg1); Check_Arg_Is_Local_Name (Arg1); Check_First_Subtype (Arg1); ! Ent := Entity (Expression (Arg1)); ! if not Is_Private_Type (Ent) ! and then not Is_Protected_Type (Ent) then Error_Pragma_Arg ! ("pragma % can only be applied to private or protected type", Arg1); end if; --- 11053,11069 ---- Check_Arg_Is_Identifier (Arg1); Check_Arg_Is_Local_Name (Arg1); Check_First_Subtype (Arg1); ! Ent := Entity (Get_Pragma_Arg (Arg1)); ! if not (Is_Private_Type (Ent) ! or else ! Is_Protected_Type (Ent) ! or else ! (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))) then Error_Pragma_Arg ! ("pragma % can only be applied to private, formal derived or " ! & "protected type", Arg1); end if; *************** package body Sem_Prag is *** 9711,9716 **** --- 11098,11105 ---- -- Persistent_BSS -- -------------------- + -- pragma Persistent_BSS [(object_NAME)]; + when Pragma_Persistent_BSS => Persistent_BSS : declare Decl : Node_Id; Ent : Entity_Id; *************** package body Sem_Prag is *** 9725,9739 **** if Arg_Count = 1 then Check_Arg_Is_Library_Level_Local_Name (Arg1); ! if not Is_Entity_Name (Expression (Arg1)) ! or else ! (Ekind (Entity (Expression (Arg1))) /= E_Variable ! and then Ekind (Entity (Expression (Arg1))) /= E_Constant) then Error_Pragma_Arg ("pragma% only applies to objects", Arg1); end if; ! Ent := Entity (Expression (Arg1)); Decl := Parent (Ent); if Rep_Item_Too_Late (Ent, N) then --- 11114,11128 ---- if Arg_Count = 1 then Check_Arg_Is_Library_Level_Local_Name (Arg1); ! if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) ! or else not ! Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, ! E_Constant) then Error_Pragma_Arg ("pragma% only applies to objects", Arg1); end if; ! Ent := Entity (Get_Pragma_Arg (Arg1)); Decl := Parent (Ent); if Rep_Item_Too_Late (Ent, N) then *************** package body Sem_Prag is *** 9751,9761 **** Arg1); end if; ! Prag := ! Make_Linker_Section_Pragma ! (Ent, Sloc (N), ".persistent.bss"); ! Insert_After (N, Prag); ! Analyze (Prag); -- Case of use as configuration pragma with no arguments --- 11140,11154 ---- Arg1); end if; ! Check_Duplicate_Pragma (Ent); ! ! if Sense then ! Prag := ! Make_Linker_Section_Pragma ! (Ent, Sloc (N), ".persistent.bss"); ! Insert_After (N, Prag); ! Analyze (Prag); ! end if; -- Case of use as configuration pragma with no arguments *************** package body Sem_Prag is *** 9776,9782 **** Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); ! Polling_Required := (Chars (Expression (Arg1)) = Name_On); ------------------- -- Postcondition -- --- 11169,11175 ---- Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); ! Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); ------------------- -- Postcondition -- *************** package body Sem_Prag is *** 9816,9822 **** Check_At_Least_N_Arguments (1); Check_At_Most_N_Arguments (2); Check_Optional_Identifier (Arg1, Name_Check); - Check_Precondition_Postcondition (In_Body); -- If in spec, nothing more to do. If in body, then we convert the --- 11209,11214 ---- *************** package body Sem_Prag is *** 9826,9844 **** -- analyze the condition itself in the proper context. if In_Body then - if Arg_Count = 2 then - Check_Optional_Identifier (Arg3, Name_Message); - Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); - end if; - Rewrite (N, Make_Pragma (Loc, Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, ! Expression => ! Make_Identifier (Loc, ! Chars => Name_Precondition)), Make_Pragma_Argument_Association (Sloc (Arg1), Expression => Relocate_Node (Get_Pragma_Arg (Arg1)))))); --- 11218,11229 ---- -- analyze the condition itself in the proper context. if In_Body then Rewrite (N, Make_Pragma (Loc, Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, ! Expression => Make_Identifier (Loc, Name_Precondition)), Make_Pragma_Argument_Association (Sloc (Arg1), Expression => Relocate_Node (Get_Pragma_Arg (Arg1)))))); *************** package body Sem_Prag is *** 9853,9858 **** --- 11238,11283 ---- end if; end Precondition; + --------------- + -- Predicate -- + --------------- + + -- pragma Predicate + -- ([Entity =>] type_LOCAL_NAME, + -- [Check =>] EXPRESSION); + + when Pragma_Predicate => Predicate : declare + Type_Id : Node_Id; + Typ : Entity_Id; + + Discard : Boolean; + pragma Unreferenced (Discard); + + begin + GNAT_Pragma; + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Check); + + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Arg1); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + end if; + + -- The remaining processing is simply to link the pragma on to + -- the rep item chain, for processing when the type is frozen. + -- This is accomplished by a call to Rep_Item_Too_Late. We also + -- mark the type as having predicates. + + Set_Has_Predicates (Typ); + Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); + end Predicate; + ------------------ -- Preelaborate -- ------------------ *************** package body Sem_Prag is *** 9875,9880 **** --- 11300,11306 ---- end if; Ent := Find_Lib_Unit_Name; + Check_Duplicate_Pragma (Ent); -- This filters out pragmas inside generic parent then -- show up inside instantiation *************** package body Sem_Prag is *** 9884,9891 **** and then Present (Generic_Parent (Pa))) then if not Debug_Flag_U then ! Set_Is_Preelaborated (Ent); ! Set_Suppress_Elaboration_Warnings (Ent); end if; end if; end Preelaborate; --- 11310,11317 ---- and then Present (Generic_Parent (Pa))) then if not Debug_Flag_U then ! Set_Is_Preelaborated (Ent, Sense); ! Set_Suppress_Elaboration_Warnings (Ent, Sense); end if; end if; end Preelaborate; *************** package body Sem_Prag is *** 9918,9927 **** -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always ! -- set to Ada_05 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. ! if Ada_Version_Explicit >= Ada_05 then Ent := Find_Lib_Unit_Name; Set_Is_Preelaborated (Ent); Set_Suppress_Elaboration_Warnings (Ent); --- 11344,11353 ---- -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always ! -- set to Ada_2012 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. ! if Ada_Version_Explicit >= Ada_2005 then Ent := Find_Lib_Unit_Name; Set_Is_Preelaborated (Ent); Set_Suppress_Elaboration_Warnings (Ent); *************** package body Sem_Prag is *** 9947,9953 **** if Nkind (P) = N_Subprogram_Body then Check_In_Main_Program; ! Arg := Expression (Arg1); Analyze_And_Resolve (Arg, Standard_Integer); -- Must be static --- 11373,11379 ---- if Nkind (P) = N_Subprogram_Body then Check_In_Main_Program; ! Arg := Get_Pragma_Arg (Arg1); Analyze_And_Resolve (Arg, Standard_Integer); -- Must be static *************** package body Sem_Prag is *** 9997,10003 **** -- Task or Protected, must be of type Integer elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then ! Arg := Expression (Arg1); -- The expression must be analyzed in the special manner -- described in "Handling of Default and Per-Object --- 11423,11429 ---- -- Task or Protected, must be of type Integer elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then ! Arg := Get_Pragma_Arg (Arg1); -- The expression must be analyzed in the special manner -- described in "Handling of Default and Per-Object *************** package body Sem_Prag is *** 10015,10024 **** Pragma_Misplaced; end if; ! if Has_Priority_Pragma (P) then Error_Pragma ("duplicate pragma% not allowed"); else ! Set_Has_Priority_Pragma (P, True); if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then Record_Rep_Item (Defining_Identifier (Parent (P)), N); --- 11441,11450 ---- Pragma_Misplaced; end if; ! if Has_Pragma_Priority (P) then Error_Pragma ("duplicate pragma% not allowed"); else ! Set_Has_Pragma_Priority (P, True); if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then Record_Rep_Item (Defining_Identifier (Parent (P)), N); *************** package body Sem_Prag is *** 10053,10066 **** Check_No_Identifiers; Check_Arg_Is_Task_Dispatching_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Expression (Arg1))); DP := Fold_Upper (Name_Buffer (1)); ! Lower_Bound := Expression (Arg2); Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer); Lower_Val := Expr_Value (Lower_Bound); ! Upper_Bound := Expression (Arg3); Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer); Upper_Val := Expr_Value (Upper_Bound); --- 11479,11492 ---- Check_No_Identifiers; Check_Arg_Is_Task_Dispatching_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); DP := Fold_Upper (Name_Buffer (1)); ! Lower_Bound := Get_Pragma_Arg (Arg2); Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer); Lower_Val := Expr_Value (Lower_Bound); ! Upper_Bound := Get_Pragma_Arg (Arg3); Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer); Upper_Val := Expr_Value (Upper_Bound); *************** package body Sem_Prag is *** 10294,10302 **** Def_Id := Entity (Internal); ! if Ekind (Def_Id) /= E_Constant ! and then Ekind (Def_Id) /= E_Variable ! then Error_Pragma_Arg ("pragma% must designate an object", Internal); end if; --- 11720,11726 ---- Def_Id := Entity (Internal); ! if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Internal); end if; *************** package body Sem_Prag is *** 10420,10429 **** -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always ! -- set to Ada_05 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. ! if Ada_Version_Explicit >= Ada_05 then Ent := Find_Lib_Unit_Name; Set_Is_Preelaborated (Ent, False); Set_Is_Pure (Ent); --- 11844,11853 ---- -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always ! -- set to Ada_2012 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. ! if Ada_Version_Explicit >= Ada_2005 then Ent := Find_Lib_Unit_Name; Set_Is_Preelaborated (Ent, False); Set_Is_Pure (Ent); *************** package body Sem_Prag is *** 10448,10454 **** Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Expression (Arg1); if Error_Posted (E_Id) then return; --- 11872,11878 ---- Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); if Error_Posted (E_Id) then return; *************** package body Sem_Prag is *** 10462,10491 **** loop Def_Id := Get_Base_Subprogram (E); ! if Ekind (Def_Id) /= E_Function ! and then Ekind (Def_Id) /= E_Generic_Function ! and then Ekind (Def_Id) /= E_Operator then Error_Pragma_Arg ("pragma% requires a function name", Arg1); end if; ! Set_Is_Pure (Def_Id); if not Has_Pragma_Pure_Function (Def_Id) then ! Set_Has_Pragma_Pure_Function (Def_Id); ! Effective := True; end if; E := Homonym (E); exit when No (E) or else Scope (E) /= Current_Scope; end loop; ! if not Effective and then Warn_On_Redundant_Constructs then ! Error_Msg_NE ("pragma Pure_Function on& is redundant?", ! N, Entity (E_Id)); end if; end if; end Pure_Function; --- 11886,11917 ---- loop Def_Id := Get_Base_Subprogram (E); ! if not Ekind_In (Def_Id, E_Function, ! E_Generic_Function, ! E_Operator) then Error_Pragma_Arg ("pragma% requires a function name", Arg1); end if; ! Set_Is_Pure (Def_Id, Sense); if not Has_Pragma_Pure_Function (Def_Id) then ! Set_Has_Pragma_Pure_Function (Def_Id, Sense); ! Effective := Sense; end if; + exit when From_Aspect_Specification (N); E := Homonym (E); exit when No (E) or else Scope (E) /= Current_Scope; end loop; ! if Sense and then not Effective and then Warn_On_Redundant_Constructs then ! Error_Msg_NE ! ("pragma Pure_Function on& is redundant?", ! N, Entity (E_Id)); end if; end if; end Pure_Function; *************** package body Sem_Prag is *** 10505,10511 **** Check_No_Identifiers; Check_Arg_Is_Queuing_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Expression (Arg1))); QP := Fold_Upper (Name_Buffer (1)); if Queuing_Policy /= ' ' --- 11931,11937 ---- Check_No_Identifiers; Check_Arg_Is_Queuing_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); QP := Fold_Upper (Name_Buffer (1)); if Queuing_Policy /= ' ' *************** package body Sem_Prag is *** 10541,10547 **** Check_No_Identifiers; Check_Arg_Count (1); ! Arg := Expression (Arg1); -- The expression must be analyzed in the special manner described -- in "Handling of Default and Per-Object Expressions" in sem.ads. --- 11967,11973 ---- Check_No_Identifiers; Check_Arg_Count (1); ! Arg := Get_Pragma_Arg (Arg1); -- The expression must be analyzed in the special manner described -- in "Handling of Default and Per-Object Expressions" in sem.ads. *************** package body Sem_Prag is *** 10658,10667 **** Set_Ravenscar_Profile (N); if Warn_On_Obsolescent_Feature then ! Error_Msg_N ! ("pragma Ravenscar is an obsolescent feature?", N); ! Error_Msg_N ! ("|use pragma Profile (Ravenscar) instead", N); end if; ------------------------- --- 12084,12091 ---- Set_Ravenscar_Profile (N); if Warn_On_Obsolescent_Feature then ! Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N); ! Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N); end if; ------------------------- *************** package body Sem_Prag is *** 10680,10687 **** if Warn_On_Obsolescent_Feature then Error_Msg_N ("pragma Restricted_Run_Time is an obsolescent feature?", N); ! Error_Msg_N ! ("|use pragma Profile (Restricted) instead", N); end if; ------------------ --- 12104,12110 ---- if Warn_On_Obsolescent_Feature then Error_Msg_N ("pragma Restricted_Run_Time is an obsolescent feature?", N); ! Error_Msg_N ("|use pragma Profile (Restricted) instead", N); end if; ------------------ *************** package body Sem_Prag is *** 10792,10797 **** --- 12215,12232 ---- Set_Is_Shared_Passive (Cunit_Ent); end Shared_Passive; + ----------------------- + -- Short_Descriptors -- + ----------------------- + + -- pragma Short_Descriptors; + + when Pragma_Short_Descriptors => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Short_Descriptors := True; + ---------------------- -- Source_File_Name -- ---------------------- *************** package body Sem_Prag is *** 10921,10927 **** -- The expression must be analyzed in the special manner described -- in "Handling of Default Expressions" in sem.ads. ! Arg := Expression (Arg1); Preanalyze_Spec_Expression (Arg, Any_Integer); if not Is_Static_Expression (Arg) then --- 12356,12362 ---- -- The expression must be analyzed in the special manner described -- in "Handling of Default Expressions" in sem.ads. ! Arg := Get_Pragma_Arg (Arg1); Preanalyze_Spec_Expression (Arg, Any_Integer); if not Is_Static_Expression (Arg) then *************** package body Sem_Prag is *** 10957,10963 **** Check_Arg_Count (1); Check_Arg_Is_Integer_Literal (Arg1); ! if Intval (Expression (Arg1)) /= UI_From_Int (Ttypes.System_Storage_Unit) then Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); --- 12392,12398 ---- Check_Arg_Count (1); Check_Arg_Is_Integer_Literal (Arg1); ! if Intval (Get_Pragma_Arg (Arg1)) /= UI_From_Int (Ttypes.System_Storage_Unit) then Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); *************** package body Sem_Prag is *** 10991,10997 **** begin Check_Arg_Is_Local_Name (Arg); ! Ent := Entity (Expression (Arg)); if Has_Homonym (Ent) then Error_Pragma_Arg --- 12426,12432 ---- begin Check_Arg_Is_Local_Name (Arg); ! Ent := Entity (Get_Pragma_Arg (Arg)); if Has_Homonym (Ent) then Error_Pragma_Arg *************** package body Sem_Prag is *** 11023,11031 **** declare Typ : constant Entity_Id := ! Underlying_Type (Entity (Expression (Arg1))); ! Read : constant Entity_Id := Entity (Expression (Arg2)); ! Write : constant Entity_Id := Entity (Expression (Arg3)); begin Check_First_Subtype (Arg1); --- 12458,12466 ---- declare Typ : constant Entity_Id := ! Underlying_Type (Entity (Get_Pragma_Arg (Arg1))); ! Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2)); ! Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3)); begin Check_First_Subtype (Arg1); *************** package body Sem_Prag is *** 11088,11094 **** -- we don't need to issue error messages here. when Pragma_Style_Checks => Style_Checks : declare ! A : constant Node_Id := Expression (Arg1); S : String_Id; C : Char_Code; --- 12523,12529 ---- -- we don't need to issue error messages here. when Pragma_Style_Checks => Style_Checks : declare ! A : constant Node_Id := Get_Pragma_Arg (Arg1); S : String_Id; C : Char_Code; *************** package body Sem_Prag is *** 11106,11112 **** E : Entity_Id; begin ! E_Id := Expression (Arg2); Analyze (E_Id); if not Is_Entity_Name (E_Id) then --- 12541,12547 ---- E : Entity_Id; begin ! E_Id := Get_Pragma_Arg (Arg2); Analyze (E_Id); if not Is_Entity_Name (E_Id) then *************** package body Sem_Prag is *** 11122,11128 **** else loop Set_Suppress_Style_Checks (E, ! (Chars (Expression (Arg1)) = Name_Off)); exit when No (Homonym (E)); E := Homonym (E); end loop; --- 12557,12563 ---- else loop Set_Suppress_Style_Checks (E, ! (Chars (Get_Pragma_Arg (Arg1)) = Name_Off)); exit when No (Homonym (E)); E := Homonym (E); end loop; *************** package body Sem_Prag is *** 11164,11170 **** elsif Nkind (A) = N_Identifier then if Chars (A) = Name_All_Checks then ! Set_Default_Style_Check_Options; elsif Chars (A) = Name_On then Style_Check := True; --- 12599,12609 ---- elsif Nkind (A) = N_Identifier then if Chars (A) = Name_All_Checks then ! if GNAT_Mode then ! Set_GNAT_Style_Check_Options; ! else ! Set_Default_Style_Check_Options; ! end if; elsif Chars (A) = Name_On then Style_Check := True; *************** package body Sem_Prag is *** 11186,11192 **** GNAT_Pragma; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Subtitle); ! Check_Arg_Is_String_Literal (Arg1); -------------- -- Suppress -- --- 12625,12632 ---- GNAT_Pragma; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Subtitle); ! Check_Arg_Is_Static_Expression (Arg1, Standard_String); ! Store_Note (N); -------------- -- Suppress -- *************** package body Sem_Prag is *** 11203,11225 **** -- pragma Suppress_All; ! -- The only check made here is that the pragma appears in the proper ! -- place, i.e. following a compilation unit. If indeed it appears in ! -- this context, then the parser has already inserted an equivalent ! -- pragma Suppress (All_Checks) to get the required effect. when Pragma_Suppress_All => GNAT_Pragma; Check_Arg_Count (0); - if Nkind (Parent (N)) /= N_Compilation_Unit_Aux - or else not Is_List_Member (N) - or else List_Containing (N) /= Pragmas_After (Parent (N)) - then - Error_Pragma - ("misplaced pragma%, must follow compilation unit"); - end if; - ------------------------- -- Suppress_Debug_Info -- ------------------------- --- 12643,12658 ---- -- pragma Suppress_All; ! -- The only check made here is that the pragma has no arguments. ! -- There are no placement rules, and the processing required (setting ! -- the Has_Pragma_Suppress_All flag in the compilation unit node was ! -- taken care of by the parser). Process_Compilation_Unit_Pragmas ! -- then creates and inserts a pragma Suppress (All_Checks). when Pragma_Suppress_All => GNAT_Pragma; Check_Arg_Count (0); ------------------------- -- Suppress_Debug_Info -- ------------------------- *************** package body Sem_Prag is *** 11231,11237 **** Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1))); ---------------------------------- -- Suppress_Exception_Locations -- --- 12664,12670 ---- Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense); ---------------------------------- -- Suppress_Exception_Locations -- *************** package body Sem_Prag is *** 11261,11267 **** Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then return; --- 12694,12700 ---- Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Get_Pragma_Arg (Arg1); if Etype (E_Id) = Any_Type then return; *************** package body Sem_Prag is *** 11318,11324 **** Check_No_Identifiers; Check_Arg_Is_Task_Dispatching_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Expression (Arg1))); DP := Fold_Upper (Name_Buffer (1)); if Task_Dispatching_Policy /= ' ' --- 12751,12757 ---- Check_No_Identifiers; Check_Arg_Is_Task_Dispatching_Policy (Arg1); Check_Valid_Configuration_Pragma; ! Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); DP := Fold_Upper (Name_Buffer (1)); if Task_Dispatching_Policy /= ' ' *************** package body Sem_Prag is *** 11359,11367 **** Check_No_Identifiers; Check_Arg_Count (1); ! Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type)); ! if Etype (Expression (Arg1)) = Any_Type then return; end if; --- 12792,12801 ---- Check_No_Identifiers; Check_Arg_Count (1); ! Analyze_And_Resolve ! (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type)); ! if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then return; end if; *************** package body Sem_Prag is *** 11386,11392 **** Check_No_Identifiers; Check_Arg_Count (1); ! Arg := Expression (Arg1); -- The expression is used in the call to Create_Task, and must be -- expanded there, not in the context of the current spec. It must --- 12820,12826 ---- Check_No_Identifiers; Check_Arg_Count (1); ! Arg := Get_Pragma_Arg (Arg1); -- The expression is used in the call to Create_Task, and must be -- expanded there, not in the context of the current spec. It must *************** package body Sem_Prag is *** 11474,11480 **** Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Library_Level_Local_Name (Arg1); ! Id := Expression (Arg1); Analyze (Id); if not Is_Entity_Name (Id) --- 12908,12914 ---- Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Library_Level_Local_Name (Arg1); ! Id := Get_Pragma_Arg (Arg1); Analyze (Id); if not Is_Entity_Name (Id) *************** package body Sem_Prag is *** 11530,11536 **** if Get_Source_Unit (Loc) = Main_Unit then Opt.Time_Slice_Set := True; ! Val := Expr_Value_R (Expression (Arg1)); if Val <= Ureal_0 then Opt.Time_Slice_Value := 0; --- 12964,12970 ---- if Get_Source_Unit (Loc) = Main_Unit then Opt.Time_Slice_Set := True; ! Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); if Val <= Ureal_0 then Opt.Time_Slice_Value := 0; *************** package body Sem_Prag is *** 11564,11573 **** begin GNAT_Pragma; Gather_Associations (Names, Args); for J in 1 .. 2 loop if Present (Args (J)) then ! Check_Arg_Is_String_Literal (Args (J)); end if; end loop; end Title; --- 12998,13008 ---- begin GNAT_Pragma; Gather_Associations (Names, Args); + Store_Note (N); for J in 1 .. 2 loop if Present (Args (J)) then ! Check_Arg_Is_Static_Expression (Args (J), Standard_String); end if; end loop; end Title; *************** package body Sem_Prag is *** 11580,11586 **** when Pragma_Unchecked_Union => Unchecked_Union : declare Assoc : constant Node_Id := Arg1; ! Type_Id : constant Node_Id := Expression (Assoc); Typ : Entity_Id; Discr : Entity_Id; Tdef : Node_Id; --- 13015,13021 ---- when Pragma_Unchecked_Union => Unchecked_Union : declare Assoc : constant Node_Id := Arg1; ! Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); Typ : Entity_Id; Discr : Entity_Id; Tdef : Node_Id; *************** package body Sem_Prag is *** 11644,11649 **** --- 13079,13085 ---- ("Unchecked_Union discriminant must have default value", Discr); end if; + Next_Discriminant (Discr); end loop; *************** package body Sem_Prag is *** 11652,11658 **** Comp := First (Component_Items (Clist)); while Present (Comp) loop ! Check_Component (Comp); Next (Comp); end loop; --- 13088,13094 ---- Comp := First (Component_Items (Clist)); while Present (Comp) loop ! Check_Component (Comp, Typ); Next (Comp); end loop; *************** package body Sem_Prag is *** 11667,11682 **** Variant := First (Variants (Vpart)); while Present (Variant) loop ! Check_Variant (Variant); Next (Variant); end loop; end if; ! Set_Is_Unchecked_Union (Typ, True); ! Set_Convention (Typ, Convention_C); ! Set_Has_Unchecked_Union (Base_Type (Typ), True); ! Set_Is_Unchecked_Union (Base_Type (Typ), True); end Unchecked_Union; ------------------------ --- 13103,13121 ---- Variant := First (Variants (Vpart)); while Present (Variant) loop ! Check_Variant (Variant, Typ); Next (Variant); end loop; end if; ! Set_Is_Unchecked_Union (Typ, Sense); ! if Sense then ! Set_Convention (Typ, Convention_C); ! end if; ! ! Set_Has_Unchecked_Union (Base_Type (Typ), Sense); ! Set_Is_Unchecked_Union (Base_Type (Typ), Sense); end Unchecked_Union; ------------------------ *************** package body Sem_Prag is *** 11727,11733 **** Check_Arg_Count (1); Check_Optional_Identifier (Arg2, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Entity (Expression (Arg1)); if E_Id = Any_Type then return; --- 13166,13172 ---- Check_Arg_Count (1); Check_Optional_Identifier (Arg2, Name_Entity); Check_Arg_Is_Local_Name (Arg1); ! E_Id := Entity (Get_Pragma_Arg (Arg1)); if E_Id = Any_Type then return; *************** package body Sem_Prag is *** 11735,11741 **** Error_Pragma_Arg ("pragma% requires type", Arg1); end if; ! Set_Universal_Aliasing (Implementation_Base_Type (E_Id)); end Universal_Alias; -------------------- --- 13174,13180 ---- Error_Pragma_Arg ("pragma% requires type", Arg1); end if; ! Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense); end Universal_Alias; -------------------- *************** package body Sem_Prag is *** 11803,11809 **** ("pragma% can only be applied to a variable", Arg_Expr); else ! Set_Has_Pragma_Unmodified (Arg_Ent); end if; end if; --- 13242,13248 ---- ("pragma% can only be applied to a variable", Arg_Expr); else ! Set_Has_Pragma_Unmodified (Arg_Ent, Sense); end if; end if; *************** package body Sem_Prag is *** 11845,11857 **** Citem := First (List_Containing (N)); while Citem /= N loop if Nkind (Citem) = N_With_Clause ! and then Same_Name (Name (Citem), Expression (Arg_Node)) then Set_Has_Pragma_Unreferenced (Cunit_Entity (Get_Source_Unit (Library_Unit (Citem)))); ! Set_Unit_Name (Expression (Arg_Node), Name (Citem)); exit; end if; --- 13284,13298 ---- Citem := First (List_Containing (N)); while Citem /= N loop if Nkind (Citem) = N_With_Clause ! and then ! Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node)) then Set_Has_Pragma_Unreferenced (Cunit_Entity (Get_Source_Unit (Library_Unit (Citem)))); ! Set_Unit_Name ! (Get_Pragma_Arg (Arg_Node), Name (Citem)); exit; end if; *************** package body Sem_Prag is *** 11896,11902 **** Generate_Reference (Arg_Ent, N); end if; ! Set_Has_Pragma_Unreferenced (Arg_Ent); end if; Next (Arg_Node); --- 13337,13343 ---- Generate_Reference (Arg_Ent, N); end if; ! Set_Has_Pragma_Unreferenced (Arg_Ent, Sense); end if; Next (Arg_Node); *************** package body Sem_Prag is *** 11931,11937 **** ("argument for pragma% must be type or subtype", Arg_Node); end if; ! Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr)); Next (Arg_Node); end loop; end Unreferenced_Objects; --- 13372,13378 ---- ("argument for pragma% must be type or subtype", Arg_Node); end if; ! Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense); Next (Arg_Node); end loop; end Unreferenced_Objects; *************** package body Sem_Prag is *** 11979,11985 **** -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); when Pragma_Validity_Checks => Validity_Checks : declare ! A : constant Node_Id := Expression (Arg1); S : String_Id; C : Char_Code; --- 13420,13426 ---- -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); when Pragma_Validity_Checks => Validity_Checks : declare ! A : constant Node_Id := Get_Pragma_Arg (Arg1); S : String_Id; C : Char_Code; *************** package body Sem_Prag is *** 12089,12095 **** elsif not Is_Static_String_Expression (Arg1) then Error_Pragma_Arg ("argument of pragma% must be On/Off or " & ! "static string expression", Arg2); -- One argument string expression case --- 13530,13536 ---- elsif not Is_Static_String_Expression (Arg1) then Error_Pragma_Arg ("argument of pragma% must be On/Off or " & ! "static string expression", Arg1); -- One argument string expression case *************** package body Sem_Prag is *** 12155,12161 **** Err : Boolean; begin ! E_Id := Expression (Arg2); Analyze (E_Id); -- In the expansion of an inlined body, a reference to --- 13596,13602 ---- Err : Boolean; begin ! E_Id := Get_Pragma_Arg (Arg2); Analyze (E_Id); -- In the expansion of an inlined body, a reference to *************** package body Sem_Prag is *** 12179,12187 **** else loop Set_Warnings_Off ! (E, (Chars (Expression (Arg1)) = Name_Off)); ! if Chars (Expression (Arg1)) = Name_Off and then Warn_On_Warnings_Off then Warnings_Off_Pragmas.Append ((N, E)); --- 13620,13629 ---- else loop Set_Warnings_Off ! (E, (Chars (Get_Pragma_Arg (Arg1)) = ! Name_Off)); ! if Chars (Get_Pragma_Arg (Arg1)) = Name_Off and then Warn_On_Warnings_Off then Warnings_Off_Pragmas.Append ((N, E)); *************** package body Sem_Prag is *** 12215,12221 **** else String_To_Name_Buffer ! (Strval (Expr_Value_S (Expression (Arg2)))); -- Note on configuration pragma case: If this is a -- configuration pragma, then for an OFF pragma, we --- 13657,13663 ---- else String_To_Name_Buffer ! (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)))); -- Note on configuration pragma case: If this is a -- configuration pragma, then for an OFF pragma, we *************** package body Sem_Prag is *** 12262,12268 **** Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Library_Level_Local_Name (Arg1); ! Ent := Entity (Expression (Arg1)); if Rep_Item_Too_Early (Ent, N) then return; --- 13704,13710 ---- Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Library_Level_Local_Name (Arg1); ! Ent := Entity (Get_Pragma_Arg (Arg1)); if Rep_Item_Too_Early (Ent, N) then return; *************** package body Sem_Prag is *** 12309,12314 **** --- 13751,13761 ---- raise Program_Error; end case; + -- AI05-0144: detect dangerous order dependence. Disabled for now, + -- until AI is formally approved. + + -- Check_Order_Dependence; + exception when Pragma_Exit => null; end Analyze_Pragma; *************** package body Sem_Prag is *** 12321,12347 **** PP : Node_Id; begin PP := Opt.Check_Policy_List; loop if No (PP) then return Assertions_Enabled; ! elsif ! Nam = Chars (Expression (First (Pragma_Argument_Associations (PP)))) ! then ! case ! Chars (Expression (Last (Pragma_Argument_Associations (PP)))) ! is ! when Name_On | Name_Check => ! return True; ! when Name_Off | Name_Ignore => ! return False; ! when others => ! raise Program_Error; ! end case; else ! PP := Next_Pragma (PP); end if; end loop; end Check_Enabled; --- 13768,13806 ---- PP : Node_Id; begin + -- Loop through entries in check policy list + PP := Opt.Check_Policy_List; loop + -- If there are no specific entries that matched, then we let the + -- setting of assertions govern. Note that this provides the needed + -- compatibility with the RM for the cases of assertion, invariant, + -- precondition, predicate, and postcondition. + if No (PP) then return Assertions_Enabled; ! -- Here we have an entry see if it matches else ! declare ! PPA : constant List_Id := Pragma_Argument_Associations (PP); ! ! begin ! if Nam = Chars (Get_Pragma_Arg (First (PPA))) then ! case (Chars (Get_Pragma_Arg (Last (PPA)))) is ! when Name_On | Name_Check => ! return True; ! when Name_Off | Name_Ignore => ! return False; ! when others => ! raise Program_Error; ! end case; ! ! else ! PP := Next_Pragma (PP); ! end if; ! end; end if; end loop; end Check_Enabled; *************** package body Sem_Prag is *** 12381,12399 **** return Result; end Get_Base_Subprogram; - -------------------- - -- Get_Pragma_Arg -- - -------------------- - - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is - begin - if Nkind (Arg) = N_Pragma_Argument_Association then - return Expression (Arg); - else - return Arg; - end if; - end Get_Pragma_Arg; - ---------------- -- Initialize -- ---------------- --- 13840,13845 ---- *************** package body Sem_Prag is *** 12471,12478 **** -- whether a given pragma is significant. -- -1 indicates that references in any argument position are significant ! -- 0 indicates that appearence in any argument is not significant ! -- +n indicates that appearence as argument n is significant, but all -- other arguments are not significant -- 99 special processing required (e.g. for pragma Check) --- 13917,13924 ---- -- whether a given pragma is significant. -- -1 indicates that references in any argument position are significant ! -- 0 indicates that appearance in any argument is not significant ! -- +n indicates that appearance as argument n is significant, but all -- other arguments are not significant -- 99 special processing required (e.g. for pragma Check) *************** package body Sem_Prag is *** 12483,12488 **** --- 13929,13936 ---- Pragma_Ada_95 => -1, Pragma_Ada_05 => -1, Pragma_Ada_2005 => -1, + Pragma_Ada_12 => -1, + Pragma_Ada_2012 => -1, Pragma_All_Calls_Remote => -1, Pragma_Annotate => -1, Pragma_Assert => -1, *************** package body Sem_Prag is *** 12500,12505 **** --- 13948,13954 ---- Pragma_CPP_Constructor => 0, Pragma_CPP_Virtual => 0, Pragma_CPP_Vtable => 0, + Pragma_CPU => -1, Pragma_C_Pass_By_Copy => 0, Pragma_Comment => 0, Pragma_Common_Object => -1, *************** package body Sem_Prag is *** 12515,12520 **** --- 13964,13970 ---- Pragma_Debug => -1, Pragma_Debug_Policy => 0, Pragma_Detect_Blocking => -1, + Pragma_Default_Storage_Pool => -1, Pragma_Dimension => -1, Pragma_Discard_Names => 0, Pragma_Elaborate => -1, *************** package body Sem_Prag is *** 12538,12544 **** Pragma_Finalize_Storage_Only => 0, Pragma_Float_Representation => 0, Pragma_Ident => -1, ! Pragma_Implemented_By_Entry => -1, Pragma_Implicit_Packing => 0, Pragma_Import => +2, Pragma_Import_Exception => 0, --- 13988,13994 ---- Pragma_Finalize_Storage_Only => 0, Pragma_Float_Representation => 0, Pragma_Ident => -1, ! Pragma_Implemented => -1, Pragma_Implicit_Packing => 0, Pragma_Import => +2, Pragma_Import_Exception => 0, *************** package body Sem_Prag is *** 12546,12551 **** --- 13996,14003 ---- Pragma_Import_Object => 0, Pragma_Import_Procedure => 0, Pragma_Import_Valued_Procedure => 0, + Pragma_Independent => 0, + Pragma_Independent_Components => 0, Pragma_Initialize_Scalars => -1, Pragma_Inline => 0, Pragma_Inline_Always => 0, *************** package body Sem_Prag is *** 12556,12561 **** --- 14008,14014 ---- Pragma_Interrupt_Handler => -1, Pragma_Interrupt_Priority => -1, Pragma_Interrupt_State => -1, + Pragma_Invariant => -1, Pragma_Java_Constructor => -1, Pragma_Java_Interface => -1, Pragma_Keep_Names => 0, *************** package body Sem_Prag is *** 12581,12586 **** --- 14034,14040 ---- Pragma_Obsolescent => 0, Pragma_Optimize => -1, Pragma_Optimize_Alignment => -1, + Pragma_Ordered => 0, Pragma_Pack => 0, Pragma_Page => -1, Pragma_Passive => -1, *************** package body Sem_Prag is *** 12589,12594 **** --- 14043,14049 ---- Pragma_Persistent_BSS => 0, Pragma_Postcondition => -1, Pragma_Precondition => -1, + Pragma_Predicate => -1, Pragma_Preelaborate => -1, Pragma_Preelaborate_05 => -1, Pragma_Priority => -1, *************** package body Sem_Prag is *** 12613,12618 **** --- 14068,14074 ---- Pragma_Share_Generic => -1, Pragma_Shared => -1, Pragma_Shared_Passive => -1, + Pragma_Short_Descriptors => 0, Pragma_Source_File_Name => -1, Pragma_Source_File_Name_Project => -1, Pragma_Source_Reference => -1, *************** package body Sem_Prag is *** 12780,12814 **** procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is begin -- A special check for pragma Suppress_All, a very strange DEC pragma, ! -- strange because it comes at the end of the unit. If we have a pragma ! -- Suppress_All in the Pragmas_After of the current unit, then we insert ! -- a pragma Suppress (All_Checks) at the start of the context clause to ! -- ensure the correct processing. ! declare ! PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N)); ! P : Node_Id; ! begin ! if Present (PA) then ! P := First (PA); ! while Present (P) loop ! if Pragma_Name (P) = Name_Suppress_All then ! Prepend_To (Context_Items (N), ! Make_Pragma (Sloc (P), ! Chars => Name_Suppress, ! Pragma_Argument_Associations => New_List ( ! Make_Pragma_Argument_Association (Sloc (P), ! Expression => ! Make_Identifier (Sloc (P), ! Chars => Name_All_Checks))))); ! exit; ! end if; - Next (P); - end loop; - end if; - end; end Process_Compilation_Unit_Pragmas; -------- --- 14236,14259 ---- procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is begin -- A special check for pragma Suppress_All, a very strange DEC pragma, ! -- strange because it comes at the end of the unit. Rational has the ! -- same name for a pragma, but treats it as a program unit pragma, In ! -- GNAT we just decide to allow it anywhere at all. If it appeared then ! -- the flag Has_Pragma_Suppress_All was set on the compilation unit ! -- node, and we insert a pragma Suppress (All_Checks) at the start of ! -- the context clause to ensure the correct processing. ! if Has_Pragma_Suppress_All (N) then ! Prepend_To (Context_Items (N), ! Make_Pragma (Sloc (N), ! Chars => Name_Suppress, ! Pragma_Argument_Associations => New_List ( ! Make_Pragma_Argument_Association (Sloc (N), ! Expression => Make_Identifier (Sloc (N), Name_All_Checks))))); ! end if; ! -- Nothing else to do at the current time! end Process_Compilation_Unit_Pragmas; -------- diff -Nrcpad gcc-4.5.2/gcc/ada/sem_prag.ads gcc-4.6.0/gcc/ada/sem_prag.ads *** gcc-4.5.2/gcc/ada/sem_prag.ads Mon Apr 14 21:07:59 2008 --- gcc-4.6.0/gcc/ada/sem_prag.ads Tue Oct 12 10:32:58 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Prag is *** 99,106 **** procedure Process_Compilation_Unit_Pragmas (N : Node_Id); -- Called at the start of processing compilation unit N to deal with any -- special issues regarding pragmas. In particular, we have to deal with ! -- Suppress_All at this stage, since it appears after the unit instead of ! -- before. procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id); -- This routine is used to set an encoded interface name. The node S is an --- 99,106 ---- procedure Process_Compilation_Unit_Pragmas (N : Node_Id); -- Called at the start of processing compilation unit N to deal with any -- special issues regarding pragmas. In particular, we have to deal with ! -- Suppress_All at this stage, since it can appear after the unit instead ! -- of before (actually we allow it to appear anywhere). procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id); -- This routine is used to set an encoded interface name. The node S is an diff -Nrcpad gcc-4.5.2/gcc/ada/sem_res.adb gcc-4.6.0/gcc/ada/sem_res.adb *** gcc-4.5.2/gcc/ada/sem_res.adb Fri Oct 30 12:02:11 2009 --- gcc-4.6.0/gcc/ada/sem_res.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Sem_Util; use Sem_Util; *** 68,73 **** --- 68,74 ---- with Sem_Type; use Sem_Type; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; + with Sinfo.CN; use Sinfo.CN; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; *************** package body Sem_Res is *** 91,96 **** --- 92,106 ---- -- Note that Resolve_Attribute is separated off in Sem_Attr + function Bad_Unordered_Enumeration_Reference + (N : Node_Id; + T : Entity_Id) return Boolean; + -- Node N contains a potentially dubious reference to type T, either an + -- explicit comparison, or an explicit range. This function returns True + -- if the type T is an enumeration type for which No pragma Order has been + -- given, and the reference N is not in the same extended source unit as + -- the declaration of T. + procedure Check_Discriminant_Use (N : Node_Id); -- Enforce the restrictions on the use of discriminants when constraining -- a component of a discriminated type (record or concurrent type). *************** package body Sem_Res is *** 130,139 **** -- declaration, and not an (anonymous) allocator type. function Is_Predefined_Op (Nam : Entity_Id) return Boolean; ! -- Utility to check whether the name in the call is a predefined ! -- operator, in which case the call is made into an operator node. ! -- An instance of an intrinsic conversion operation may be given ! -- an operator name, but is not treated like an operator. procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); -- If a default expression in entry call N depends on the discriminants --- 140,153 ---- -- declaration, and not an (anonymous) allocator type. function Is_Predefined_Op (Nam : Entity_Id) return Boolean; ! -- Utility to check whether the entity for an operator is a predefined ! -- operator, in which case the expression is left as an operator in the ! -- tree (else it is rewritten into a call). An instance of an intrinsic ! -- conversion operation may be given an operator name, but is not treated ! -- like an operator. Note that an operator that is an imported back-end ! -- builtin has convention Intrinsic, but is expected to be rewritten into ! -- a call, so such an operator is not treated as predefined by this ! -- predicate. procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); -- If a default expression in entry call N depends on the discriminants *************** package body Sem_Res is *** 160,171 **** procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); ! procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); --- 174,187 ---- procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); ! procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); *************** package body Sem_Res is *** 176,181 **** --- 192,198 ---- procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); *************** package body Sem_Res is *** 211,219 **** procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); -- A call to a user-defined intrinsic operator is rewritten as a call -- to the corresponding predefined operator, with suitable conversions. procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); ! -- Ditto, for unary operators (only arithmetic ones) procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, --- 228,240 ---- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); -- A call to a user-defined intrinsic operator is rewritten as a call -- to the corresponding predefined operator, with suitable conversions. + -- Note that this applies only for intrinsic operators that denote + -- predefined operators, not operators that are intrinsic imports of + -- back-end builtins. procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); ! -- Ditto, for unary operators (arithmetic ones and "not" on signed ! -- integer types for VMS). procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, *************** package body Sem_Res is *** 276,291 **** -- First the ones in Standard ! Error_Msg_N ! ("\\possible interpretation: Character!", C); ! Error_Msg_N ! ("\\possible interpretation: Wide_Character!", C); -- Include Wide_Wide_Character in Ada 2005 mode ! if Ada_Version >= Ada_05 then ! Error_Msg_N ! ("\\possible interpretation: Wide_Wide_Character!", C); end if; -- Now any other types that match --- 297,309 ---- -- First the ones in Standard ! Error_Msg_N ("\\possible interpretation: Character!", C); ! Error_Msg_N ("\\possible interpretation: Wide_Character!", C); -- Include Wide_Wide_Character in Ada 2005 mode ! if Ada_Version >= Ada_2005 then ! Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C); end if; -- Now any other types that match *************** package body Sem_Res is *** 393,398 **** --- 411,432 ---- end if; end Analyze_And_Resolve; + ---------------------------------------- + -- Bad_Unordered_Enumeration_Reference -- + ---------------------------------------- + + function Bad_Unordered_Enumeration_Reference + (N : Node_Id; + T : Entity_Id) return Boolean + is + begin + return Is_Enumeration_Type (T) + and then Comes_From_Source (N) + and then Warn_On_Unordered_Enumeration_Type + and then not Has_Pragma_Ordered (T) + and then not In_Same_Extended_Unit (N, T); + end Bad_Unordered_Enumeration_Reference; + ---------------------------- -- Check_Discriminant_Use -- ---------------------------- *************** package body Sem_Res is *** 632,640 **** procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is begin if Is_Invisible_Operator (N, T) then ! Error_Msg_NE ("operator for} is not directly visible!", N, First_Subtype (T)); ! Error_Msg_N ("use clause would make operation legal!", N); end if; end Check_For_Visible_Operator; --- 666,675 ---- procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is begin if Is_Invisible_Operator (N, T) then ! Error_Msg_NE -- CODEFIX ("operator for} is not directly visible!", N, First_Subtype (T)); ! Error_Msg_N -- CODEFIX ! ("use clause would make operation legal!", N); end if; end Check_For_Visible_Operator; *************** package body Sem_Res is *** 674,680 **** -- are handled by Analyze_Access_Attribute, Analyze_Assignment, -- Analyze_Object_Renaming, and Freeze_Entity. ! elsif Ada_Version >= Ada_05 and then Is_Entity_Name (Pref) and then Is_Access_Type (Etype (Pref)) and then Ekind (Directly_Designated_Type (Etype (Pref))) = --- 709,715 ---- -- are handled by Analyze_Access_Attribute, Analyze_Assignment, -- Analyze_Object_Renaming, and Freeze_Entity. ! elsif Ada_Version >= Ada_2005 and then Is_Entity_Name (Pref) and then Is_Access_Type (Etype (Pref)) and then Ekind (Directly_Designated_Type (Etype (Pref))) = *************** package body Sem_Res is *** 784,791 **** if Nkind_In (P, N_Or_Else, N_And_Then, ! N_If_Statement, ! N_Case_Statement) then return False; --- 819,828 ---- if Nkind_In (P, N_Or_Else, N_And_Then, ! N_Case_Expression, ! N_Case_Statement, ! N_Conditional_Expression, ! N_If_Statement) then return False; *************** package body Sem_Res is *** 898,907 **** Expr := Original_Node (Expression (Parent (Comp))); -- Return True if the expression is a call to a function ! -- (including an attribute function such as Image) with ! -- a result that requires a transient scope. if (Nkind (Expr) = N_Function_Call or else (Nkind (Expr) = N_Attribute_Reference and then Present (Expressions (Expr)))) and then Requires_Transient_Scope (Etype (Expr)) --- 935,946 ---- Expr := Original_Node (Expression (Parent (Comp))); -- Return True if the expression is a call to a function ! -- (including an attribute function such as Image, or a ! -- user-defined operator) with a result that requires a ! -- transient scope. if (Nkind (Expr) = N_Function_Call + or else Nkind (Expr) in N_Op or else (Nkind (Expr) = N_Attribute_Reference and then Present (Expressions (Expr)))) and then Requires_Transient_Scope (Etype (Expr)) *************** package body Sem_Res is *** 975,980 **** --- 1014,1030 ---- It : Interp; begin + -- If the context is an attribute reference that can apply to + -- functions, this is never a parameterless call (RM 4.1.4(6)). + + if Nkind (Parent (N)) = N_Attribute_Reference + and then (Attribute_Name (Parent (N)) = Name_Address + or else Attribute_Name (Parent (N)) = Name_Code_Address + or else Attribute_Name (Parent (N)) = Name_Access) + then + return False; + end if; + if not Is_Overloaded (N) then return Ekind (Etype (N)) = E_Subprogram_Type *************** package body Sem_Res is *** 1031,1040 **** -- overloaded case) a function call. If we know for sure that the entity -- is an enumeration literal, we do not rewrite it. if (Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) and then (Ekind (Entity (N)) /= E_Enumeration_Literal ! or else Is_Overloaded (N))) -- Rewrite as call if it is an explicit dereference of an expression of -- a subprogram access type, and the subprogram type is not that of a --- 1081,1096 ---- -- overloaded case) a function call. If we know for sure that the entity -- is an enumeration literal, we do not rewrite it. + -- If the entity is the name of an operator, it cannot be a call because + -- operators cannot have default parameters. In this case, this must be + -- a string whose contents coincide with an operator name. Set the kind + -- of the node appropriately. + if (Is_Entity_Name (N) + and then Nkind (N) /= N_Operator_Symbol and then Is_Overloadable (Entity (N)) and then (Ekind (Entity (N)) /= E_Enumeration_Literal ! or else Is_Overloaded (N))) -- Rewrite as call if it is an explicit dereference of an expression of -- a subprogram access type, and the subprogram type is not that of a *************** package body Sem_Res is *** 1050,1060 **** or else (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function ! or else ! ((Ekind (Entity (Selector_Name (N))) = E_Entry ! or else ! Ekind (Entity (Selector_Name (N))) = E_Procedure) ! and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. -- Apply the rewriting only once. --- 1106,1115 ---- or else (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function ! or else ! (Ekind_In (Entity (Selector_Name (N)), E_Entry, ! E_Procedure) ! and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. -- Apply the rewriting only once. *************** package body Sem_Res is *** 1081,1086 **** --- 1136,1146 ---- elsif Nkind (N) = N_Parameter_Association then Check_Parameterless_Call (Explicit_Actual_Parameter (N)); + + elsif Nkind (N) = N_Operator_Symbol then + Change_Operator_Symbol_To_String_Literal (N); + Set_Is_Overloaded (N, False); + Set_Etype (N, Any_String); end if; end Check_Parameterless_Call; *************** package body Sem_Res is *** 1102,1112 **** function Is_Predefined_Op (Nam : Entity_Id) return Boolean is begin ! return Is_Intrinsic_Subprogram (Nam) ! and then not Is_Generic_Instance (Nam) and then Chars (Nam) in Any_Operator_Name ! and then (No (Alias (Nam)) ! or else Is_Predefined_Op (Alias (Nam))); end Is_Predefined_Op; ----------------------------- --- 1162,1182 ---- function Is_Predefined_Op (Nam : Entity_Id) return Boolean is begin ! -- Predefined operators are intrinsic subprograms ! ! if not Is_Intrinsic_Subprogram (Nam) then ! return False; ! end if; ! ! -- A call to a back-end builtin is never a predefined operator ! ! if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then ! return False; ! end if; ! ! return not Is_Generic_Instance (Nam) and then Chars (Nam) in Any_Operator_Name ! and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam))); end Is_Predefined_Op; ----------------------------- *************** package body Sem_Res is *** 1132,1144 **** type Kind_Test is access function (E : Entity_Id) return Boolean; function Operand_Type_In_Scope (S : Entity_Id) return Boolean; ! -- If the operand is not universal, and the operator is given by a ! -- expanded name, verify that the operand has an interpretation with ! -- a type defined in the given scope of the operator. function Type_In_P (Test : Kind_Test) return Entity_Id; ! -- Find a type of the given class in the package Pack that contains ! -- the operator. --------------------------- -- Operand_Type_In_Scope -- --- 1202,1214 ---- type Kind_Test is access function (E : Entity_Id) return Boolean; function Operand_Type_In_Scope (S : Entity_Id) return Boolean; ! -- If the operand is not universal, and the operator is given by an ! -- expanded name, verify that the operand has an interpretation with a ! -- type defined in the given scope of the operator. function Type_In_P (Test : Kind_Test) return Entity_Id; ! -- Find a type of the given class in package Pack that contains the ! -- operator. --------------------------- -- Operand_Type_In_Scope -- *************** package body Sem_Res is *** 1213,1224 **** -- Start of processing for Type_In_P begin ! -- If the context type is declared in the prefix package, this ! -- is the desired base type. ! if Scope (Base_Type (Typ)) = Pack ! and then Test (Typ) ! then return Base_Type (Typ); else --- 1283,1292 ---- -- Start of processing for Type_In_P begin ! -- If the context type is declared in the prefix package, this is the ! -- desired base type. ! if Scope (Base_Type (Typ)) = Pack and then Test (Typ) then return Base_Type (Typ); else *************** package body Sem_Res is *** 1274,1289 **** -- you courtesy of b33302a. The type itself must be frozen, so we must -- find the type of the proper class in the given scope. ! -- A final wrinkle is the multiplication operator for fixed point ! -- types, which is defined in Standard only, and not in the scope of ! -- the fixed_point type itself. if Nkind (Name (N)) = N_Expanded_Name then Pack := Entity (Prefix (Name (N))); ! -- If the entity being called is defined in the given package, ! -- it is a renaming of a predefined operator, and known to be ! -- legal. if Scope (Entity (Name (N))) = Pack and then Pack /= Standard_Standard --- 1342,1356 ---- -- you courtesy of b33302a. The type itself must be frozen, so we must -- find the type of the proper class in the given scope. ! -- A final wrinkle is the multiplication operator for fixed point types, ! -- which is defined in Standard only, and not in the scope of the ! -- fixed point type itself. if Nkind (Name (N)) = N_Expanded_Name then Pack := Entity (Prefix (Name (N))); ! -- If the entity being called is defined in the given package, it is ! -- a renaming of a predefined operator, and known to be legal. if Scope (Entity (Name (N))) = Pack and then Pack /= Standard_Standard *************** package body Sem_Res is *** 1297,1304 **** elsif In_Instance then null; ! elsif (Op_Name = Name_Op_Multiply ! or else Op_Name = Name_Op_Divide) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) then --- 1364,1370 ---- elsif In_Instance then null; ! elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) then *************** package body Sem_Res is *** 1306,1315 **** Error := True; end if; ! -- Ada 2005, AI-420: Predefined equality on Universal_Access ! -- is available. ! elsif Ada_Version >= Ada_05 and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type then --- 1372,1381 ---- Error := True; end if; ! -- Ada 2005 AI-420: Predefined equality on Universal_Access is ! -- available. ! elsif Ada_Version >= Ada_2005 and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type then *************** package body Sem_Res is *** 1338,1344 **** if Pack /= Standard_Standard then if Opnd_Type = Universal_Integer then ! Orig_Type := Type_In_P (Is_Integer_Type'Access); elsif Opnd_Type = Universal_Real then Orig_Type := Type_In_P (Is_Real_Type'Access); --- 1404,1410 ---- if Pack /= Standard_Standard then if Opnd_Type = Universal_Integer then ! Orig_Type := Type_In_P (Is_Integer_Type'Access); elsif Opnd_Type = Universal_Real then Orig_Type := Type_In_P (Is_Real_Type'Access); *************** package body Sem_Res is *** 1347,1353 **** Orig_Type := Type_In_P (Is_String_Type'Access); elsif Opnd_Type = Any_Access then ! Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); elsif Opnd_Type = Any_Composite then Orig_Type := Type_In_P (Is_Composite_Type'Access); --- 1413,1419 ---- Orig_Type := Type_In_P (Is_String_Type'Access); elsif Opnd_Type = Any_Access then ! Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); elsif Opnd_Type = Any_Composite then Orig_Type := Type_In_P (Is_Composite_Type'Access); *************** package body Sem_Res is *** 1407,1412 **** --- 1473,1513 ---- ("& not declared in&", N, Selector_Name (Name (N))); Set_Etype (N, Any_Type); return; + + -- Detect a mismatch between the context type and the result type + -- in the named package, which is otherwise not detected if the + -- operands are universal. Check is only needed if source entity is + -- an operator, not a function that renames an operator. + + elsif Nkind (Parent (N)) /= N_Type_Conversion + and then Ekind (Entity (Name (N))) = E_Operator + and then Is_Numeric_Type (Typ) + and then not Is_Universal_Numeric_Type (Typ) + and then Scope (Base_Type (Typ)) /= Pack + and then not In_Instance + then + if Is_Fixed_Point_Type (Typ) + and then (Op_Name = Name_Op_Multiply + or else + Op_Name = Name_Op_Divide) + then + -- Already checked above + + null; + + -- Operator may be defined in an extension of System + + elsif Present (System_Aux_Id) + and then Scope (Opnd_Type) = System_Aux_Id + then + null; + + else + -- Could we use Wrong_Type here??? (this would require setting + -- Etype (N) to the actual type found where Typ was expected). + + Error_Msg_NE ("expect }", N, Typ); + end if; end if; end if; *************** package body Sem_Res is *** 1468,1481 **** else Resolve (N, Typ); end if; - - -- For predefined operators on literals, the operation freezes - -- their type. - - if Present (Orig_Type) then - Set_Etype (Act1, Orig_Type); - Freeze_Expression (Act1); - end if; end Make_Call_Into_Operator; ------------------- --- 1569,1574 ---- *************** package body Sem_Res is *** 1669,1674 **** --- 1762,1771 ---- -- Try and fix up a literal so that it matches its expected type. New -- literals are manufactured if necessary to avoid cascaded errors. + procedure Report_Ambiguous_Argument; + -- Additional diagnostics when an ambiguous call has an ambiguous + -- argument (typically a controlling actual). + procedure Resolution_Failed; -- Called when attempt at resolving current expression fails *************** package body Sem_Res is *** 1733,1738 **** --- 1830,1868 ---- end if; end Patch_Up_Value; + ------------------------------- + -- Report_Ambiguous_Argument -- + ------------------------------- + + procedure Report_Ambiguous_Argument is + Arg : constant Node_Id := First (Parameter_Associations (N)); + I : Interp_Index; + It : Interp; + + begin + if Nkind (Arg) = N_Function_Call + and then Is_Entity_Name (Name (Arg)) + and then Is_Overloaded (Name (Arg)) + then + Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); + + -- Could use comments on what is going on here ??? + + Get_First_Interp (Name (Arg), I, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + + if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then + Error_Msg_N ("interpretation (inherited) #!", Arg); + else + Error_Msg_N ("interpretation #!", Arg); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end Report_Ambiguous_Argument; + ----------------------- -- Resolution_Failed -- ----------------------- *************** package body Sem_Res is *** 1805,1810 **** --- 1935,1941 ---- -- Check that Typ is a remote access-to-subprogram type if Is_Remote_Access_To_Subprogram_Type (Typ) then + -- Prefix (N) must statically denote a remote subprogram -- declared in a package specification. *************** package body Sem_Res is *** 1917,1923 **** -- type against which we are resolving is the same as the -- type of the interpretation. ! if Ada_Version >= Ada_05 and then It.Typ = Typ and then Typ /= Universal_Integer and then Typ /= Universal_Real --- 2048,2054 ---- -- type against which we are resolving is the same as the -- type of the interpretation. ! if Ada_Version >= Ada_2005 and then It.Typ = Typ and then Typ /= Universal_Integer and then Typ /= Universal_Real *************** package body Sem_Res is *** 2037,2042 **** --- 2168,2180 ---- Error_Msg_N -- CODEFIX ("\\possible interpretation#!", N); end if; + + if Nkind_In + (N, N_Procedure_Call_Statement, N_Function_Call) + and then Present (Parameter_Associations (N)) + then + Report_Ambiguous_Argument; + end if; end if; Error_Msg_Sloc := Sloc (It.Nam); *************** package body Sem_Res is *** 2077,2083 **** -- If this is an indirect call, use the subprogram_type -- in the message, to have a meaningful location. ! -- Indicate as well if this is an inherited operation, -- created by a type declaration. elsif Nkind (N) = N_Function_Call --- 2215,2221 ---- -- If this is an indirect call, use the subprogram_type -- in the message, to have a meaningful location. ! -- Also indicate if this is an inherited operation, -- created by a type declaration. elsif Nkind (N) = N_Function_Call *************** package body Sem_Res is *** 2134,2139 **** --- 2272,2280 ---- Set_Entity (N, Seen); Generate_Reference (Seen, N); + elsif Nkind (N) = N_Case_Expression then + Set_Etype (N, Expr_Type); + elsif Nkind (N) = N_Character_Literal then Set_Etype (N, Expr_Type); *************** package body Sem_Res is *** 2158,2168 **** null; -- For procedure or function calls, set the type of the name, ! -- and also the entity pointer for the prefix elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) ! and then (Is_Entity_Name (Name (N)) ! or else Nkind (Name (N)) = N_Operator_Symbol) then Set_Etype (Name (N), Expr_Type); Set_Entity (Name (N), Seen); --- 2299,2308 ---- null; -- For procedure or function calls, set the type of the name, ! -- and also the entity pointer for the prefix. elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) ! and then Is_Entity_Name (Name (N)) then Set_Etype (Name (N), Expr_Type); Set_Entity (Name (N), Seen); *************** package body Sem_Res is *** 2194,2202 **** end if; -- At this stage Found indicates whether or not an acceptable ! -- interpretation exists. If not, then we have an error, except ! -- that if the context is Any_Type as a result of some other error, ! -- then we suppress the error report. if not Found then if Typ /= Any_Type then --- 2334,2342 ---- end if; -- At this stage Found indicates whether or not an acceptable ! -- interpretation exists. If not, then we have an error, except that if ! -- the context is Any_Type as a result of some other error, then we ! -- suppress the error report. if not Found then if Typ /= Any_Type then *************** package body Sem_Res is *** 2489,2494 **** --- 2629,2637 ---- when N_Attribute_Reference => Resolve_Attribute (N, Ctx_Type); + when N_Case_Expression + => Resolve_Case_Expression (N, Ctx_Type); + when N_Character_Literal => Resolve_Character_Literal (N, Ctx_Type); *************** package body Sem_Res is *** 2498,2509 **** when N_Expanded_Name => Resolve_Entity_Name (N, Ctx_Type); - when N_Extension_Aggregate - => Resolve_Extension_Aggregate (N, Ctx_Type); - when N_Explicit_Dereference => Resolve_Explicit_Dereference (N, Ctx_Type); when N_Function_Call => Resolve_Call (N, Ctx_Type); --- 2641,2655 ---- when N_Expanded_Name => Resolve_Entity_Name (N, Ctx_Type); when N_Explicit_Dereference => Resolve_Explicit_Dereference (N, Ctx_Type); + when N_Expression_With_Actions + => Resolve_Expression_With_Actions (N, Ctx_Type); + + when N_Extension_Aggregate + => Resolve_Extension_Aggregate (N, Ctx_Type); + when N_Function_Call => Resolve_Call (N, Ctx_Type); *************** package body Sem_Res is *** 2555,2560 **** --- 2701,2709 ---- when N_Qualified_Expression => Resolve_Qualified_Expression (N, Ctx_Type); + when N_Quantified_Expression + => Resolve_Quantified_Expression (N, Ctx_Type); + when N_Raise_xxx_Error => Set_Etype (N, Ctx_Type); *************** package body Sem_Res is *** 2584,2590 **** when N_Unchecked_Type_Conversion => Resolve_Unchecked_Type_Conversion (N, Ctx_Type); - end case; -- If the subexpression was replaced by a non-subexpression, then --- 2733,2738 ---- *************** package body Sem_Res is *** 2598,2603 **** --- 2746,2763 ---- return; end if; + -- AI05-144-2: Check dangerous order dependence within an expression + -- that is not a subexpression. Exclude RHS of an assignment, because + -- both sides may have side-effects and the check must be performed + -- over the statement. + + if Nkind (Parent (N)) not in N_Subexpr + and then Nkind (Parent (N)) /= N_Assignment_Statement + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement + then + Check_Order_Dependence; + end if; + -- The expression is definitely NOT overloaded at this point, so -- we reset the Is_Overloaded flag to avoid any confusion when -- reanalyzing the node. *************** package body Sem_Res is *** 2978,2985 **** -- If the default expression raises constraint error, then just -- silently replace it with an N_Raise_Constraint_Error node, -- since we already gave the warning on the subprogram spec. ! if Raises_Constraint_Error (Actval) then Rewrite (Actval, Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed)); --- 3138,3149 ---- -- If the default expression raises constraint error, then just -- silently replace it with an N_Raise_Constraint_Error node, -- since we already gave the warning on the subprogram spec. + -- If node is already a Raise_Constraint_Error leave as is, to + -- prevent loops in the warnings removal machinery. ! if Raises_Constraint_Error (Actval) ! and then Nkind (Actval) /= N_Raise_Constraint_Error ! then Rewrite (Actval, Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed)); *************** package body Sem_Res is *** 3172,3216 **** if Ekind (F) = E_In_Out_Parameter and then Is_Array_Type (Etype (F)) then ! if Has_Aliased_Components (Etype (Expression (A))) ! /= Has_Aliased_Components (Etype (F)) ! then ! ! -- In a view conversion, the conversion must be legal in ! -- both directions, and thus both component types must be ! -- aliased, or neither (4.6 (8)). ! -- The additional rule 4.6 (24.9.2) seems unduly ! -- restrictive: the privacy requirement should not apply ! -- to generic types, and should be checked in an ! -- instance. ARG query is in order ??? Error_Msg_N ("both component types in a view conversion must be" & " aliased, or neither", A); elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) then if Is_By_Reference_Type (Etype (F)) or else Is_By_Reference_Type (Etype (Expression (A))) then Error_Msg_N ("view conversion between unrelated by reference " & "array types not allowed (\'A'I-00246)", A); ! else declare Comp_Type : constant Entity_Id := Component_Type (Etype (Expression (A))); begin ! if Comes_From_Source (A) ! and then Ada_Version >= Ada_05 ! and then ! ((Is_Private_Type (Comp_Type) ! and then not Is_Generic_Type (Comp_Type)) ! or else Is_Tagged_Type (Comp_Type) ! or else Is_Volatile (Comp_Type)) then Error_Msg_N ("component type of a view conversion cannot" --- 3336,3390 ---- if Ekind (F) = E_In_Out_Parameter and then Is_Array_Type (Etype (F)) then ! -- In a view conversion, the conversion must be legal in ! -- both directions, and thus both component types must be ! -- aliased, or neither (4.6 (8)). ! -- The extra rule in 4.6 (24.9.2) seems unduly restrictive: ! -- the privacy requirement should not apply to generic ! -- types, and should be checked in an instance. ARG query ! -- is in order ??? + if Has_Aliased_Components (Etype (Expression (A))) /= + Has_Aliased_Components (Etype (F)) + then Error_Msg_N ("both component types in a view conversion must be" & " aliased, or neither", A); + -- Comment here??? what set of cases??? + elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) then + -- Check view conv between unrelated by ref array types + if Is_By_Reference_Type (Etype (F)) or else Is_By_Reference_Type (Etype (Expression (A))) then Error_Msg_N ("view conversion between unrelated by reference " & "array types not allowed (\'A'I-00246)", A); ! ! -- In Ada 2005 mode, check view conversion component ! -- type cannot be private, tagged, or volatile. Note ! -- that we only apply this to source conversions. The ! -- generated code can contain conversions which are ! -- not subject to this test, and we cannot extract the ! -- component type in such cases since it is not present. ! ! elsif Comes_From_Source (A) ! and then Ada_Version >= Ada_2005 ! then declare Comp_Type : constant Entity_Id := Component_Type (Etype (Expression (A))); begin ! if (Is_Private_Type (Comp_Type) ! and then not Is_Generic_Type (Comp_Type)) ! or else Is_Tagged_Type (Comp_Type) ! or else Is_Volatile (Comp_Type) then Error_Msg_N ("component type of a view conversion cannot" *************** package body Sem_Res is *** 3223,3230 **** end if; end if; if (Conversion_OK (A) ! or else Valid_Conversion (A, Etype (A), Expression (A))) and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) then Resolve (Expression (A)); --- 3397,3406 ---- end if; end if; + -- Resolve expression if conversion is all OK + if (Conversion_OK (A) ! or else Valid_Conversion (A, Etype (A), Expression (A))) and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) then Resolve (Expression (A)); *************** package body Sem_Res is *** 3379,3384 **** --- 3555,3565 ---- A_Typ := Etype (A); F_Typ := Etype (F); + -- Save actual for subsequent check on order dependence, and + -- indicate whether actual is modifiable. For AI05-0144-2. + + Save_Actual (A, Ekind (F) /= E_In_Parameter); + -- For mode IN, if actual is an entity, and the type of the formal -- has warnings suppressed, then we reset Never_Set_In_Source for -- the calling entity. The reason for this is to catch cases like *************** package body Sem_Res is *** 3490,3498 **** -- might not be done in the In Out case since Gigi does not do -- any analysis. More thought required about this ??? ! if Ekind (F) = E_In_Parameter ! or else Ekind (F) = E_In_Out_Parameter ! then if Is_Scalar_Type (Etype (A)) then Apply_Scalar_Range_Check (A, F_Typ); --- 3671,3690 ---- -- might not be done in the In Out case since Gigi does not do -- any analysis. More thought required about this ??? ! if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then ! ! -- Apply predicate checks, unless this is a call to the ! -- predicate check function itself, which would cause an ! -- infinite recursion. ! ! if not (Ekind (Nam) = E_Function ! and then Has_Predicates (Nam)) ! then ! Apply_Predicate_Check (A, F_Typ); ! end if; ! ! -- Apply required constraint checks ! if Is_Scalar_Type (Etype (A)) then Apply_Scalar_Range_Check (A, F_Typ); *************** package body Sem_Res is *** 3523,3546 **** Apply_Range_Check (A, F_Typ); end if; ! -- Ada 2005 (AI-231) ! if Ada_Version >= Ada_05 ! and then Is_Access_Type (F_Typ) and then Can_Never_Be_Null (F_Typ) and then Known_Null (A) then ! Apply_Compile_Time_Constraint_Error ! (N => A, ! Msg => "(Ada 2005) null not allowed in " ! & "null-excluding formal?", ! Reason => CE_Null_Not_Allowed); end if; end if; ! if Ekind (F) = E_Out_Parameter ! or else Ekind (F) = E_In_Out_Parameter ! then if Nkind (A) = N_Type_Conversion then if Is_Scalar_Type (A_Typ) then Apply_Scalar_Range_Check --- 3715,3746 ---- Apply_Range_Check (A, F_Typ); end if; ! -- Ada 2005 (AI-231): Note that the controlling parameter case ! -- already existed in Ada 95, which is partially checked ! -- elsewhere (see Checks), and we don't want the warning ! -- message to differ. ! if Is_Access_Type (F_Typ) and then Can_Never_Be_Null (F_Typ) and then Known_Null (A) then ! if Is_Controlling_Formal (F) then ! Apply_Compile_Time_Constraint_Error ! (N => A, ! Msg => "null value not allowed here?", ! Reason => CE_Access_Check_Failed); ! ! elsif Ada_Version >= Ada_2005 then ! Apply_Compile_Time_Constraint_Error ! (N => A, ! Msg => "(Ada 2005) null not allowed in " ! & "null-excluding formal?", ! Reason => CE_Null_Not_Allowed); ! end if; end if; end if; ! if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then if Nkind (A) = N_Type_Conversion then if Is_Scalar_Type (A_Typ) then Apply_Scalar_Range_Check *************** package body Sem_Res is *** 3672,3679 **** Eval_Actual (A); ! -- If it is a named association, treat the selector_name as ! -- a proper identifier, and mark the corresponding entity. if Nkind (Parent (A)) = N_Parameter_Association then Set_Entity (Selector_Name (Parent (A)), F); --- 3872,3879 ---- Eval_Actual (A); ! -- If it is a named association, treat the selector_name as a ! -- proper identifier, and mark the corresponding entity. if Nkind (Parent (A)) = N_Parameter_Association then Set_Entity (Selector_Name (Parent (A)), F); *************** package body Sem_Res is *** 4110,4116 **** -- the case of an initialized allocator with a class-wide argument (see -- Expand_Allocator_Expression). ! if Ada_Version >= Ada_05 and then Is_Class_Wide_Type (Designated_Type (Typ)) then declare --- 4310,4316 ---- -- the case of an initialized allocator with a class-wide argument (see -- Expand_Allocator_Expression). ! if Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (Designated_Type (Typ)) then declare *************** package body Sem_Res is *** 4151,4165 **** -- Check for allocation from an empty storage pool if No_Pool_Assigned (Typ) then ! declare ! Loc : constant Source_Ptr := Sloc (N); ! begin ! Error_Msg_N ("?allocation from empty storage pool!", N); ! Error_Msg_N ("\?Storage_Error will be raised at run time!", N); ! Insert_Action (N, ! Make_Raise_Storage_Error (Loc, ! Reason => SE_Empty_Storage_Pool)); ! end; -- If the context is an unchecked conversion, as may happen within -- an inlined subprogram, the allocator is being resolved with its --- 4351,4357 ---- -- Check for allocation from an empty storage pool if No_Pool_Assigned (Typ) then ! Error_Msg_N ("allocation from empty storage pool!", N); -- If the context is an unchecked conversion, as may happen within -- an inlined subprogram, the allocator is being resolved with its *************** package body Sem_Res is *** 4173,4178 **** --- 4365,4374 ---- (Typ, Associated_Storage_Pool (Etype (Parent (N)))); end if; + if Ekind (Etype (N)) = E_Anonymous_Access_Type then + Check_Restriction (No_Anonymous_Allocators, N); + end if; + -- An erroneous allocator may be rewritten as a raise Program_Error -- statement. *************** package body Sem_Res is *** 4568,4574 **** -- If the context is Universal_Fixed and the operands are also -- universal fixed, this is an error, unless there is only one ! -- applicable fixed_point type (usually duration). if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then T := Unique_Fixed_Point_Type (N); --- 4764,4770 ---- -- If the context is Universal_Fixed and the operands are also -- universal fixed, this is an error, unless there is only one ! -- applicable fixed_point type (usually Duration). if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then T := Unique_Fixed_Point_Type (N); *************** package body Sem_Res is *** 4659,4665 **** -- violated if either operand can be negative for mod, or for rem -- if both operands can be negative. ! if Restrictions.Set (No_Implicit_Conditionals) and then Nkind_In (N, N_Op_Rem, N_Op_Mod) then declare --- 4855,4861 ---- -- violated if either operand can be negative for mod, or for rem -- if both operands can be negative. ! if Restriction_Check_Required (No_Implicit_Conditionals) and then Nkind_In (N, N_Op_Rem, N_Op_Mod) then declare *************** package body Sem_Res is *** 4689,4695 **** -- expander does, so we match its logic here). -- The second case is mod where either operand can be negative. ! -- In this case, the back end has to generate additonal tests. if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) or else --- 4885,4891 ---- -- expander does, so we match its logic here). -- The second case is mod where either operand can be negative. ! -- In this case, the back end has to generate additional tests. if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) or else *************** package body Sem_Res is *** 4719,4724 **** --- 4915,4942 ---- Scop : Entity_Id; Rtype : Entity_Id; + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean; + -- Returns True if the subprogram entity S is the same as E or else + -- S is an alias of E. + + --------------------------------- + -- Same_Or_Aliased_Subprograms -- + --------------------------------- + + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean + is + Subp_Alias : constant Entity_Id := Alias (S); + begin + return S = E + or else (Present (Subp_Alias) and then Subp_Alias = E); + end Same_Or_Aliased_Subprograms; + + -- Start of processing for Resolve_Call + begin -- The context imposes a unique interpretation with type Typ on a -- procedure or function call. Find the entity of the subprogram that *************** package body Sem_Res is *** 4884,4890 **** and then Nkind (N) /= N_Entry_Call_Statement and then Entry_Call_Statement (Parent (N)) = N then ! if Ada_Version < Ada_05 then Error_Msg_N ("entry call required in select statement", N); -- Ada 2005 (AI-345): If a procedure_call_statement is used --- 5102,5108 ---- and then Nkind (N) /= N_Entry_Call_Statement and then Entry_Call_Statement (Parent (N)) = N then ! if Ada_Version < Ada_2005 then Error_Msg_N ("entry call required in select statement", N); -- Ada 2005 (AI-345): If a procedure_call_statement is used *************** package body Sem_Res is *** 4990,4996 **** -- An Ada 2005 prefixed call to a primitive operation -- whose first parameter is the prefix. This prefix was -- prepended to the parameter list, which is actually a ! -- list of indices. Remove the prefix in order to build -- the proper indexed component. Index_Node := --- 5208,5214 ---- -- An Ada 2005 prefixed call to a primitive operation -- whose first parameter is the prefix. This prefix was -- prepended to the parameter list, which is actually a ! -- list of indexes. Remove the prefix in order to build -- the proper indexed component. Index_Node := *************** package body Sem_Res is *** 5004,5013 **** --- 5222,5236 ---- Expressions => Parameter_Associations (N)); end if; + -- Preserve the parenthesis count of the node + + Set_Paren_Count (Index_Node, Paren_Count (N)); + -- Since we are correcting a node classification error made -- by the parser, we call Replace rather than Rewrite. Replace (N, Index_Node); + Set_Etype (Prefix (N), Ret_Type); Set_Etype (N, Typ); Resolve_Indexed_Component (N, Typ); *************** package body Sem_Res is *** 5051,5063 **** -- Issue warning for possible infinite recursion in the absence -- of the No_Recursion restriction. ! if Nam = Scop and then not Restriction_Active (No_Recursion) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do ! -- not need to test the case below for further warnings. Also if ! -- we now have a raise SE node, we are all done. if Nkind (N) = N_Raise_Storage_Error then return; --- 5274,5286 ---- -- Issue warning for possible infinite recursion in the absence -- of the No_Recursion restriction. ! if Same_Or_Aliased_Subprograms (Nam, Scop) and then not Restriction_Active (No_Recursion) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do ! -- not need to test the case below for further warnings. Also we ! -- are all done if we now have a raise SE node. if Nkind (N) = N_Raise_Storage_Error then return; *************** package body Sem_Res is *** 5068,5074 **** else Scope_Loop : while Scop /= Standard_Standard loop ! if Nam = Scop then -- Although in general case, recursion is not statically -- checkable, the case of calling an immediately containing --- 5291,5297 ---- else Scope_Loop : while Scop /= Standard_Standard loop ! if Same_Or_Aliased_Subprograms (Nam, Scop) then -- Although in general case, recursion is not statically -- checkable, the case of calling an immediately containing *************** package body Sem_Res is *** 5123,5129 **** K : constant Node_Kind := Nkind (Parent (N)); begin if (K = N_Loop_Statement ! and then Present (Iteration_Scheme (Parent (N)))) or else K = N_If_Statement or else K = N_Elsif_Part or else K = N_Case_Statement_Alternative --- 5346,5352 ---- K : constant Node_Kind := Nkind (Parent (N)); begin if (K = N_Loop_Statement ! and then Present (Iteration_Scheme (Parent (N)))) or else K = N_If_Statement or else K = N_Elsif_Part or else K = N_Case_Statement_Alternative *************** package body Sem_Res is *** 5149,5154 **** --- 5372,5381 ---- end if; end if; + -- Check obsolescent reference to Ada.Characters.Handling subprogram + + Check_Obsolescent_2005_Entity (Nam, Subp); + -- If subprogram name is a predefined operator, it was given in -- functional notation. Replace call node with operator node, so -- that actuals can be resolved appropriately. *************** package body Sem_Res is *** 5316,5324 **** F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop ! if (Ekind (F) = E_Out_Parameter ! or else ! Ekind (F) = E_In_Out_Parameter) and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) --- 5543,5549 ---- F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop ! if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) *************** package body Sem_Res is *** 5357,5366 **** then Generate_Reference (Nam, Subp, 'R'); ! -- Normal case, not a dispatching call else ! Generate_Reference (Nam, Subp); end if; if Is_Intrinsic_Subprogram (Nam) then --- 5582,5591 ---- then Generate_Reference (Nam, Subp, 'R'); ! -- Normal case, not a dispatching call. Generate a call reference. else ! Generate_Reference (Nam, Subp, 's'); end if; if Is_Intrinsic_Subprogram (Nam) then *************** package body Sem_Res is *** 5380,5388 **** Check_Potentially_Blocking_Operation (N); end if; ! -- Issue an error for a call to an eliminated subprogram ! Check_For_Eliminated_Subprogram (Subp, Nam); -- All done, evaluate call and deal with elaboration issues --- 5605,5625 ---- Check_Potentially_Blocking_Operation (N); end if; ! -- A call to Ada.Real_Time.Timing_Events.Set_Handler violates ! -- restriction No_Relative_Delay (AI-0211). ! if Is_RTE (Nam, RE_Set_Handler) then ! Check_Restriction (No_Relative_Delay, N); ! end if; ! ! -- Issue an error for a call to an eliminated subprogram. We skip this ! -- in a spec expression, e.g. a call in a default parameter value, since ! -- we are not really doing a call at this time. That's important because ! -- the spec expression may itself belong to an eliminated subprogram. ! ! if not In_Spec_Expression then ! Check_For_Eliminated_Subprogram (Subp, Nam); ! end if; -- All done, evaluate call and deal with elaboration issues *************** package body Sem_Res is *** 5391,5396 **** --- 5628,5651 ---- Warn_On_Overlapping_Actuals (Nam, N); end Resolve_Call; + ----------------------------- + -- Resolve_Case_Expression -- + ----------------------------- + + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is + Alt : Node_Id; + + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Resolve (Expression (Alt), Typ); + Next (Alt); + end loop; + + Set_Etype (N, Typ); + Eval_Case_Expression (N); + end Resolve_Case_Expression; + ------------------------------- -- Resolve_Character_Literal -- ------------------------------- *************** package body Sem_Res is *** 5506,5535 **** Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); ! if T /= Any_Type then ! if T = Any_String or else ! T = Any_Composite or else ! T = Any_Character ! then ! if T = Any_Character then ! Ambiguous_Character (L); ! else ! Error_Msg_N ("ambiguous operands for comparison", N); ! end if; ! Set_Etype (N, Any_Type); ! return; else ! Resolve (L, T); ! Resolve (R, T); ! Check_Unset_Reference (L); ! Check_Unset_Reference (R); ! Generate_Operator_Reference (N, T); ! Check_Low_Bound_Tested (N); ! Eval_Relational_Op (N); end if; end if; end Resolve_Comparison_Op; ------------------------------------ --- 5761,5809 ---- Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); ! -- Skip remaining processing if already set to Any_Type ! if T = Any_Type then ! return; ! end if; ! ! -- Deal with other error cases + if T = Any_String or else + T = Any_Composite or else + T = Any_Character + then + if T = Any_Character then + Ambiguous_Character (L); else ! Error_Msg_N ("ambiguous operands for comparison", N); end if; + + Set_Etype (N, Any_Type); + return; end if; + + -- Resolve the operands if types OK + + Resolve (L, T); + Resolve (R, T); + Check_Unset_Reference (L); + Check_Unset_Reference (R); + Generate_Operator_Reference (N, T); + Check_Low_Bound_Tested (N); + + -- Check comparison on unordered enumeration + + if Comes_From_Source (N) + and then Bad_Unordered_Enumeration_Reference (N, Etype (L)) + then + Error_Msg_N ("comparison on unordered enumeration type?", N); + end if; + + -- Evaluate the relation (note we do this after the above check + -- since this Eval call may change N to True/False. + + Eval_Relational_Op (N); end Resolve_Comparison_Op; ------------------------------------ *************** package body Sem_Res is *** 5689,5704 **** Set_Etype (N, Typ); Eval_Named_Real (N); ! -- Allow use of subtype only if it is a concurrent type where we are ! -- currently inside the body. This will eventually be expanded into a ! -- call to Self (for tasks) or _object (for protected objects). Any ! -- other use of a subtype is invalid. elsif Is_Type (E) then if Is_Concurrent_Type (E) and then In_Open_Scopes (E) then null; else Error_Msg_N ("invalid use of subtype mark in expression or call", N); --- 5963,5992 ---- Set_Etype (N, Typ); Eval_Named_Real (N); ! -- For enumeration literals, we need to make sure that a proper style ! -- check is done, since such literals are overloaded, and thus we did ! -- not do a style check during the first phase of analysis. ! ! elsif Ekind (E) = E_Enumeration_Literal then ! Set_Entity_With_Style_Check (N, E); ! Eval_Entity_Name (N); ! ! -- Case of subtype name appearing as an operand in expression elsif Is_Type (E) then + + -- Allow use of subtype if it is a concurrent type where we are + -- currently inside the body. This will eventually be expanded into a + -- call to Self (for tasks) or _object (for protected objects). Any + -- other use of a subtype is invalid. + if Is_Concurrent_Type (E) and then In_Open_Scopes (E) then null; + + -- Any other use is an error + else Error_Msg_N ("invalid use of subtype mark in expression or call", N); *************** package body Sem_Res is *** 5743,5749 **** and then not In_Spec_Expression and then not Is_Imported (E) then - if No_Initialization (Parent (E)) or else (Present (Full_View (E)) and then No_Initialization (Parent (Full_View (E)))) --- 6031,6036 ---- *************** package body Sem_Res is *** 5794,5800 **** -- to the discriminant of the same name in the target task. If the -- entry name is the target of a requeue statement and the entry is -- in the current protected object, the bound to be used is the ! -- discriminal of the object (see apply_range_checks for details of -- the transformation). ----------------------------- --- 6081,6087 ---- -- to the discriminant of the same name in the target task. If the -- entry name is the target of a requeue statement and the entry is -- in the current protected object, the bound to be used is the ! -- discriminal of the object (see Apply_Range_Checks for details of -- the transformation). ----------------------------- *************** package body Sem_Res is *** 5817,5823 **** and then In_Open_Scopes (Tsk) and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement then ! return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); else Ref := --- 6104,6117 ---- and then In_Open_Scopes (Tsk) and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement then ! -- Note: here Bound denotes a discriminant of the corresponding ! -- record type tskV, whose discriminal is a formal of the ! -- init-proc tskVIP. What we want is the body discriminal, ! -- which is associated to the discriminant of the original ! -- concurrent type tsk. ! ! return New_Occurrence_Of ! (Find_Body_Discriminal (Entity (Bound)), Loc); else Ref := *************** package body Sem_Res is *** 6084,6089 **** --- 6378,6414 ---- end; end if; + if Ekind_In (Nam, E_Entry, E_Entry_Family) + and then Present (PPC_Wrapper (Nam)) + and then Current_Scope /= PPC_Wrapper (Nam) + then + -- Rewrite as call to the precondition wrapper, adding the task + -- object to the list of actuals. If the call is to a member of + -- an entry family, include the index as well. + + declare + New_Call : Node_Id; + New_Actuals : List_Id; + begin + New_Actuals := New_List (Obj); + + if Nkind (Entry_Name) = N_Indexed_Component then + Append_To (New_Actuals, + New_Copy_Tree (First (Expressions (Entry_Name)))); + end if; + + Append_List (Parameter_Associations (N), New_Actuals); + New_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (PPC_Wrapper (Nam), Loc), + Parameter_Associations => New_Actuals); + Rewrite (N, New_Call); + Analyze_And_Resolve (N); + return; + end; + end if; + -- The operation name may have been overloaded. Order the actuals -- according to the formals of the resolved entity, and set the -- return type to that of the operation. *************** package body Sem_Res is *** 6095,6105 **** end if; Resolve_Actuals (N, Nam); - Generate_Reference (Nam, Entry_Name); ! if Ekind (Nam) = E_Entry ! or else Ekind (Nam) = E_Entry_Family ! then Check_Potentially_Blocking_Operation (N); end if; --- 6420,6431 ---- end if; Resolve_Actuals (N, Nam); ! -- Create a call reference to the entry ! ! Generate_Reference (Nam, Entry_Name, 's'); ! ! if Ekind_In (Nam, E_Entry, E_Entry_Family) then Check_Potentially_Blocking_Operation (N); end if; *************** package body Sem_Res is *** 6183,6194 **** --- 6509,6549 ---- R : constant Node_Id := Right_Opnd (N); T : Entity_Id := Find_Unique_Type (L, R); + procedure Check_Conditional_Expression (Cond : Node_Id); + -- The resolution rule for conditional expressions requires that each + -- such must have a unique type. This means that if several dependent + -- expressions are of a non-null anonymous access type, and the context + -- does not impose an expected type (as can be the case in an equality + -- operation) the expression must be rejected. + function Find_Unique_Access_Type return Entity_Id; -- In the case of allocators, make a last-ditch attempt to find a single -- access type with the right designated type. This is semantically -- dubious, and of no interest to any real code, but c48008a makes it -- all worthwhile. + ---------------------------------- + -- Check_Conditional_Expression -- + ---------------------------------- + + procedure Check_Conditional_Expression (Cond : Node_Id) is + Then_Expr : Node_Id; + Else_Expr : Node_Id; + + begin + if Nkind (Cond) = N_Conditional_Expression then + Then_Expr := Next (First (Expressions (Cond))); + Else_Expr := Next (Then_Expr); + + if Nkind (Then_Expr) /= N_Null + and then Nkind (Else_Expr) /= N_Null + then + Error_Msg_N + ("cannot determine type of conditional expression", Cond); + end if; + end if; + end Check_Conditional_Expression; + ----------------------------- -- Find_Unique_Access_Type -- ----------------------------- *************** package body Sem_Res is *** 6253,6260 **** return; elsif T = Any_Access ! or else Ekind (T) = E_Allocator_Type ! or else Ekind (T) = E_Access_Attribute_Type then T := Find_Unique_Access_Type; --- 6608,6614 ---- return; elsif T = Any_Access ! or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) then T := Find_Unique_Access_Type; *************** package body Sem_Res is *** 6263,6268 **** --- 6617,6635 ---- Set_Etype (N, Any_Type); return; end if; + + -- Conditional expressions must have a single type, and if the + -- context does not impose one the dependent expressions cannot + -- be anonymous access types. + + elsif Ada_Version >= Ada_2012 + and then Ekind_In (Etype (L), E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + and then Ekind_In (Etype (R), E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + then + Check_Conditional_Expression (L); + Check_Conditional_Expression (R); end if; Resolve (L, T); *************** package body Sem_Res is *** 6282,6288 **** and then Entity (R) = Standard_True and then Comes_From_Source (R) then ! Error_Msg_N ("?comparison with True is redundant!", R); end if; Check_Unset_Reference (L); --- 6649,6656 ---- and then Entity (R) = Standard_True and then Comes_From_Source (R) then ! Error_Msg_N -- CODEFIX ! ("?comparison with True is redundant!", R); end if; Check_Unset_Reference (L); *************** package body Sem_Res is *** 6321,6328 **** if Expander_Active and then ! (Ekind (T) = E_Anonymous_Access_Type ! or else Ekind (T) = E_Anonymous_Access_Subprogram_Type or else Is_Private_Type (T)) then if Etype (L) /= T then --- 6689,6696 ---- if Expander_Active and then ! (Ekind_In (T, E_Anonymous_Access_Type, ! E_Anonymous_Access_Subprogram_Type) or else Is_Private_Type (T)) then if Etype (L) /= T then *************** package body Sem_Res is *** 6434,6439 **** --- 6802,6816 ---- end Resolve_Explicit_Dereference; + ------------------------------------- + -- Resolve_Expression_With_Actions -- + ------------------------------------- + + procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + end Resolve_Expression_With_Actions; + ------------------------------- -- Resolve_Indexed_Component -- ------------------------------- *************** package body Sem_Res is *** 6556,6561 **** --- 6933,6956 ---- Warn_On_Suspicious_Index (Name, First (Expressions (N))); Eval_Indexed_Component (N); end if; + + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Indexed_Component + and then (Is_Atomic (Array_Type) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Bit_Packed_Array (Array_Type) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic array", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; end Resolve_Indexed_Component; ----------------------------- *************** package body Sem_Res is *** 6573,6584 **** -------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is ! Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); ! Op : Entity_Id; ! Arg1 : Node_Id; ! Arg2 : Node_Id; begin Op := Entity (N); while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); --- 6968,6987 ---- -------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is ! Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); ! Op : Entity_Id; ! Orig_Op : constant Entity_Id := Entity (N); ! Arg1 : Node_Id; ! Arg2 : Node_Id; begin + -- We must preserve the original entity in a generic setting, so that + -- the legality of the operation can be verified in an instance. + + if not Expander_Active then + return; + end if; + Op := Entity (N); while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); *************** package body Sem_Res is *** 6601,6608 **** Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); end if; ! Save_Interps (Left_Opnd (N), Expression (Arg1)); ! Save_Interps (Right_Opnd (N), Expression (Arg2)); Set_Left_Opnd (N, Arg1); Set_Right_Opnd (N, Arg2); --- 7004,7016 ---- Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); end if; ! if Nkind (Arg1) = N_Type_Conversion then ! Save_Interps (Left_Opnd (N), Expression (Arg1)); ! end if; ! ! if Nkind (Arg2) = N_Type_Conversion then ! Save_Interps (Right_Opnd (N), Expression (Arg2)); ! end if; Set_Left_Opnd (N, Arg1); Set_Right_Opnd (N, Arg2); *************** package body Sem_Res is *** 6615,6633 **** or else Typ /= Etype (Right_Opnd (N)) then -- Add explicit conversion where needed, and save interpretations in ! -- case operands are overloaded. Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N)); if Nkind (Arg1) = N_Type_Conversion then Save_Interps (Left_Opnd (N), Expression (Arg1)); else Save_Interps (Left_Opnd (N), Arg1); end if; if Nkind (Arg2) = N_Type_Conversion then Save_Interps (Right_Opnd (N), Expression (Arg2)); else Save_Interps (Right_Opnd (N), Arg2); end if; --- 7023,7053 ---- or else Typ /= Etype (Right_Opnd (N)) then -- Add explicit conversion where needed, and save interpretations in ! -- case operands are overloaded. If the context is a VMS operation, ! -- assert that the conversion is legal (the operands have the proper ! -- types to select the VMS intrinsic). Note that in rare cases the ! -- VMS operators may be visible, but the default System is being used ! -- and Address is a private type. Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N)); if Nkind (Arg1) = N_Type_Conversion then Save_Interps (Left_Opnd (N), Expression (Arg1)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg1); + end if; else Save_Interps (Left_Opnd (N), Arg1); end if; if Nkind (Arg2) = N_Type_Conversion then Save_Interps (Right_Opnd (N), Expression (Arg2)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg2); + end if; else Save_Interps (Right_Opnd (N), Arg2); end if; *************** package body Sem_Res is *** 6699,6711 **** B_Typ := Base_Type (Typ); end if; -- The following test is required because the operands of the operation -- may be literals, in which case the resulting type appears to be -- compatible with a signed integer type, when in fact it is compatible -- only with modular types. If the context itself is universal, the -- operation is illegal. ! if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid context for logical operation", N); Set_Etype (N, Any_Type); return; --- 7119,7136 ---- B_Typ := Base_Type (Typ); end if; + -- OK if this is a VMS-specific intrinsic operation + + if Is_VMS_Operator (Entity (N)) then + null; + -- The following test is required because the operands of the operation -- may be literals, in which case the resulting type appears to be -- compatible with a signed integer type, when in fact it is compatible -- only with modular types. If the context itself is universal, the -- operation is illegal. ! elsif not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid context for logical operation", N); Set_Etype (N, Any_Type); return; *************** package body Sem_Res is *** 6808,6816 **** -- end Test; -- In this case we have nothing else to do. The membership test will be ! -- done at run-time. ! elsif Ada_Version >= Ada_05 and then Is_Class_Wide_Type (Etype (L)) and then Is_Interface (Etype (L)) and then Is_Class_Wide_Type (Etype (R)) --- 7233,7241 ---- -- end Test; -- In this case we have nothing else to do. The membership test will be ! -- done at run time. ! elsif Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (Etype (L)) and then Is_Interface (Etype (L)) and then Is_Class_Wide_Type (Etype (R)) *************** package body Sem_Res is *** 6822,6827 **** --- 7247,7264 ---- T := Intersect_Types (L, R); end if; + -- If mixed-mode operations are present and operands are all literal, + -- the only interpretation involves Duration, which is probably not + -- the intention of the programmer. + + if T = Any_Fixed then + T := Unique_Fixed_Point_Type (N); + + if T = Any_Type then + return; + end if; + end if; + Resolve (L, T); Check_Unset_Reference (L); *************** package body Sem_Res is *** 6854,6860 **** -- Ada 2005 (AI-231): Remove restriction ! if Ada_Version < Ada_05 and then not Debug_Flag_J and then Ekind (Typ) = E_Anonymous_Access_Type and then Comes_From_Source (N) --- 7291,7297 ---- -- Ada 2005 (AI-231): Remove restriction ! if Ada_Version < Ada_2005 and then not Debug_Flag_J and then Ekind (Typ) = E_Anonymous_Access_Type and then Comes_From_Source (N) *************** package body Sem_Res is *** 6879,6885 **** -- Ada 2005 (AI-231): Generate the null-excluding check in case of -- assignment to a null-excluding object ! if Ada_Version >= Ada_05 and then Can_Never_Be_Null (Typ) and then Nkind (Parent (N)) = N_Assignment_Statement then --- 7316,7322 ---- -- Ada 2005 (AI-231): Generate the null-excluding check in case of -- assignment to a null-excluding object ! if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Typ) and then Nkind (Parent (N)) = N_Assignment_Statement then *************** package body Sem_Res is *** 7249,7257 **** B_Typ := Base_Type (Typ); end if; -- Straightforward case of incorrect arguments ! if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); Set_Etype (N, Any_Type); return; --- 7686,7697 ---- B_Typ := Base_Type (Typ); end if; + if Is_VMS_Operator (Entity (N)) then + null; + -- Straightforward case of incorrect arguments ! elsif not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); Set_Etype (N, Any_Type); return; *************** package body Sem_Res is *** 7349,7357 **** Wrong_Type (Expr, Target_Typ); end if; ! -- If the target type is unconstrained, then we reset the type of ! -- the result from the type of the expression. For other cases, the ! -- actual subtype of the expression is the target type. if Is_Composite_Type (Target_Typ) and then not Is_Constrained (Target_Typ) --- 7789,7797 ---- Wrong_Type (Expr, Target_Typ); end if; ! -- If the target type is unconstrained, then we reset the type of the ! -- result from the type of the expression. For other cases, the actual ! -- subtype of the expression is the target type. if Is_Composite_Type (Target_Typ) and then not Is_Constrained (Target_Typ) *************** package body Sem_Res is *** 7362,7367 **** --- 7802,7823 ---- Eval_Qualified_Expression (N); end Resolve_Qualified_Expression; + ----------------------------------- + -- Resolve_Quantified_Expression -- + ----------------------------------- + + procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is + begin + -- The loop structure is already resolved during its analysis, only the + -- resolution of the condition needs to be done. Expansion is disabled + -- so that checks and other generated code are inserted in the tree + -- after expression has been rewritten as a loop. + + Expander_Mode_Save_And_Set (False); + Resolve (Condition (N), Typ); + Expander_Mode_Restore; + end Resolve_Quantified_Expression; + ------------------- -- Resolve_Range -- ------------------- *************** package body Sem_Res is *** 7370,7380 **** --- 7826,7883 ---- L : constant Node_Id := Low_Bound (N); H : constant Node_Id := High_Bound (N); + function First_Last_Ref return Boolean; + -- Returns True if N is of the form X'First .. X'Last where X is the + -- same entity for both attributes. + + -------------------- + -- First_Last_Ref -- + -------------------- + + function First_Last_Ref return Boolean is + Lorig : constant Node_Id := Original_Node (L); + Horig : constant Node_Id := Original_Node (H); + + begin + if Nkind (Lorig) = N_Attribute_Reference + and then Nkind (Horig) = N_Attribute_Reference + and then Attribute_Name (Lorig) = Name_First + and then Attribute_Name (Horig) = Name_Last + then + declare + PL : constant Node_Id := Prefix (Lorig); + PH : constant Node_Id := Prefix (Horig); + begin + if Is_Entity_Name (PL) + and then Is_Entity_Name (PH) + and then Entity (PL) = Entity (PH) + then + return True; + end if; + end; + end if; + + return False; + end First_Last_Ref; + + -- Start of processing for Resolve_Range + begin Set_Etype (N, Typ); Resolve (L, Typ); Resolve (H, Typ); + -- Check for inappropriate range on unordered enumeration type + + if Bad_Unordered_Enumeration_Reference (N, Typ) + + -- Exclude X'First .. X'Last if X is the same entity for both + + and then not First_Last_Ref + then + Error_Msg ("subrange of unordered enumeration type?", Sloc (N)); + end if; + Check_Unset_Reference (L); Check_Unset_Reference (H); *************** package body Sem_Res is *** 7628,7634 **** Comp := Next_Entity (Comp); end loop; - end if; Get_Next_Interp (I, It); --- 8131,8136 ---- *************** package body Sem_Res is *** 7666,7674 **** end if; if Has_Discriminants (T) ! and then (Ekind (Entity (S)) = E_Component ! or else ! Ekind (Entity (S)) = E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component and then Present (Discriminant_Checking_Func --- 8168,8174 ---- end if; if Has_Discriminants (T) ! and then Ekind_In (Entity (S), E_Component, E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component and then Present (Discriminant_Checking_Func *************** package body Sem_Res is *** 7697,7702 **** --- 8197,8219 ---- -- Note: No Eval processing is required, because the prefix is of a -- record type, or protected type, and neither can possibly be static. + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Selected_Component + and then (Is_Atomic (T) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Packed (T) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic record", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; end Resolve_Selected_Component; ------------------- *************** package body Sem_Res is *** 7772,7786 **** then null; else ! -- Issue warning. Note that we don't want to make this ! -- an unconditional warning, because if the assert is ! -- within deleted code we do not want the warning. But ! -- we do not want the deletion of the IF/AND-THEN to ! -- take this message with it. We achieve this by making ! -- sure that the expanded code points to the Sloc of ! -- the expression, not the original pragma. ! Error_Msg_N ("?assertion would fail at run-time", Orig); end if; end; --- 8289,8303 ---- then null; else ! -- Issue warning. We do not want the deletion of the ! -- IF/AND-THEN to take this message with it. We achieve ! -- this by making sure that the expanded code points to ! -- the Sloc of the expression, not the original pragma. ! Error_Msg_N ! ("?assertion would fail at run time!", ! Expression ! (First (Pragma_Argument_Associations (Orig)))); end if; end; *************** package body Sem_Res is *** 7803,7809 **** then null; else ! Error_Msg_N ("?check would fail at run-time", Orig); end if; end; end if; --- 8320,8329 ---- then null; else ! Error_Msg_N ! ("?check would fail at run time!", ! Expression ! (Last (Pragma_Argument_Associations (Orig)))); end if; end; end if; *************** package body Sem_Res is *** 7905,7910 **** --- 8425,8431 ---- end if; elsif Is_Entity_Name (Name) + or else Nkind (Name) = N_Explicit_Dereference or else (Nkind (Name) = N_Function_Call and then not Is_Constrained (Etype (Name))) then *************** package body Sem_Res is *** 7949,7977 **** Index := First_Index (Array_Type); Resolve (Drange, Base_Type (Etype (Index))); ! if Nkind (Drange) = N_Range -- Do not apply the range check to nodes associated with the -- frontend expansion of the dispatch table. We first check ! -- if Ada.Tags is already loaded to void the addition of an -- undesired dependence on such run-time unit. ! and then ! (not Tagged_Type_Expansion ! or else not ! (RTU_Loaded (Ada_Tags) ! and then Nkind (Prefix (N)) = N_Selected_Component ! and then Present (Entity (Selector_Name (Prefix (N)))) ! and then Entity (Selector_Name (Prefix (N))) = ! RTE_Record_Component (RE_Prims_Ptr))) ! then ! Apply_Range_Check (Drange, Etype (Index)); end if; end if; Set_Slice_Subtype (N); ! if Nkind (Drange) = N_Range then Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; --- 8470,8512 ---- Index := First_Index (Array_Type); Resolve (Drange, Base_Type (Etype (Index))); ! if Nkind (Drange) = N_Range then ! ! -- Ensure that side effects in the bounds are properly handled ! ! Remove_Side_Effects (Low_Bound (Drange), Variable_Ref => True); ! Remove_Side_Effects (High_Bound (Drange), Variable_Ref => True); -- Do not apply the range check to nodes associated with the -- frontend expansion of the dispatch table. We first check ! -- if Ada.Tags is already loaded to avoid the addition of an -- undesired dependence on such run-time unit. ! if not Tagged_Type_Expansion ! or else not ! (RTU_Loaded (Ada_Tags) ! and then Nkind (Prefix (N)) = N_Selected_Component ! and then Present (Entity (Selector_Name (Prefix (N)))) ! and then Entity (Selector_Name (Prefix (N))) = ! RTE_Record_Component (RE_Prims_Ptr)) ! then ! Apply_Range_Check (Drange, Etype (Index)); ! end if; end if; end if; Set_Slice_Subtype (N); ! -- Check bad use of type with predicates ! ! if Has_Predicates (Etype (Drange)) then ! Bad_Predicated_Subtype_Use ! ("subtype& has predicate, not allowed in slice", ! Drange, Etype (Drange)); ! ! -- Otherwise here is where we check suspicious indexes ! ! elsif Nkind (Drange) = N_Range then Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; *************** package body Sem_Res is *** 8262,8267 **** --- 8797,8806 ---- Orig_N : Node_Id; Orig_T : Node_Id; + Test_Redundant : Boolean := Warn_On_Redundant_Constructs; + -- Set to False to suppress cases where we want to suppress the test + -- for redundancy to avoid possible false positives on this warning. + begin if not Conv_OK and then not Valid_Conversion (N, Target_Typ, Operand) *************** package body Sem_Res is *** 8269,8275 **** return; end if; ! if Etype (Operand) = Any_Fixed then -- Mixed-mode operation involving a literal. Context must be a fixed -- type which is applied to the literal subsequently. --- 8808,8827 ---- return; end if; ! -- If the Operand Etype is Universal_Fixed, then the conversion is ! -- never redundant. We need this check because by the time we have ! -- finished the rather complex transformation, the conversion looks ! -- redundant when it is not. ! ! if Operand_Typ = Universal_Fixed then ! Test_Redundant := False; ! ! -- If the operand is marked as Any_Fixed, then special processing is ! -- required. This is also a case where we suppress the test for a ! -- redundant conversion, since most certainly it is not redundant. ! ! elsif Operand_Typ = Any_Fixed then ! Test_Redundant := False; -- Mixed-mode operation involving a literal. Context must be a fixed -- type which is applied to the literal subsequently. *************** package body Sem_Res is *** 8375,8383 **** Orig_N := Original_Node (N); ! if Warn_On_Redundant_Constructs ! and then Comes_From_Source (Orig_N) and then Nkind (Orig_N) = N_Type_Conversion and then not In_Instance then Orig_N := Original_Node (Expression (Orig_N)); --- 8927,8939 ---- Orig_N := Original_Node (N); ! -- Here we test for a redundant conversion if the warning mode is ! -- active (and was not locally reset), and we have a type conversion ! -- from source not appearing in a generic instance. ! ! if Test_Redundant and then Nkind (Orig_N) = N_Type_Conversion + and then Comes_From_Source (Orig_N) and then not In_Instance then Orig_N := Original_Node (Expression (Orig_N)); *************** package body Sem_Res is *** 8393,8404 **** Orig_T := Etype (Parent (N)); end if; ! if Is_Entity_Name (Orig_N) ! and then ! (Etype (Entity (Orig_N)) = Orig_T ! or else ! (Ekind (Entity (Orig_N)) = E_Loop_Parameter ! and then Covers (Orig_T, Etype (Entity (Orig_N))))) then -- One more check, do not give warning if the analyzed conversion -- has an expression with non-static bounds, and the bounds of the --- 8949,8969 ---- Orig_T := Etype (Parent (N)); end if; ! -- If we have an entity name, then give the warning if the entity ! -- is the right type, or if it is a loop parameter covered by the ! -- original type (that's needed because loop parameters have an ! -- odd subtype coming from the bounds). ! ! if (Is_Entity_Name (Orig_N) ! and then ! (Etype (Entity (Orig_N)) = Orig_T ! or else ! (Ekind (Entity (Orig_N)) = E_Loop_Parameter ! and then Covers (Orig_T, Etype (Entity (Orig_N)))))) ! ! -- If not an entity, then type of expression must match ! ! or else Etype (Orig_N) = Orig_T then -- One more check, do not give warning if the analyzed conversion -- has an expression with non-static bounds, and the bounds of the *************** package body Sem_Res is *** 8411,8423 **** then null; ! -- Here we give the redundant conversion warning else ! Error_Msg_Node_2 := Orig_T; ! Error_Msg_NE -- CODEFIX ! ("?redundant conversion, & is of type &!", ! N, Entity (Orig_N)); end if; end if; end if; --- 8976,9018 ---- then null; ! -- Finally, if this type conversion occurs in a context that ! -- requires a prefix, and the expression is a qualified expression ! -- then the type conversion is not redundant, because a qualified ! -- expression is not a prefix, whereas a type conversion is. For ! -- example, "X := T'(Funx(...)).Y;" is illegal because a selected ! -- component requires a prefix, but a type conversion makes it ! -- legal: "X := T(T'(Funx(...))).Y;" ! ! -- In Ada 2012, a qualified expression is a name, so this idiom is ! -- no longer needed, but we still suppress the warning because it ! -- seems unfriendly for warnings to pop up when you switch to the ! -- newer language version. ! ! elsif Nkind (Orig_N) = N_Qualified_Expression ! and then Nkind_In (Parent (N), N_Attribute_Reference, ! N_Indexed_Component, ! N_Selected_Component, ! N_Slice, ! N_Explicit_Dereference) ! then ! null; ! ! -- Here we give the redundant conversion warning. If it is an ! -- entity, give the name of the entity in the message. If not, ! -- just mention the expression. else ! if Is_Entity_Name (Orig_N) then ! Error_Msg_Node_2 := Orig_T; ! Error_Msg_NE -- CODEFIX ! ("?redundant conversion, & is of type &!", ! N, Entity (Orig_N)); ! else ! Error_Msg_NE ! ("?redundant conversion, expression is of type&!", ! N, Orig_T); ! end if; end if; end if; end if; *************** package body Sem_Res is *** 8426,8432 **** -- No need to perform any interface conversion if the type of the -- expression coincides with the target type. ! if Ada_Version >= Ada_05 and then Expander_Active and then Operand_Typ /= Target_Typ then --- 9021,9027 ---- -- No need to perform any interface conversion if the type of the -- expression coincides with the target type. ! if Ada_Version >= Ada_2005 and then Expander_Active and then Operand_Typ /= Target_Typ then *************** package body Sem_Res is *** 8436,8446 **** begin if Is_Access_Type (Opnd) then ! Opnd := Directly_Designated_Type (Opnd); end if; if Is_Access_Type (Target_Typ) then ! Target := Directly_Designated_Type (Target); end if; if Opnd = Target then --- 9031,9041 ---- begin if Is_Access_Type (Opnd) then ! Opnd := Designated_Type (Opnd); end if; if Is_Access_Type (Target_Typ) then ! Target := Designated_Type (Target); end if; if Opnd = Target then *************** package body Sem_Res is *** 8454,8460 **** if From_With_Type (Opnd) then Error_Msg_Qual_Level := 99; ! Error_Msg_NE ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); Error_Msg_N ("type conversions require visibility of the full view", --- 9049,9056 ---- if From_With_Type (Opnd) then Error_Msg_Qual_Level := 99; ! Error_Msg_NE -- CODEFIX ! ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); Error_Msg_N ("type conversions require visibility of the full view", *************** package body Sem_Res is *** 8466,8472 **** and then Present (Non_Limited_View (Etype (Target)))) then Error_Msg_Qual_Level := 99; ! Error_Msg_NE ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); Error_Msg_N ("type conversions require visibility of the full view", --- 9062,9069 ---- and then Present (Non_Limited_View (Etype (Target)))) then Error_Msg_Qual_Level := 99; ! Error_Msg_NE -- CODEFIX ! ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); Error_Msg_N ("type conversions require visibility of the full view", *************** package body Sem_Res is *** 8482,8490 **** -- Handle subtypes ! if Ekind (Opnd) = E_Protected_Subtype ! or else Ekind (Opnd) = E_Task_Subtype ! then Opnd := Etype (Opnd); end if; --- 9079,9085 ---- -- Handle subtypes ! if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then Opnd := Etype (Opnd); end if; *************** package body Sem_Res is *** 8497,8503 **** -- The static analysis is not enough to know if the -- interface is implemented or not. Hence we must pass -- the work to the expander to generate code to evaluate ! -- the conversion at run-time. Expand_Interface_Conversion (N, Is_Static => False); --- 9092,9098 ---- -- The static analysis is not enough to know if the -- interface is implemented or not. Hence we must pass -- the work to the expander to generate code to evaluate ! -- the conversion at run time. Expand_Interface_Conversion (N, Is_Static => False); *************** package body Sem_Res is *** 8560,8566 **** Determine_Range (Right_Opnd (N), OK, Lo, Hi); if OK and then Hi >= Lo and then Lo >= 0 then ! Error_Msg_N ("?abs applied to known non-negative value has no effect", N); end if; end if; --- 9155,9161 ---- Determine_Range (Right_Opnd (N), OK, Lo, Hi); if OK and then Hi >= Lo and then Lo >= 0 then ! Error_Msg_N -- CODEFIX ("?abs applied to known non-negative value has no effect", N); end if; end if; *************** package body Sem_Res is *** 8736,8742 **** Resolve (Operand, Opnd_Type); Eval_Unchecked_Conversion (N); - end Resolve_Unchecked_Type_Conversion; ------------------------------ --- 9331,9336 ---- *************** package body Sem_Res is *** 8784,8792 **** -- Exclude user-defined intrinsic operations of the same name, which are -- treated separately and rewritten as calls. ! if Ekind (Op) /= E_Function ! or else Chars (N) /= Nam ! then Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); Set_Chars (Op_Node, Nam); Set_Etype (Op_Node, Etype (N)); --- 9378,9384 ---- -- Exclude user-defined intrinsic operations of the same name, which are -- treated separately and rewritten as calls. ! if Ekind (Op) /= E_Function or else Chars (N) /= Nam then Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); Set_Chars (Op_Node, Nam); Set_Etype (Op_Node, Etype (N)); *************** package body Sem_Res is *** 8805,8813 **** Rewrite (N, Op_Node); ! -- If the context type is private, add the appropriate conversions ! -- so that the operator is applied to the full view. This is done ! -- in the routines that resolve intrinsic operators, if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) --- 9397,9405 ---- Rewrite (N, Op_Node); ! -- If the context type is private, add the appropriate conversions so ! -- that the operator is applied to the full view. This is done in the ! -- routines that resolve intrinsic operators. if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) *************** package body Sem_Res is *** 8825,8836 **** end case; end if; ! elsif Ekind (Op) = E_Function ! and then Is_Intrinsic_Subprogram (Op) ! then ! -- Operator renames a user-defined operator of the same name. Use ! -- the original operator in the node, which is the one that Gigi ! -- knows about. Set_Entity (N, Op); Set_Is_Overloaded (N, False); --- 9417,9426 ---- end case; end if; ! elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then ! ! -- Operator renames a user-defined operator of the same name. Use the ! -- original operator in the node, which is the one Gigi knows about. Set_Entity (N, Op); Set_Is_Overloaded (N, False); *************** package body Sem_Res is *** 8841,8852 **** -- Set_Slice_Subtype -- ----------------------- ! -- Build an implicit subtype declaration to represent the type delivered ! -- by the slice. This is an abbreviated version of an array subtype. We ! -- define an index subtype for the slice, using either the subtype name ! -- or the discrete range of the slice. To be consistent with index usage ! -- elsewhere, we create a list header to hold the single index. This list ! -- is not otherwise attached to the syntax tree. procedure Set_Slice_Subtype (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); --- 9431,9442 ---- -- Set_Slice_Subtype -- ----------------------- ! -- Build an implicit subtype declaration to represent the type delivered by ! -- the slice. This is an abbreviated version of an array subtype. We define ! -- an index subtype for the slice, using either the subtype name or the ! -- discrete range of the slice. To be consistent with index usage elsewhere ! -- we create a list header to hold the single index. This list is not ! -- otherwise attached to the syntax tree. procedure Set_Slice_Subtype (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); *************** package body Sem_Res is *** 8877,8883 **** Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); ! Set_Scalar_Range (Index_Subtype, Drange); Set_Etype (Index_Subtype, Index_Type); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); --- 9467,9483 ---- Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); ! -- Take a new copy of Drange (where bounds have been rewritten to ! -- reference side-effect-free names). Using a separate tree ensures ! -- that further expansion (e.g. while rewriting a slice assignment ! -- into a FOR loop) does not attempt to remove side effects on the ! -- bounds again (which would cause the bounds in the index subtype ! -- definition to refer to temporaries before they are defined) (the ! -- reason is that some names are considered side effect free here ! -- for the subtype, but not in the context of a loop iteration ! -- scheme). ! ! Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); Set_Etype (Index_Subtype, Index_Type); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); *************** package body Sem_Res is *** 8900,8917 **** Set_Etype (N, Slice_Subtype); ! -- In the packed case, this must be immediately frozen ! ! -- Couldn't we always freeze here??? and if we did, then the above ! -- call to Check_Compile_Time_Size could be eliminated, which would ! -- be nice, because then that routine could be made private to Freeze. ! ! -- Why the test for In_Spec_Expression here ??? if Is_Packed (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); - end if; end Set_Slice_Subtype; -------------------------------- --- 9500,9521 ---- Set_Etype (N, Slice_Subtype); ! -- For packed slice subtypes, freeze immediately (except in the ! -- case of being in a "spec expression" where we never freeze ! -- when we first see the expression). if Is_Packed (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); + -- For all other cases insert an itype reference in the slice's actions + -- so that the itype is frozen at the proper place in the tree (i.e. at + -- the point where actions for the slice are analyzed). Note that this + -- is different from freezing the itype immediately, which might be + -- premature (e.g. if the slice is within a transient scope). + + else + Ensure_Defined (Typ => Slice_Subtype, N => N); + end if; end Set_Slice_Subtype; -------------------------------- *************** package body Sem_Res is *** 8938,8947 **** if Is_OK_Static_Expression (Low_Bound) then ! -- The low bound is set from the low bound of the corresponding ! -- index type. Note that we do not store the high bound in the ! -- string literal subtype, but it can be deduced if necessary ! -- from the length and the low bound. Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); --- 9542,9551 ---- if Is_OK_Static_Expression (Low_Bound) then ! -- The low bound is set from the low bound of the corresponding index ! -- type. Note that we do not store the high bound in the string literal ! -- subtype, but it can be deduced if necessary from the length and the ! -- low bound. Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); *************** package body Sem_Res is *** 8981,8989 **** -- be used when generating attributes of the string, for example -- in the context of a slice assignment. ! Set_Etype (Index_Subtype, Base_Type (Index_Type)); ! Set_Size_Info (Index_Subtype, Index_Type); ! Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); Array_Subtype := Create_Itype (E_Array_Subtype, N); --- 9585,9593 ---- -- be used when generating attributes of the string, for example -- in the context of a slice assignment. ! Set_Etype (Index_Subtype, Base_Type (Index_Type)); ! Set_Size_Info (Index_Subtype, Index_Type); ! Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); Array_Subtype := Create_Itype (E_Array_Subtype, N); *************** package body Sem_Res is *** 9034,9040 **** -- ityp (x) ! -- with the Float_Truncate flag set, which is more efficient then Rewrite (Operand, --- 9638,9644 ---- -- ityp (x) ! -- with the Float_Truncate flag set, which is more efficient. then Rewrite (Operand, *************** package body Sem_Res is *** 9162,9169 **** -- Specifically test for validity of tagged conversions function Valid_Array_Conversion return Boolean; ! -- Check index and component conformance, and accessibility levels ! -- if the component types are anonymous access types (Ada 2005) ---------------------- -- Conversion_Check -- --- 9766,9773 ---- -- Specifically test for validity of tagged conversions function Valid_Array_Conversion return Boolean; ! -- Check index and component conformance, and accessibility levels if ! -- the component types are anonymous access types (Ada 2005). ---------------------- -- Conversion_Check -- *************** package body Sem_Res is *** 9253,9261 **** -- out-of-scope references. elsif ! (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type ! or else ! Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type) and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) and then Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) --- 9857,9864 ---- -- out-of-scope references. elsif ! Ekind_In (Target_Comp_Base, E_Anonymous_Access_Type, ! E_Anonymous_Access_Subprogram_Type) and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) and then Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) *************** package body Sem_Res is *** 9384,9389 **** --- 9987,9993 ---- It : Interp; It1 : Interp; N1 : Entity_Id; + T1 : Entity_Id; begin -- Remove procedure calls, which syntactically cannot appear in *************** package body Sem_Res is *** 9397,9406 **** -- is no context type and the removal of the spurious operations -- must be done explicitly here. ! -- The node may be labelled overloaded, but still contain only ! -- one interpretation because others were discarded in previous ! -- filters. If this is the case, retain the single interpretation ! -- if legal. Get_First_Interp (Operand, I, It); Opnd_Type := It.Typ; --- 10001,10009 ---- -- is no context type and the removal of the spurious operations -- must be done explicitly here. ! -- The node may be labelled overloaded, but still contain only one ! -- interpretation because others were discarded earlier. If this ! -- is the case, retain the single interpretation if legal. Get_First_Interp (Operand, I, It); Opnd_Type := It.Typ; *************** package body Sem_Res is *** 9440,9455 **** if Present (It.Typ) then N1 := It1.Nam; It1 := Disambiguate (Operand, I1, I, Any_Type); if It1 = No_Interp then Error_Msg_N ("ambiguous operand in conversion", Operand); ! Error_Msg_Sloc := Sloc (It.Nam); Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); ! Error_Msg_Sloc := Sloc (N1); Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); --- 10043,10072 ---- if Present (It.Typ) then N1 := It1.Nam; + T1 := It1.Typ; It1 := Disambiguate (Operand, I1, I, Any_Type); if It1 = No_Interp then Error_Msg_N ("ambiguous operand in conversion", Operand); ! -- If the interpretation involves a standard operator, use ! -- the location of the type, which may be user-defined. ! ! if Sloc (It.Nam) = Standard_Location then ! Error_Msg_Sloc := Sloc (It.Typ); ! else ! Error_Msg_Sloc := Sloc (It.Nam); ! end if; ! Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); ! if Sloc (N1) = Standard_Location then ! Error_Msg_Sloc := Sloc (T1); ! else ! Error_Msg_Sloc := Sloc (N1); ! end if; ! Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); *************** package body Sem_Res is *** 9484,9490 **** -- this situation can arise in source code. elsif In_Instance or else In_Inlined_Body then ! return True; -- Otherwise we need the conversion check --- 10101,10107 ---- -- this situation can arise in source code. elsif In_Instance or else In_Inlined_Body then ! return True; -- Otherwise we need the conversion check *************** package body Sem_Res is *** 9501,9508 **** or else Opnd_Type = Any_Composite or else Opnd_Type = Any_String then ! Error_Msg_N ! ("illegal operand for array conversion", Operand); return False; else return Valid_Array_Conversion; --- 10118,10124 ---- or else Opnd_Type = Any_Composite or else Opnd_Type = Any_String then ! Error_Msg_N ("illegal operand for array conversion", Operand); return False; else return Valid_Array_Conversion; *************** package body Sem_Res is *** 9511,9519 **** -- Ada 2005 (AI-251): Anonymous access types where target references an -- interface type. ! elsif (Ekind (Target_Type) = E_General_Access_Type ! or else ! Ekind (Target_Type) = E_Anonymous_Access_Type) and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the --- 10127,10134 ---- -- Ada 2005 (AI-251): Anonymous access types where target references an -- interface type. ! elsif Ekind_In (Target_Type, E_General_Access_Type, ! E_Anonymous_Access_Type) and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the *************** package body Sem_Res is *** 9582,9589 **** if Is_Entity_Name (Operand) and then not Is_Local_Anonymous_Access (Opnd_Type) ! and then (Ekind (Entity (Operand)) = E_In_Parameter ! or else Ekind (Entity (Operand)) = E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N --- 10197,10204 ---- if Is_Entity_Name (Operand) and then not Is_Local_Anonymous_Access (Opnd_Type) ! and then ! Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N *************** package body Sem_Res is *** 9598,9612 **** -- General and anonymous access types ! elsif (Ekind (Target_Type) = E_General_Access_Type ! or else Ekind (Target_Type) = E_Anonymous_Access_Type) and then Conversion_Check (Is_Access_Type (Opnd_Type) ! and then Ekind (Opnd_Type) /= ! E_Access_Subprogram_Type ! and then Ekind (Opnd_Type) /= ! E_Access_Protected_Subprogram_Type, "must be an access-to-object type") then if Is_Access_Constant (Opnd_Type) --- 10213,10226 ---- -- General and anonymous access types ! elsif Ekind_In (Target_Type, E_General_Access_Type, ! E_Anonymous_Access_Type) and then Conversion_Check (Is_Access_Type (Opnd_Type) ! and then not ! Ekind_In (Opnd_Type, E_Access_Subprogram_Type, ! E_Access_Protected_Subprogram_Type), "must be an access-to-object type") then if Is_Access_Constant (Opnd_Type) *************** package body Sem_Res is *** 9656,9662 **** elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type and then not Is_Local_Anonymous_Access (Opnd_Type) then - -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by -- the prefix of the selected name (Object_Access_Level handles --- 10270,10275 ---- *************** package body Sem_Res is *** 9693,9700 **** -- access type. if Is_Entity_Name (Operand) ! and then (Ekind (Entity (Operand)) = E_In_Parameter ! or else Ekind (Entity (Operand)) = E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N --- 10306,10313 ---- -- access type. if Is_Entity_Name (Operand) ! and then ! Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N *************** package body Sem_Res is *** 9797,9807 **** end Check_Limited; -- Access to subprogram types. If the operand is an access parameter, ! -- the type has a deeper accessibility that any master, and cannot ! -- be assigned. We must make an exception if the conversion is part ! -- of an assignment and the target is the return object of an extended ! -- return statement, because in that case the accessibility check ! -- takes place after the return. elsif Is_Access_Subprogram_Type (Target_Type) and then No (Corresponding_Remote_Type (Opnd_Type)) --- 10410,10420 ---- end Check_Limited; -- Access to subprogram types. If the operand is an access parameter, ! -- the type has a deeper accessibility that any master, and cannot be ! -- assigned. We must make an exception if the conversion is part of an ! -- assignment and the target is the return object of an extended return ! -- statement, because in that case the accessibility check takes place ! -- after the return. elsif Is_Access_Subprogram_Type (Target_Type) and then No (Corresponding_Remote_Type (Opnd_Type)) *************** package body Sem_Res is *** 9889,9895 **** -- If both are tagged types, check legality of view conversions elsif Is_Tagged_Type (Target_Type) ! and then Is_Tagged_Type (Opnd_Type) then return Valid_Tagged_Conversion (Target_Type, Opnd_Type); --- 10502,10509 ---- -- If both are tagged types, check legality of view conversions elsif Is_Tagged_Type (Target_Type) ! and then ! Is_Tagged_Type (Opnd_Type) then return Valid_Tagged_Conversion (Target_Type, Opnd_Type); *************** package body Sem_Res is *** 9898,9905 **** elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then return True; ! -- In an instance or an inlined body, there may be inconsistent ! -- views of the same type, or of types derived from a common root. elsif (In_Instance or In_Inlined_Body) and then --- 10512,10519 ---- elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then return True; ! -- In an instance or an inlined body, there may be inconsistent views of ! -- the same type, or of types derived from a common root. elsif (In_Instance or In_Inlined_Body) and then *************** package body Sem_Res is *** 9914,9920 **** and then Is_Access_Type (Opnd_Type) then Error_Msg_N ("target type must be general access type!", N); ! Error_Msg_NE ("add ALL to }!", N, Target_Type); return False; else --- 10528,10535 ---- and then Is_Access_Type (Opnd_Type) then Error_Msg_N ("target type must be general access type!", N); ! Error_Msg_NE -- CODEFIX ! ("add ALL to }!", N, Target_Type); return False; else diff -Nrcpad gcc-4.5.2/gcc/ada/sem_scil.adb gcc-4.6.0/gcc/ada/sem_scil.adb *** gcc-4.5.2/gcc/ada/sem_scil.adb Mon Nov 30 14:24:04 2009 --- gcc-4.6.0/gcc/ada/sem_scil.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2009-2010, 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- -- *************** *** 23,671 **** -- -- ------------------------------------------------------------------------------ ! with Einfo; use Einfo; ! with Namet; use Namet; ! with Nlists; use Nlists; ! with Opt; use Opt; ! with Rtsfind; use Rtsfind; ! with Sem; use Sem; ! with Sem_Aux; use Sem_Aux; ! with Sem_Util; use Sem_Util; ! with Sinfo; use Sinfo; ! with Snames; use Snames; ! with Stand; use Stand; package body Sem_SCIL is - ---------------------- - -- Adjust_SCIL_Node -- - ---------------------- - - procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is - SCIL_Node : Node_Id; - - begin - pragma Assert (Generate_SCIL); - - -- Check cases in which no action is required. Currently the only SCIL - -- nodes that may require adjustment are those of dispatching calls - -- internally generated by the frontend. - - if Comes_From_Source (Old_Node) - or else not - Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement) - then - return; - - -- Conditional expression associated with equality operator. Old_Node - -- may be part of the expansion of the predefined equality operator of - -- a tagged type and hence we need to check if it has a SCIL dispatching - -- node that needs adjustment. - - elsif Nkind (Old_Node) = N_Conditional_Expression - and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq - or else - (Nkind (Original_Node (Old_Node)) = N_Function_Call - and then Chars (Name (Original_Node (Old_Node))) = - Name_Op_Eq)) - then - null; - - -- Type conversions may involve dispatching calls to functions whose - -- associated SCIL dispatching node needs adjustment. - - elsif Nkind_In (Old_Node, N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - null; - - -- Relocated subprogram call - - elsif Nkind (Old_Node) = Nkind (New_Node) - and then Original_Node (Old_Node) = Original_Node (New_Node) - then - null; - - else - return; - end if; - - -- Search for the SCIL node and update it (if found) - - SCIL_Node := Find_SCIL_Node (Old_Node); - - if Present (SCIL_Node) then - Set_SCIL_Related_Node (SCIL_Node, New_Node); - end if; - end Adjust_SCIL_Node; - --------------------- -- Check_SCIL_Node -- --------------------- function Check_SCIL_Node (N : Node_Id) return Traverse_Result is ! Ctrl_Tag : Node_Id; ! Ctrl_Typ : Entity_Id; begin ! if Nkind (N) = N_SCIL_Membership_Test then ! ! -- Check contents of the boolean expression associated with the ! -- membership test. ! ! pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier ! and then Etype (SCIL_Related_Node (N)) = Standard_Boolean); ! ! -- Check the entity identifier of the associated tagged type (that ! -- is, in testing for membership in T'Class, the entity id of the ! -- specific type T). ! ! -- Note: When the SCIL node is generated the private and full-view ! -- of the tagged types may have been swapped and hence the node ! -- referenced by attribute SCIL_Entity may be the private view. ! -- Therefore, in order to uniformily locate the full-view we use ! -- attribute Underlying_Type. ! ! pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N)))); ! ! -- Interface types are unsupported ! ! pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N)))); ! ! -- Check the decoration of the expression that denotes the tag value ! -- being tested ! ! Ctrl_Tag := SCIL_Tag_Value (N); ! ! case Nkind (Ctrl_Tag) is ! ! -- For class-wide membership tests the SCIL tag value is the tag ! -- of the tested object (i.e. Obj.Tag). ! ! when N_Selected_Component => ! pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); ! null; ! ! when others => ! pragma Assert (False); ! null; ! ! end case; ! ! return Skip; ! ! elsif Nkind (N) = N_SCIL_Dispatching_Call then ! Ctrl_Tag := SCIL_Controlling_Tag (N); ! ! -- SCIL_Related_Node of SCIL dispatching call nodes MUST reference ! -- subprogram calls. ! ! if not Nkind_In (SCIL_Related_Node (N), N_Function_Call, ! N_Procedure_Call_Statement) ! then ! pragma Assert (False); ! raise Program_Error; ! ! -- In simple cases the controlling tag is the tag of the controlling ! -- argument (i.e. Obj.Tag). ! ! elsif Nkind (Ctrl_Tag) = N_Selected_Component then ! Ctrl_Typ := Etype (Ctrl_Tag); ! ! -- Interface types are unsupported ! ! if Is_Interface (Ctrl_Typ) ! or else (RTE_Available (RE_Interface_Tag) ! and then Ctrl_Typ = RTE (RE_Interface_Tag)) ! then ! null; ! ! else ! pragma Assert (Ctrl_Typ = RTE (RE_Tag)); ! null; ! end if; ! ! -- When the controlling tag of a dispatching call is an identifier ! -- the SCIL_Controlling_Tag attribute references the corresponding ! -- object or parameter declaration. Interface types are still ! -- unsupported. ! ! elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, ! N_Parameter_Specification) ! then ! Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); ! ! -- Interface types are unsupported. ! ! if Is_Interface (Ctrl_Typ) ! or else (RTE_Available (RE_Interface_Tag) ! and then Ctrl_Typ = RTE (RE_Interface_Tag)) ! or else (Is_Access_Type (Ctrl_Typ) ! and then ! Is_Interface ! (Available_View ! (Base_Type (Designated_Type (Ctrl_Typ))))) ! then ! null; ! ! else ! pragma Assert ! (Ctrl_Typ = RTE (RE_Tag) ! or else ! (Is_Access_Type (Ctrl_Typ) ! and then Available_View ! (Base_Type (Designated_Type (Ctrl_Typ))) = ! RTE (RE_Tag))); ! null; ! end if; ! ! -- Interface types are unsupported ! ! elsif Is_Interface (Etype (Ctrl_Tag)) then ! null; ! ! else ! pragma Assert (False); ! raise Program_Error; ! end if; ! ! return Skip; ! ! -- Node is not N_SCIL_Dispatching_Call ! else return OK; end if; - end Check_SCIL_Node; - - -------------------- - -- Find_SCIL_Node -- - -------------------- ! function Find_SCIL_Node (Node : Node_Id) return Node_Id is ! Found_Node : Node_Id; ! -- This variable stores the last node found by the nested subprogram ! -- Find_SCIL_Node. ! ! function Find_SCIL_Node (L : List_Id) return Boolean; ! -- Searches in list L for a SCIL node associated with a dispatching call ! -- whose SCIL_Related_Node is Node. If found returns true and stores the ! -- SCIL node in Found_Node; otherwise returns False and sets Found_Node ! -- to Empty. ! ! -------------------- ! -- Find_SCIL_Node -- ! -------------------- ! ! function Find_SCIL_Node (L : List_Id) return Boolean is ! N : Node_Id; ! ! begin ! N := First (L); ! while Present (N) loop ! if Nkind (N) in N_SCIL_Node ! and then SCIL_Related_Node (N) = Node ! then ! Found_Node := N; ! return True; ! end if; ! ! Next (N); ! end loop; ! ! Found_Node := Empty; ! return False; ! end Find_SCIL_Node; ! ! -- Local variables ! ! P : Node_Id; ! ! -- Start of processing for Find_SCIL_Node ! begin ! pragma Assert (Generate_SCIL); ! -- Search for the SCIL node in list associated with a transient scope ! if Scope_Is_Transient then ! declare ! SE : Scope_Stack_Entry ! renames Scope_Stack.Table (Scope_Stack.Last); ! begin ! if SE.Is_Transient ! and then Present (SE.Actions_To_Be_Wrapped_Before) ! and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before) then ! return Found_Node; ! end if; ! end; ! end if; ! -- Otherwise climb up the tree searching for the SCIL node analyzing ! -- all the lists in which Insert_Actions may have inserted it ! P := Node; ! while Present (P) loop ! case Nkind (P) is ! -- Actions associated with AND THEN or OR ELSE ! when N_Short_Circuit => ! if Present (Actions (P)) ! and then Find_SCIL_Node (Actions (P)) then ! return Found_Node; ! end if; ! ! -- Actions of conditional expressions ! when N_Conditional_Expression => ! if (Present (Then_Actions (P)) ! and then Find_SCIL_Node (Actions (P))) ! or else ! (Present (Else_Actions (P)) ! and then Find_SCIL_Node (Else_Actions (P))) ! then ! return Found_Node; end if; ! -- Actions in handled sequence of statements ! when ! N_Handled_Sequence_Of_Statements => ! if Find_SCIL_Node (Statements (P)) then ! return Found_Node; ! end if; ! -- Conditions of while expression or elsif. ! when N_Iteration_Scheme | ! N_Elsif_Part ! => ! if Present (Condition_Actions (P)) ! and then Find_SCIL_Node (Condition_Actions (P)) then - return Found_Node; - end if; - - -- Statements, declarations, pragmas, representation clauses - - when - -- Statements - - N_Procedure_Call_Statement | - N_Statement_Other_Than_Procedure_Call | - - -- Pragmas - - N_Pragma | - - -- Representation_Clause - - N_At_Clause | - N_Attribute_Definition_Clause | - N_Enumeration_Representation_Clause | - N_Record_Representation_Clause | - - -- Declarations - - N_Abstract_Subprogram_Declaration | - N_Entry_Body | - N_Exception_Declaration | - N_Exception_Renaming_Declaration | - N_Formal_Abstract_Subprogram_Declaration | - N_Formal_Concrete_Subprogram_Declaration | - N_Formal_Object_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Function_Instantiation | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Generic_Subprogram_Declaration | - N_Implicit_Label_Declaration | - N_Incomplete_Type_Declaration | - N_Number_Declaration | - N_Object_Declaration | - N_Object_Renaming_Declaration | - N_Package_Body | - N_Package_Body_Stub | - N_Package_Declaration | - N_Package_Instantiation | - N_Package_Renaming_Declaration | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Procedure_Instantiation | - N_Protected_Body | - N_Protected_Body_Stub | - N_Protected_Type_Declaration | - N_Single_Task_Declaration | - N_Subprogram_Body | - N_Subprogram_Body_Stub | - N_Subprogram_Declaration | - N_Subprogram_Renaming_Declaration | - N_Subtype_Declaration | - N_Task_Body | - N_Task_Body_Stub | - N_Task_Type_Declaration | - - -- Freeze entity behaves like a declaration or statement - - N_Freeze_Entity - => - -- Do not search here if the item is not a list member - - if not Is_List_Member (P) then - null; - - -- Do not search if parent of P is an N_Component_Association - -- node (i.e. we are in the context of an N_Aggregate or - -- N_Extension_Aggregate node). In this case the node should - -- have been added before the entire aggregate. - - elsif Nkind (Parent (P)) = N_Component_Association then null; ! -- Do not search if the parent of P is either an N_Variant ! -- node or an N_Record_Definition node. In this case the node ! -- should have been added before the entire record. ! ! elsif Nkind (Parent (P)) = N_Variant ! or else Nkind (Parent (P)) = N_Record_Definition ! then null; - - -- Otherwise search it in the list containing this node - - elsif Find_SCIL_Node (List_Containing (P)) then - return Found_Node; end if; ! -- A special case, N_Raise_xxx_Error can act either as a statement ! -- or a subexpression. We diferentiate them by looking at the ! -- Etype. It is set to Standard_Void_Type in the statement case. ! ! when ! N_Raise_xxx_Error => ! if Etype (P) = Standard_Void_Type then ! if Is_List_Member (P) ! and then Find_SCIL_Node (List_Containing (P)) ! then ! return Found_Node; ! end if; ! -- In the subexpression case, keep climbing ! else ! null; ! end if; ! -- If a component association appears within a loop created for ! -- an array aggregate, check if the SCIL node was added to the ! -- the list of nodes attached to the association. ! when ! N_Component_Association => ! if Nkind (Parent (P)) = N_Aggregate ! and then Present (Loop_Actions (P)) ! and then Find_SCIL_Node (Loop_Actions (P)) ! then ! return Found_Node; ! end if; ! -- Another special case, an attribute denoting a procedure call ! when ! N_Attribute_Reference => ! if Is_Procedure_Attribute_Name (Attribute_Name (P)) ! and then Find_SCIL_Node (List_Containing (P)) ! then ! return Found_Node; ! -- In the subexpression case, keep climbing ! else ! null; ! end if; ! -- SCIL nodes do not have subtrees and hence they can never be ! -- found climbing tree ! when ! N_SCIL_Dispatch_Table_Object_Init | ! N_SCIL_Dispatch_Table_Tag_Init | ! N_SCIL_Dispatching_Call | ! N_SCIL_Membership_Test | ! N_SCIL_Tag_Init ! => ! pragma Assert (False); ! raise Program_Error; ! -- For all other node types, keep climbing tree ! when ! N_Abortable_Part | ! N_Accept_Alternative | ! N_Access_Definition | ! N_Access_Function_Definition | ! N_Access_Procedure_Definition | ! N_Access_To_Object_Definition | ! N_Aggregate | ! N_Allocator | ! N_Case_Statement_Alternative | ! N_Character_Literal | ! N_Compilation_Unit | ! N_Compilation_Unit_Aux | ! N_Component_Clause | ! N_Component_Declaration | ! N_Component_Definition | ! N_Component_List | ! N_Constrained_Array_Definition | ! N_Decimal_Fixed_Point_Definition | ! N_Defining_Character_Literal | ! N_Defining_Identifier | ! N_Defining_Operator_Symbol | ! N_Defining_Program_Unit_Name | ! N_Delay_Alternative | ! N_Delta_Constraint | ! N_Derived_Type_Definition | ! N_Designator | ! N_Digits_Constraint | ! N_Discriminant_Association | ! N_Discriminant_Specification | ! N_Empty | ! N_Entry_Body_Formal_Part | ! N_Entry_Call_Alternative | ! N_Entry_Declaration | ! N_Entry_Index_Specification | ! N_Enumeration_Type_Definition | ! N_Error | ! N_Exception_Handler | ! N_Expanded_Name | ! N_Explicit_Dereference | ! N_Extension_Aggregate | ! N_Floating_Point_Definition | ! N_Formal_Decimal_Fixed_Point_Definition | ! N_Formal_Derived_Type_Definition | ! N_Formal_Discrete_Type_Definition | ! N_Formal_Floating_Point_Definition | ! N_Formal_Modular_Type_Definition | ! N_Formal_Ordinary_Fixed_Point_Definition | ! N_Formal_Package_Declaration | ! N_Formal_Private_Type_Definition | ! N_Formal_Signed_Integer_Type_Definition | ! N_Function_Call | ! N_Function_Specification | ! N_Generic_Association | ! N_Identifier | ! N_In | ! N_Index_Or_Discriminant_Constraint | ! N_Indexed_Component | ! N_Integer_Literal | ! N_Itype_Reference | ! N_Label | ! N_Loop_Parameter_Specification | ! N_Mod_Clause | ! N_Modular_Type_Definition | ! N_Not_In | ! N_Null | ! N_Op_Abs | ! N_Op_Add | ! N_Op_And | ! N_Op_Concat | ! N_Op_Divide | ! N_Op_Eq | ! N_Op_Expon | ! N_Op_Ge | ! N_Op_Gt | ! N_Op_Le | ! N_Op_Lt | ! N_Op_Minus | ! N_Op_Mod | ! N_Op_Multiply | ! N_Op_Ne | ! N_Op_Not | ! N_Op_Or | ! N_Op_Plus | ! N_Op_Rem | ! N_Op_Rotate_Left | ! N_Op_Rotate_Right | ! N_Op_Shift_Left | ! N_Op_Shift_Right | ! N_Op_Shift_Right_Arithmetic | ! N_Op_Subtract | ! N_Op_Xor | ! N_Operator_Symbol | ! N_Ordinary_Fixed_Point_Definition | ! N_Others_Choice | ! N_Package_Specification | ! N_Parameter_Association | ! N_Parameter_Specification | ! N_Pop_Constraint_Error_Label | ! N_Pop_Program_Error_Label | ! N_Pop_Storage_Error_Label | ! N_Pragma_Argument_Association | ! N_Procedure_Specification | ! N_Protected_Definition | ! N_Push_Constraint_Error_Label | ! N_Push_Program_Error_Label | ! N_Push_Storage_Error_Label | ! N_Qualified_Expression | ! N_Range | ! N_Range_Constraint | ! N_Real_Literal | ! N_Real_Range_Specification | ! N_Record_Definition | ! N_Reference | ! N_Selected_Component | ! N_Signed_Integer_Type_Definition | ! N_Single_Protected_Declaration | ! N_Slice | ! N_String_Literal | ! N_Subprogram_Info | ! N_Subtype_Indication | ! N_Subunit | ! N_Task_Definition | ! N_Terminate_Alternative | ! N_Triggering_Alternative | ! N_Type_Conversion | ! N_Unchecked_Expression | ! N_Unchecked_Type_Conversion | ! N_Unconstrained_Array_Definition | ! N_Unused_At_End | ! N_Unused_At_Start | ! N_Use_Package_Clause | ! N_Use_Type_Clause | ! N_Variant | ! N_Variant_Part | ! N_Validate_Unchecked_Conversion | ! N_With_Clause ! => ! null; ! end case; ! -- If we fall through above tests, keep climbing tree ! if Nkind (Parent (P)) = N_Subunit then ! -- This is the proper body corresponding to a stub. Insertion done ! -- at the point of the stub, which is in the declarative part of ! -- the parent unit. ! P := Corresponding_Stub (Parent (P)); ! else ! P := Parent (P); ! end if; ! end loop; ! -- SCIL node not found ! return Empty; ! end Find_SCIL_Node; ------------------------- -- First_Non_SCIL_Node -- --- 23,192 ---- -- -- ------------------------------------------------------------------------------ ! with Einfo; use Einfo; ! with Nlists; use Nlists; ! with Rtsfind; use Rtsfind; ! with Sem_Aux; use Sem_Aux; ! with Sinfo; use Sinfo; ! with Stand; use Stand; ! with SCIL_LL; use SCIL_LL; package body Sem_SCIL is --------------------- -- Check_SCIL_Node -- --------------------- function Check_SCIL_Node (N : Node_Id) return Traverse_Result is ! SCIL_Node : constant Node_Id := Get_SCIL_Node (N); ! Ctrl_Tag : Node_Id; ! Ctrl_Typ : Entity_Id; begin ! -- For nodes that do not have SCIL node continue traversing the tree ! if No (SCIL_Node) then return OK; end if; ! case Nkind (SCIL_Node) is ! when N_SCIL_Dispatch_Table_Tag_Init => ! pragma Assert (Nkind (N) = N_Object_Declaration); ! null; ! when N_SCIL_Dispatching_Call => ! Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node); ! -- Parent of SCIL dispatching call nodes MUST be a subprogram call ! if not Nkind_In (N, N_Function_Call, ! N_Procedure_Call_Statement) then ! pragma Assert (False); ! raise Program_Error; ! -- In simple cases the controlling tag is the tag of the ! -- controlling argument (i.e. Obj.Tag). ! elsif Nkind (Ctrl_Tag) = N_Selected_Component then ! Ctrl_Typ := Etype (Ctrl_Tag); ! -- Interface types are unsupported ! if Is_Interface (Ctrl_Typ) ! or else (RTE_Available (RE_Interface_Tag) ! and then Ctrl_Typ = RTE (RE_Interface_Tag)) then ! null; ! else ! pragma Assert (Ctrl_Typ = RTE (RE_Tag)); ! null; end if; ! -- When the controlling tag of a dispatching call is an identifier ! -- the SCIL_Controlling_Tag attribute references the corresponding ! -- object or parameter declaration. Interface types are still ! -- unsupported. ! elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, ! N_Parameter_Specification) ! then ! Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); ! -- Interface types are unsupported. ! if Is_Interface (Ctrl_Typ) ! or else (RTE_Available (RE_Interface_Tag) ! and then Ctrl_Typ = RTE (RE_Interface_Tag)) ! or else (Is_Access_Type (Ctrl_Typ) ! and then ! Is_Interface ! (Available_View ! (Base_Type (Designated_Type (Ctrl_Typ))))) then null; ! else ! pragma Assert ! (Ctrl_Typ = RTE (RE_Tag) ! or else ! (Is_Access_Type (Ctrl_Typ) ! and then Available_View ! (Base_Type (Designated_Type (Ctrl_Typ))) ! = RTE (RE_Tag))); null; end if; ! -- Interface types are unsupported ! elsif Is_Interface (Etype (Ctrl_Tag)) then ! null; ! else ! pragma Assert (False); ! raise Program_Error; ! end if; ! return Skip; ! when N_SCIL_Membership_Test => ! -- Check contents of the boolean expression associated with the ! -- membership test. ! pragma Assert (Nkind_In (N, N_Identifier, ! N_And_Then, ! N_Or_Else, ! N_Expression_With_Actions) ! and then Etype (N) = Standard_Boolean); ! -- Check the entity identifier of the associated tagged type (that ! -- is, in testing for membership in T'Class, the entity id of the ! -- specific type T). ! -- Note: When the SCIL node is generated the private and full-view ! -- of the tagged types may have been swapped and hence the node ! -- referenced by attribute SCIL_Entity may be the private view. ! -- Therefore, in order to uniformly locate the full-view we use ! -- attribute Underlying_Type. ! pragma Assert ! (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node)))); ! -- Interface types are unsupported ! pragma Assert ! (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node)))); ! -- Check the decoration of the expression that denotes the tag ! -- value being tested ! Ctrl_Tag := SCIL_Tag_Value (SCIL_Node); ! case Nkind (Ctrl_Tag) is ! -- For class-wide membership tests the SCIL tag value is the ! -- tag of the tested object (i.e. Obj.Tag). ! when N_Selected_Component => ! pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); ! null; ! when others => ! pragma Assert (False); ! null; ! end case; ! return Skip; ! when others => ! pragma Assert (False); ! raise Program_Error; ! end case; ! return Skip; ! end Check_SCIL_Node; ------------------------- -- First_Non_SCIL_Node -- diff -Nrcpad gcc-4.5.2/gcc/ada/sem_scil.ads gcc-4.6.0/gcc/ada/sem_scil.ads *** gcc-4.5.2/gcc/ada/sem_scil.ads Wed Jul 29 08:43:58 2009 --- gcc-4.6.0/gcc/ada/sem_scil.ads Wed Jun 23 06:11:20 2010 *************** *** 4,12 **** -- -- -- S E M _ S C I L -- -- -- ! -- B o d y -- -- -- ! -- Copyright (C) 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- -- --- 4,12 ---- -- -- -- S E M _ S C I L -- -- -- ! -- S p e c -- -- -- ! -- Copyright (C) 2009-2010, 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- -- *************** package Sem_SCIL is *** 33,42 **** -- Here would be a good place to document what SCIL is all about ??? - procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id); - -- Searches for a SCIL dispatching node associated with Old_Node. If found - -- then update its SCIL_Related_Node field to reference New_Node. - function Check_SCIL_Node (N : Node_Id) return Traverse_Result; -- Process a single node during the tree traversal. Done to verify that -- SCIL nodes decoration fulfill the requirements of the SCIL backend. --- 33,38 ---- *************** package Sem_SCIL is *** 44,53 **** procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node); -- The traversal procedure itself - function Find_SCIL_Node (Node : Node_Id) return Node_Id; - -- Searches for a SCIL dispatching node associated with Node. If not found - -- then return Empty. - function First_Non_SCIL_Node (L : List_Id) return Node_Id; -- Returns the first non-SCIL node of list L --- 40,45 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/sem_type.adb gcc-4.6.0/gcc/ada/sem_type.adb *** gcc-4.5.2/gcc/ada/sem_type.adb Thu Oct 29 14:42:50 2009 --- gcc-4.6.0/gcc/ada/sem_type.adb Mon Oct 18 09:37:14 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sem_Type is *** 230,236 **** -- Find out whether the new entry references interpretations that -- are abstract or disabled by abstract operators. ! if Ada_Version >= Ada_05 then if Nkind (N) in N_Binary_Op then Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name); elsif Nkind (N) = N_Function_Call then --- 230,236 ---- -- Find out whether the new entry references interpretations that -- are abstract or disabled by abstract operators. ! if Ada_Version >= Ada_2005 then if Nkind (N) in N_Binary_Op then Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name); elsif Nkind (N) = N_Function_Call then *************** package body Sem_Type is *** 362,368 **** -- performed, given that the operator was visible in the generic. if Ekind (E) = E_Operator then - if Present (Opnd_Type) then Vis_Type := Opnd_Type; else --- 362,367 ---- *************** package body Sem_Type is *** 481,490 **** then Add_Entry (Entity (N), Etype (N)); ! elsif (Nkind (N) = N_Function_Call ! or else Nkind (N) = N_Procedure_Call_Statement) ! and then (Nkind (Name (N)) = N_Operator_Symbol ! or else Is_Entity_Name (Name (N))) then Add_Entry (Entity (Name (N)), Etype (N)); --- 480,487 ---- then Add_Entry (Entity (N), Etype (N)); ! elsif Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) ! and then Is_Entity_Name (Name (N)) then Add_Entry (Entity (Name (N)), Etype (N)); *************** package body Sem_Type is *** 758,763 **** --- 755,768 ---- end if; end if; + -- First check for Standard_Void_Type, which is special. Subsequent + -- processing in this routine assumes T1 and T2 are bona fide types; + -- Standard_Void_Type is a special entity that has some, but not all, + -- properties of types. + + if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then + return False; + -- Simplest case: same types are compatible, and types that have the -- same base type and are not generic actuals are compatible. Generic -- actuals belong to their class but are not compatible with other *************** package body Sem_Type is *** 773,779 **** -- the same actual, so that different subprograms end up with the same -- signature in the instance. ! if T1 = T2 then return True; elsif BT1 = BT2 --- 778,784 ---- -- the same actual, so that different subprograms end up with the same -- signature in the instance. ! elsif T1 = T2 then return True; elsif BT1 = BT2 *************** package body Sem_Type is *** 803,810 **** then return True; ! -- The context may be class wide, and a class-wide type is ! -- compatible with any member of the class. elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) --- 808,815 ---- then return True; ! -- The context may be class wide, and a class-wide type is compatible ! -- with any member of the class. elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) *************** package body Sem_Type is *** 820,826 **** -- Ada 2005 (AI-345): A class-wide abstract interface type covers a -- task_type or protected_type that implements the interface. ! elsif Ada_Version >= Ada_05 and then Is_Class_Wide_Type (T1) and then Is_Interface (Etype (T1)) and then Is_Concurrent_Type (T2) --- 825,831 ---- -- Ada 2005 (AI-345): A class-wide abstract interface type covers a -- task_type or protected_type that implements the interface. ! elsif Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (T1) and then Is_Interface (Etype (T1)) and then Is_Concurrent_Type (T2) *************** package body Sem_Type is *** 833,839 **** -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an -- object T2 implementing T1 ! elsif Ada_Version >= Ada_05 and then Is_Class_Wide_Type (T1) and then Is_Interface (Etype (T1)) and then Is_Tagged_Type (T2) --- 838,844 ---- -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an -- object T2 implementing T1 ! elsif Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (T1) and then Is_Interface (Etype (T1)) and then Is_Tagged_Type (T2) *************** package body Sem_Type is *** 878,887 **** return False; end; ! -- In a dispatching call the actual may be class-wide elsif Is_Class_Wide_Type (T2) ! and then Base_Type (Root_Type (T2)) = Base_Type (T1) then return True; --- 883,895 ---- return False; end; ! -- In a dispatching call the actual may be class-wide, the formal ! -- may be its specific type, or that of a descendent of it. elsif Is_Class_Wide_Type (T2) ! and then ! (Class_Wide_Type (T1) = T2 ! or else Base_Type (Root_Type (T2)) = Base_Type (T1)) then return True; *************** package body Sem_Type is *** 901,907 **** -- An aggregate is compatible with an array or record type elsif T2 = Any_Composite ! and then Ekind (T1) in E_Array_Type .. E_Record_Subtype then return True; --- 909,915 ---- -- An aggregate is compatible with an array or record type elsif T2 = Any_Composite ! and then Is_Aggregate_Type (T1) then return True; *************** package body Sem_Type is *** 997,1005 **** -- imposed by context. elsif Ekind (T2) = E_Access_Attribute_Type ! and then (Ekind (BT1) = E_General_Access_Type ! or else ! Ekind (BT1) = E_Access_Type) and then Covers (Designated_Type (T1), Designated_Type (T2)) then -- If the target type is a RACW type while the source is an access --- 1005,1011 ---- -- imposed by context. elsif Ekind (T2) = E_Access_Attribute_Type ! and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) and then Covers (Designated_Type (T1), Designated_Type (T2)) then -- If the target type is a RACW type while the source is an access *************** package body Sem_Type is *** 1153,1159 **** -- package Instance is new G (Formal => Actual, -- Formal_Obj => Actual_Obj); ! elsif Ada_Version >= Ada_05 and then Ekind (T1) = E_Anonymous_Access_Type and then Ekind (T2) = E_Anonymous_Access_Type and then Is_Generic_Type (Directly_Designated_Type (T1)) --- 1159,1165 ---- -- package Instance is new G (Formal => Actual, -- Formal_Obj => Actual_Obj); ! elsif Ada_Version >= Ada_2005 and then Ekind (T1) = E_Anonymous_Access_Type and then Ekind (T2) = E_Anonymous_Access_Type and then Is_Generic_Type (Directly_Designated_Type (T1)) *************** package body Sem_Type is *** 1299,1305 **** begin if Nkind (N) not in N_Op ! or else Ada_Version < Ada_05 or else not Is_Overloaded (N) or else No (Universal_Interpretation (N)) then --- 1305,1311 ---- begin if Nkind (N) not in N_Op ! or else Ada_Version < Ada_2005 or else not Is_Overloaded (N) or else No (Universal_Interpretation (N)) then *************** package body Sem_Type is *** 1535,1549 **** It2 := It; Nam2 := It.Nam; ! if Ada_Version < Ada_05 then ! -- Check whether one of the entities is an Ada 2005 entity and we are ! -- operating in an earlier mode, in which case we discard the Ada ! -- 2005 entity, so that we get proper Ada 95 overload resolution. ! if Is_Ada_2005_Only (Nam1) then return It2; ! elsif Is_Ada_2005_Only (Nam2) then return It1; end if; end if; --- 1541,1566 ---- It2 := It; Nam2 := It.Nam; ! -- Check whether one of the entities is an Ada 2005/2012 and we are ! -- operating in an earlier mode, in which case we discard the Ada ! -- 2005/2012 entity, so that we get proper Ada 95 overload resolution. ! if Ada_Version < Ada_2005 then ! if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then ! return It2; ! elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then ! return It1; ! end if; ! end if; ! -- Check whether one of the entities is an Ada 2012 entity and we are ! -- operating in Ada 2005 mode, in which case we discard the Ada 2012 ! -- entity, so that we get proper Ada 2005 overload resolution. ! ! if Ada_Version = Ada_2005 then ! if Is_Ada_2012_Only (Nam1) then return It2; ! elsif Is_Ada_2012_Only (Nam2) then return It1; end if; end if; *************** package body Sem_Type is *** 1625,1633 **** Arg1 := Left_Opnd (N); Arg2 := Right_Opnd (N); ! elsif Is_Entity_Name (N) ! or else Nkind (N) = N_Operator_Symbol ! then Arg1 := First_Entity (Entity (N)); Arg2 := Next_Entity (Arg1); --- 1642,1648 ---- Arg1 := Left_Opnd (N); Arg2 := Right_Opnd (N); ! elsif Is_Entity_Name (N) then Arg1 := First_Entity (Entity (N)); Arg2 := Next_Entity (Arg1); *************** package body Sem_Type is *** 1677,1685 **** elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration and then Present (Access_Definition (Parent (N))) then ! if Ekind (It1.Typ) = E_Anonymous_Access_Type ! or else ! Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type then if Ekind (It2.Typ) = Ekind (It1.Typ) then --- 1692,1699 ---- elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration and then Present (Access_Definition (Parent (N))) then ! if Ekind_In (It1.Typ, E_Anonymous_Access_Type, ! E_Anonymous_Access_Subprogram_Type) then if Ekind (It2.Typ) = Ekind (It1.Typ) then *************** package body Sem_Type is *** 1691,1699 **** return It1; end if; ! elsif Ekind (It2.Typ) = E_Anonymous_Access_Type ! or else ! Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type then return It2; --- 1705,1712 ---- return It1; end if; ! elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, ! E_Anonymous_Access_Subprogram_Type) then return It2; *************** package body Sem_Type is *** 1866,1876 **** elsif (Chars (Nam1) = Name_Op_Eq or else Chars (Nam1) = Name_Op_Ne) ! and then Ada_Version >= Ada_05 and then Etype (User_Subp) = Standard_Boolean then declare Opnd : Node_Id; begin if Nkind (N) = N_Function_Call then Opnd := First_Actual (N); --- 1879,1890 ---- elsif (Chars (Nam1) = Name_Op_Eq or else Chars (Nam1) = Name_Op_Ne) ! and then Ada_Version >= Ada_2005 and then Etype (User_Subp) = Standard_Boolean then declare Opnd : Node_Id; + begin if Nkind (N) = N_Function_Call then Opnd := First_Actual (N); *************** package body Sem_Type is *** 1880,1887 **** if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type and then ! List_Containing (Parent (Designated_Type (Etype (Opnd)))) ! = List_Containing (Unit_Declaration_Node (User_Subp)) then if It2.Nam = Predef_Subp then return It1; --- 1894,1901 ---- if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type and then ! In_Same_List (Parent (Designated_Type (Etype (Opnd))), ! Unit_Declaration_Node (User_Subp)) then if It2.Nam = Predef_Subp then return It1; *************** package body Sem_Type is *** 2011,2017 **** -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there -- is no rule in 4.6 that allows "access Integer" to be converted to P. ! elsif Ada_Version >= Ada_05 and then (Ekind (Etype (L)) = E_Anonymous_Access_Type or else --- 2025,2031 ---- -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there -- is no rule in 4.6 that allows "access Integer" to be converted to P. ! elsif Ada_Version >= Ada_2005 and then (Ekind (Etype (L)) = E_Anonymous_Access_Type or else *************** package body Sem_Type is *** 2021,2027 **** then return Etype (L); ! elsif Ada_Version >= Ada_05 and then (Ekind (Etype (R)) = E_Anonymous_Access_Type or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type) --- 2035,2041 ---- then return Etype (L); ! elsif Ada_Version >= Ada_2005 and then (Ekind (Etype (R)) = E_Anonymous_Access_Type or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type) *************** package body Sem_Type is *** 2559,2567 **** BT1 := Base_Type (T1); BT2 := Base_Type (T2); ! -- Handle underlying view of records with unknown discriminants ! -- using the original entity that motivated the construction of ! -- this underlying record view (see Build_Derived_Private_Type). if Is_Underlying_Record_View (BT1) then BT1 := Underlying_Record_View (BT1); --- 2573,2581 ---- BT1 := Base_Type (T1); BT2 := Base_Type (T2); ! -- Handle underlying view of records with unknown discriminants using ! -- the original entity that motivated the construction of this ! -- underlying record view (see Build_Derived_Private_Type). if Is_Underlying_Record_View (BT1) then BT1 := Underlying_Record_View (BT1); *************** package body Sem_Type is *** 2574,2585 **** --- 2588,2607 ---- if BT1 = BT2 then return True; + -- The predicate must look past privacy + elsif Is_Private_Type (T1) and then Present (Full_View (T1)) and then BT2 = Base_Type (Full_View (T1)) then return True; + elsif Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then BT1 = Base_Type (Full_View (T2)) + then + return True; + else Par := Etype (BT2); *************** package body Sem_Type is *** 2603,2609 **** return True; elsif Etype (Par) /= Par then ! Par := Etype (Par); else return False; end if; --- 2625,2646 ---- return True; elsif Etype (Par) /= Par then ! ! -- If this is a private type and its parent is an interface ! -- then use the parent of the full view (which is a type that ! -- implements such interface) ! ! if Is_Private_Type (Par) ! and then Is_Interface (Etype (Par)) ! and then Present (Full_View (Par)) ! then ! Par := Etype (Full_View (Par)); ! else ! Par := Etype (Par); ! end if; ! ! -- For all other cases return False, not an Ancestor ! else return False; end if; *************** package body Sem_Type is *** 2650,2655 **** --- 2687,2704 ---- end if; end Is_Invisible_Operator; + -------------------- + -- Is_Progenitor -- + -------------------- + + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean + is + begin + return Implements_Interface (Typ, Iface, Exclude_Parents => True); + end Is_Progenitor; + ------------------- -- Is_Subtype_Of -- ------------------- *************** package body Sem_Type is *** 3029,3040 **** return T1; elsif T2 = Any_Composite ! and then Ekind (T1) in E_Array_Type .. E_Record_Subtype then return T1; elsif T1 = Any_Composite ! and then Ekind (T2) in E_Array_Type .. E_Record_Subtype then return T2; --- 3078,3089 ---- return T1; elsif T2 = Any_Composite ! and then Is_Aggregate_Type (T1) then return T1; elsif T1 = Any_Composite ! and then Is_Aggregate_Type (T2) then return T2; *************** package body Sem_Type is *** 3191,3197 **** Write_Str (" Index: "); Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); Write_Str (" Next: "); ! Write_Int (Int (Interp_Map.Table (Map_Ptr).Next)); Write_Eol; end Write_Interp_Ref; --- 3240,3246 ---- Write_Str (" Index: "); Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); Write_Str (" Next: "); ! Write_Int (Interp_Map.Table (Map_Ptr).Next); Write_Eol; end Write_Interp_Ref; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_type.ads gcc-4.6.0/gcc/ada/sem_type.ads *** gcc-4.5.2/gcc/ada/sem_type.ads Wed Jul 22 10:31:30 2009 --- gcc-4.6.0/gcc/ada/sem_type.ads Thu Sep 9 10:07:52 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Type is *** 221,226 **** --- 221,234 ---- -- T1 is a tagged type (not class-wide). Verify that it is one of the -- ancestors of type T2 (which may or not be class-wide). + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Determine whether the interface Iface is implemented by Typ. It requires + -- traversing the list of abstract interfaces of the type, as well as that + -- of the ancestor types. The predicate is used to determine when a formal + -- in the signature of an inherited operation must carry the derived type. + function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies -- only to scalar subtypes??? diff -Nrcpad gcc-4.5.2/gcc/ada/sem_util.adb gcc-4.6.0/gcc/ada/sem_util.adb *** gcc-4.5.2/gcc/ada/sem_util.adb Mon Nov 30 16:08:37 2009 --- gcc-4.6.0/gcc/ada/sem_util.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Nlists; use Nlists; *** 41,48 **** with Output; use Output; with Opt; use Opt; with Rtsfind; use Rtsfind; - with Scans; use Scans; - with Scn; use Scn; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Attr; use Sem_Attr; --- 41,46 ---- *************** with Sem_Ch8; use Sem_Ch8; *** 50,68 **** with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; - with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; with Style; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uname; use Uname; with GNAT.HTable; use GNAT.HTable; package body Sem_Util is ---------------------------------------- --- 48,67 ---- with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; with Style; with Stringt; use Stringt; + with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uname; use Uname; with GNAT.HTable; use GNAT.HTable; + package body Sem_Util is ---------------------------------------- *************** package body Sem_Util is *** 74,80 **** -- safely used by New_Copy_Tree, since there is no case of a recursive -- call from the processing inside New_Copy_Tree. ! NCT_Hash_Threshhold : constant := 20; -- If there are more than this number of pairs of entries in the -- map, then Hash_Tables_Used will be set, and the hash tables will -- be initialized and used for the searches. --- 73,79 ---- -- safely used by New_Copy_Tree, since there is no case of a recursive -- call from the processing inside New_Copy_Tree. ! NCT_Hash_Threshold : constant := 20; -- If there are more than this number of pairs of entries in the -- map, then Hash_Tables_Used will be set, and the hash tables will -- be initialized and used for the searches. *************** package body Sem_Util is *** 83,89 **** -- Set to True if hash tables are in use NCT_Table_Entries : Nat; ! -- Count entries in table to see if threshhold is reached NCT_Hash_Table_Setup : Boolean := False; -- Set to True if hash table contains data. We set this True if we --- 82,88 ---- -- Set to True if hash tables are in use NCT_Table_Entries : Nat; ! -- Count entries in table to see if threshold is reached NCT_Hash_Table_Setup : Boolean := False; -- Set to True if hash table contains data. We set this True if we *************** package body Sem_Util is *** 94,99 **** --- 93,122 ---- subtype NCT_Header_Num is Int range 0 .. 511; -- Defines range of headers in hash tables (512 headers) + ---------------------------------- + -- Order Dependence (AI05-0144) -- + ---------------------------------- + + -- Each actual in a call is entered into the table below. A flag indicates + -- whether the corresponding formal is OUT or IN OUT. Each top-level call + -- (procedure call, condition, assignment) examines all the actuals for a + -- possible order dependence. The table is reset after each such check. + -- The actuals to be checked in a call to Check_Order_Dependence are at + -- positions 1 .. Last. + + type Actual_Name is record + Act : Node_Id; + Is_Writable : Boolean; + end record; + + package Actuals_In_Call is new Table.Table ( + Table_Component_Type => Actual_Name, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Actuals"); + ----------------------- -- Local Subprograms -- ----------------------- *************** package body Sem_Util is *** 220,225 **** --- 243,270 ---- Analyze (N); end Add_Global_Declaration; + ----------------- + -- Addressable -- + ----------------- + + -- For now, just 8/16/32/64. but analyze later if AAMP is special??? + + function Addressable (V : Uint) return Boolean is + begin + return V = Uint_8 or else + V = Uint_16 or else + V = Uint_32 or else + V = Uint_64; + end Addressable; + + function Addressable (V : Int) return Boolean is + begin + return V = 8 or else + V = 16 or else + V = 32 or else + V = 64; + end Addressable; + ----------------------- -- Alignment_In_Bits -- ----------------------- *************** package body Sem_Util is *** 284,289 **** --- 329,358 ---- end if; end Apply_Compile_Time_Constraint_Error; + -------------------------------- + -- Bad_Predicated_Subtype_Use -- + -------------------------------- + + procedure Bad_Predicated_Subtype_Use + (Msg : String; + N : Node_Id; + Typ : Entity_Id) + is + begin + if Has_Predicates (Typ) then + if Is_Generic_Actual_Type (Typ) then + Error_Msg_FE (Msg & '?', N, Typ); + Error_Msg_F ("\Program_Error will be raised at run time?", N); + Insert_Action (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Bad_Predicated_Generic_Type)); + + else + Error_Msg_FE (Msg, N, Typ); + end if; + end if; + end Bad_Predicated_Subtype_Use; + -------------------------- -- Build_Actual_Subtype -- -------------------------- *************** package body Sem_Util is *** 398,406 **** end loop; end if; ! Subt := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); Set_Is_Internal (Subt); Decl := --- 467,473 ---- end loop; end if; ! Subt := Make_Temporary (Loc, 'S', Related_Node => N); Set_Is_Internal (Subt); Decl := *************** package body Sem_Util is *** 543,550 **** and then Is_Constrained (Root_Type (T))) and then not Has_Unknown_Discriminants (T) then ! -- If the type of the dereference is already constrained, it ! -- is an actual subtype. if Is_Array_Type (Etype (N)) and then Is_Constrained (Etype (N)) --- 610,617 ---- and then Is_Constrained (Root_Type (T))) and then not Has_Unknown_Discriminants (T) then ! -- If the type of the dereference is already constrained, it is an ! -- actual subtype. if Is_Array_Type (Etype (N)) and then Is_Constrained (Etype (N)) *************** package body Sem_Util is *** 624,632 **** return Empty; end if; ! Subt := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); Set_Is_Internal (Subt); Decl := --- 691,697 ---- return Empty; end if; ! Subt := Make_Temporary (Loc, 'S'); Set_Is_Internal (Subt); Decl := *************** package body Sem_Util is *** 666,675 **** end if; declare ! Act : constant Entity_Id := ! Make_Defining_Identifier (Loc, ! Chars => New_Internal_Name ('S')); ! Constraints : constant List_Id := New_List; Decl : Node_Id; --- 731,737 ---- end if; declare ! Act : constant Entity_Id := Make_Temporary (Loc, 'S'); Constraints : constant List_Id := New_List; Decl : Node_Id; *************** package body Sem_Util is *** 1151,1162 **** --- 1213,1284 ---- end if; end Check_Nested_Access; + ---------------------------- + -- Check_Order_Dependence -- + ---------------------------- + + procedure Check_Order_Dependence is + Act1 : Node_Id; + Act2 : Node_Id; + + begin + if Ada_Version < Ada_2012 then + return; + end if; + + -- Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested + -- calls within a construct have been collected. If one of them is + -- writable and overlaps with another one, evaluation of the enclosing + -- construct is nondeterministic. This is illegal in Ada 2012, but is + -- treated as a warning for now. + + for J in 1 .. Actuals_In_Call.Last loop + if Actuals_In_Call.Table (J).Is_Writable then + Act1 := Actuals_In_Call.Table (J).Act; + + if Nkind (Act1) = N_Attribute_Reference then + Act1 := Prefix (Act1); + end if; + + for K in 1 .. Actuals_In_Call.Last loop + if K /= J then + Act2 := Actuals_In_Call.Table (K).Act; + + if Nkind (Act2) = N_Attribute_Reference then + Act2 := Prefix (Act2); + end if; + + if Actuals_In_Call.Table (K).Is_Writable + and then K < J + then + -- Already checked + + null; + + elsif Denotes_Same_Object (Act1, Act2) + and then Parent (Act1) /= Parent (Act2) + then + Error_Msg_N + ("result may differ if evaluated " + & "after other actual in expression?", Act1); + end if; + end if; + end loop; + end if; + end loop; + + -- Remove checked actuals from table + + Actuals_In_Call.Set_Last (0); + end Check_Order_Dependence; + ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ procedure Check_Potentially_Blocking_Operation (N : Node_Id) is S : Entity_Id; + begin -- N is one of the potentially blocking operations listed in 9.5.1(8). -- When pragma Detect_Blocking is active, the run time will raise *************** package body Sem_Util is *** 1173,1179 **** if Is_Protected_Type (S) then Error_Msg_N ("potentially blocking operation in protected operation?", N); - return; end if; --- 1295,1300 ---- *************** package body Sem_Util is *** 1499,1520 **** function Search_Tag (Iface : Entity_Id) return Entity_Id is ADT : Elmt_Id; - begin ! ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); while Present (ADT) ! and then Ekind (Node (ADT)) = E_Constant and then Related_Type (Node (ADT)) /= Iface loop ! -- Skip the secondary dispatch tables of Iface Next_Elmt (ADT); ! Next_Elmt (ADT); ! Next_Elmt (ADT); ! Next_Elmt (ADT); end loop; ! pragma Assert (Ekind (Node (ADT)) = E_Constant); return Node (ADT); end Search_Tag; --- 1620,1667 ---- function Search_Tag (Iface : Entity_Id) return Entity_Id is ADT : Elmt_Id; begin ! if not Is_CPP_Class (T) then ! ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); ! else ! ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); ! end if; ! while Present (ADT) ! and then Is_Tag (Node (ADT)) and then Related_Type (Node (ADT)) /= Iface loop ! -- Skip secondary dispatch table referencing thunks to user ! -- defined primitives covered by this interface. + pragma Assert (Has_Suffix (Node (ADT), 'P')); Next_Elmt (ADT); ! ! -- Skip secondary dispatch tables of Ada types ! ! if not Is_CPP_Class (T) then ! ! -- Skip secondary dispatch table referencing thunks to ! -- predefined primitives. ! ! pragma Assert (Has_Suffix (Node (ADT), 'Y')); ! Next_Elmt (ADT); ! ! -- Skip secondary dispatch table referencing user-defined ! -- primitives covered by this interface. ! ! pragma Assert (Has_Suffix (Node (ADT), 'D')); ! Next_Elmt (ADT); ! ! -- Skip secondary dispatch table referencing predefined ! -- primitives. ! ! pragma Assert (Has_Suffix (Node (ADT), 'Z')); ! Next_Elmt (ADT); ! end if; end loop; ! pragma Assert (Is_Tag (Node (ADT))); return Node (ADT); end Search_Tag; *************** package body Sem_Util is *** 1566,1571 **** --- 1713,1756 ---- end loop; end Collect_Interfaces_Info; + --------------------- + -- Collect_Parents -- + --------------------- + + procedure Collect_Parents + (T : Entity_Id; + List : out Elist_Id; + Use_Full_View : Boolean := True) + is + Current_Typ : Entity_Id := T; + Parent_Typ : Entity_Id; + + begin + List := New_Elmt_List; + + -- No action if the if the type has no parents + + if T = Etype (T) then + return; + end if; + + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) + and then Present (Full_View (Parent_Typ)) + and then Use_Full_View + then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + Append_Elmt (Parent_Typ, List); + + exit when Parent_Typ = Current_Typ; + Current_Typ := Parent_Typ; + end loop; + end Collect_Parents; + ---------------------------------- -- Collect_Primitive_Operations -- ---------------------------------- *************** package body Sem_Util is *** 1580,1585 **** --- 1765,1791 ---- Formal_Derived : Boolean := False; Id : Entity_Id; + function Match (E : Entity_Id) return Boolean; + -- True if E's base type is B_Type, or E is of an anonymous access type + -- and the base type of its designated type is B_Type. + + ----------- + -- Match -- + ----------- + + function Match (E : Entity_Id) return Boolean is + Etyp : Entity_Id := Etype (E); + + begin + if Ekind (Etyp) = E_Anonymous_Access_Type then + Etyp := Designated_Type (Etyp); + end if; + + return Base_Type (Etyp) = B_Type; + end Match; + + -- Start of processing for Collect_Primitive_Operations + begin -- For tagged types, the primitive operations are collected as they -- are declared, and held in an explicit list which is simply returned. *************** package body Sem_Util is *** 1648,1666 **** then Is_Prim := False; ! if Base_Type (Etype (Id)) = B_Type then Is_Prim := True; else Formal := First_Formal (Id); while Present (Formal) loop ! if Base_Type (Etype (Formal)) = B_Type then ! Is_Prim := True; ! exit; ! ! elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type ! and then Base_Type ! (Designated_Type (Etype (Formal))) = B_Type ! then Is_Prim := True; exit; end if; --- 1854,1866 ---- then Is_Prim := False; ! if Match (Id) then Is_Prim := True; + else Formal := First_Formal (Id); while Present (Formal) loop ! if Match (Formal) then Is_Prim := True; exit; end if; *************** package body Sem_Util is *** 1677,1694 **** and then (not Formal_Derived or else Present (Alias (Id))) then ! Append_Elmt (Id, Op_List); end if; end if; Next_Entity (Id); ! -- For a type declared in System, some of its operations ! -- may appear in the target-specific extension to System. if No (Id) ! and then Chars (B_Scope) = Name_System ! and then Scope (B_Scope) = Standard_Standard and then Present_System_Aux then B_Scope := System_Aux_Id; --- 1877,1916 ---- and then (not Formal_Derived or else Present (Alias (Id))) then ! -- In the special case of an equality operator aliased to ! -- an overriding dispatching equality belonging to the same ! -- type, we don't include it in the list of primitives. ! -- This avoids inheriting multiple equality operators when ! -- deriving from untagged private types whose full type is ! -- tagged, which can otherwise cause ambiguities. Note that ! -- this should only happen for this kind of untagged parent ! -- type, since normally dispatching operations are inherited ! -- using the type's Primitive_Operations list. ! ! if Chars (Id) = Name_Op_Eq ! and then Is_Dispatching_Operation (Id) ! and then Present (Alias (Id)) ! and then Present (Overridden_Operation (Alias (Id))) ! and then Base_Type (Etype (First_Entity (Id))) = ! Base_Type (Etype (First_Entity (Alias (Id)))) ! then ! null; ! ! -- Include the subprogram in the list of primitives ! ! else ! Append_Elmt (Id, Op_List); ! end if; end if; end if; Next_Entity (Id); ! -- For a type declared in System, some of its operations may ! -- appear in the target-specific extension to System. if No (Id) ! and then B_Scope = RTU_Entity (System) and then Present_System_Aux then B_Scope := System_Aux_Id; *************** package body Sem_Util is *** 2080,2088 **** -- so we can continue semantic analysis elsif Nam = Error then ! Err := ! Make_Defining_Identifier (Sloc (N), ! Chars => New_Internal_Name ('T')); Set_Defining_Unit_Name (N, Err); return Err; --- 2302,2308 ---- -- so we can continue semantic analysis elsif Nam = Error then ! Err := Make_Temporary (Sloc (N), 'T'); Set_Defining_Unit_Name (N, Err); return Err; *************** package body Sem_Util is *** 2142,2190 **** ------------------------- function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is begin -- If we have entity names, then must be same entity ! if Is_Entity_Name (A1) then ! if Is_Entity_Name (A2) then ! return Entity (A1) = Entity (A2); else return False; end if; -- No match if not same node kind ! elsif Nkind (A1) /= Nkind (A2) then return False; -- For selected components, must have same prefix and selector ! elsif Nkind (A1) = N_Selected_Component then ! return Denotes_Same_Object (Prefix (A1), Prefix (A2)) and then ! Entity (Selector_Name (A1)) = Entity (Selector_Name (A2)); -- For explicit dereferences, prefixes must be same ! elsif Nkind (A1) = N_Explicit_Dereference then ! return Denotes_Same_Object (Prefix (A1), Prefix (A2)); -- For indexed components, prefixes and all subscripts must be the same ! elsif Nkind (A1) = N_Indexed_Component then ! if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then declare Indx1 : Node_Id; Indx2 : Node_Id; begin ! Indx1 := First (Expressions (A1)); ! Indx2 := First (Expressions (A2)); while Present (Indx1) loop ! -- Shouldn't we be checking that values are the same??? ! if not Denotes_Same_Object (Indx1, Indx2) then return False; end if; --- 2362,2471 ---- ------------------------- function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is + Obj1 : Node_Id := A1; + Obj2 : Node_Id := A2; + + procedure Check_Renaming (Obj : in out Node_Id); + -- If an object is a renaming, examine renamed object. If it is a + -- dereference of a variable, or an indexed expression with non-constant + -- indexes, no overlap check can be reported. + + -------------------- + -- Check_Renaming -- + -------------------- + + procedure Check_Renaming (Obj : in out Node_Id) is + begin + if Is_Entity_Name (Obj) + and then Present (Renamed_Entity (Entity (Obj))) + then + Obj := Renamed_Entity (Entity (Obj)); + if Nkind (Obj) = N_Explicit_Dereference + and then Is_Variable (Prefix (Obj)) + then + Obj := Empty; + + elsif Nkind (Obj) = N_Indexed_Component then + declare + Indx : Node_Id; + + begin + Indx := First (Expressions (Obj)); + while Present (Indx) loop + if not Is_OK_Static_Expression (Indx) then + Obj := Empty; + exit; + end if; + + Next_Index (Indx); + end loop; + end; + end if; + end if; + end Check_Renaming; + + -- Start of processing for Denotes_Same_Object + begin + Check_Renaming (Obj1); + Check_Renaming (Obj2); + + if No (Obj1) + or else No (Obj2) + then + return False; + end if; + -- If we have entity names, then must be same entity ! if Is_Entity_Name (Obj1) then ! if Is_Entity_Name (Obj2) then ! return Entity (Obj1) = Entity (Obj2); else return False; end if; -- No match if not same node kind ! elsif Nkind (Obj1) /= Nkind (Obj2) then return False; -- For selected components, must have same prefix and selector ! elsif Nkind (Obj1) = N_Selected_Component then ! return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) and then ! Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); -- For explicit dereferences, prefixes must be same ! elsif Nkind (Obj1) = N_Explicit_Dereference then ! return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); -- For indexed components, prefixes and all subscripts must be the same ! elsif Nkind (Obj1) = N_Indexed_Component then ! if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then declare Indx1 : Node_Id; Indx2 : Node_Id; begin ! Indx1 := First (Expressions (Obj1)); ! Indx2 := First (Expressions (Obj2)); while Present (Indx1) loop ! -- Indexes must denote the same static value or same object ! if Is_OK_Static_Expression (Indx1) then ! if not Is_OK_Static_Expression (Indx2) then ! return False; ! ! elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then ! return False; ! end if; ! ! elsif not Denotes_Same_Object (Indx1, Indx2) then return False; end if; *************** package body Sem_Util is *** 2200,2229 **** -- For slices, prefixes must match and bounds must match ! elsif Nkind (A1) = N_Slice ! and then Denotes_Same_Object (Prefix (A1), Prefix (A2)) then declare Lo1, Lo2, Hi1, Hi2 : Node_Id; begin ! Get_Index_Bounds (Etype (A1), Lo1, Hi1); ! Get_Index_Bounds (Etype (A2), Lo2, Hi2); -- Check whether bounds are statically identical. There is no -- attempt to detect partial overlap of slices. - -- What about an array and a slice of an array??? - return Denotes_Same_Object (Lo1, Lo2) and then Denotes_Same_Object (Hi1, Hi2); end; ! -- Literals will appear as indices. Isn't this where we should check -- Known_At_Compile_Time at least if we are generating warnings ??? ! elsif Nkind (A1) = N_Integer_Literal then ! return Intval (A1) = Intval (A2); else return False; --- 2481,2508 ---- -- For slices, prefixes must match and bounds must match ! elsif Nkind (Obj1) = N_Slice ! and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then declare Lo1, Lo2, Hi1, Hi2 : Node_Id; begin ! Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); ! Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); -- Check whether bounds are statically identical. There is no -- attempt to detect partial overlap of slices. return Denotes_Same_Object (Lo1, Lo2) and then Denotes_Same_Object (Hi1, Hi2); end; ! -- Literals will appear as indexes. Isn't this where we should check -- Known_At_Compile_Time at least if we are generating warnings ??? ! elsif Nkind (Obj1) = N_Integer_Literal then ! return Intval (Obj1) = Intval (Obj2); else return False; *************** package body Sem_Util is *** 2238,2244 **** begin if Is_Entity_Name (A1) then ! if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then return Denotes_Same_Object (A1, Prefix (A2)) or else Denotes_Same_Prefix (A1, Prefix (A2)); else --- 2517,2525 ---- begin if Is_Entity_Name (A1) then ! if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) ! and then not Is_Access_Type (Etype (A1)) ! then return Denotes_Same_Object (A1, Prefix (A2)) or else Denotes_Same_Prefix (A1, Prefix (A2)); else *************** package body Sem_Util is *** 2412,2417 **** --- 2693,2720 ---- end if; end Designate_Same_Unit; + -------------------------- + -- Enclosing_CPP_Parent -- + -------------------------- + + function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is + Parent_Typ : Entity_Id := Typ; + + begin + while not Is_CPP_Class (Parent_Typ) + and then Etype (Parent_Typ) /= Parent_Typ + loop + Parent_Typ := Etype (Parent_Typ); + + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + end loop; + + pragma Assert (Is_CPP_Class (Parent_Typ)); + return Parent_Typ; + end Enclosing_CPP_Parent; + ---------------------------- -- Enclosing_Generic_Body -- ---------------------------- *************** package body Sem_Util is *** 2558,2564 **** elsif Ekind (Dynamic_Scope) = E_Task_Type then return Get_Task_Body_Procedure (Dynamic_Scope); ! elsif Convention (Dynamic_Scope) = Convention_Protected then return Protected_Body_Subprogram (Dynamic_Scope); else --- 2861,2878 ---- elsif Ekind (Dynamic_Scope) = E_Task_Type then return Get_Task_Body_Procedure (Dynamic_Scope); ! elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type ! and then Present (Full_View (Dynamic_Scope)) ! and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type ! then ! return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); ! ! -- No body is generated if the protected operation is eliminated ! ! elsif Convention (Dynamic_Scope) = Convention_Protected ! and then not Is_Eliminated (Dynamic_Scope) ! and then Present (Protected_Body_Subprogram (Dynamic_Scope)) ! then return Protected_Body_Subprogram (Dynamic_Scope); else *************** package body Sem_Util is *** 2731,2739 **** Set_Scope (Def_Id, Current_Scope); return; ! -- Analogous to privals, the discriminal generated for an entry ! -- index parameter acts as a weak declaration. Perform minimal ! -- decoration to avoid bogus errors. elsif Is_Discriminal (Def_Id) and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter --- 3045,3053 ---- Set_Scope (Def_Id, Current_Scope); return; ! -- Analogous to privals, the discriminal generated for an entry index ! -- parameter acts as a weak declaration. Perform minimal decoration ! -- to avoid bogus errors. elsif Is_Discriminal (Def_Id) and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter *************** package body Sem_Util is *** 2741,2751 **** Set_Scope (Def_Id, Current_Scope); return; ! -- In the body or private part of an instance, a type extension ! -- may introduce a component with the same name as that of an ! -- actual. The legality rule is not enforced, but the semantics ! -- of the full type with two components of the same name are not ! -- clear at this point ??? elsif In_Instance_Not_Visible then null; --- 3055,3064 ---- Set_Scope (Def_Id, Current_Scope); return; ! -- In the body or private part of an instance, a type extension may ! -- introduce a component with the same name as that of an actual. The ! -- legality rule is not enforced, but the semantics of the full type ! -- with two components of same name are not clear at this point??? elsif In_Instance_Not_Visible then null; *************** package body Sem_Util is *** 2759,2767 **** then null; ! -- Conversely, with front-end inlining we may compile the parent ! -- body first, and a child unit subsequently. The context is now ! -- the parent spec, and body entities are not visible. elsif Is_Child_Unit (Def_Id) and then Is_Package_Body_Entity (E) --- 3072,3080 ---- then null; ! -- Conversely, with front-end inlining we may compile the parent body ! -- first, and a child unit subsequently. The context is now the ! -- parent spec, and body entities are not visible. elsif Is_Child_Unit (Def_Id) and then Is_Package_Body_Entity (E) *************** package body Sem_Util is *** 2775,2782 **** Error_Msg_Sloc := Sloc (E); -- If the previous declaration is an incomplete type declaration ! -- this may be an attempt to complete it with a private type. ! -- The following avoids confusing cascaded errors. if Nkind (Parent (E)) = N_Incomplete_Type_Declaration and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration --- 3088,3095 ---- Error_Msg_Sloc := Sloc (E); -- If the previous declaration is an incomplete type declaration ! -- this may be an attempt to complete it with a private type. The ! -- following avoids confusing cascaded errors. if Nkind (Parent (E)) = N_Incomplete_Type_Declaration and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration *************** package body Sem_Util is *** 2799,2807 **** Error_Msg_N ("& conflicts with declaration#", E); return; ! -- If the name of the unit appears in its own context clause, ! -- a dummy package with the name has already been created, and ! -- the error emitted. Try to continue quietly. elsif Error_Posted (E) and then Sloc (E) = No_Location --- 3112,3120 ---- Error_Msg_N ("& conflicts with declaration#", E); return; ! -- If the name of the unit appears in its own context clause, a ! -- dummy package with the name has already been created, and the ! -- error emitted. Try to continue quietly. elsif Error_Posted (E) and then Sloc (E) = No_Location *************** package body Sem_Util is *** 2817,2825 **** -- Avoid cascaded messages with duplicate components in -- derived types. ! if Ekind (E) = E_Component ! or else Ekind (E) = E_Discriminant ! then return; end if; end if; --- 3130,3136 ---- -- Avoid cascaded messages with duplicate components in -- derived types. ! if Ekind_In (E, E_Component, E_Discriminant) then return; end if; end if; *************** package body Sem_Util is *** 2832,2840 **** Error_Msg_N ("\generic units cannot be overloaded", Def_Id); end if; ! -- If entity is in standard, then we are in trouble, because ! -- it means that we have a library package with a duplicated ! -- name. That's hard to recover from, so abort! if S = Standard_Standard then raise Unrecoverable_Error; --- 3143,3151 ---- Error_Msg_N ("\generic units cannot be overloaded", Def_Id); end if; ! -- If entity is in standard, then we are in trouble, because it ! -- means that we have a library package with a duplicated name. ! -- That's hard to recover from, so abort! if S = Standard_Standard then raise Unrecoverable_Error; *************** package body Sem_Util is *** 2848,2866 **** end if; end if; ! -- If we fall through, declaration is OK , or OK enough to continue ! -- If Def_Id is a discriminant or a record component we are in the ! -- midst of inheriting components in a derived record definition. ! -- Preserve their Ekind and Etype. ! if Ekind (Def_Id) = E_Discriminant ! or else Ekind (Def_Id) = E_Component ! then null; ! -- If a type is already set, leave it alone (happens whey a type ! -- declaration is reanalyzed following a call to the optimizer) elsif Present (Etype (Def_Id)) then null; --- 3159,3175 ---- end if; end if; ! -- If we fall through, declaration is OK, at least OK enough to continue ! -- If Def_Id is a discriminant or a record component we are in the midst ! -- of inheriting components in a derived record definition. Preserve ! -- their Ekind and Etype. ! if Ekind_In (Def_Id, E_Discriminant, E_Component) then null; ! -- If a type is already set, leave it alone (happens when a type ! -- declaration is reanalyzed following a call to the optimizer). elsif Present (Etype (Def_Id)) then null; *************** package body Sem_Util is *** 2876,2883 **** -- Inherited discriminants and components in derived record types are -- immediately visible. Itypes are not. ! if Ekind (Def_Id) = E_Discriminant ! or else Ekind (Def_Id) = E_Component or else (No (Corresponding_Remote_Type (Def_Id)) and then not Is_Itype (Def_Id)) then --- 3185,3191 ---- -- Inherited discriminants and components in derived record types are -- immediately visible. Itypes are not. ! if Ekind_In (Def_Id, E_Discriminant, E_Component) or else (No (Corresponding_Remote_Type (Def_Id)) and then not Is_Itype (Def_Id)) then *************** package body Sem_Util is *** 2918,2925 **** and then In_Extended_Main_Source_Unit (Def_Id) ! -- Finally, the hidden entity must be either immediately visible ! -- or use visible (from a used package) and then (Is_Immediately_Visible (C) --- 3226,3233 ---- and then In_Extended_Main_Source_Unit (Def_Id) ! -- Finally, the hidden entity must be either immediately visible or ! -- use visible (i.e. from a used package). and then (Is_Immediately_Visible (C) *************** package body Sem_Util is *** 3048,3053 **** --- 3356,3393 ---- Call := Empty; end Find_Actual; + --------------------------- + -- Find_Body_Discriminal -- + --------------------------- + + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id + is + pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); + + Tsk : constant Entity_Id := + Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); + Disc : Entity_Id; + + begin + -- Find discriminant of original concurrent type, and use its current + -- discriminal, which is the renaming within the task/protected body. + + Disc := First_Discriminant (Tsk); + while Present (Disc) loop + if Chars (Disc) = Chars (Spec_Discriminant) then + return Discriminal (Disc); + end if; + + Next_Discriminant (Disc); + end loop; + + -- That loop should always succeed in finding a matching entry and + -- returning. Fatal error if not. + + raise Program_Error; + end Find_Body_Discriminal; + ------------------------------------- -- Find_Corresponding_Discriminant -- ------------------------------------- *************** package body Sem_Util is *** 3301,3371 **** end if; end First_Actual; - ------------------------- - -- Full_Qualified_Name -- - ------------------------- - - function Full_Qualified_Name (E : Entity_Id) return String_Id is - Res : String_Id; - pragma Warnings (Off, Res); - - function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id; - -- Compute recursively the qualified name without NUL at the end - - ---------------------------------- - -- Internal_Full_Qualified_Name -- - ---------------------------------- - - function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is - Ent : Entity_Id := E; - Parent_Name : String_Id := No_String; - - begin - -- Deals properly with child units - - if Nkind (Ent) = N_Defining_Program_Unit_Name then - Ent := Defining_Identifier (Ent); - end if; - - -- Compute qualification recursively (only "Standard" has no scope) - - if Present (Scope (Scope (Ent))) then - Parent_Name := Internal_Full_Qualified_Name (Scope (Ent)); - end if; - - -- Every entity should have a name except some expanded blocks - -- don't bother about those. - - if Chars (Ent) = No_Name then - return Parent_Name; - end if; - - -- Add a period between Name and qualification - - if Parent_Name /= No_String then - Start_String (Parent_Name); - Store_String_Char (Get_Char_Code ('.')); - - else - Start_String; - end if; - - -- Generates the entity name in upper case - - Get_Decoded_Name_String (Chars (Ent)); - Set_All_Upper_Case; - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - return End_String; - end Internal_Full_Qualified_Name; - - -- Start of processing for Full_Qualified_Name - - begin - Res := Internal_Full_Qualified_Name (E); - Store_String_Char (Get_Char_Code (ASCII.NUL)); - return End_String; - end Full_Qualified_Name; - ----------------------- -- Gather_Components -- ----------------------- --- 3641,3646 ---- *************** package body Sem_Util is *** 4452,4466 **** (T : Entity_Id; Use_Full_View : Boolean := True) return Boolean is ! Typ : Entity_Id; begin -- Handle concurrent types ! if Is_Concurrent_Type (T) then ! Typ := Corresponding_Record_Type (T); ! else ! Typ := T; end if; if not Present (Typ) --- 4727,4739 ---- (T : Entity_Id; Use_Full_View : Boolean := True) return Boolean is ! Typ : Entity_Id := Base_Type (T); begin -- Handle concurrent types ! if Is_Concurrent_Type (Typ) then ! Typ := Corresponding_Record_Type (Typ); end if; if not Present (Typ) *************** package body Sem_Util is *** 4848,4885 **** -- We are interested only in components and discriminants ! if Ekind (Ent) = E_Component ! or else ! Ekind (Ent) = E_Discriminant ! then ! -- Get default expression if any. If there is no declaration ! -- node, it means we have an internal entity. The parent and ! -- tag fields are examples of such entities. For these cases, ! -- we just test the type of the entity. ! if Present (Declaration_Node (Ent)) then ! Exp := Expression (Declaration_Node (Ent)); ! else ! Exp := Empty; ! end if; ! -- A component has PI if it has no default expression and the ! -- component type has PI. ! if No (Exp) then ! if not Has_Preelaborable_Initialization (Etype (Ent)) then ! Has_PE := False; ! exit; end if; ! -- Require the default expression to be preelaborable ! elsif not Is_Preelaborable_Expression (Exp) then Has_PE := False; exit; end if; end if; Next_Entity (Ent); end loop; end Check_Components; --- 5121,5170 ---- -- We are interested only in components and discriminants ! Exp := Empty; ! case Ekind (Ent) is ! when E_Component => ! -- Get default expression if any. If there is no declaration ! -- node, it means we have an internal entity. The parent and ! -- tag fields are examples of such entities. For such cases, ! -- we just test the type of the entity. ! if Present (Declaration_Node (Ent)) then ! Exp := Expression (Declaration_Node (Ent)); end if; ! when E_Discriminant => ! -- Note: for a renamed discriminant, the Declaration_Node ! -- may point to the one from the ancestor, and have a ! -- different expression, so use the proper attribute to ! -- retrieve the expression from the derived constraint. ! ! Exp := Discriminant_Default_Value (Ent); ! ! when others => ! goto Check_Next_Entity; ! end case; ! ! -- A component has PI if it has no default expression and the ! -- component type has PI. ! ! if No (Exp) then ! if not Has_Preelaborable_Initialization (Etype (Ent)) then Has_PE := False; exit; end if; + + -- Require the default expression to be preelaborable + + elsif not Is_Preelaborable_Expression (Exp) then + Has_PE := False; + exit; end if; + <> Next_Entity (Ent); end loop; end Check_Components; *************** package body Sem_Util is *** 5093,5098 **** --- 5378,5393 ---- end if; end Has_Stream; + ---------------- + -- Has_Suffix -- + ---------------- + + function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is + begin + Get_Name_String (Chars (E)); + return Name_Buffer (Name_Len) = Suffix; + end Has_Suffix; + -------------------------- -- Has_Tagged_Component -- -------------------------- *************** package body Sem_Util is *** 5129,5134 **** --- 5424,5441 ---- end if; end Has_Tagged_Component; + ------------------------- + -- Implementation_Kind -- + ------------------------- + + function Implementation_Kind (Subp : Entity_Id) return Name_Id is + Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented); + begin + pragma Assert (Present (Impl_Prag)); + return + Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag)))); + end Implementation_Kind; + -------------------------- -- Implements_Interface -- -------------------------- *************** package body Sem_Util is *** 5406,5421 **** begin Save_Interps (N, New_Prefix); ! -- Check if the node relocation requires readjustment of some SCIL ! -- dispatching node. ! ! if Generate_SCIL ! and then Nkind (N) = N_Function_Call ! then ! Adjust_SCIL_Node (N, New_Prefix); ! end if; ! ! Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix)); Set_Etype (N, Designated_Type (Etype (New_Prefix))); --- 5713,5721 ---- begin Save_Interps (N, New_Prefix); ! Rewrite (N, ! Make_Explicit_Dereference (Sloc (Parent (N)), ! Prefix => New_Prefix)); Set_Etype (N, Designated_Type (Etype (New_Prefix))); *************** package body Sem_Util is *** 5446,5451 **** --- 5746,5752 ---- if Is_Entity_Name (New_Prefix) then Ent := Entity (New_Prefix); + Pref := New_Prefix; -- For a retrieval of a subcomponent of some composite object, -- retrieve the ultimate entity if there is one. *************** package body Sem_Util is *** 5467,5474 **** end if; end if; if Present (Ent) then ! Generate_Reference (Ent, New_Prefix); end if; end if; end Insert_Explicit_Dereference; --- 5768,5777 ---- end if; end if; + -- Place the reference on the entity node + if Present (Ent) then ! Generate_Reference (Ent, Pref); end if; end if; end Insert_Explicit_Dereference; *************** package body Sem_Util is *** 5494,5501 **** and then Comes_From_Source (Decl) ! -- The constant is not completed. A full object declaration ! -- or a pragma Import complete a deferred constant. and then not Has_Completion (Defining_Identifier (Decl)) then --- 5797,5804 ---- and then Comes_From_Source (Decl) ! -- The constant is not completed. A full object declaration or a ! -- pragma Import complete a deferred constant. and then not Has_Completion (Defining_Identifier (Decl)) then *************** package body Sem_Util is *** 5508,5525 **** end loop; end Inspect_Deferred_Constant_Completion; - ------------------- - -- Is_AAMP_Float -- - ------------------- - - function Is_AAMP_Float (E : Entity_Id) return Boolean is - pragma Assert (Is_Type (E)); - begin - return AAMP_On_Target - and then Is_Floating_Point_Type (E) - and then E = Base_Type (E); - end Is_AAMP_Float; - ----------------------------- -- Is_Actual_Out_Parameter -- ----------------------------- --- 5811,5816 ---- *************** package body Sem_Util is *** 5529,5536 **** Call : Node_Id; begin Find_Actual (N, Formal, Call); ! return Present (Formal) ! and then Ekind (Formal) = E_Out_Parameter; end Is_Actual_Out_Parameter; ------------------------- --- 5820,5826 ---- Call : Node_Id; begin Find_Actual (N, Formal, Call); ! return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; end Is_Actual_Out_Parameter; ------------------------- *************** package body Sem_Util is *** 5700,5706 **** -- Start of processing for Is_Atomic_Object begin ! if Is_Atomic (Etype (N)) or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) then return True; --- 5990,6001 ---- -- Start of processing for Is_Atomic_Object begin ! -- Predicate is not relevant to subprograms ! ! if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then ! return False; ! ! elsif Is_Atomic (Etype (N)) or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) then return True; *************** package body Sem_Util is *** 5797,5808 **** and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- ---------------------------------------------- function Is_Dependent_Component_Of_Mutable_Object ! (Object : Node_Id) return Boolean is P : Node_Id; Prefix_Type : Entity_Id; --- 6092,6151 ---- and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; + ----------------- + -- Is_Delegate -- + ----------------- + + function Is_Delegate (T : Entity_Id) return Boolean is + Desig_Type : Entity_Id; + + begin + if VM_Target /= CLI_Target then + return False; + end if; + + -- Access-to-subprograms are delegates in CIL + + if Ekind (T) = E_Access_Subprogram_Type then + return True; + end if; + + if Ekind (T) not in Access_Kind then + + -- A delegate is a managed pointer. If no designated type is defined + -- it means that it's not a delegate. + + return False; + end if; + + Desig_Type := Etype (Directly_Designated_Type (T)); + + if not Is_Tagged_Type (Desig_Type) then + return False; + end if; + + -- Test if the type is inherited from [mscorlib]System.Delegate + + while Etype (Desig_Type) /= Desig_Type loop + if Chars (Scope (Desig_Type)) /= No_Name + and then Is_Imported (Scope (Desig_Type)) + and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" + then + return True; + end if; + + Desig_Type := Etype (Desig_Type); + end loop; + + return False; + end Is_Delegate; + ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- ---------------------------------------------- function Is_Dependent_Component_Of_Mutable_Object ! (Object : Node_Id) return Boolean is P : Node_Id; Prefix_Type : Entity_Id; *************** package body Sem_Util is *** 5842,5851 **** P_Aliased := True; end if; ! -- A discriminant check on a selected component may be ! -- expanded into a dereference when removing side-effects. ! -- Recover the original node and its type, which may be ! -- unconstrained. elsif Nkind (P) = N_Explicit_Dereference and then not (Comes_From_Source (P)) --- 6185,6193 ---- P_Aliased := True; end if; ! -- A discriminant check on a selected component may be expanded ! -- into a dereference when removing side-effects. Recover the ! -- original node and its type, which may be unconstrained. elsif Nkind (P) = N_Explicit_Dereference and then not (Comes_From_Source (P)) *************** package body Sem_Util is *** 5854,5860 **** Prefix_Type := Etype (P); else ! -- Check for prefix being an aliased component ??? null; end if; --- 6196,6203 ---- Prefix_Type := Etype (P); else ! -- Check for prefix being an aliased component??? ! null; end if; *************** package body Sem_Util is *** 5870,5883 **** -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are -- semantic rules -- these rules are acknowledged to need fixing). ! if Ada_Version < Ada_05 then if Is_Access_Type (Prefix_Type) or else Nkind (P) = N_Explicit_Dereference then return False; end if; ! elsif Ada_Version >= Ada_05 then if Is_Access_Type (Prefix_Type) then -- If the access type is pool-specific, and there is no --- 6213,6226 ---- -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are -- semantic rules -- these rules are acknowledged to need fixing). ! if Ada_Version < Ada_2005 then if Is_Access_Type (Prefix_Type) or else Nkind (P) = N_Explicit_Dereference then return False; end if; ! elsif Ada_Version >= Ada_2005 then if Is_Access_Type (Prefix_Type) then -- If the access type is pool-specific, and there is no *************** package body Sem_Util is *** 5903,5910 **** Comp := Original_Record_Component (Entity (Selector_Name (Object))); ! -- As per AI-0017, the renaming is illegal in a generic body, ! -- even if the subtype is indefinite. -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable --- 6246,6253 ---- Comp := Original_Record_Component (Entity (Selector_Name (Object))); ! -- As per AI-0017, the renaming is illegal in a generic body, even ! -- if the subtype is indefinite. -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable *************** package body Sem_Util is *** 5917,5923 **** and then (Is_Declared_Within_Variant (Comp) or else Has_Discriminant_Dependent_Constraint (Comp)) ! and then (not P_Aliased or else Ada_Version >= Ada_05) then return True; --- 6260,6266 ---- and then (Is_Declared_Within_Variant (Comp) or else Has_Discriminant_Dependent_Constraint (Comp)) ! and then (not P_Aliased or else Ada_Version >= Ada_2005) then return True; *************** package body Sem_Util is *** 6353,6359 **** -- the corresponding procedure has been created, and which therefore do -- not have an assigned scope. ! if Ekind (E) in Formal_Kind then return False; end if; --- 6696,6702 ---- -- the corresponding procedure has been created, and which therefore do -- not have an assigned scope. ! if Is_Formal (E) then return False; end if; *************** package body Sem_Util is *** 6376,6385 **** Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin ! if Ekind (Ent) /= E_Variable ! and then ! Ekind (Ent) /= E_In_Out_Parameter ! then return False; else return Present (Sub) and then Sub = Current_Subprogram; --- 6719,6725 ---- Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin ! if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then return False; else return Present (Sub) and then Sub = Current_Subprogram; *************** package body Sem_Util is *** 6532,6550 **** -- Is_Partially_Initialized_Type -- ----------------------------------- ! function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is begin if Is_Scalar_Type (Typ) then return False; elsif Is_Access_Type (Typ) then ! return True; elsif Is_Array_Type (Typ) then -- If component type is partially initialized, so is array type ! if Is_Partially_Initialized_Type (Component_Type (Typ)) then return True; -- Otherwise we are only partially initialized if we are fully --- 6872,6895 ---- -- Is_Partially_Initialized_Type -- ----------------------------------- ! function Is_Partially_Initialized_Type ! (Typ : Entity_Id; ! Include_Implicit : Boolean := True) return Boolean ! is begin if Is_Scalar_Type (Typ) then return False; elsif Is_Access_Type (Typ) then ! return Include_Implicit; elsif Is_Array_Type (Typ) then -- If component type is partially initialized, so is array type ! if Is_Partially_Initialized_Type ! (Component_Type (Typ), Include_Implicit) ! then return True; -- Otherwise we are only partially initialized if we are fully *************** package body Sem_Util is *** 6557,6565 **** elsif Is_Record_Type (Typ) then ! -- A discriminated type is always partially initialized ! if Has_Discriminants (Typ) then return True; -- A tagged type is always partially initialized --- 6902,6911 ---- elsif Is_Record_Type (Typ) then ! -- A discriminated type is always partially initialized if in ! -- all mode ! if Has_Discriminants (Typ) and then Include_Implicit then return True; -- A tagged type is always partially initialized *************** package body Sem_Util is *** 6597,6603 **** -- If a component is of a type which is itself partially -- initialized, then the enclosing record type is also. ! elsif Is_Partially_Initialized_Type (Etype (Ent)) then return True; end if; end if; --- 6943,6951 ---- -- If a component is of a type which is itself partially -- initialized, then the enclosing record type is also. ! elsif Is_Partially_Initialized_Type ! (Etype (Ent), Include_Implicit) ! then return True; end if; end if; *************** package body Sem_Util is *** 6636,6642 **** if No (U) then return True; else ! return Is_Partially_Initialized_Type (U); end if; end; --- 6984,6990 ---- if No (U) then return True; else ! return Is_Partially_Initialized_Type (U, Include_Implicit); end if; end; *************** package body Sem_Util is *** 6749,6755 **** -- because they denote entities that are not necessarily visible. -- Neither of them can apply to a protected type. ! return Ada_Version >= Ada_05 and then Is_Entity_Name (N) and then Present (Entity (N)) and then Is_Protected_Type (Entity (N)) --- 7097,7103 ---- -- because they denote entities that are not necessarily visible. -- Neither of them can apply to a protected type. ! return Ada_Version >= Ada_2005 and then Is_Entity_Name (N) and then Present (Entity (N)) and then Is_Protected_Type (Entity (N)) *************** package body Sem_Util is *** 7033,7038 **** --- 7381,7395 ---- return (U /= 0); end Is_True; + ------------------------------- + -- Is_Universal_Numeric_Type -- + ------------------------------- + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is + begin + return T = Universal_Integer or else T = Universal_Real; + end Is_Universal_Numeric_Type; + ------------------- -- Is_Value_Type -- ------------------- *************** package body Sem_Util is *** 7045,7097 **** and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; ! ----------------- ! -- Is_Delegate -- ! ----------------- ! ! function Is_Delegate (T : Entity_Id) return Boolean is ! Desig_Type : Entity_Id; begin ! if VM_Target /= CLI_Target then ! return False; ! end if; ! ! -- Access-to-subprograms are delegates in CIL ! ! if Ekind (T) = E_Access_Subprogram_Type then ! return True; ! end if; ! ! if Ekind (T) not in Access_Kind then ! ! -- A delegate is a managed pointer. If no designated type is defined ! -- it means that it's not a delegate. ! ! return False; ! end if; ! ! Desig_Type := Etype (Directly_Designated_Type (T)); ! ! if not Is_Tagged_Type (Desig_Type) then ! return False; ! end if; ! ! -- Test if the type is inherited from [mscorlib]System.Delegate ! ! while Etype (Desig_Type) /= Desig_Type loop ! if Chars (Scope (Desig_Type)) /= No_Name ! and then Is_Imported (Scope (Desig_Type)) ! and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" ! then ! return True; ! end if; ! ! Desig_Type := Etype (Desig_Type); ! end loop; ! return False; ! end Is_Delegate; ----------------- -- Is_Variable -- --- 7402,7426 ---- and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; ! --------------------- ! -- Is_VMS_Operator -- ! --------------------- + function Is_VMS_Operator (Op : Entity_Id) return Boolean is begin ! -- The VMS operators are declared in a child of System that is loaded ! -- through pragma Extend_System. In some rare cases a program is run ! -- with this extension but without indicating that the target is VMS. ! return Ekind (Op) = E_Function ! and then Is_Intrinsic_Subprogram (Op) ! and then ! ((Present_System_Aux ! and then Scope (Op) = System_Aux_Id) ! or else ! (True_VMS_Target ! and then Scope (Scope (Op)) = RTU_Entity (System))); ! end Is_VMS_Operator; ----------------- -- Is_Variable -- *************** package body Sem_Util is *** 7107,7120 **** -- expansion. function In_Protected_Function (E : Entity_Id) return Boolean; ! -- Within a protected function, the private components of the ! -- enclosing protected type are constants. A function nested within ! -- a (protected) procedure is not itself protected. function Is_Variable_Prefix (P : Node_Id) return Boolean; ! -- Prefixes can involve implicit dereferences, in which case we ! -- must test for the case of a reference of a constant access ! -- type, which can never be a variable. --------------------------- -- In_Protected_Function -- --- 7436,7449 ---- -- expansion. function In_Protected_Function (E : Entity_Id) return Boolean; ! -- Within a protected function, the private components of the enclosing ! -- protected type are constants. A function nested within a (protected) ! -- procedure is not itself protected. function Is_Variable_Prefix (P : Node_Id) return Boolean; ! -- Prefixes can involve implicit dereferences, in which case we must ! -- test for the case of a reference of a constant access type, which can ! -- can never be a variable. --------------------------- -- In_Protected_Function -- *************** package body Sem_Util is *** 7130,7138 **** else S := Current_Scope; while Present (S) and then S /= Prot loop ! if Ekind (S) = E_Function ! and then Scope (S) = Prot ! then return True; end if; --- 7459,7465 ---- else S := Current_Scope; while Present (S) and then S /= Prot loop ! if Ekind (S) = E_Function and then Scope (S) = Prot then return True; end if; *************** package body Sem_Util is *** 7177,7192 **** if Nkind (N) in N_Subexpr and then Assignment_OK (N) then return True; ! -- Normally we go to the original node, but there is one exception ! -- where we use the rewritten node, namely when it is an explicit ! -- dereference. The generated code may rewrite a prefix which is an ! -- access type with an explicit dereference. The dereference is a ! -- variable, even though the original node may not be (since it could ! -- be a constant of the access type). ! -- In Ada 2005 we have a further case to consider: the prefix may be ! -- a function call given in prefix notation. The original node appears ! -- to be a selected component, but we need to examine the call. elsif Nkind (N) = N_Explicit_Dereference and then Nkind (Orig_Node) /= N_Explicit_Dereference --- 7504,7519 ---- if Nkind (N) in N_Subexpr and then Assignment_OK (N) then return True; ! -- Normally we go to the original node, but there is one exception where ! -- we use the rewritten node, namely when it is an explicit dereference. ! -- The generated code may rewrite a prefix which is an access type with ! -- an explicit dereference. The dereference is a variable, even though ! -- the original node may not be (since it could be a constant of the ! -- access type). ! -- In Ada 2005 we have a further case to consider: the prefix may be a ! -- function call given in prefix notation. The original node appears to ! -- be a selected component, but we need to examine the call. elsif Nkind (N) = N_Explicit_Dereference and then Nkind (Orig_Node) /= N_Explicit_Dereference *************** package body Sem_Util is *** 7679,7695 **** when N_Explicit_Dereference => return False; ! -- Function call arguments are never lvalues ! ! when N_Function_Call => ! return False; ! ! -- Positional parameter for procedure, entry, or accept call ! when N_Procedure_Call_Statement | N_Entry_Call_Statement | N_Accept_Statement => declare Proc : Entity_Id; Form : Entity_Id; --- 8006,8029 ---- when N_Explicit_Dereference => return False; ! -- Positional parameter for subprogram, entry, or accept call. ! -- In older versions of Ada function call arguments are never ! -- lvalues. In Ada 2012 functions can have in-out parameters. ! when N_Function_Call | ! N_Procedure_Call_Statement | N_Entry_Call_Statement | N_Accept_Statement => + if Nkind (P) = N_Function_Call + and then Ada_Version < Ada_2012 + then + return False; + end if; + + -- The following mechanism is clumsy and fragile. A single + -- flag set in Resolve_Actuals would be preferable ??? + declare Proc : Entity_Id; Form : Entity_Id; *************** package body Sem_Util is *** 7805,7810 **** --- 8139,8155 ---- if Nkind (N) = N_Allocator then if Is_Dynamic then Set_Is_Dynamic_Coextension (N); + + -- If the allocator expression is potentially dynamic, it may + -- be expanded out of order and require dynamic allocation + -- anyway, so we treat the coextension itself as dynamic. + -- Potential optimization ??? + + elsif Nkind (Expression (N)) = N_Qualified_Expression + and then Nkind (Expression (Expression (N))) = N_Op_Concat + then + Set_Is_Dynamic_Coextension (N); + else Set_Is_Static_Coextension (N); end if; *************** package body Sem_Util is *** 7844,7850 **** Formal : Entity_Id; begin ! if Ada_Version >= Ada_05 and then Present (First_Formal (E)) then Formal := Next_Formal (First_Formal (E)); --- 8189,8195 ---- Formal : Entity_Id; begin ! if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then Formal := Next_Formal (First_Formal (E)); *************** package body Sem_Util is *** 7903,7909 **** -- Itype references within the copied tree. -- The following hash tables are used if the Map supplied has more ! -- than hash threshhold entries to speed up access to the map. If -- there are fewer entries, then the map is searched sequentially -- (because setting up a hash table for only a few entries takes -- more time than it saves. --- 8248,8254 ---- -- Itype references within the copied tree. -- The following hash tables are used if the Map supplied has more ! -- than hash threshold entries to speed up access to the map. If -- there are fewer entries, then the map is searched sequentially -- (because setting up a hash table for only a few entries takes -- more time than it saves. *************** package body Sem_Util is *** 8639,8645 **** else NCT_Table_Entries := NCT_Table_Entries + 1; ! if NCT_Table_Entries > NCT_Hash_Threshhold then Build_NCT_Hash_Tables; end if; end if; --- 8984,8990 ---- else NCT_Table_Entries := NCT_Table_Entries + 1; ! if NCT_Table_Entries > NCT_Hash_Threshold then Build_NCT_Hash_Tables; end if; end if; *************** package body Sem_Util is *** 8647,8655 **** -- If a record subtype is simply copied, the entity list will be -- shared. Thus cloned_Subtype must be set to indicate the sharing. ! if Ekind (Old_Itype) = E_Record_Subtype ! or else Ekind (Old_Itype) = E_Class_Wide_Subtype ! then Set_Cloned_Subtype (New_Itype, Old_Itype); end if; --- 8992,8998 ---- -- If a record subtype is simply copied, the entity list will be -- shared. Thus cloned_Subtype must be set to indicate the sharing. ! if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then Set_Cloned_Subtype (New_Itype, Old_Itype); end if; *************** package body Sem_Util is *** 8775,8781 **** Next_Elmt (Elmt); end loop; ! if NCT_Table_Entries > NCT_Hash_Threshhold then Build_NCT_Hash_Tables; else NCT_Hash_Tables_Used := False; --- 9118,9124 ---- Next_Elmt (Elmt); end loop; ! if NCT_Table_Entries > NCT_Hash_Threshold then Build_NCT_Hash_Tables; else NCT_Hash_Tables_Used := False; *************** package body Sem_Util is *** 8852,8859 **** Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is ! N : constant Entity_Id := ! Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char)); begin Set_Ekind (N, Kind); --- 9195,9201 ---- Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is ! N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin Set_Ekind (N, Kind); *************** package body Sem_Util is *** 9273,9279 **** if Comes_From_Source (Exp) or else Modification_Comes_From_Source then ! if Has_Pragma_Unmodified (Ent) then Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent); end if; --- 9615,9624 ---- if Comes_From_Source (Exp) or else Modification_Comes_From_Source then ! -- Give warning if pragma unmodified given and we are ! -- sure this is a modification. ! ! if Has_Pragma_Unmodified (Ent) and then Sure then Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent); end if; *************** package body Sem_Util is *** 9303,9308 **** --- 9648,9676 ---- if Modification_Comes_From_Source then Generate_Reference (Ent, Exp, 'm'); + + -- If the target of the assignment is the bound variable + -- in an iterator, indicate that the corresponding array + -- or container is also modified. + + if Ada_Version >= Ada_2012 + and then + Nkind (Parent (Ent)) = N_Iterator_Specification + then + declare + Domain : constant Node_Id := Name (Parent (Ent)); + + begin + -- TBD : in the full version of the construct, the + -- domain of iteration can be given by an expression. + + if Is_Entity_Name (Domain) then + Generate_Reference (Entity (Domain), Exp, 'm'); + Set_Is_True_Constant (Entity (Domain), False); + Set_Never_Set_In_Source (Entity (Domain), False); + end if; + end; + end if; end if; Check_Nested_Access (Ent); *************** package body Sem_Util is *** 9468,9482 **** then return Object_Access_Level (Expression (Obj)); - -- Function results are objects, so we get either the access level of - -- the function or, in the case of an indirect call, the level of the - -- access-to-subprogram type. - elsif Nkind (Obj) = N_Function_Call then ! if Is_Entity_Name (Name (Obj)) then ! return Subprogram_Access_Level (Entity (Name (Obj))); else ! return Type_Access_Level (Etype (Prefix (Name (Obj)))); end if; -- For convenience we handle qualified expressions, even though --- 9836,9947 ---- then return Object_Access_Level (Expression (Obj)); elsif Nkind (Obj) = N_Function_Call then ! ! -- Function results are objects, so we get either the access level of ! -- the function or, in the case of an indirect call, the level of the ! -- access-to-subprogram type. (This code is used for Ada 95, but it ! -- looks wrong, because it seems that we should be checking the level ! -- of the call itself, even for Ada 95. However, using the Ada 2005 ! -- version of the code causes regressions in several tests that are ! -- compiled with -gnat95. ???) ! ! if Ada_Version < Ada_2005 then ! if Is_Entity_Name (Name (Obj)) then ! return Subprogram_Access_Level (Entity (Name (Obj))); ! else ! return Type_Access_Level (Etype (Prefix (Name (Obj)))); ! end if; ! ! -- For Ada 2005, the level of the result object of a function call is ! -- defined to be the level of the call's innermost enclosing master. ! -- We determine that by querying the depth of the innermost enclosing ! -- dynamic scope. ! else ! Return_Master_Scope_Depth_Of_Call : declare ! ! function Innermost_Master_Scope_Depth ! (N : Node_Id) return Uint; ! -- Returns the scope depth of the given node's innermost ! -- enclosing dynamic scope (effectively the accessibility ! -- level of the innermost enclosing master). ! ! ---------------------------------- ! -- Innermost_Master_Scope_Depth -- ! ---------------------------------- ! ! function Innermost_Master_Scope_Depth ! (N : Node_Id) return Uint ! is ! Node_Par : Node_Id := Parent (N); ! ! begin ! -- Locate the nearest enclosing node (by traversing Parents) ! -- that Defining_Entity can be applied to, and return the ! -- depth of that entity's nearest enclosing dynamic scope. ! ! while Present (Node_Par) loop ! case Nkind (Node_Par) is ! when N_Component_Declaration | ! N_Entry_Declaration | ! N_Formal_Object_Declaration | ! N_Formal_Type_Declaration | ! N_Full_Type_Declaration | ! N_Incomplete_Type_Declaration | ! N_Loop_Parameter_Specification | ! N_Object_Declaration | ! N_Protected_Type_Declaration | ! N_Private_Extension_Declaration | ! N_Private_Type_Declaration | ! N_Subtype_Declaration | ! N_Function_Specification | ! N_Procedure_Specification | ! N_Task_Type_Declaration | ! N_Body_Stub | ! N_Generic_Instantiation | ! N_Proper_Body | ! N_Implicit_Label_Declaration | ! N_Package_Declaration | ! N_Single_Task_Declaration | ! N_Subprogram_Declaration | ! N_Generic_Declaration | ! N_Renaming_Declaration | ! N_Block_Statement | ! N_Formal_Subprogram_Declaration | ! N_Abstract_Subprogram_Declaration | ! N_Entry_Body | ! N_Exception_Declaration | ! N_Formal_Package_Declaration | ! N_Number_Declaration | ! N_Package_Specification | ! N_Parameter_Specification | ! N_Single_Protected_Declaration | ! N_Subunit => ! ! return Scope_Depth ! (Nearest_Dynamic_Scope ! (Defining_Entity (Node_Par))); ! ! when others => ! null; ! end case; ! ! Node_Par := Parent (Node_Par); ! end loop; ! ! pragma Assert (False); ! ! -- Should never reach the following return ! ! return Scope_Depth (Current_Scope) + 1; ! end Innermost_Master_Scope_Depth; ! ! -- Start of processing for Return_Master_Scope_Depth_Of_Call ! ! begin ! return Innermost_Master_Scope_Depth (Obj); ! end Return_Master_Scope_Depth_Of_Call; end if; -- For convenience we handle qualified expressions, even though *************** package body Sem_Util is *** 9495,9500 **** --- 9960,9995 ---- end if; end Object_Access_Level; + -------------------------------------- + -- Original_Corresponding_Operation -- + -------------------------------------- + + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id + is + Typ : constant Entity_Id := Find_Dispatching_Type (S); + + begin + -- If S is an inherited primitive S2 the original corresponding + -- operation of S is the original corresponding operation of S2 + + if Present (Alias (S)) + and then Find_Dispatching_Type (Alias (S)) /= Typ + then + return Original_Corresponding_Operation (Alias (S)); + + -- If S overrides an inherited subprogram S2 the original corresponding + -- operation of S is the original corresponding operation of S2 + + elsif Present (Overridden_Operation (S)) then + return Original_Corresponding_Operation (Overridden_Operation (S)); + + -- otherwise it is S itself + + else + return S; + end if; + end Original_Corresponding_Operation; + ----------------------- -- Private_Component -- ----------------------- *************** package body Sem_Util is *** 9799,9843 **** Set_Sloc (Endl, Loc); end Process_End_Label; - ------------------ - -- Real_Convert -- - ------------------ - - -- We do the conversion to get the value of the real string by using - -- the scanner, see Sinput for details on use of the internal source - -- buffer for scanning internal strings. - - function Real_Convert (S : String) return Node_Id is - Save_Src : constant Source_Buffer_Ptr := Source; - Negative : Boolean; - - begin - Source := Internal_Source_Ptr; - Scan_Ptr := 1; - - for J in S'Range loop - Source (Source_Ptr (J)) := S (J); - end loop; - - Source (S'Length + 1) := EOF; - - if Source (Scan_Ptr) = '-' then - Negative := True; - Scan_Ptr := Scan_Ptr + 1; - else - Negative := False; - end if; - - Scan; - - if Negative then - Set_Realval (Token_Node, UR_Negate (Realval (Token_Node))); - end if; - - Source := Save_Src; - return Token_Node; - end Real_Convert; - ------------------------------------ -- References_Generic_Formal_Type -- ------------------------------------ --- 10294,10299 ---- *************** package body Sem_Util is *** 10140,10151 **** while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; ! if Ekind (R_Scope) /= E_Package ! and then ! Ekind (R_Scope) /= E_Block ! and then ! Ekind (R_Scope) /= E_Loop ! then return False; else R_Scope := Scope (R_Scope); --- 10596,10602 ---- while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; ! if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then return False; else R_Scope := Scope (R_Scope); *************** package body Sem_Util is *** 10237,10256 **** begin -- First case, both are entities with same entity ! if K1 in N_Has_Entity ! and then K2 in N_Has_Entity ! and then Present (Entity (N1)) ! and then Present (Entity (N2)) ! and then (Ekind (Entity (N1)) = E_Variable ! or else ! Ekind (Entity (N1)) = E_Constant) ! and then Entity (N1) = Entity (N2) ! then ! return True; -- Second case, selected component with same selector, same record ! elsif K1 = N_Selected_Component and then K2 = N_Selected_Component and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) then --- 10688,10711 ---- begin -- First case, both are entities with same entity ! if K1 in N_Has_Entity and then K2 in N_Has_Entity then ! declare ! EN1 : constant Entity_Id := Entity (N1); ! EN2 : constant Entity_Id := Entity (N2); ! begin ! if Present (EN1) and then Present (EN2) ! and then (Ekind_In (EN1, E_Variable, E_Constant) ! or else Is_Formal (EN1)) ! and then EN1 = EN2 ! then ! return True; ! end if; ! end; ! end if; -- Second case, selected component with same selector, same record ! if K1 = N_Selected_Component and then K2 = N_Selected_Component and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2)) then *************** package body Sem_Util is *** 10341,10346 **** --- 10796,10830 ---- end if; end Same_Value; + ----------------- + -- Save_Actual -- + ----------------- + + procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is + begin + if Ada_Version < Ada_2012 then + return; + + elsif Is_Entity_Name (N) + or else + Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice) + or else + (Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Access) + + then + -- We are only interested in IN OUT parameters of inner calls + + if not Writable + or else Nkind (Parent (N)) = N_Function_Call + or else Nkind (Parent (N)) in N_Op + then + Actuals_In_Call.Increment_Last; + Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable); + end if; + end if; + end Save_Actual; + ------------------------ -- Scope_Is_Transient -- ------------------------ *************** package body Sem_Util is *** 10489,10494 **** --- 10973,10981 ---- end loop; end; + -- For a class wide subtype, we also need debug information + -- for the equivalent type. + if Ekind (T) = E_Class_Wide_Subtype then Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); end if; *************** package body Sem_Util is *** 10964,10985 **** return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; - -------------------- - -- Ultimate_Alias -- - -------------------- - -- To do: add occurrences calling this new subprogram - - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is - E : Entity_Id := Prim; - - begin - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - return E; - end Ultimate_Alias; - -------------------------- -- Unit_Declaration_Node -- -------------------------- --- 11451,11456 ---- *************** package body Sem_Util is *** 11080,11085 **** --- 11551,11597 ---- end if; end Unqualify; + ----------------------- + -- Visible_Ancestors -- + ----------------------- + + function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is + List_1 : Elist_Id; + List_2 : Elist_Id; + Elmt : Elmt_Id; + + begin + pragma Assert (Is_Record_Type (Typ) + and then Is_Tagged_Type (Typ)); + + -- Collect all the parents and progenitors of Typ. If the full-view of + -- private parents and progenitors is available then it is used to + -- generate the list of visible ancestors; otherwise their partial + -- view is added to the resulting list. + + Collect_Parents + (T => Typ, + List => List_1, + Use_Full_View => True); + + Collect_Interfaces + (T => Typ, + Ifaces_List => List_2, + Exclude_Parents => True, + Use_Full_View => True); + + -- Join the two lists. Avoid duplications because an interface may + -- simultaneously be parent and progenitor of a type. + + Elmt := First_Elmt (List_2); + while Present (Elmt) loop + Append_Unique_Elmt (Node (Elmt), List_1); + Next_Elmt (Elmt); + end loop; + + return List_1; + end Visible_Ancestors; + ---------------------- -- Within_Init_Proc -- ---------------------- *************** package body Sem_Util is *** 11218,11225 **** and then Covers (Designated_Type (Expec_Type), Designated_Type (Found_Type)) then ! Error_Msg_N ("result must be general access type!", Expr); ! Error_Msg_NE ("add ALL to }!", Expr, Expec_Type); -- Another special check, if the expected type is an integer type, -- but the expression is of type System.Address, and the parent is --- 11730,11739 ---- and then Covers (Designated_Type (Expec_Type), Designated_Type (Found_Type)) then ! Error_Msg_N -- CODEFIX ! ("result must be general access type!", Expr); ! Error_Msg_NE -- CODEFIX ! ("add ALL to }!", Expr, Expec_Type); -- Another special check, if the expected type is an integer type, -- but the expression is of type System.Address, and the parent is *************** package body Sem_Util is *** 11266,11272 **** if From_With_Type (Found_Type) then Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_Qual_Level := 99; ! Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type)); Error_Msg_Qual_Level := 0; else Error_Msg_NE ("found}!", Expr, Found_Type); --- 11780,11787 ---- if From_With_Type (Found_Type) then Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_Qual_Level := 99; ! Error_Msg_NE -- CODEFIX ! ("\\missing `WITH &;", Expr, Scope (Found_Type)); Error_Msg_Qual_Level := 0; else Error_Msg_NE ("found}!", Expr, Found_Type); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_util.ads gcc-4.6.0/gcc/ada/sem_util.ads *** gcc-4.5.2/gcc/ada/sem_util.ads Mon Nov 30 16:31:31 2009 --- gcc-4.6.0/gcc/ada/sem_util.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sem_Util is *** 51,56 **** --- 51,62 ---- -- for the current unit. The declarations are added in the current scope, -- so the caller should push a new scope as required before the call. + function Addressable (V : Uint) return Boolean; + function Addressable (V : Int) return Boolean; + pragma Inline (Addressable); + -- Returns True if the value of V is the word size of an addressable + -- factor of the word size (typically 8, 16, 32 or 64). + function Alignment_In_Bits (E : Entity_Id) return Uint; -- If the alignment of the type or object E is currently known to the -- compiler, then this function returns the alignment value in bits. *************** package Sem_Util is *** 84,92 **** -- node that is built is normally Etype (N), but if the Typ parameter -- is present, this is used instead. Warn is normally False. If it is -- True then the message is treated as a warning even though it does ! -- not end with a ? (this is used when the caller wants to parametrize -- whether an error or warning is given. function Build_Actual_Subtype (T : Entity_Id; N : Node_Or_Entity_Id) return Node_Id; --- 90,113 ---- -- node that is built is normally Etype (N), but if the Typ parameter -- is present, this is used instead. Warn is normally False. If it is -- True then the message is treated as a warning even though it does ! -- not end with a ? (this is used when the caller wants to parameterize -- whether an error or warning is given. + procedure Bad_Predicated_Subtype_Use + (Msg : String; + N : Node_Id; + Typ : Entity_Id); + -- This is called when Typ, a predicated subtype, is used in a context + -- which does not allow the use of a predicated subtype. Msg is passed + -- to Error_Msg_FE to output an appropriate message using N as the + -- location, and Typ as the entity. The caller must set up any insertions + -- other than the & for the type itself. Note that if Typ is a generic + -- actual type, then the message will be output as a warning, and a + -- raise Program_Error is inserted using Insert_Action with node N as + -- the insertion point. Node N also supplies the source location for + -- construction of the raise node. If Typ is NOT a type with predicates + -- this call has no effect. + function Build_Actual_Subtype (T : Entity_Id; N : Node_Or_Entity_Id) return Node_Id; *************** package Sem_Util is *** 132,146 **** -- Check wrong use of dynamically tagged expression procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); ! -- Verify that the full declaration of type T has been seen. If not, ! -- place error message on node N. Used in object declarations, type ! -- conversions, qualified expressions. procedure Check_Nested_Access (Ent : Entity_Id); -- Check whether Ent denotes an entity declared in an uplevel scope, which -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag -- accordingly. This is currently only enabled for VM_Target /= No_VM. procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. --- 153,172 ---- -- Check wrong use of dynamically tagged expression procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); ! -- Verify that the full declaration of type T has been seen. If not, place ! -- error message on node N. Used in object declarations, type conversions ! -- and qualified expressions. procedure Check_Nested_Access (Ent : Entity_Id); -- Check whether Ent denotes an entity declared in an uplevel scope, which -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag -- accordingly. This is currently only enabled for VM_Target /= No_VM. + procedure Check_Order_Dependence; + -- Examine the actuals in a top-level call to determine whether aliasing + -- between two actuals, one of which is writable, can make the call + -- order-dependent. + procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. *************** package Sem_Util is *** 153,162 **** -- a possible unlocked access to data. procedure Check_VMS (Construct : Node_Id); ! -- Check that this the target is OpenVMS, and if so, return with ! -- no effect, otherwise post an error noting this can only be used ! -- with OpenVMS ports. The argument is the construct in question ! -- and is used to post the error message. procedure Collect_Interfaces (T : Entity_Id; --- 179,188 ---- -- a possible unlocked access to data. procedure Check_VMS (Construct : Node_Id); ! -- Check that this the target is OpenVMS, and if so, return with no effect, ! -- otherwise post an error noting this can only be used with OpenVMS ports. ! -- The argument is the construct in question and is used to post the error ! -- message. procedure Collect_Interfaces (T : Entity_Id; *************** package Sem_Util is *** 186,196 **** -- of elements, and elements at the same position on these tables provide -- information on the same interface type. function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; ! -- Called upon type derivation and extension. We scan the declarative ! -- part in which the type appears, and collect subprograms that have ! -- one subsidiary subtype of the type. These subprograms can only ! -- appear after the type itself. function Compile_Time_Constraint_Error (N : Node_Id; --- 212,229 ---- -- of elements, and elements at the same position on these tables provide -- information on the same interface type. + procedure Collect_Parents + (T : Entity_Id; + List : out Elist_Id; + Use_Full_View : Boolean := True); + -- Collect all the parents of Typ. Use_Full_View is used to collect them + -- using the full-view of private parents (if available). + function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; ! -- Called upon type derivation and extension. We scan the declarative part ! -- in which the type appears, and collect subprograms that have one ! -- subsidiary subtype of the type. These subprograms can only appear after ! -- the type itself. function Compile_Time_Constraint_Error (N : Node_Id; *************** package Sem_Util is *** 202,213 **** -- generates a warning (or error) message in the same manner, but it does -- not replace any nodes. For convenience, the function always returns its -- first argument. The message is a warning if the message ends with ?, or ! -- we are operating in Ada 83 mode, or if the Warn parameter is set to ! -- True. procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id); ! -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag ! -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false); function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; -- Utility to create a parameter profile for a new subprogram spec, when --- 235,245 ---- -- generates a warning (or error) message in the same manner, but it does -- not replace any nodes. For convenience, the function always returns its -- first argument. The message is a warning if the message ends with ?, or ! -- we are operating in Ada 83 mode, or the Warn parameter is set to True. procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id); ! -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag of ! -- Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false). function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; -- Utility to create a parameter profile for a new subprogram spec, when *************** package Sem_Util is *** 216,221 **** --- 248,254 ---- -- for stubbed subprograms. function Current_Entity (N : Node_Id) return Entity_Id; + pragma Inline (Current_Entity); -- Find the currently visible definition for a given identifier, that is to -- say the first entry in the visibility chain for the Chars of N. *************** package Sem_Util is *** 235,255 **** -- from a library package which is not within any subprogram. function Defining_Entity (N : Node_Id) return Entity_Id; ! -- Given a declaration N, returns the associated defining entity. If ! -- the declaration has a specification, the entity is obtained from ! -- the specification. If the declaration has a defining unit name, ! -- then the defining entity is obtained from the defining unit name ! -- ignoring any child unit prefixes. function Denotes_Discriminant (N : Node_Id; Check_Concurrent : Boolean := False) return Boolean; ! -- Returns True if node N is an Entity_Name node for a discriminant. ! -- If the flag Check_Concurrent is true, function also returns true ! -- when N denotes the discriminal of the discriminant of a concurrent ! -- type. This is necessary to disable some optimizations on private ! -- components of protected types, and constraint checks on entry ! -- families constrained by discriminants. function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean; function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean; --- 268,287 ---- -- from a library package which is not within any subprogram. function Defining_Entity (N : Node_Id) return Entity_Id; ! -- Given a declaration N, returns the associated defining entity. If the ! -- declaration has a specification, the entity is obtained from the ! -- specification. If the declaration has a defining unit name, then the ! -- defining entity is obtained from the defining unit name ignoring any ! -- child unit prefixes. function Denotes_Discriminant (N : Node_Id; Check_Concurrent : Boolean := False) return Boolean; ! -- Returns True if node N is an Entity_Name node for a discriminant. If the ! -- flag Check_Concurrent is true, function also returns true when N denotes ! -- the discriminal of the discriminant of a concurrent type. This is needed ! -- to disable some optimizations on private components of protected types, ! -- and constraint checks on entry families constrained by discriminants. function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean; function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean; *************** package Sem_Util is *** 271,319 **** function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean; ! -- Return true if Name1 and Name2 designate the same unit name; ! -- each of these names is supposed to be a selected component name, ! -- an expanded name, a defining program unit name or an identifier function Enclosing_Generic_Body (N : Node_Id) return Node_Id; ! -- Returns the Node_Id associated with the innermost enclosing ! -- generic body, if any. If none, then returns Empty. function Enclosing_Generic_Unit (N : Node_Id) return Node_Id; ! -- Returns the Node_Id associated with the innermost enclosing ! -- generic unit, if any. If none, then returns Empty. function Enclosing_Lib_Unit_Entity return Entity_Id; -- Returns the entity of enclosing N_Compilation_Unit Node which is the ! -- root of the current scope (which must not be Standard_Standard, and ! -- the caller is responsible for ensuring this condition). function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id; ! -- Returns the enclosing N_Compilation_Unit Node that is the root ! -- of a subtree containing N. function Enclosing_Subprogram (E : Entity_Id) return Entity_Id; -- Utility function to return the Ada entity of the subprogram enclosing -- the entity E, if any. Returns Empty if no enclosing subprogram. procedure Ensure_Freeze_Node (E : Entity_Id); ! -- Make sure a freeze node is allocated for entity E. If necessary, ! -- build and initialize a new freeze node and set Has_Delayed_Freeze ! -- true for entity E. procedure Enter_Name (Def_Id : Entity_Id); -- Insert new name in symbol table of current scope with check for ! -- duplications (error message is issued if a conflict is found) ! -- Note: Enter_Name is not used for overloadable entities, instead ! -- these are entered using Sem_Ch6.Enter_Overloadable_Entity. procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); ! -- This procedure is called after issuing a message complaining ! -- about an inappropriate use of limited type T. If useful, it ! -- adds additional continuation lines to the message explaining ! -- why type T is limited. Messages are placed at node N. procedure Find_Actual (N : Node_Id; --- 303,353 ---- function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean; ! -- Return true if Name1 and Name2 designate the same unit name; each of ! -- these names is supposed to be a selected component name, an expanded ! -- name, a defining program unit name or an identifier. ! ! function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id; ! -- Returns the closest ancestor of Typ that is a CPP type. function Enclosing_Generic_Body (N : Node_Id) return Node_Id; ! -- Returns the Node_Id associated with the innermost enclosing generic ! -- body, if any. If none, then returns Empty. function Enclosing_Generic_Unit (N : Node_Id) return Node_Id; ! -- Returns the Node_Id associated with the innermost enclosing generic ! -- unit, if any. If none, then returns Empty. function Enclosing_Lib_Unit_Entity return Entity_Id; -- Returns the entity of enclosing N_Compilation_Unit Node which is the ! -- root of the current scope (which must not be Standard_Standard, and the ! -- caller is responsible for ensuring this condition). function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id; ! -- Returns the enclosing N_Compilation_Unit Node that is the root of a ! -- subtree containing N. function Enclosing_Subprogram (E : Entity_Id) return Entity_Id; -- Utility function to return the Ada entity of the subprogram enclosing -- the entity E, if any. Returns Empty if no enclosing subprogram. procedure Ensure_Freeze_Node (E : Entity_Id); ! -- Make sure a freeze node is allocated for entity E. If necessary, build ! -- and initialize a new freeze node and set Has_Delayed_Freeze True for E. procedure Enter_Name (Def_Id : Entity_Id); -- Insert new name in symbol table of current scope with check for ! -- duplications (error message is issued if a conflict is found). ! -- Note: Enter_Name is not used for overloadable entities, instead these ! -- are entered using Sem_Ch6.Enter_Overloadable_Entity. procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); ! -- This procedure is called after issuing a message complaining about an ! -- inappropriate use of limited type T. If useful, it adds additional ! -- continuation lines to the message explaining why type T is limited. ! -- Messages are placed at node N. procedure Find_Actual (N : Node_Id; *************** package Sem_Util is *** 329,339 **** function Find_Corresponding_Discriminant (Id : Node_Id; Typ : Entity_Id) return Entity_Id; ! -- Because discriminants may have different names in a generic unit ! -- and in an instance, they are resolved positionally when possible. ! -- A reference to a discriminant carries the discriminant that it ! -- denotes when analyzed. Subsequent uses of this id on a different ! -- type denote the discriminant at the same position in this new type. procedure Find_Overlaid_Entity (N : Node_Id; --- 363,373 ---- function Find_Corresponding_Discriminant (Id : Node_Id; Typ : Entity_Id) return Entity_Id; ! -- Because discriminants may have different names in a generic unit and in ! -- an instance, they are resolved positionally when possible. A reference ! -- to a discriminant carries the discriminant that it denotes when it is ! -- analyzed. Subsequent uses of this id on a different type denotes the ! -- discriminant at the same position in this new type. procedure Find_Overlaid_Entity (N : Node_Id; *************** package Sem_Util is *** 355,360 **** --- 389,400 ---- -- Determine the alternative chosen, so that the code of non-selected -- alternatives, and the warnings that may apply to them, are removed. + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id; + -- Given a discriminant of the record type that implements a task or + -- protected type, return the discriminal of the corresponding discriminant + -- of the actual concurrent type. + function First_Actual (Node : Node_Id) return Node_Id; -- Node is an N_Function_Call or N_Procedure_Call_Statement node. The -- result returned is the first actual parameter in declaration order *************** package Sem_Util is *** 364,377 **** -- iterating through the actuals in declaration order is to use this -- function to find the first actual, and then use Next_Actual to obtain -- the next actual in declaration order. Note that the value returned ! -- is always the expression (not the N_Parameter_Association nodes -- even if named association is used). - function Full_Qualified_Name (E : Entity_Id) return String_Id; - -- Generates the string literal corresponding to the E's full qualified - -- name in upper case. An ASCII.NUL is appended as the last character. - -- The names in the string are generated by Namet.Get_Decoded_Name_String. - procedure Gather_Components (Typ : Entity_Id; Comp_List : Node_Id; --- 404,412 ---- -- iterating through the actuals in declaration order is to use this -- function to find the first actual, and then use Next_Actual to obtain -- the next actual in declaration order. Note that the value returned ! -- is always the expression (not the N_Parameter_Association nodes, -- even if named association is used). procedure Gather_Components (Typ : Entity_Id; Comp_List : Node_Id; *************** package Sem_Util is *** 409,423 **** function Get_Actual_Subtype (N : Node_Id) return Entity_Id; -- Given a node for an expression, obtain the actual subtype of the -- expression. In the case of a parameter where the formal is an ! -- unconstrained array or discriminated type, this will be the ! -- previously constructed subtype of the actual. Note that this is ! -- not quite the "Actual Subtype" of the RM, since it is always ! -- a constrained type, i.e. it is the subtype of the value of the ! -- actual. The actual subtype is also returned in other cases where ! -- it has already been constructed for an object. Otherwise the ! -- expression type is returned unchanged, except for the case of an ! -- unconstrained array type, where an actual subtype is created, using ! -- Insert_Actions if necessary to insert any associated actions. function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id; -- This is like Get_Actual_Subtype, except that it never constructs an --- 444,458 ---- function Get_Actual_Subtype (N : Node_Id) return Entity_Id; -- Given a node for an expression, obtain the actual subtype of the -- expression. In the case of a parameter where the formal is an ! -- unconstrained array or discriminated type, this will be the previously ! -- constructed subtype of the actual. Note that this is not quite the ! -- "Actual Subtype" of the RM, since it is always a constrained type, i.e. ! -- it is the subtype of the value of the actual. The actual subtype is also ! -- returned in other cases where it has already been constructed for an ! -- object. Otherwise the expression type is returned unchanged, except for ! -- the case of an unconstrained array type, where an actual subtype is ! -- created, using Insert_Actions if necessary to insert any associated ! -- actions. function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id; -- This is like Get_Actual_Subtype, except that it never constructs an *************** package Sem_Util is *** 427,467 **** function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id; -- This is used to construct the string literal node representing a ! -- default external name, i.e. one that is constructed from the name ! -- of an entity, or (in the case of extended DEC import/export pragmas, ! -- an identifier provided as the external name. Letters in the name are -- according to the setting of Opt.External_Name_Default_Casing. function Get_Generic_Entity (N : Node_Id) return Entity_Id; ! -- Returns the true generic entity in an instantiation. If the name in ! -- the instantiation is a renaming, the function returns the renamed ! -- generic. procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id); ! -- This procedure assigns to L and H respectively the values of the ! -- low and high bounds of node N, which must be a range, subtype ! -- indication, or the name of a scalar subtype. The result in L, H ! -- may be set to Error if there was an earlier error in the range. function Get_Enum_Lit_From_Pos (T : Entity_Id; Pos : Uint; ! Loc : Source_Ptr) return Entity_Id; ! -- This function obtains the E_Enumeration_Literal entity for the ! -- specified value from the enumeration type or subtype T. The ! -- second argument is the Pos value, which is assumed to be in range. ! -- The third argument supplies a source location for constructed ! -- nodes returned by this function. procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id); -- Retrieve the fully expanded name of the library unit declared by -- Decl_Node into the name buffer. function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; -- An entity value is associated with each name in the name table. The ! -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, ! -- which is the innermost visible entity with the given name. See the ! -- body of Sem_Ch8 for further details on handling of entity visibility. function Get_Pragma_Id (N : Node_Id) return Pragma_Id; pragma Inline (Get_Pragma_Id); --- 462,502 ---- function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id; -- This is used to construct the string literal node representing a ! -- default external name, i.e. one that is constructed from the name of an ! -- entity, or (in the case of extended DEC import/export pragmas, an ! -- identifier provided as the external name. Letters in the name are -- according to the setting of Opt.External_Name_Default_Casing. function Get_Generic_Entity (N : Node_Id) return Entity_Id; ! -- Returns the true generic entity in an instantiation. If the name in the ! -- instantiation is a renaming, the function returns the renamed generic. procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id); ! -- This procedure assigns to L and H respectively the values of the low and ! -- high bounds of node N, which must be a range, subtype indication, or the ! -- name of a scalar subtype. The result in L, H may be set to Error if ! -- there was an earlier error in the range. function Get_Enum_Lit_From_Pos (T : Entity_Id; Pos : Uint; ! Loc : Source_Ptr) return Node_Id; ! -- This function obtains the E_Enumeration_Literal entity for the specified ! -- value from the enumeration type or subtype T and returns an identifier ! -- node referencing this value. The second argument is the Pos value, which ! -- is assumed to be in range. The third argument supplies a source location ! -- for constructed nodes returned by this function. procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id); -- Retrieve the fully expanded name of the library unit declared by -- Decl_Node into the name buffer. function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; + pragma Inline (Get_Name_Entity_Id); -- An entity value is associated with each name in the name table. The ! -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, which ! -- is the innermost visible entity with the given name. See the body of ! -- Sem_Ch8 for further details on handling of entity visibility. function Get_Pragma_Id (N : Node_Id) return Pragma_Id; pragma Inline (Get_Pragma_Id); *************** package Sem_Util is *** 479,500 **** -- with any other kind of entity. function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; ! -- Nod is either a procedure call statement, or a function call, or ! -- an accept statement node. This procedure finds the Entity_Id of the ! -- related subprogram or entry and returns it, or if no subprogram can ! -- be found, returns Empty. function Get_Subprogram_Body (E : Entity_Id) return Node_Id; ! -- Given the entity for a subprogram (E_Function or E_Procedure), ! -- return the corresponding N_Subprogram_Body node. If the corresponding ! -- body of the declaration is missing (as for an imported subprogram) ! -- return Empty. function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id; pragma Inline (Get_Task_Body_Procedure); -- Given an entity for a task type or subtype, retrieves the ! -- Task_Body_Procedure field from the corresponding task type ! -- declaration. function Has_Access_Values (T : Entity_Id) return Boolean; -- Returns true if type or subtype T is an access type, or has a component --- 514,533 ---- -- with any other kind of entity. function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; ! -- Nod is either a procedure call statement, or a function call, or an ! -- accept statement node. This procedure finds the Entity_Id of the related ! -- subprogram or entry and returns it, or if no subprogram can be found, ! -- returns Empty. function Get_Subprogram_Body (E : Entity_Id) return Node_Id; ! -- Given the entity for a subprogram (E_Function or E_Procedure), return ! -- the corresponding N_Subprogram_Body node. If the corresponding body ! -- is missing (as for an imported subprogram), return Empty. function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id; pragma Inline (Get_Task_Body_Procedure); -- Given an entity for a task type or subtype, retrieves the ! -- Task_Body_Procedure field from the corresponding task type declaration. function Has_Access_Values (T : Entity_Id) return Boolean; -- Returns true if type or subtype T is an access type, or has a component *************** package Sem_Util is *** 524,541 **** -- -- Note: Known_Incompatible does not mean that at run time the alignment -- of Expr is known to be wrong for Obj, just that it can be determined ! -- that alignments have been explicitly or implicitly specified which ! -- are incompatible (whereas Unknown means that even this is not known). ! -- The appropriate reaction of a caller to Known_Incompatible is to treat ! -- it as Unknown, but issue a warning that there may be an alignment error. function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations function Has_Discriminant_Dependent_Constraint (Comp : Entity_Id) return Boolean; ! -- Returns True if and only if Comp has a constrained subtype ! -- that depends on a discriminant. function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes --- 557,574 ---- -- -- Note: Known_Incompatible does not mean that at run time the alignment -- of Expr is known to be wrong for Obj, just that it can be determined ! -- that alignments have been explicitly or implicitly specified which are ! -- incompatible (whereas Unknown means that even this is not known). The ! -- appropriate reaction of a caller to Known_Incompatible is to treat it as ! -- Unknown, but issue a warning that there may be an alignment error. function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations function Has_Discriminant_Dependent_Constraint (Comp : Entity_Id) return Boolean; ! -- Returns True if and only if Comp has a constrained subtype that depends ! -- on a discriminant. function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes *************** package Sem_Util is *** 565,589 **** -- yet received a full declaration. function Has_Stream (T : Entity_Id) return Boolean; ! -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or ! -- in the case of a composite type, has a component for which this ! -- predicate is True, and if so returns True. Otherwise a result of ! -- False means that there is no Stream type in sight. For a private ! -- type, the test is applied to the underlying type (or returns False ! -- if there is no underlying type). function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Returns True if Typ is a composite type (array or record) which is -- either itself a tagged type, or has a component (recursively) which is -- a tagged type. Returns False for non-composite type, or if no tagged ! -- component is present. This function is used to check if '=' has to be -- expanded into a bunch component comparisons. function Implements_Interface (Typ_Ent : Entity_Id; Iface_Ent : Entity_Id; Exclude_Parents : Boolean := False) return Boolean; ! -- Returns true if the Typ implements interface Iface function In_Instance return Boolean; -- Returns True if the current scope is within a generic instance --- 598,630 ---- -- yet received a full declaration. function Has_Stream (T : Entity_Id) return Boolean; ! -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the ! -- case of a composite type, has a component for which this predicate is ! -- True, and if so returns True. Otherwise a result of False means that ! -- there is no Stream type in sight. For a private type, the test is ! -- applied to the underlying type (or returns False if there is no ! -- underlying type). ! ! function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean; ! -- Returns true if the last character of E is Suffix. Used in Assertions. function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Returns True if Typ is a composite type (array or record) which is -- either itself a tagged type, or has a component (recursively) which is -- a tagged type. Returns False for non-composite type, or if no tagged ! -- component is present. This function is used to check if "=" has to be -- expanded into a bunch component comparisons. + function Implementation_Kind (Subp : Entity_Id) return Name_Id; + -- Subp is a subprogram marked with pragma Implemented. Return the specific + -- implementation requirement which the pragma imposes. The return value is + -- either Name_By_Any, Name_By_Entry or Name_By_Protected_Procedure. + function Implements_Interface (Typ_Ent : Entity_Id; Iface_Ent : Entity_Id; Exclude_Parents : Boolean := False) return Boolean; ! -- Returns true if the Typ_Ent implements interface Iface_Ent function In_Instance return Boolean; -- Returns True if the current scope is within a generic instance *************** package Sem_Util is *** 607,617 **** -- Returns True if node N belongs to a parameter specification function In_Subprogram_Or_Concurrent_Unit return Boolean; ! -- Determines if the current scope is within a subprogram compilation ! -- unit (inside a subprogram declaration, subprogram body, or generic ! -- subprogram declaration) or within a task or protected body. The test ! -- is for appearing anywhere within such a construct (that is it does not ! -- need to be directly within). function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; -- Determine whether a declaration occurs within the visible part of a --- 648,658 ---- -- Returns True if node N belongs to a parameter specification function In_Subprogram_Or_Concurrent_Unit return Boolean; ! -- Determines if the current scope is within a subprogram compilation unit ! -- (inside a subprogram declaration, subprogram body, or generic ! -- subprogram declaration) or within a task or protected body. The test is ! -- for appearing anywhere within such a construct (that is it does not need ! -- to be directly within). function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; -- Determine whether a declaration occurs within the visible part of a *************** package Sem_Util is *** 628,641 **** -- whether they have been completed by a full constant declaration or an -- Import pragma. Emit the error message if that is not the case. - function Is_AAMP_Float (E : Entity_Id) return Boolean; - -- Defined for all type entities. Returns True only for the base type of - -- float types with AAMP format. The particular format is determined by the - -- Digits_Value value which is 6 for the 32-bit floating point type, or 9 - -- for the 48-bit type. This is not an attribute function (like VAX_Float) - -- in order to not use up an extra flag and to prevent the dependency of - -- Einfo on Targparm which would be required for a synthesized attribute. - function Is_Actual_Out_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter of out mode in a subprogram call --- 669,674 ---- *************** package Sem_Util is *** 643,650 **** -- Determines if N is an actual parameter in a subprogram call function Is_Aliased_View (Obj : Node_Id) return Boolean; ! -- Determine if Obj is an aliased view, i.e. the name of an ! -- object to which 'Access or 'Unchecked_Access can apply. function Is_Ancestor_Package (E1 : Entity_Id; --- 676,683 ---- -- Determines if N is an actual parameter in a subprogram call function Is_Aliased_View (Obj : Node_Id) return Boolean; ! -- Determine if Obj is an aliased view, i.e. the name of an object to which ! -- 'Access or 'Unchecked_Access can apply. function Is_Ancestor_Package (E1 : Entity_Id; *************** package Sem_Util is *** 652,659 **** -- Determine whether package E1 is an ancestor of E2 function Is_Atomic_Object (N : Node_Id) return Boolean; ! -- Determines if the given node denotes an atomic object in the sense ! -- of the legality checks described in RM C.6(12). function Is_Coextension_Root (N : Node_Id) return Boolean; -- Determine whether node N is an allocator which acts as a coextension --- 685,692 ---- -- Determine whether package E1 is an ancestor of E2 function Is_Atomic_Object (N : Node_Id) return Boolean; ! -- Determines if the given node denotes an atomic object in the sense of ! -- the legality checks described in RM C.6(12). function Is_Coextension_Root (N : Node_Id) return Boolean; -- Determine whether node N is an allocator which acts as a coextension *************** package Sem_Util is *** 690,698 **** -- it is of protected, synchronized or task kind. function Is_False (U : Uint) return Boolean; ! -- The argument is a Uint value which is the Boolean'Pos value of a ! -- Boolean operand (i.e. is either 0 for False, or 1 for True). This ! -- function simply tests if it is False (i.e. zero) function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean; -- Returns True iff the number U is a model number of the fixed- --- 723,732 ---- -- it is of protected, synchronized or task kind. function Is_False (U : Uint) return Boolean; ! pragma Inline (Is_False); ! -- The argument is a Uint value which is the Boolean'Pos value of a Boolean ! -- operand (i.e. is either 0 for False, or 1 for True). This function tests ! -- if it is False (i.e. zero). function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean; -- Returns True iff the number U is a model number of the fixed- *************** package Sem_Util is *** 712,718 **** -- by a derived type declarations. function Is_LHS (N : Node_Id) return Boolean; ! -- Returns True iff N is used as Name in an assignment statement. function Is_Library_Level_Entity (E : Entity_Id) return Boolean; -- A library-level declaration is one that is accessible from Standard, --- 746,752 ---- -- by a derived type declarations. function Is_LHS (N : Node_Id) return Boolean; ! -- Returns True iff N is used as Name in an assignment statement function Is_Library_Level_Entity (E : Entity_Id) return Boolean; -- A library-level declaration is one that is accessible from Standard, *************** package Sem_Util is *** 728,745 **** -- variable and constant objects return True (compare Is_Variable). function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean; ! -- Used to test if AV is an acceptable formal for an OUT or IN OUT ! -- formal. Note that the Is_Variable function is not quite the right ! -- test because this is a case in which conversions whose expression ! -- is a variable (in the Is_Variable sense) with a non-tagged type ! -- target are considered view conversions and hence variables. ! function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is partly -- initialized, meaning that an object of the type is at least partly -- initialized (in particular in the record case, that at least one -- component has an initialization expression). Note that initialization -- resulting from the use of pragma Normalized_Scalars does not count. function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; -- Determines if type T is a potentially persistent type. A potentially --- 762,788 ---- -- variable and constant objects return True (compare Is_Variable). function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean; ! -- Used to test if AV is an acceptable formal for an OUT or IN OUT formal. ! -- Note that the Is_Variable function is not quite the right test because ! -- this is a case in which conversions whose expression is a variable (in ! -- the Is_Variable sense) with a non-tagged type target are considered view ! -- conversions and hence variables. ! function Is_Partially_Initialized_Type ! (Typ : Entity_Id; ! Include_Implicit : Boolean := True) return Boolean; -- Typ is a type entity. This function returns true if this type is partly -- initialized, meaning that an object of the type is at least partly -- initialized (in particular in the record case, that at least one -- component has an initialization expression). Note that initialization -- resulting from the use of pragma Normalized_Scalars does not count. + -- Include_Implicit controls whether implicit initialization of access + -- values to null, and of discriminant values, is counted as making the + -- type be partially initialized. For the default setting of True, these + -- implicit cases do count, and discriminated types or types containing + -- access values not explicitly initialized will return True. Otherwise + -- if Include_Implicit is False, these cases do not count as making the + -- type be partially initialized. function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; -- Determines if type T is a potentially persistent type. A potentially *************** package Sem_Util is *** 776,781 **** --- 819,825 ---- -- normally such nodes represent a direct name. function Is_Statement (N : Node_Id) return Boolean; + pragma Inline (Is_Statement); -- Check if the node N is a statement node. Note that this includes -- the case of procedure call statements (unlike the direct use of -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). *************** package Sem_Util is *** 785,798 **** -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) function Is_Transfer (N : Node_Id) return Boolean; ! -- Returns True if the node N is a statement which is known to cause ! -- an unconditional transfer of control at runtime, i.e. the following -- statement definitely will not be executed. function Is_True (U : Uint) return Boolean; ! -- The argument is a Uint value which is the Boolean'Pos value of a ! -- Boolean operand (i.e. is either 0 for False, or 1 for True). This ! -- function simply tests if it is True (i.e. non-zero) function Is_Value_Type (T : Entity_Id) return Boolean; -- Returns true if type T represents a value type. This is only relevant to --- 829,847 ---- -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) function Is_Transfer (N : Node_Id) return Boolean; ! -- Returns True if the node N is a statement which is known to cause an ! -- unconditional transfer of control at runtime, i.e. the following -- statement definitely will not be executed. function Is_True (U : Uint) return Boolean; ! pragma Inline (Is_True); ! -- The argument is a Uint value which is the Boolean'Pos value of a Boolean ! -- operand (i.e. is either 0 for False, or 1 for True). This function tests ! -- if it is True (i.e. non-zero). ! ! function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean; ! pragma Inline (Is_Universal_Numeric_Type); ! -- True if T is Universal_Integer or Universal_Real function Is_Value_Type (T : Entity_Id) return Boolean; -- Returns true if type T represents a value type. This is only relevant to *************** package Sem_Util is *** 800,805 **** --- 849,858 ---- -- object that is accessed directly, as opposed to the other CIL objects -- that are accessed through managed pointers. + function Is_VMS_Operator (Op : Entity_Id) return Boolean; + -- Determine whether an operator is one of the intrinsics defined + -- in the DEC system extension. + function Is_Delegate (T : Entity_Id) return Boolean; -- Returns true if type T represents a delegate. A Delegate is the CIL -- object used to represent access-to-subprogram types. This is only *************** package Sem_Util is *** 990,996 **** procedure Next_Actual (Actual_Id : in out Node_Id); pragma Inline (Next_Actual); ! -- Next_Actual (N) is equivalent to N := Next_Actual (N) function Next_Actual (Actual_Id : Node_Id) return Node_Id; -- Find next actual parameter in declaration order. As described for --- 1043,1050 ---- procedure Next_Actual (Actual_Id : in out Node_Id); pragma Inline (Next_Actual); ! -- Next_Actual (N) is equivalent to N := Next_Actual (N). Note that we ! -- inline this procedural form, but not the functional form that follows. function Next_Actual (Actual_Id : Node_Id) return Node_Id; -- Find next actual parameter in declaration order. As described for *************** package Sem_Util is *** 1022,1027 **** --- 1076,1087 ---- -- (e.g. target of assignment, or out parameter), and to False if the -- modification is only potential (e.g. address of entity taken). + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; + -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, + -- or overrides an inherited dispatching primitive S2, the original + -- corresponding operation of S is the original corresponding operation of + -- S2. Otherwise, it is S itself. + function Object_Access_Level (Obj : Node_Id) return Uint; -- Return the accessibility level of the view of the object Obj. -- For convenience, qualified expressions applied to object names *************** package Sem_Util is *** 1053,1062 **** -- parameter Ent gives the entity to which the End_Label refers, -- and to which cross-references are to be generated. - function Real_Convert (S : String) return Node_Id; - -- S is a possibly signed syntactically valid real literal. The result - -- returned is an N_Real_Literal node representing the literal value. - function References_Generic_Formal_Type (N : Node_Id) return Boolean; -- Returns True if the expression Expr contains any references to a -- generic type. This can only happen within a generic template. --- 1113,1118 ---- *************** package Sem_Util is *** 1148,1153 **** --- 1204,1214 ---- -- are only partially ordered, so Scope_Within_Or_Same (A,B) and -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B. + procedure Save_Actual (N : Node_Id; Writable : Boolean := False); + -- Enter an actual in a call in a table global, for subsequent check of + -- possible order dependence in the presence of IN OUT parameters for + -- functions in Ada 2012 (or access parameters in older language versions). + function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean; -- Like Scope_Within_Or_Same, except that this function returns -- False in the case where Scope1 and Scope2 are the same scope. *************** package Sem_Util is *** 1158,1163 **** --- 1219,1225 ---- -- foreign convention, then we set Can_Use_Internal_Rep to False on E. procedure Set_Current_Entity (E : Entity_Id); + pragma Inline (Set_Current_Entity); -- Establish the entity E as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name) *************** package Sem_Util is *** 1175,1180 **** --- 1237,1243 ---- -- can check identifier spelling style. procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id); + pragma Inline (Set_Name_Entity_Id); -- Sets the Entity_Id value associated with the given name, which is the -- Id of the innermost visible entity with the given name. See the body -- of package Sem_Ch8 for further details on the handling of visibility. *************** package Sem_Util is *** 1205,1210 **** --- 1268,1274 ---- -- Set the flag Is_Transient of the current scope procedure Set_Size_Info (T1, T2 : Entity_Id); + pragma Inline (Set_Size_Info); -- Copies the Esize field and Has_Biased_Representation flag from sub(type) -- entity T2 to (sub)type entity T1. Also copies the Is_Unsigned_Type flag -- in the fixed-point and discrete cases, and also copies the alignment *************** package Sem_Util is *** 1237,1246 **** function Type_Access_Level (Typ : Entity_Id) return Uint; -- Return the accessibility level of Typ - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; - -- Return the last entity in the chain of aliased entities of Prim. - -- If Prim has no alias return Prim. - function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the --- 1301,1306 ---- *************** package Sem_Util is *** 1249,1279 **** -- may be a child unit with any number of ancestors. function Universal_Interpretation (Opnd : Node_Id) return Entity_Id; ! -- Yields universal_Integer or Universal_Real if this is a candidate function Unqualify (Expr : Node_Id) return Node_Id; ! -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), ! -- this returns X. If Expr is not a qualified expression, returns Expr. function Within_Init_Proc return Boolean; -- Determines if Current_Scope is within an init proc procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id); ! -- Output error message for incorrectly typed expression. Expr is the ! -- node for the incorrectly typed construct (Etype (Expr) is the type ! -- found), and Expected_Type is the entity for the expected type. Note ! -- that Expr does not have to be a subexpression, anything with an ! -- Etype field may be used. ! ! private ! pragma Inline (Current_Entity); ! pragma Inline (Get_Name_Entity_Id); ! pragma Inline (Is_False); ! pragma Inline (Is_Statement); ! pragma Inline (Is_True); ! pragma Inline (Set_Current_Entity); ! pragma Inline (Set_Name_Entity_Id); ! pragma Inline (Set_Size_Info); ! pragma Inline (Unqualify); end Sem_Util; --- 1309,1336 ---- -- may be a child unit with any number of ancestors. function Universal_Interpretation (Opnd : Node_Id) return Entity_Id; ! -- Yields Universal_Integer or Universal_Real if this is a candidate function Unqualify (Expr : Node_Id) return Node_Id; ! pragma Inline (Unqualify); ! -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), this ! -- returns X. If Expr is not a qualified expression, returns Expr. ! ! function Visible_Ancestors (Typ : Entity_Id) return Elist_Id; ! -- [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors ! -- of a type extension or private extension declaration. If the full-view ! -- of private parents and progenitors is available then it is used to ! -- generate the list of visible ancestors; otherwise their partial ! -- view is added to the resulting list. function Within_Init_Proc return Boolean; -- Determines if Current_Scope is within an init proc procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id); ! -- Output error message for incorrectly typed expression. Expr is the node ! -- for the incorrectly typed construct (Etype (Expr) is the type found), ! -- and Expected_Type is the entity for the expected type. Note that Expr ! -- does not have to be a subexpression, anything with an Etype field may ! -- be used. end Sem_Util; diff -Nrcpad gcc-4.5.2/gcc/ada/sem_vfpt.adb gcc-4.6.0/gcc/ada/sem_vfpt.adb *** gcc-4.5.2/gcc/ada/sem_vfpt.adb Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/sem_vfpt.adb Fri Oct 22 10:19:58 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1997-2010, 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- -- *************** with Einfo; use Einfo; *** 28,34 **** with Opt; use Opt; with Stand; use Stand; with Targparm; use Targparm; - with Ttypef; use Ttypef; package body Sem_VFpt is --- 28,33 ---- *************** package body Sem_VFpt is *** 37,47 **** ----------------- procedure Set_D_Float (E : Entity_Id) is begin Init_Size (Base_Type (E), 64); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), VAXDF_Digits); ! Set_Vax_Float (Base_Type (E), True); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 64); --- 36,48 ---- ----------------- procedure Set_D_Float (E : Entity_Id) is + VAXDF_Digits : constant := 9; + begin Init_Size (Base_Type (E), 64); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), VAXDF_Digits); ! Set_Float_Rep (Base_Type (E), VAX_Native); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 64); *************** package body Sem_VFpt is *** 55,65 **** ----------------- procedure Set_F_Float (E : Entity_Id) is begin Init_Size (Base_Type (E), 32); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), VAXFF_Digits); ! Set_Vax_Float (Base_Type (E), True); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 32); --- 56,68 ---- ----------------- procedure Set_F_Float (E : Entity_Id) is + VAXFF_Digits : constant := 6; + begin Init_Size (Base_Type (E), 32); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), VAXFF_Digits); ! Set_Float_Rep (Base_Type (E), VAX_Native); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 32); *************** package body Sem_VFpt is *** 73,83 **** ----------------- procedure Set_G_Float (E : Entity_Id) is begin Init_Size (Base_Type (E), 64); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), VAXGF_Digits); ! Set_Vax_Float (Base_Type (E), True); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 64); --- 76,88 ---- ----------------- procedure Set_G_Float (E : Entity_Id) is + VAXGF_Digits : constant := 15; + begin Init_Size (Base_Type (E), 64); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), VAXGF_Digits); ! Set_Float_Rep (Base_Type (E), VAX_Native); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 64); *************** package body Sem_VFpt is *** 91,101 **** ------------------- procedure Set_IEEE_Long (E : Entity_Id) is begin Init_Size (Base_Type (E), 64); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), IEEEL_Digits); ! Set_Vax_Float (Base_Type (E), False); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 64); --- 96,108 ---- ------------------- procedure Set_IEEE_Long (E : Entity_Id) is + IEEEL_Digits : constant := 15; + begin Init_Size (Base_Type (E), 64); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), IEEEL_Digits); ! Set_Float_Rep (Base_Type (E), IEEE_Binary); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 64); *************** package body Sem_VFpt is *** 109,119 **** -------------------- procedure Set_IEEE_Short (E : Entity_Id) is begin Init_Size (Base_Type (E), 32); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), IEEES_Digits); ! Set_Vax_Float (Base_Type (E), False); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 32); --- 116,128 ---- -------------------- procedure Set_IEEE_Short (E : Entity_Id) is + IEEES_Digits : constant := 6; + begin Init_Size (Base_Type (E), 32); Init_Alignment (Base_Type (E)); Init_Digits_Value (Base_Type (E), IEEES_Digits); ! Set_Float_Rep (Base_Type (E), IEEE_Binary); Set_Float_Bounds (Base_Type (E)); Init_Size (E, 32); diff -Nrcpad gcc-4.5.2/gcc/ada/sem_warn.adb gcc-4.6.0/gcc/ada/sem_warn.adb *** gcc-4.5.2/gcc/ada/sem_warn.adb Mon Nov 30 16:08:37 2009 --- gcc-4.6.0/gcc/ada/sem_warn.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1999-2010, 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- -- *************** package body Sem_Warn is *** 234,243 **** -- within the body of the loop. procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is ! Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); Ref : Node_Id := Empty; ! -- Reference in iteration scheme to variable that might not be modified -- in loop, indicating a possible infinite loop. Var : Entity_Id := Empty; --- 234,244 ---- -- within the body of the loop. procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is ! Expression : Node_Id := Empty; ! -- Set to WHILE or EXIT WHEN condition to be tested Ref : Node_Id := Empty; ! -- Reference in Expression to variable that might not be modified -- in loop, indicating a possible infinite loop. Var : Entity_Id := Empty; *************** package body Sem_Warn is *** 267,275 **** function Test_Ref (N : Node_Id) return Traverse_Result; -- Test for reference to variable in question. Returns Abandon if ! -- matching reference found. ! function Find_Ref is new Traverse_Func (Test_Ref); -- Function to traverse body of procedure. Returns Abandon if matching -- reference found. --- 268,276 ---- function Test_Ref (N : Node_Id) return Traverse_Result; -- Test for reference to variable in question. Returns Abandon if ! -- matching reference found. Used in instantiation of No_Ref_Found. ! function No_Ref_Found is new Traverse_Func (Test_Ref); -- Function to traverse body of procedure. Returns Abandon if matching -- reference found. *************** package body Sem_Warn is *** 465,473 **** function Test_Ref (N : Node_Id) return Traverse_Result is begin ! -- Waste of time to look at iteration scheme ! if N = Iter then return Skip; -- Direct reference to variable in question --- 466,474 ---- function Test_Ref (N : Node_Id) return Traverse_Result is begin ! -- Waste of time to look at the expression we are testing ! if N = Expression then return Skip; -- Direct reference to variable in question *************** package body Sem_Warn is *** 537,542 **** --- 538,566 ---- then return Abandon; end if; + + -- If any of the arguments are of type access to subprogram, then + -- we may have funny side effects, so no warning in this case. + + declare + Actual : Node_Id; + begin + Actual := First_Actual (N); + while Present (Actual) loop + if Is_Access_Subprogram_Type (Etype (Actual)) then + return Abandon; + else + Next_Actual (Actual); + end if; + end loop; + end; + + -- Declaration of the variable in question + + elsif Nkind (N) = N_Object_Declaration + and then Defining_Identifier (N) = Var + then + return Abandon; end if; -- All OK, continue scan *************** package body Sem_Warn is *** 547,566 **** -- Start of processing for Check_Infinite_Loop_Warning begin ! -- We need a while iteration with no condition actions. Condition ! -- actions just make things too complicated to get the warning right. ! if No (Iter) ! or else No (Condition (Iter)) ! or else Present (Condition_Actions (Iter)) ! or else Debug_Flag_Dot_W ! then return; end if; -- Initial conditions met, see if condition is of right form ! Find_Var (Condition (Iter)); -- Nothing to do if local variable from source not found. If it's a -- renaming, it is probably renaming something too complicated to deal --- 571,666 ---- -- Start of processing for Check_Infinite_Loop_Warning begin ! -- Skip processing if debug flag gnatd.w is set ! if Debug_Flag_Dot_W then ! return; ! end if; ! ! -- Deal with Iteration scheme present ! ! declare ! Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); ! ! begin ! if Present (Iter) then ! ! -- While iteration ! ! if Present (Condition (Iter)) then ! ! -- Skip processing for while iteration with conditions actions, ! -- since they make it too complicated to get the warning right. ! ! if Present (Condition_Actions (Iter)) then ! return; ! end if; ! ! -- Capture WHILE condition ! ! Expression := Condition (Iter); ! ! -- For iteration, do not process, since loop will always terminate ! ! elsif Present (Loop_Parameter_Specification (Iter)) then ! return; ! end if; ! end if; ! end; ! ! -- Check chain of EXIT statements, we only process loops that have a ! -- single exit condition (either a single EXIT WHEN statement, or a ! -- WHILE loop not containing any EXIT WHEN statements). ! ! declare ! Ident : constant Node_Id := Identifier (Loop_Statement); ! Exit_Stmt : Node_Id; ! ! begin ! -- If we don't have a proper chain set, ignore call entirely. This ! -- happens because of previous errors. ! ! if No (Entity (Ident)) ! or else Ekind (Entity (Ident)) /= E_Loop ! then ! return; ! end if; ! ! -- Otherwise prepare to scan list of EXIT statements ! ! Exit_Stmt := First_Exit_Statement (Entity (Ident)); ! while Present (Exit_Stmt) loop ! ! -- Check for EXIT WHEN ! ! if Present (Condition (Exit_Stmt)) then ! ! -- Quit processing if EXIT WHEN in WHILE loop, or more than ! -- one EXIT WHEN statement present in the loop. ! ! if Present (Expression) then ! return; ! ! -- Otherwise capture condition from EXIT WHEN statement ! ! else ! Expression := Condition (Exit_Stmt); ! end if; ! end if; ! ! Exit_Stmt := Next_Exit_Statement (Exit_Stmt); ! end loop; ! end; ! ! -- Return if no condition to test ! ! if No (Expression) then return; end if; -- Initial conditions met, see if condition is of right form ! Find_Var (Expression); -- Nothing to do if local variable from source not found. If it's a -- renaming, it is probably renaming something too complicated to deal *************** package body Sem_Warn is *** 608,614 **** -- We have a variable reference of the right form, now we scan the loop -- body to see if it looks like it might not be modified ! if Find_Ref (Loop_Statement) = OK then Error_Msg_NE ("?variable& is not modified in loop body!", Ref, Var); Error_Msg_N --- 708,714 ---- -- We have a variable reference of the right form, now we scan the loop -- body to see if it looks like it might not be modified ! if No_Ref_Found (Loop_Statement) = OK then Error_Msg_NE ("?variable& is not modified in loop body!", Ref, Var); Error_Msg_N *************** package body Sem_Warn is *** 758,766 **** procedure Output_Reference_Error (M : String) is begin ! -- Never issue messages for internal names ! if Is_Internal_Name (Chars (E1)) then return; end if; --- 858,868 ---- procedure Output_Reference_Error (M : String) is begin ! -- Never issue messages for internal names, nor for renamings ! if Is_Internal_Name (Chars (E1)) ! or else Nkind (Parent (E1)) = N_Object_Renaming_Declaration ! then return; end if; *************** package body Sem_Warn is *** 927,935 **** -- we exclude protected types, too complicated to worry about. if Ekind (E1) = E_Variable ! or else ! ((Ekind (E1) = E_Out_Parameter ! or else Ekind (E1) = E_In_Out_Parameter) and then not Is_Protected_Type (Current_Scope)) then -- Case of an unassigned variable --- 1029,1036 ---- -- we exclude protected types, too complicated to worry about. if Ekind (E1) = E_Variable ! or else ! (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) and then not Is_Protected_Type (Current_Scope)) then -- Case of an unassigned variable *************** package body Sem_Warn is *** 1245,1251 **** while Present (Comp) loop if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = ! N_Component_Declaration and then No (Expression (Parent (Comp))) then Error_Msg_Node_2 := Comp; --- 1346,1352 ---- while Present (Comp) loop if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = ! N_Component_Declaration and then No (Expression (Parent (Comp))) then Error_Msg_Node_2 := Comp; *************** package body Sem_Warn is *** 1323,1330 **** or else Referenced_As_Out_Parameter_Check_Spec (E1)) ! -- Labels, and enumeration literals, and exceptions. The ! -- warnings are also placed on local packages that cannot be -- referenced from elsewhere, including those declared within a -- package body. --- 1424,1430 ---- or else Referenced_As_Out_Parameter_Check_Spec (E1)) ! -- All other entities, including local packages that cannot be -- referenced from elsewhere, including those declared within a -- package body. *************** package body Sem_Warn is *** 1364,1375 **** -- a separate spec. and then not (Is_Formal (E1) ! and then ! Ekind (Scope (E1)) = E_Subprogram_Body ! and then ! Present (Spec_Entity (E1)) ! and then ! Referenced (Spec_Entity (E1))) -- Consider private type referenced if full view is referenced. -- If there is not full view, this is a generic type on which --- 1464,1472 ---- -- a separate spec. and then not (Is_Formal (E1) ! and then Ekind (Scope (E1)) = E_Subprogram_Body ! and then Present (Spec_Entity (E1)) ! and then Referenced (Spec_Entity (E1))) -- Consider private type referenced if full view is referenced. -- If there is not full view, this is a generic type on which *************** package body Sem_Warn is *** 1377,1384 **** and then not (Is_Private_Type (E1) ! and then ! Present (Full_View (E1)) and then Referenced (Full_View (E1))) -- Don't worry about full view, only about private type --- 1474,1480 ---- and then not (Is_Private_Type (E1) ! and then Present (Full_View (E1)) and then Referenced (Full_View (E1))) -- Don't worry about full view, only about private type *************** package body Sem_Warn is *** 1408,1423 **** -- be non-referenced, since they start up tasks! and then ((Ekind (E1) /= E_Variable ! and then Ekind (E1) /= E_Constant ! and then Ekind (E1) /= E_Component) ! or else not Is_Task_Type (E1T)) -- For subunits, only place warnings on the main unit itself, -- since parent units are not completely compiled. and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit ! or else ! Get_Source_Unit (E1) = Main_Unit) -- No warning on a return object, because these are often -- created with a single expression and an implicit return. --- 1504,1518 ---- -- be non-referenced, since they start up tasks! and then ((Ekind (E1) /= E_Variable ! and then Ekind (E1) /= E_Constant ! and then Ekind (E1) /= E_Component) ! or else not Is_Task_Type (E1T)) -- For subunits, only place warnings on the main unit itself, -- since parent units are not completely compiled. and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit ! or else Get_Source_Unit (E1) = Main_Unit) -- No warning on a return object, because these are often -- created with a single expression and an implicit return. *************** package body Sem_Warn is *** 1432,1440 **** -- since they refer to problems in internal units). if GNAT_Mode ! or else not ! Is_Internal_File_Name ! (Unit_File_Name (Get_Source_Unit (E1))) then -- We do not immediately flag the error. This is because we -- have not expanded generic bodies yet, and they may have --- 1527,1534 ---- -- since they refer to problems in internal units). if GNAT_Mode ! or else not Is_Internal_File_Name ! (Unit_File_Name (Get_Source_Unit (E1))) then -- We do not immediately flag the error. This is because we -- have not expanded generic bodies yet, and they may have *************** package body Sem_Warn is *** 1475,1481 **** if not Warnings_Off_E1 then Unreferenced_Entities.Append (E1); ! -- Force warning on entity Set_Referenced (E1, False); end if; --- 1569,1575 ---- if not Warnings_Off_E1 then Unreferenced_Entities.Append (E1); ! -- Force warning on entity Set_Referenced (E1, False); end if; *************** package body Sem_Warn is *** 1961,1967 **** -- or a pragma, and a warning is worthwhile as well. function Check_System_Aux return Boolean; ! -- Before giving a warning on a with_clause for System, check wheter -- a system extension is present. function Find_Package_Renaming --- 2055,2061 ---- -- or a pragma, and a warning is worthwhile as well. function Check_System_Aux return Boolean; ! -- Before giving a warning on a with_clause for System, check whether -- a system extension is present. function Find_Package_Renaming *************** package body Sem_Warn is *** 2004,2010 **** while Present (Nam) loop if Entity (Nam) = Pack then Error_Msg_Qual_Level := 1; ! Error_Msg_NE ("?no entities of package& are referenced!", Nam, Pack); Error_Msg_Qual_Level := 0; --- 2098,2104 ---- while Present (Nam) loop if Entity (Nam) = Pack then Error_Msg_Qual_Level := 1; ! Error_Msg_NE -- CODEFIX ("?no entities of package& are referenced!", Nam, Pack); Error_Msg_Qual_Level := 0; *************** package body Sem_Warn is *** 2201,2207 **** -- else or a pragma elaborate with a body library task). elsif Has_Visible_Entities (Entity (Name (Item))) then ! Error_Msg_N ("?unit& is not referenced!", Name (Item)); end if; end if; --- 2295,2301 ---- -- else or a pragma elaborate with a body library task). elsif Has_Visible_Entities (Entity (Name (Item))) then ! Error_Msg_N -- CODEFIX ("?unit& is not referenced!", Name (Item)); end if; end if; *************** package body Sem_Warn is *** 2278,2284 **** if not Has_Unreferenced (Entity (Name (Item))) then ! Error_Msg_N ("?no entities of & are referenced!", Name (Item)); end if; --- 2372,2378 ---- if not Has_Unreferenced (Entity (Name (Item))) then ! Error_Msg_N -- CODEFIX ("?no entities of & are referenced!", Name (Item)); end if; *************** package body Sem_Warn is *** 2294,2300 **** and then not Has_Warnings_Off (Lunit) and then not Has_Unreferenced (Pack) then ! Error_Msg_NE ("?no entities of & are referenced!", Unit_Declaration_Node (Pack), Pack); --- 2388,2394 ---- and then not Has_Warnings_Off (Lunit) and then not Has_Unreferenced (Pack) then ! Error_Msg_NE -- CODEFIX ("?no entities of & are referenced!", Unit_Declaration_Node (Pack), Pack); *************** package body Sem_Warn is *** 2334,2345 **** end if; if Unreferenced_In_Spec (Item) then ! Error_Msg_N ("?unit& is not referenced in spec!", Name (Item)); elsif No_Entities_Ref_In_Spec (Item) then ! Error_Msg_N ("?no entities of & are referenced in spec!", Name (Item)); --- 2428,2439 ---- end if; if Unreferenced_In_Spec (Item) then ! Error_Msg_N -- CODEFIX ("?unit& is not referenced in spec!", Name (Item)); elsif No_Entities_Ref_In_Spec (Item) then ! Error_Msg_N -- CODEFIX ("?no entities of & are referenced in spec!", Name (Item)); *************** package body Sem_Warn is *** 2688,2695 **** -- default mode. elsif Check_Unreferenced then ! Error_Msg_N ("?formal parameter& is read but " ! & "never assigned!", E1); end if; end if; --- 2782,2790 ---- -- default mode. elsif Check_Unreferenced then ! Error_Msg_N ! ("?formal parameter& is read but " ! & "never assigned!", E1); end if; end if; *************** package body Sem_Warn is *** 2783,2791 **** -- Reference to obsolescent component ! elsif Ekind (E) = E_Component ! or else Ekind (E) = E_Discriminant ! then Error_Msg_NE ("?reference to obsolescent component& declared#", N, E); --- 2878,2884 ---- -- Reference to obsolescent component ! elsif Ekind_In (E, E_Component, E_Discriminant) then Error_Msg_NE ("?reference to obsolescent component& declared#", N, E); *************** package body Sem_Warn is *** 2975,2981 **** --- 3068,3076 ---- Elab_Warnings := True; Implementation_Unit_Warnings := True; Ineffective_Inline_Warnings := True; + List_Inherited_Aspects := True; Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; Warn_On_All_Unread_Out_Parameters := True; Warn_On_Assertion_Failure := True; Warn_On_Assumed_Low_Bound := True; *************** package body Sem_Warn is *** 2992,3002 **** --- 3087,3100 ---- Warn_On_Object_Renames_Function := True; Warn_On_Obsolescent_Feature := True; Warn_On_Overlap := True; + Warn_On_Overridden_Size := True; Warn_On_Parameter_Order := True; Warn_On_Questionable_Missing_Parens := True; + Warn_On_Record_Holes := True; Warn_On_Redundant_Constructs := True; Warn_On_Reverse_Bit_Order := True; Warn_On_Unchecked_Conversion := True; + Warn_On_Unordered_Enumeration_Type := True; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := True; Warn_On_Warnings_Off := True; *************** package body Sem_Warn is *** 3004,3015 **** --- 3102,3125 ---- when 'g' => Set_GNAT_Mode_Warnings; + when 'h' => + Warn_On_Record_Holes := True; + + when 'H' => + Warn_On_Record_Holes := False; + when 'i' => Warn_On_Overlap := True; when 'I' => Warn_On_Overlap := False; + when 'l' => + List_Inherited_Aspects := True; + + when 'L' => + List_Inherited_Aspects := False; + when 'm' => Warn_On_Suspicious_Modulus_Value := True; *************** package body Sem_Warn is *** 3034,3039 **** --- 3144,3161 ---- when 'R' => Warn_On_Object_Renames_Function := False; + when 's' => + Warn_On_Overridden_Size := True; + + when 'S' => + Warn_On_Overridden_Size := False; + + when 'u' => + Warn_On_Unordered_Enumeration_Type := True; + + when 'U' => + Warn_On_Unordered_Enumeration_Type := False; + when 'v' => Warn_On_Reverse_Bit_Order := True; *************** package body Sem_Warn is *** 3074,3080 **** --- 3196,3204 ---- Elab_Warnings := False; Implementation_Unit_Warnings := False; Ineffective_Inline_Warnings := True; + List_Inherited_Aspects := False; Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; Warn_On_All_Unread_Out_Parameters := False; Warn_On_Assertion_Failure := True; Warn_On_Assumed_Low_Bound := True; *************** package body Sem_Warn is *** 3095,3100 **** --- 3219,3225 ---- Warn_On_Reverse_Bit_Order := False; Warn_On_Object_Renames_Function := True; Warn_On_Unchecked_Conversion := True; + Warn_On_Unordered_Enumeration_Type := False; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := False; Warn_On_Warnings_Off := False; *************** package body Sem_Warn is *** 3114,3120 **** --- 3239,3247 ---- Constant_Condition_Warnings := True; Implementation_Unit_Warnings := True; Ineffective_Inline_Warnings := True; + List_Inherited_Aspects := True; Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; Warn_On_Assertion_Failure := True; Warn_On_Assumed_Low_Bound := True; Warn_On_Bad_Fixed_Value := True; *************** package body Sem_Warn is *** 3143,3149 **** --- 3270,3278 ---- Elab_Warnings := False; Implementation_Unit_Warnings := False; Ineffective_Inline_Warnings := False; + List_Inherited_Aspects := False; Warn_On_Ada_2005_Compatibility := False; + Warn_On_Ada_2012_Compatibility := False; Warn_On_All_Unread_Out_Parameters := False; Warn_On_Assertion_Failure := False; Warn_On_Assumed_Low_Bound := False; *************** package body Sem_Warn is *** 3160,3170 **** --- 3289,3302 ---- Warn_On_Object_Renames_Function := False; Warn_On_Obsolescent_Feature := False; Warn_On_Overlap := False; + Warn_On_Overridden_Size := False; Warn_On_Parameter_Order := False; + Warn_On_Record_Holes := False; Warn_On_Questionable_Missing_Parens := False; Warn_On_Redundant_Constructs := False; Warn_On_Reverse_Bit_Order := False; Warn_On_Unchecked_Conversion := False; + Warn_On_Unordered_Enumeration_Type := False; Warn_On_Unrecognized_Pragma := False; Warn_On_Unrepped_Components := False; Warn_On_Warnings_Off := False; *************** package body Sem_Warn is *** 3306,3314 **** --- 3438,3448 ---- when 'y' => Warn_On_Ada_2005_Compatibility := True; + Warn_On_Ada_2012_Compatibility := True; when 'Y' => Warn_On_Ada_2005_Compatibility := False; + Warn_On_Ada_2012_Compatibility := False; when 'z' => Warn_On_Unchecked_Conversion := True; *************** package body Sem_Warn is *** 3423,3450 **** and then Is_Known_Branch then declare - Start : Source_Ptr; - Dummy : Source_Ptr; - Typ : Character; Atrue : Boolean; begin - Sloc_Range (Orig, Start, Dummy); Atrue := Test_Result; ! if Present (Parent (C)) ! and then Nkind (Parent (C)) = N_Op_Not ! then Atrue := not Atrue; end if; ! if Atrue then ! Typ := 't'; ! else ! Typ := 'f'; ! end if; ! ! Set_SCO_Condition (Start, Typ); end; end if; --- 3557,3572 ---- and then Is_Known_Branch then declare Atrue : Boolean; begin Atrue := Test_Result; ! if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then Atrue := not Atrue; end if; ! Set_SCO_Condition (Orig, Atrue); end; end if; *************** package body Sem_Warn is *** 3586,3592 **** Form1 := First_Formal (Subp); Act1 := First_Actual (N); while Present (Form1) and then Present (Act1) loop ! if Ekind (Form1) = E_In_Out_Parameter then Form2 := First_Formal (Subp); Act2 := First_Actual (N); while Present (Form2) and then Present (Act2) loop --- 3708,3714 ---- Form1 := First_Formal (Subp); Act1 := First_Actual (N); while Present (Form1) and then Present (Act1) loop ! if Ekind (Form1) /= E_In_Parameter then Form2 := First_Formal (Subp); Act2 := First_Actual (N); while Present (Form2) and then Present (Act2) loop *************** package body Sem_Warn is *** 3617,3627 **** elsif Nkind (Act2) = N_Function_Call then null; ! -- If either type is elementary the aliasing is harmless. ! elsif Is_Elementary_Type (Underlying_Type (Etype (Form1))) ! or else ! Is_Elementary_Type (Underlying_Type (Etype (Form2))) then null; --- 3739,3749 ---- elsif Nkind (Act2) = N_Function_Call then null; ! -- If type is not by-copy we can assume that the aliasing is ! -- intended. ! elsif ! Is_By_Reference_Type (Underlying_Type (Etype (Form1))) then null; *************** package body Sem_Warn is *** 3640,3650 **** Next_Actual (Act); end loop; -- If the call was written in prefix notation, and -- thus its prefix before rewriting was a selected -- component, count only visible actuals in the call. ! if Is_Entity_Name (First_Actual (N)) and then Nkind (Original_Node (N)) = Nkind (N) and then Nkind (Name (Original_Node (N))) = N_Selected_Component --- 3762,3782 ---- Next_Actual (Act); end loop; + if Is_Elementary_Type (Etype (Act1)) + and then Ekind (Form2) = E_In_Parameter + then + null; -- no real aliasing. + + elsif Is_Elementary_Type (Etype (Act2)) + and then Ekind (Form2) = E_In_Parameter + then + null; -- ditto + -- If the call was written in prefix notation, and -- thus its prefix before rewriting was a selected -- component, count only visible actuals in the call. ! elsif Is_Entity_Name (First_Actual (N)) and then Nkind (Original_Node (N)) = Nkind (N) and then Nkind (Name (Original_Node (N))) = N_Selected_Component *************** package body Sem_Warn is *** 3665,3673 **** end if; else Error_Msg_FE ! ("writable actual overlaps with actual for&?", ! Act1, Form); end if; end; end if; --- 3797,3806 ---- end if; else + Error_Msg_Node_2 := Form; Error_Msg_FE ! ("writable actual for & overlaps with" ! & " actual for&?", Act1, Form1); end if; end; end if; *************** package body Sem_Warn is *** 3776,3782 **** procedure Warn1 is begin Error_Msg_Uint_1 := Low_Bound; ! Error_Msg_FE ("?index for& may assume lower bound of^", X, Ent); end Warn1; -- Start of processing for Test_Suspicious_Index --- 3909,3916 ---- procedure Warn1 is begin Error_Msg_Uint_1 := Low_Bound; ! Error_Msg_FE -- CODEFIX ! ("?index for& may assume lower bound of^", X, Ent); end Warn1; -- Start of processing for Test_Suspicious_Index *************** package body Sem_Warn is *** 3800,3810 **** if Nkind (Original_Node (X)) = N_Integer_Literal then if Intval (X) = Low_Bound then ! Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First`", X, Ent); else Error_Msg_Uint_1 := Intval (X) - Low_Bound; ! Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First + ^`", X, Ent); end if; --- 3934,3944 ---- if Nkind (Original_Node (X)) = N_Integer_Literal then if Intval (X) = Low_Bound then ! Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First`", X, Ent); else Error_Msg_Uint_1 := Intval (X) - Low_Bound; ! Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First + ^`", X, Ent); end if; *************** package body Sem_Warn is *** 3910,3916 **** -- Replacement subscript is now in string buffer ! Error_Msg_FE -- CODEFIX ("\suggested replacement: `&~`", Original_Node (X), Ent); end if; --- 4044,4050 ---- -- Replacement subscript is now in string buffer ! Error_Msg_FE -- CODEFIX ("\suggested replacement: `&~`", Original_Node (X), Ent); end if; *************** package body Sem_Warn is *** 4082,4091 **** if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then ! Error_Msg_N ("?renamed variable & is not referenced!", E); else ! Error_Msg_N ("?variable & is not referenced!", E); end if; end if; --- 4216,4225 ---- if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then ! Error_Msg_N -- CODEFIX ("?renamed variable & is not referenced!", E); else ! Error_Msg_N -- CODEFIX ("?variable & is not referenced!", E); end if; end if; *************** package body Sem_Warn is *** 4095,4104 **** if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then ! Error_Msg_N ("?renamed constant & is not referenced!", E); else ! Error_Msg_N ("?constant & is not referenced!", E); end if; when E_In_Parameter | --- 4229,4239 ---- if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then ! Error_Msg_N -- CODEFIX ("?renamed constant & is not referenced!", E); else ! Error_Msg_N -- CODEFIX ! ("?constant & is not referenced!", E); end if; when E_In_Parameter | *************** package body Sem_Warn is *** 4123,4129 **** end if; if not Is_Trivial_Subprogram (Scope (E)) then ! Error_Msg_NE ("?formal parameter & is not referenced!", E, Spec_E); end if; --- 4258,4264 ---- end if; if not Is_Trivial_Subprogram (Scope (E)) then ! Error_Msg_NE -- CODEFIX ("?formal parameter & is not referenced!", E, Spec_E); end if; *************** package body Sem_Warn is *** 4138,4165 **** when E_Named_Integer | E_Named_Real => ! Error_Msg_N ("?named number & is not referenced!", E); when Formal_Object_Kind => ! Error_Msg_N ("?formal object & is not referenced!", E); when E_Enumeration_Literal => ! Error_Msg_N ("?literal & is not referenced!", E); when E_Function => ! Error_Msg_N ("?function & is not referenced!", E); when E_Procedure => ! Error_Msg_N ("?procedure & is not referenced!", E); when E_Package => ! Error_Msg_N ("?package & is not referenced!", E); when E_Exception => ! Error_Msg_N ("?exception & is not referenced!", E); when E_Label => ! Error_Msg_N ("?label & is not referenced!", E); when E_Generic_Procedure => Error_Msg_N -- CODEFIX --- 4273,4308 ---- when E_Named_Integer | E_Named_Real => ! Error_Msg_N -- CODEFIX ! ("?named number & is not referenced!", E); when Formal_Object_Kind => ! Error_Msg_N -- CODEFIX ! ("?formal object & is not referenced!", E); when E_Enumeration_Literal => ! Error_Msg_N -- CODEFIX ! ("?literal & is not referenced!", E); when E_Function => ! Error_Msg_N -- CODEFIX ! ("?function & is not referenced!", E); when E_Procedure => ! Error_Msg_N -- CODEFIX ! ("?procedure & is not referenced!", E); when E_Package => ! Error_Msg_N -- CODEFIX ! ("?package & is not referenced!", E); when E_Exception => ! Error_Msg_N -- CODEFIX ! ("?exception & is not referenced!", E); when E_Label => ! Error_Msg_N -- CODEFIX ! ("?label & is not referenced!", E); when E_Generic_Procedure => Error_Msg_N -- CODEFIX *************** package body Sem_Warn is *** 4170,4179 **** ("?generic function & is never instantiated!", E); when Type_Kind => ! Error_Msg_N ("?type & is not referenced!", E); when others => ! Error_Msg_N ("?& is not referenced!", E); end case; -- Kill warnings on the entity on which the message has been posted --- 4313,4324 ---- ("?generic function & is never instantiated!", E); when Type_Kind => ! Error_Msg_N -- CODEFIX ! ("?type & is not referenced!", E); when others => ! Error_Msg_N -- CODEFIX ! ("?& is not referenced!", E); end case; -- Kill warnings on the entity on which the message has been posted *************** package body Sem_Warn is *** 4270,4276 **** ("?& modified by call, but value never referenced", Last_Assignment (Ent), Ent); else ! Error_Msg_NE ("?useless assignment to&, value never referenced!", Last_Assignment (Ent), Ent); end if; --- 4415,4421 ---- ("?& modified by call, but value never referenced", Last_Assignment (Ent), Ent); else ! Error_Msg_NE -- CODEFIX ("?useless assignment to&, value never referenced!", Last_Assignment (Ent), Ent); end if; *************** package body Sem_Warn is *** 4286,4292 **** ("?& modified by call, but value overwritten #!", Last_Assignment (Ent), Ent); else ! Error_Msg_NE ("?useless assignment to&, value overwritten #!", Last_Assignment (Ent), Ent); end if; --- 4431,4437 ---- ("?& modified by call, but value overwritten #!", Last_Assignment (Ent), Ent); else ! Error_Msg_NE -- CODEFIX ("?useless assignment to&, value overwritten #!", Last_Assignment (Ent), Ent); end if; *************** package body Sem_Warn is *** 4321,4327 **** -- variable in question, or if the entity in question -- is an OUT or IN OUT parameter, which which case -- the caller can reference it after the exception ! -- hanlder completes else if Is_Formal (Ent) then --- 4466,4472 ---- -- variable in question, or if the entity in question -- is an OUT or IN OUT parameter, which which case -- the caller can reference it after the exception ! -- handler completes. else if Is_Formal (Ent) then diff -Nrcpad gcc-4.5.2/gcc/ada/sem_warn.ads gcc-4.6.0/gcc/ada/sem_warn.ads *** gcc-4.5.2/gcc/ada/sem_warn.ads Tue Oct 27 14:14:44 2009 --- gcc-4.6.0/gcc/ada/sem_warn.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1999-2010, 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- -- *************** with Types; use Types; *** 33,38 **** --- 33,58 ---- package Sem_Warn is + ------------------- + -- Warning Flags -- + ------------------- + + -- These flags are activated or deactivated by -gnatw switches and control + -- whether warnings of a given class will be generated or not. + + -- Note: most of these flags are still in opt, but the plan is to move them + -- here as time goes by. + + Warn_On_Record_Holes : Boolean := False; + -- Warn when explicit record component clauses leave uncovered holes (gaps) + -- in a record layout. Off by default, set by -gnatw.h (but not -gnatwa). + + Warn_On_Overridden_Size : Boolean := False; + -- Warn when explicit record component clause or array component_size + -- clause specifies a size that overrides a size for the type which was + -- set with an explicit size clause. Off by default, set by -gnatw.s (but + -- not -gnatwa). + ------------------------ -- Warnings Off Table -- ------------------------ *************** package Sem_Warn is *** 170,176 **** procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id); -- N is the node for a loop statement. This procedure checks if a warning ! -- should be given for a possible infinite loop, and if so issues it. procedure Check_Low_Bound_Tested (Expr : Node_Id); -- Expr is the node for a comparison operation. This procedure checks if --- 190,197 ---- procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id); -- N is the node for a loop statement. This procedure checks if a warning ! -- for a possible infinite loop should be given for a suspicious WHILE or ! -- EXIT WHEN condition. procedure Check_Low_Bound_Tested (Expr : Node_Id); -- Expr is the node for a comparison operation. This procedure checks if diff -Nrcpad gcc-4.5.2/gcc/ada/sfn_scan.adb gcc-4.6.0/gcc/ada/sfn_scan.adb *** gcc-4.5.2/gcc/ada/sfn_scan.adb Thu Jun 11 15:48:14 2009 --- gcc-4.6.0/gcc/ada/sfn_scan.adb Tue Jun 22 17:04:37 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2000-2010, 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- -- *************** package body SFN_Scan is *** 37,47 **** -- Allow easy access to control character definitions EOF : constant Character := ASCII.SUB; ! -- The character SUB (16#1A#) is used in DOS and other systems derived ! -- from DOS (OS/2, NT etc.) to signal the end of a text file. If this ! -- character appears as the last character of a file scanned by a call ! -- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as ! -- an illegal character. type String_Ptr is access String; --- 37,46 ---- -- Allow easy access to control character definitions EOF : constant Character := ASCII.SUB; ! -- The character SUB (16#1A#) is used in DOS-derived systems, such as ! -- Windows to signal the end of a text file. If this character appears as ! -- the last character of a file scanned by a call to Scan_SFN_Pragmas, then ! -- it is ignored, otherwise it is treated as an illegal character. type String_Ptr is access String; *************** package body SFN_Scan is *** 637,643 **** loop if At_EOF or else S (P) = LF or else S (P) = CR then ! Error -- CODEFIX ("missing string quote"); elsif S (P) = HT then --- 636,642 ---- loop if At_EOF or else S (P) = LF or else S (P) = CR then ! Error -- CODEFIX ("missing string quote"); elsif S (P) = HT then diff -Nrcpad gcc-4.5.2/gcc/ada/sinfo.adb gcc-4.6.0/gcc/ada/sinfo.adb *** gcc-4.5.2/gcc/ada/sinfo.adb Tue Jan 26 13:49:56 2010 --- gcc-4.6.0/gcc/ada/sinfo.adb Fri Oct 22 14:51:40 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sinfo is *** 146,152 **** --- 146,154 ---- begin pragma Assert (False or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); return List1 (N); *************** package body Sinfo is *** 221,227 **** begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition ! or else NT (N).Nkind = N_Access_To_Object_Definition); return Flag15 (N); end All_Present; --- 223,231 ---- begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition ! or else NT (N).Nkind = N_Access_To_Object_Definition ! or else NT (N).Nkind = N_Quantified_Expression ! or else NT (N).Nkind = N_Use_Type_Clause); return Flag15 (N); end All_Present; *************** package body Sinfo is *** 229,234 **** --- 233,239 ---- (N : Node_Id) return List_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_In or else NT (N).Nkind = N_Not_In); *************** package body Sinfo is *** 251,256 **** --- 256,277 ---- return Node3 (N); end Array_Aggregate; + function Aspect_Cancel + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag11 (N); + end Aspect_Cancel; + + function Aspect_Rep_Item + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + return Node2 (N); + end Aspect_Rep_Item; + function Assignment_OK (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 388,393 **** --- 409,423 ---- return List1 (N); end Choices; + function Class_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + return Flag6 (N); + end Class_Present; + function Coextensions (N : Node_Id) return Elist_Id is begin *************** package body Sinfo is *** 483,488 **** --- 513,519 ---- or else NT (N).Nkind = N_Exit_Statement or else NT (N).Nkind = N_If_Statement or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression or else NT (N).Nkind = N_Raise_Constraint_Error or else NT (N).Nkind = N_Raise_Program_Error or else NT (N).Nkind = N_Raise_Storage_Error *************** package body Sinfo is *** 678,683 **** --- 709,722 ---- return Node5 (N); end Default_Expression; + function Default_Storage_Pool + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux); + return Node3 (N); + end Default_Storage_Pool; + function Default_Name (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 705,710 **** --- 744,750 ---- or else NT (N).Nkind = N_Full_Type_Declaration or else NT (N).Nkind = N_Implicit_Label_Declaration or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Loop_Parameter_Specification or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration *************** package body Sinfo is *** 791,796 **** --- 831,837 ---- (N : Node_Id) return List_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant); return List4 (N); *************** package body Sinfo is *** 1026,1033 **** begin pragma Assert (False or else NT (N).Nkind in N_Has_Entity ! or else NT (N).Nkind = N_Freeze_Entity ! or else NT (N).Nkind = N_Attribute_Definition_Clause); return Node4 (N); end Entity; --- 1067,1075 ---- begin pragma Assert (False or else NT (N).Nkind in N_Has_Entity ! or else NT (N).Nkind = N_Aspect_Specification ! or else NT (N).Nkind = N_Attribute_Definition_Clause ! or else NT (N).Nkind = N_Freeze_Entity); return Node4 (N); end Entity; *************** package body Sinfo is *** 1166,1174 **** --- 1208,1219 ---- begin pragma Assert (False or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association *************** package body Sinfo is *** 1178,1189 **** --- 1223,1236 ---- or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Parameterized_Expression or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Raise_Statement *************** package body Sinfo is *** 1280,1285 **** --- 1327,1341 ---- return Flag5 (N); end Forwards_OK; + function From_Aspect_Specification + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + return Flag13 (N); + end From_Aspect_Specification; + function From_At_End (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 1378,1384 **** begin return Flag10 (N); end Has_Dynamic_Length_Check; - function Has_Dynamic_Range_Check (N : Node_Id) return Boolean is begin --- 1434,1439 ---- *************** package body Sinfo is *** 1409,1415 **** return Flag17 (N); end Has_No_Elaboration_Code; ! function Has_Priority_Pragma (N : Node_Id) return Boolean is begin pragma Assert (False --- 1464,1479 ---- return Flag17 (N); end Has_No_Elaboration_Code; ! function Has_Pragma_CPU ! (N : Node_Id) return Boolean is ! begin ! pragma Assert (False ! or else NT (N).Nkind = N_Subprogram_Body ! or else NT (N).Nkind = N_Task_Definition); ! return Flag14 (N); ! end Has_Pragma_CPU; ! ! function Has_Pragma_Priority (N : Node_Id) return Boolean is begin pragma Assert (False *************** package body Sinfo is *** 1417,1423 **** or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Definition); return Flag6 (N); ! end Has_Priority_Pragma; function Has_Private_View (N : Node_Id) return Boolean is --- 1481,1495 ---- or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Definition); return Flag6 (N); ! end Has_Pragma_Priority; ! ! function Has_Pragma_Suppress_All ! (N : Node_Id) return Boolean is ! begin ! pragma Assert (False ! or else NT (N).Nkind = N_Compilation_Unit); ! return Flag14 (N); ! end Has_Pragma_Suppress_All; function Has_Private_View (N : Node_Id) return Boolean is *************** package body Sinfo is *** 1512,1517 **** --- 1584,1590 ---- (N : Node_Id) return Node_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Designator *************** package body Sinfo is *** 1555,1560 **** --- 1628,1641 ---- return Flag16 (N); end Interface_Present; + function Import_Interface_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag16 (N); + end Import_Interface_Present; + function In_Present (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 1572,1577 **** --- 1653,1666 ---- return Flag11 (N); end Includes_Infinities; + function Inherited_Discriminant + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + return Flag13 (N); + end Inherited_Discriminant; + function Instance_Spec (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 1631,1636 **** --- 1720,1734 ---- return Flag16 (N); end Is_Controlling_Actual; + function Is_Delayed_Aspect + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + return Flag14 (N); + end Is_Delayed_Aspect; + function Is_Dynamic_Coextension (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 1769,1774 **** --- 1867,1881 ---- return Node2 (N); end Iteration_Scheme; + function Iterator_Specification + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression); + return Node2 (N); + end Iterator_Specification; + function Itype (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 1893,1899 **** (N : Node_Id) return Node_Id is begin pragma Assert (False ! or else NT (N).Nkind = N_Iteration_Scheme); return Node4 (N); end Loop_Parameter_Specification; --- 2000,2007 ---- (N : Node_Id) return Node_Id is begin pragma Assert (False ! or else NT (N).Nkind = N_Iteration_Scheme ! or else NT (N).Nkind = N_Quantified_Expression); return Node4 (N); end Loop_Parameter_Specification; *************** package body Sinfo is *** 1988,1993 **** --- 2096,2102 ---- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Goto_Statement + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration *************** package body Sinfo is *** 2021,2026 **** --- 2130,2143 ---- return Node2 (N); end Next_Entity; + function Next_Exit_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + return Node3 (N); + end Next_Exit_Statement; + function Next_Implicit_With (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 2049,2054 **** --- 2166,2172 ---- (N : Node_Id) return Node_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Enumeration_Representation_Clause or else NT (N).Nkind = N_Pragma *************** package body Sinfo is *** 2163,2168 **** --- 2281,2294 ---- return Node4 (N); end Object_Definition; + function Of_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification); + return Flag16 (N); + end Of_Present; + function Original_Discriminant (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 2523,2528 **** --- 2649,2655 ---- (N : Node_Id) return Boolean is begin pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Loop_Parameter_Specification); return Flag15 (N); end Reverse_Present; *************** package body Sinfo is *** 2561,2586 **** (N : Node_Id) return Node_Id is begin pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call ! or else NT (N).Nkind = N_SCIL_Membership_Test ! or else NT (N).Nkind = N_SCIL_Tag_Init); return Node4 (N); end SCIL_Entity; - function SCIL_Related_Node - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init - or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); - return Node1 (N); - end SCIL_Related_Node; - function SCIL_Tag_Value (N : Node_Id) return Node_Id is begin --- 2688,2699 ---- (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call ! or else NT (N).Nkind = N_SCIL_Membership_Test); return Node4 (N); end SCIL_Entity; function SCIL_Tag_Value (N : Node_Id) return Node_Id is begin *************** package body Sinfo is *** 2664,2669 **** --- 2777,2783 ---- or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Parameterized_Expression or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Declaration *************** package body Sinfo is *** 2671,2676 **** --- 2785,2799 ---- return Node1 (N); end Specification; + function Split_PPC + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + return Flag17 (N); + end Split_PPC; + function Statements (N : Node_Id) return List_Id is begin *************** package body Sinfo is *** 2722,2732 **** --- 2845,2865 ---- or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Component_Definition or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Subtype_Declaration); return Node5 (N); end Subtype_Indication; + function Suppress_Assignment_Checks + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Object_Declaration); + return Flag18 (N); + end Suppress_Assignment_Checks; + function Suppress_Loop_Warnings (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 2931,2936 **** --- 3064,3077 ---- return Flag13 (N); end Was_Originally_Stub; + function Withed_Body + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Node1 (N); + end Withed_Body; + function Zero_Cost_Handling (N : Node_Id) return Boolean is begin *************** package body Sinfo is *** 3033,3039 **** --- 3174,3182 ---- begin pragma Assert (False or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); Set_List1_With_Parent (N, Val); *************** package body Sinfo is *** 3108,3114 **** begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition ! or else NT (N).Nkind = N_Access_To_Object_Definition); Set_Flag15 (N, Val); end Set_All_Present; --- 3251,3259 ---- begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition ! or else NT (N).Nkind = N_Access_To_Object_Definition ! or else NT (N).Nkind = N_Quantified_Expression ! or else NT (N).Nkind = N_Use_Type_Clause); Set_Flag15 (N, Val); end Set_All_Present; *************** package body Sinfo is *** 3116,3121 **** --- 3261,3267 ---- (N : Node_Id; Val : List_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_In or else NT (N).Nkind = N_Not_In); *************** package body Sinfo is *** 3138,3143 **** --- 3284,3305 ---- Set_Node3_With_Parent (N, Val); end Set_Array_Aggregate; + procedure Set_Aspect_Cancel + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag11 (N, Val); + end Set_Aspect_Cancel; + + procedure Set_Aspect_Rep_Item + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + Set_Node2 (N, Val); + end Set_Aspect_Rep_Item; + procedure Set_Assignment_OK (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 3275,3280 **** --- 3437,3451 ---- Set_List1_With_Parent (N, Val); end Set_Choices; + procedure Set_Class_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + Set_Flag6 (N, Val); + end Set_Class_Present; + procedure Set_Coextensions (N : Node_Id; Val : Elist_Id) is begin *************** package body Sinfo is *** 3370,3375 **** --- 3541,3547 ---- or else NT (N).Nkind = N_Exit_Statement or else NT (N).Nkind = N_If_Statement or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression or else NT (N).Nkind = N_Raise_Constraint_Error or else NT (N).Nkind = N_Raise_Program_Error or else NT (N).Nkind = N_Raise_Storage_Error *************** package body Sinfo is *** 3565,3570 **** --- 3737,3750 ---- Set_Node5 (N, Val); -- semantic field, no parent set end Set_Default_Expression; + procedure Set_Default_Storage_Pool + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit_Aux); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Default_Storage_Pool; + procedure Set_Default_Name (N : Node_Id; Val : Node_Id) is begin *************** package body Sinfo is *** 3592,3597 **** --- 3772,3778 ---- or else NT (N).Nkind = N_Full_Type_Declaration or else NT (N).Nkind = N_Implicit_Label_Declaration or else NT (N).Nkind = N_Incomplete_Type_Declaration + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Loop_Parameter_Specification or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration *************** package body Sinfo is *** 3678,3683 **** --- 3859,3865 ---- (N : Node_Id; Val : List_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant); Set_List4_With_Parent (N, Val); *************** package body Sinfo is *** 3913,3920 **** begin pragma Assert (False or else NT (N).Nkind in N_Has_Entity ! or else NT (N).Nkind = N_Freeze_Entity ! or else NT (N).Nkind = N_Attribute_Definition_Clause); Set_Node4 (N, Val); -- semantic field, no parent set end Set_Entity; --- 4095,4103 ---- begin pragma Assert (False or else NT (N).Nkind in N_Has_Entity ! or else NT (N).Nkind = N_Aspect_Specification ! or else NT (N).Nkind = N_Attribute_Definition_Clause ! or else NT (N).Nkind = N_Freeze_Entity); Set_Node4 (N, Val); -- semantic field, no parent set end Set_Entity; *************** package body Sinfo is *** 4044,4052 **** --- 4227,4238 ---- begin pragma Assert (False or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association *************** package body Sinfo is *** 4056,4067 **** --- 4242,4255 ---- or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Parameterized_Expression or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Raise_Statement *************** package body Sinfo is *** 4158,4163 **** --- 4346,4360 ---- Set_Flag5 (N, Val); end Set_Forwards_OK; + procedure Set_From_Aspect_Specification + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + Set_Flag13 (N, Val); + end Set_From_Aspect_Specification; + procedure Set_From_At_End (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 4287,4293 **** Set_Flag17 (N, Val); end Set_Has_No_Elaboration_Code; ! procedure Set_Has_Priority_Pragma (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False --- 4484,4499 ---- Set_Flag17 (N, Val); end Set_Has_No_Elaboration_Code; ! procedure Set_Has_Pragma_CPU ! (N : Node_Id; Val : Boolean := True) is ! begin ! pragma Assert (False ! or else NT (N).Nkind = N_Subprogram_Body ! or else NT (N).Nkind = N_Task_Definition); ! Set_Flag14 (N, Val); ! end Set_Has_Pragma_CPU; ! ! procedure Set_Has_Pragma_Priority (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False *************** package body Sinfo is *** 4295,4301 **** or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Definition); Set_Flag6 (N, Val); ! end Set_Has_Priority_Pragma; procedure Set_Has_Private_View (N : Node_Id; Val : Boolean := True) is --- 4501,4515 ---- or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Definition); Set_Flag6 (N, Val); ! end Set_Has_Pragma_Priority; ! ! procedure Set_Has_Pragma_Suppress_All ! (N : Node_Id; Val : Boolean := True) is ! begin ! pragma Assert (False ! or else NT (N).Nkind = N_Compilation_Unit); ! Set_Flag14 (N, Val); ! end Set_Has_Pragma_Suppress_All; procedure Set_Has_Private_View (N : Node_Id; Val : Boolean := True) is *************** package body Sinfo is *** 4390,4395 **** --- 4604,4610 ---- (N : Node_Id; Val : Node_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Designator *************** package body Sinfo is *** 4433,4438 **** --- 4648,4661 ---- Set_Flag16 (N, Val); end Set_Interface_Present; + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag16 (N, Val); + end Set_Import_Interface_Present; + procedure Set_In_Present (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 4450,4455 **** --- 4673,4686 ---- Set_Flag11 (N, Val); end Set_Includes_Infinities; + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + Set_Flag13 (N, Val); + end Set_Inherited_Discriminant; + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id) is begin *************** package body Sinfo is *** 4509,4514 **** --- 4740,4754 ---- Set_Flag16 (N, Val); end Set_Is_Controlling_Actual; + procedure Set_Is_Delayed_Aspect + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + Set_Flag14 (N, Val); + end Set_Is_Delayed_Aspect; + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 4647,4652 **** --- 4887,4901 ---- Set_Node2_With_Parent (N, Val); end Set_Iteration_Scheme; + procedure Set_Iterator_Specification + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iteration_Scheme + or else NT (N).Nkind = N_Quantified_Expression); + Set_Node2_With_Parent (N, Val); + end Set_Iterator_Specification; + procedure Set_Itype (N : Node_Id; Val : Entity_Id) is begin *************** package body Sinfo is *** 4771,4777 **** (N : Node_Id; Val : Node_Id) is begin pragma Assert (False ! or else NT (N).Nkind = N_Iteration_Scheme); Set_Node4_With_Parent (N, Val); end Set_Loop_Parameter_Specification; --- 5020,5027 ---- (N : Node_Id; Val : Node_Id) is begin pragma Assert (False ! or else NT (N).Nkind = N_Iteration_Scheme ! or else NT (N).Nkind = N_Quantified_Expression); Set_Node4_With_Parent (N, Val); end Set_Loop_Parameter_Specification; *************** package body Sinfo is *** 4866,4871 **** --- 5116,5122 ---- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Goto_Statement + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration *************** package body Sinfo is *** 4899,4904 **** --- 5150,5163 ---- Set_Node2 (N, Val); -- semantic field, no parent set end Set_Next_Entity; + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Next_Exit_Statement; + procedure Set_Next_Implicit_With (N : Node_Id; Val : Node_Id) is begin *************** package body Sinfo is *** 4927,4932 **** --- 5186,5192 ---- (N : Node_Id; Val : Node_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Enumeration_Representation_Clause or else NT (N).Nkind = N_Pragma *************** package body Sinfo is *** 5041,5046 **** --- 5301,5314 ---- Set_Node4_With_Parent (N, Val); end Set_Object_Definition; + procedure Set_Of_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification); + Set_Flag16 (N, Val); + end Set_Of_Present; + procedure Set_Original_Discriminant (N : Node_Id; Val : Node_Id) is begin *************** package body Sinfo is *** 5401,5406 **** --- 5669,5675 ---- (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Loop_Parameter_Specification); Set_Flag15 (N, Val); end Set_Reverse_Present; *************** package body Sinfo is *** 5439,5464 **** (N : Node_Id; Val : Node_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call ! or else NT (N).Nkind = N_SCIL_Membership_Test ! or else NT (N).Nkind = N_SCIL_Tag_Init); Set_Node4 (N, Val); -- semantic field, no parent set end Set_SCIL_Entity; - procedure Set_SCIL_Related_Node - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init - or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); - Set_Node1 (N, Val); -- semantic field, no parent set - end Set_SCIL_Related_Node; - procedure Set_SCIL_Tag_Value (N : Node_Id; Val : Node_Id) is begin --- 5708,5719 ---- (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call ! or else NT (N).Nkind = N_SCIL_Membership_Test); Set_Node4 (N, Val); -- semantic field, no parent set end Set_SCIL_Entity; procedure Set_SCIL_Tag_Value (N : Node_Id; Val : Node_Id) is begin *************** package body Sinfo is *** 5542,5547 **** --- 5797,5803 ---- or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Declaration + or else NT (N).Nkind = N_Parameterized_Expression or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Declaration *************** package body Sinfo is *** 5549,5554 **** --- 5805,5819 ---- Set_Node1_With_Parent (N, Val); end Set_Specification; + procedure Set_Split_PPC + (N : Node_Id; Val : Boolean) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + Set_Flag17 (N, Val); + end Set_Split_PPC; + procedure Set_Statements (N : Node_Id; Val : List_Id) is begin *************** package body Sinfo is *** 5600,5605 **** --- 5865,5871 ---- or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Component_Definition or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Iterator_Specification or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Subtype_Declaration); Set_Node5_With_Parent (N, Val); *************** package body Sinfo is *** 5629,5634 **** --- 5895,5909 ---- Set_List2_With_Parent (N, Val); end Set_Subtype_Marks; + procedure Set_Suppress_Assignment_Checks + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Object_Declaration); + Set_Flag18 (N, Val); + end Set_Suppress_Assignment_Checks; + procedure Set_Suppress_Loop_Warnings (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 5809,5814 **** --- 6084,6097 ---- Set_Flag13 (N, Val); end Set_Was_Originally_Stub; + procedure Set_Withed_Body + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Node1 (N, Val); + end Set_Withed_Body; + procedure Set_Zero_Cost_Handling (N : Node_Id; Val : Boolean := True) is begin *************** package body Sinfo is *** 5856,5861 **** --- 6139,6157 ---- end if; end End_Location; + -------------------- + -- Get_Pragma_Arg -- + -------------------- + + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is + begin + if Nkind (Arg) = N_Pragma_Argument_Association then + return Expression (Arg); + else + return Arg; + end if; + end Get_Pragma_Arg; + ---------------------- -- Set_End_Location -- ---------------------- *************** package body Sinfo is *** 5982,5988 **** T = V8; end Nkind_In; - function Nkind_In (T : Node_Kind; V1 : Node_Kind; --- 6278,6283 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/sinfo.ads gcc-4.6.0/gcc/ada/sinfo.ads *** gcc-4.5.2/gcc/ada/sinfo.ads Tue Jan 26 13:49:56 2010 --- gcc-4.6.0/gcc/ada/sinfo.ads Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sinfo is *** 59,73 **** -- If changes are made to this file, a number of related steps must be -- carried out to ensure consistency. First, if a field access function is ! -- added, it appears in seven places: ! -- The documentation associated with the node ! -- The spec of the access function in sinfo.ads ! -- The body of the access function in sinfo.adb ! -- The pragma Inline at the end of sinfo.ads for the access function ! -- The spec of the set procedure in sinfo.ads ! -- The body of the set procedure in sinfo.adb ! -- The pragma Inline at the end of sinfo.ads for the set procedure -- The field chosen must be consistent in all places, and, for a node that -- is a subexpression, must not overlap any of the standard expression --- 59,77 ---- -- If changes are made to this file, a number of related steps must be -- carried out to ensure consistency. First, if a field access function is ! -- added, it appears in these places: ! -- In sinfo.ads: ! -- The documentation associated with the field (if semantic) ! -- The documentation associated with the node ! -- The spec of the access function ! -- The spec of the set procedure ! -- The entries in Is_Syntactic_Field ! -- The pragma Inline for the access function ! -- The pragma Inline for the set procedure ! -- In sinfo.adb: ! -- The body of the access function ! -- The body of the set procedure -- The field chosen must be consistent in all places, and, for a node that -- is a subexpression, must not overlap any of the standard expression *************** package Sinfo is *** 96,105 **** -- Finally, four utility programs must be run: ! -- Run CSinfo to check that you have made the changes consistently. It ! -- checks most of the rules given above, with clear error messages. This ! -- utility reads sinfo.ads and sinfo.adb and generates a report to ! -- standard output. -- Run XSinfo to create sinfo.h, the corresponding C header. This -- utility reads sinfo.ads and generates sinfo.h. Note that it does --- 100,109 ---- -- Finally, four utility programs must be run: ! -- (Optional.) Run CSinfo to check that you have made the changes ! -- consistently. It checks most of the rules given above. This utility ! -- reads sinfo.ads and sinfo.adb and generates a report to standard ! -- output. This step is optional because XSinfo runs CSinfo. -- Run XSinfo to create sinfo.h, the corresponding C header. This -- utility reads sinfo.ads and generates sinfo.h. Note that it does *************** package Sinfo is *** 116,123 **** -- spec of the Nmake package which contains functions for constructing -- nodes. ! -- All of the above steps except CSinfo are done automatically by the ! -- build scripts when you do a full bootstrap. -- Note: sometime we could write a utility that actually generated the body -- of sinfo from the spec instead of simply checking it, since, as noted --- 120,127 ---- -- spec of the Nmake package which contains functions for constructing -- nodes. ! -- The above steps are done automatically by the build scripts when you do ! -- a full bootstrap. -- Note: sometime we could write a utility that actually generated the body -- of sinfo from the spec instead of simply checking it, since, as noted *************** package Sinfo is *** 455,467 **** -- The following flag fields appear in all nodes ! -- Analyzed (Flag1) -- This flag is used to indicate that a node (and all its children have -- been analyzed. It is used to avoid reanalysis of a node that has -- already been analyzed, both for efficiency and functional correctness -- reasons. ! -- Comes_From_Source (Flag2) -- This flag is set if the node comes directly from an explicit construct -- in the source. It is normally on for any nodes built by the scanner or -- parser from the source program, with the exception that in a few cases --- 459,471 ---- -- The following flag fields appear in all nodes ! -- Analyzed -- This flag is used to indicate that a node (and all its children have -- been analyzed. It is used to avoid reanalysis of a node that has -- already been analyzed, both for efficiency and functional correctness -- reasons. ! -- Comes_From_Source -- This flag is set if the node comes directly from an explicit construct -- in the source. It is normally on for any nodes built by the scanner or -- parser from the source program, with the exception that in a few cases *************** package Sinfo is *** 475,481 **** -- from the source program (e.g. the allocator built for build-in-place -- case), and the Comes_From_Source flag is deliberately set. ! -- Error_Posted (Flag3) -- This flag is used to avoid multiple error messages being posted on or -- referring to the same node. This flag is set if an error message -- refers to a node or is posted on its source location, and has the --- 479,485 ---- -- from the source program (e.g. the allocator built for build-in-place -- case), and the Comes_From_Source flag is deliberately set. ! -- Error_Posted -- This flag is used to avoid multiple error messages being posted on or -- referring to the same node. This flag is set if an error message -- refers to a node or is posted on its source location, and has the *************** package Sinfo is *** 587,592 **** --- 591,608 ---- -- is used for translation of the at end handler into a normal exception -- handler. + -- Aspect_Cancel (Flag11-Sem) + -- Processing of aspect specifications typically generates pragmas and + -- attribute definition clauses that are inserted into the tree after + -- the declaration node to get the desired aspect effect. In the case + -- of Boolean aspects that use "=> False" to cancel the effect of an + -- aspect (i.e. turn if off), the generated pragma has the Aspect_Cancel + -- flag set to indicate that the pragma operates in the opposite sense. + + -- Aspect_Rep_Item (Node2-Sem) + -- Present in N_Aspect_Specification nodes. Points to the corresponding + -- pragma/attribute definition node used to process the aspect. + -- Assignment_OK (Flag15-Sem) -- This flag is set in a subexpression node for an object, indicating -- that the associated object can be modified, even if this would not *************** package Sinfo is *** 793,798 **** --- 809,820 ---- -- for the default expression). Default_Expression is used for -- conformance checking. + -- Default_Storage_Pool (Node3-Sem) + -- This field is present in N_Compilation_Unit_Aux nodes. It is set to a + -- copy of Opt.Default_Pool at the end of the compilation unit. See + -- package Opt for details. This is used for inheriting the + -- Default_Storage_Pool in child units. + -- Discr_Check_Funcs_Built (Flag11-Sem) -- This flag is present in N_Full_Type_Declaration nodes. It is set when -- discriminant checking functions are constructed. The purpose is to *************** package Sinfo is *** 1056,1061 **** --- 1078,1089 ---- -- cannot figure it out. If both flags Forwards_OK and Backwards_OK are -- set, it means that the front end can assure no overlap of operands. + -- From_Aspect_Specification (Flag13-Sem) + -- Processing of aspect specifications typically results in insertion in + -- the tree of corresponding pragma or attribute definition clause nodes. + -- These generated nodes have the From_Aspect_Specification flag set to + -- indicate that they came from aspect specifications originally. + -- From_At_End (Flag4-Sem) -- This flag is set on an N_Raise_Statement node if it corresponds to -- the reraise statement generated as the last statement of an AT END *************** package Sinfo is *** 1115,1121 **** -- generate elaboration code, and non-preelaborated packages which do -- not generate elaboration code. ! -- Has_Priority_Pragma (Flag6-Sem) -- A flag present in N_Subprogram_Body, N_Task_Definition and -- N_Protected_Definition nodes to flag the presence of either a Priority -- or Interrupt_Priority pragma in the declaration sequence (public or --- 1143,1163 ---- -- generate elaboration code, and non-preelaborated packages which do -- not generate elaboration code. ! -- Has_Pragma_CPU (Flag14-Sem) ! -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to ! -- flag the presence of a CPU pragma in the declaration sequence (public ! -- or private in the task case). ! ! -- Has_Pragma_Suppress_All (Flag14-Sem) ! -- This flag is set in an N_Compilation_Unit node if the Suppress_All ! -- pragma appears anywhere in the unit. This accommodates the rather ! -- strange placement rules of other compilers (DEC permits it at the ! -- end of a unit, and Rational allows it as a program unit pragma). We ! -- allow it anywhere at all, and consider it equivalent to a pragma ! -- Suppress (All_Checks) appearing at the start of the configuration ! -- pragmas for the unit. ! ! -- Has_Pragma_Priority (Flag6-Sem) -- A flag present in N_Subprogram_Body, N_Task_Definition and -- N_Protected_Definition nodes to flag the presence of either a Priority -- or Interrupt_Priority pragma in the declaration sequence (public or *************** package Sinfo is *** 1172,1177 **** --- 1214,1224 ---- -- 'Address or 'Tag attribute. ???There are other implicit with clauses -- as well. + -- Import_Interface_Present (Flag16-Sem) + -- This flag is set in an Interface or Import pragma if a matching + -- pragma of the other kind is also present. This is used to avoid + -- generating some unwanted error messages. + -- Includes_Infinities (Flag11-Sem) -- This flag is present in N_Range nodes. It is set for the range of -- unconstrained float types defined in Standard, which include not only *************** package Sinfo is *** 1180,1185 **** --- 1227,1238 ---- -- range is given by the programmer, even if that range is identical to -- the range for Float. + -- Inherited_Discriminant (Flag13-Sem) + -- This flag is present in N_Component_Association nodes. It indicates + -- that a given component association in an extension aggregate is the + -- value obtained from a constraint on an ancestor. Used to prevent + -- double expansion when the aggregate has expansion delayed. + -- Instance_Spec (Node5-Sem) -- This field is present in generic instantiation nodes, and also in -- formal package declaration nodes (formal package declarations are *************** package Sinfo is *** 1205,1210 **** --- 1258,1268 ---- -- operand is of the component type of the result. Used in resolving -- concatenation nodes in instances. + -- Is_Delayed_Aspect (Flag14-Sem) + -- Present in N_Pragma and N_Attribute_Definition_Clause nodes which + -- come from aspect specifications, where the evaluation of the aspect + -- must be delayed to the freeze point. + -- Is_Controlling_Actual (Flag16-Sem) -- This flag is set on in an expression that is a controlling argument in -- a dispatching call. It is off in all other cases. See Sem_Disp for *************** package Sinfo is *** 1395,1400 **** --- 1453,1464 ---- -- scope are chained, and this field is used as the forward pointer for -- this list. See Einfo for further details. + -- Next_Exit_Statement (Node3-Sem) + -- Present in N_Exit_Statement nodes. The exit statements for a loop are + -- chained (in reverse order of appearance) from the First_Exit_Statement + -- field of the E_Loop entity for the loop. Next_Exit_Statement points to + -- the next entry on this chain (Empty = end of list). + -- Next_Implicit_With (Node3-Sem) -- Present in N_With_Clause. Part of a chain of with_clauses generated -- in rtsfind to indicate implicit dependencies on predefined units. Used *************** package Sinfo is *** 1402,1408 **** -- A postorder traversal of the tree whose nodes are units and whose -- links are with_clauses defines the order in which Inspector must -- examine a compiled unit and its full context. This ordering ensures ! -- that any subprogram call is examined after the subprogram declartion -- has been seen. -- Next_Named_Actual (Node4-Sem) --- 1466,1472 ---- -- A postorder traversal of the tree whose nodes are units and whose -- links are with_clauses defines the order in which Inspector must -- examine a compiled unit and its full context. This ordering ensures ! -- that any subprogram call is examined after the subprogram declaration -- has been seen. -- Next_Named_Actual (Node4-Sem) *************** package Sinfo is *** 1425,1433 **** -- details). -- Next_Rep_Item (Node5-Sem) ! -- Present in pragma nodes and attribute definition nodes. Used to link ! -- representation items that apply to an entity. See description of ! -- First_Rep_Item field in Einfo for full details. -- Next_Use_Clause (Node3-Sem) -- While use clauses are active during semantic processing, they are --- 1489,1498 ---- -- details). -- Next_Rep_Item (Node5-Sem) ! -- Present in pragma nodes, attribute definition nodes, enumeration rep ! -- clauses, record rep clauses, aspect specification nodes. Used to link ! -- representation items that apply to an entity. See full description of ! -- First_Rep_Item field in Einfo for further details. -- Next_Use_Clause (Node3-Sem) -- While use clauses are active during semantic processing, they are *************** package Sinfo is *** 1609,1618 **** -- Present in SCIL nodes. Used to reference the tagged type associated -- with the SCIL node. - -- SCIL_Related_Node (Node1-Sem) - -- Present in SCIL nodes. Used to reference a tree node that requires - -- special processing in the CodePeer backend. - -- SCIL_Controlling_Tag (Node5-Sem) -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the -- controlling tag of a dispatching call. --- 1674,1679 ---- *************** package Sinfo is *** 1643,1648 **** --- 1704,1717 ---- -- source type entity for the unchecked conversion instantiation -- which gigi must do size validation for. + -- Split_PPC (Flag17) + -- When a Pre or Postaspect specification is processed, it is broken + -- into AND THEN sections. The left most section has Split_PPC set to + -- False, indicating that it is the original specification (e.g. for + -- posting errors). For other sections, Split_PPC is set to True. + -- This flag is set in both the N_Aspect_Specification node itself, + -- and in the pragma which is generated from this node. + -- Static_Processing_OK (Flag4-Sem) -- Present in N_Aggregate nodes. When the Compile_Time_Known_Aggregate -- flag is set, the full value of the aggregate can be determined at *************** package Sinfo is *** 1664,1669 **** --- 1733,1745 ---- -- value of a type whose size is not known at compile time on the -- secondary stack. + -- Suppress_Assignment_Checks (Flag18-Sem) + -- Used in generated N_Assignment_Statement nodes to suppress predicate + -- and range checks in cases where the generated code knows that the + -- value being assigned is in range and satisfies any predicate. Also + -- can be set in N_Object_Declaration nodes, to similarly suppress any + -- checks on the initializing value. + -- Suppress_Loop_Warnings (Flag17-Sem) -- Used in N_Loop_Statement node to indicate that warnings within the -- body of the loop should be suppressed. This is set when the range *************** package Sinfo is *** 1723,1728 **** --- 1799,1810 ---- -- Original_Node here because of the case of nested instantiations where -- the substituted node can be copied. + -- Withed_Body (Node1-Sem) + -- Present in N_With_Clause nodes. Set if the unit in whose context + -- the with_clause appears instantiates a generic contained in the + -- library unit of the with_clause and as a result loads its body. + -- Used for a more precise unit traversal for CodePeer. + -- Zero_Cost_Handling (Flag5-Sem) -- This flag is set in all handled sequence of statement and exception -- handler nodes if exceptions are to be handled using the zero-cost *************** package Sinfo is *** 1866,1872 **** -- Note: the value of an integer literal node created by the front end -- is never outside the range of values of the base type. However, it ! -- can be the case that the value is outside the range of the -- particular subtype. This happens in the case of integer overflows -- with checks suppressed. --- 1948,1954 ---- -- Note: the value of an integer literal node created by the front end -- is never outside the range of values of the base type. However, it ! -- can be the case that the created value is outside the range of the -- particular subtype. This happens in the case of integer overflows -- with checks suppressed. *************** package Sinfo is *** 1974,1986 **** -- which are explicitly documented. -- N_Pragma ! -- Sloc points to pragma identifier -- Next_Pragma (Node1-Sem) -- Pragma_Argument_Associations (List2) (set to No_List if none) ! -- Debug_Statement (Node3) (set to Empty if not Debug, Assert) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) -- Pragma_Enabled (Flag5-Sem) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma --- 2056,2074 ---- -- which are explicitly documented. -- N_Pragma ! -- Sloc points to PRAGMA -- Next_Pragma (Node1-Sem) -- Pragma_Argument_Associations (List2) (set to No_List if none) ! -- Debug_Statement (Node3) (set to Empty if not Debug) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) -- Pragma_Enabled (Flag5-Sem) + -- From_Aspect_Specification (Flag13-Sem) + -- Is_Delayed_Aspect (Flag14-Sem) + -- Import_Interface_Present (Flag16-Sem) + -- Aspect_Cancel (Flag11-Sem) + -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set + -- Class_Present (Flag6) set if from Aspect with 'Class -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma *************** package Sinfo is *** 1990,1996 **** -- Note: a utility function Pragma_Name may be applied to pragma nodes -- to conveniently obtain the Chars field of the Pragma_Identifier. ! -------------------------------------- -- 2.8 Pragma Argument Association -- -------------------------------------- --- 2078,2089 ---- -- Note: a utility function Pragma_Name may be applied to pragma nodes -- to conveniently obtain the Chars field of the Pragma_Identifier. ! -- Note: if From_Aspect_Specification is set, then Sloc points to the ! -- aspect name, as does the Pragma_Identifier. In this case if the ! -- pragma has a local name argument (such as pragma Inline), it is ! -- resolved to point to the specific entity affected by the pragma. ! ! -------------------------------------- -- 2.8 Pragma Argument Association -- -------------------------------------- *************** package Sinfo is *** 2068,2074 **** -- FULL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- is TYPE_DEFINITION; -- | TASK_TYPE_DECLARATION -- | PROTECTED_TYPE_DECLARATION --- 2161,2169 ---- -- FULL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- is TYPE_DEFINITION ! -- [ASPECT_SPECIFICATIONS]; ! -- | TASK_TYPE_DECLARATION -- | PROTECTED_TYPE_DECLARATION *************** package Sinfo is *** 2175,2185 **** -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] ! -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] ! -- ACCESS_DEFINITION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] ! -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; -- | SINGLE_TASK_DECLARATION -- | SINGLE_PROTECTED_DECLARATION --- 2270,2283 ---- -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] ! -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] ! -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] ! -- ACCESS_DEFINITION [:= EXPRESSION] ! -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] ! -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] ! -- [ASPECT_SPECIFICATIONS]; -- | SINGLE_TASK_DECLARATION -- | SINGLE_PROTECTED_DECLARATION *************** package Sinfo is *** 2240,2245 **** --- 2338,2344 ---- -- Exception_Junk (Flag8-Sem) -- Is_Subprogram_Descriptor (Flag16-Sem) -- Has_Init_Expression (Flag14) + -- Suppress_Assignment_Checks (Flag18-Sem) ------------------------------------- -- 3.3.1 Defining Identifier List -- *************** package Sinfo is *** 2790,2795 **** --- 2889,2895 ---- -- COMPONENT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION -- [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- Note: although the syntax does not permit a component definition to -- be an anonymous array (and the parser will diagnose such an attempt *************** package Sinfo is *** 3328,3333 **** --- 3428,3434 ---- -- Loop_Actions (List2-Sem) -- Expression (Node3) -- Box_Present (Flag15) + -- Inherited_Discriminant (Flag13) -- Note: this structure is used for both record component associations -- and array component associations, since the two cases aren't always *************** package Sinfo is *** 3415,3428 **** -------------------------------------------------- -- EXPRESSION ::= ! -- RELATION {and RELATION} | RELATION {and then RELATION} ! -- | RELATION {or RELATION} | RELATION {or else RELATION} ! -- | RELATION {xor RELATION} ! -- RELATION ::= -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] ! -- | SIMPLE_EXPRESSION [not] in RANGE ! -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK -- SIMPLE_EXPRESSION ::= -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} --- 3516,3539 ---- -------------------------------------------------- -- EXPRESSION ::= ! -- RELATION {LOGICAL_OPERATOR RELATION} ! -- CHOICE_EXPRESSION ::= ! -- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION} ! ! -- CHOICE_RELATION ::= -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] ! ! -- RELATION ::= ! -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST ! ! -- MEMBERSHIP_CHOICE_LIST ::= ! -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE} ! ! -- MEMBERSHIP_CHOICE ::= ! -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK ! ! -- LOGICAL_OPERATOR ::= and | and then | or | or else | xor -- SIMPLE_EXPRESSION ::= -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} *************** package Sinfo is *** 3437,3442 **** --- 3548,3561 ---- -- constituent components of an expression (e.g. identifier is -- an example of an expression). + -- Note: the above syntax is that Ada 2012 syntax which restricts + -- choice relations to simple expressions to avoid ambiguities in + -- some contexts with set membership notation. It has been decided + -- that in retrospect, the Ada 95 change allowing general expressions + -- in this context was a mistake, so we have reverted to the above + -- syntax in Ada 95 and Ada 2005 modes (the restriction to simple + -- expressions was there in Ada 83 from the start). + ------------------ -- 4.4 Primary -- ------------------ *************** package Sinfo is *** 3522,3529 **** --------------------------- -- RELATION ::= ! -- SIMPLE_EXPRESSION [not] in RANGE ! -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK -- Note: although the grammar above allows only a range or a subtype -- mark, the parser in fact will accept any simple expression in place --- 3641,3653 ---- --------------------------- -- RELATION ::= ! -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST ! ! -- MEMBERSHIP_CHOICE_LIST ::= ! -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE} ! ! -- MEMBERSHIP_CHOICE ::= ! -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK -- Note: although the grammar above allows only a range or a subtype -- mark, the parser in fact will accept any simple expression in place *************** package Sinfo is *** 3531,3549 **** -- to deal with, and diagnose a simple expression other than a name for -- the right operand. This simplifies error recovery in the parser. ! -- If extensions are enabled, the grammar is as follows: ! ! -- RELATION ::= ! -- SIMPLE_EXPRESSION [not] in SET_ALTERNATIVE {| SET_ALTERNATIVE} ! ! -- SET_ALTERNATIVE ::= RANGE | SUBTYPE_MARK ! -- The Alternatives field below is present only if there is more than ! -- one Set_Alternative present, in which case Right_Opnd is set to ! -- Empty, and Alternatives contains the list of alternatives. In the ! -- tree passed to the back end, Alternatives is always No_List, and ! -- Right_Opnd is set (i.e. the expansion circuitry expands out the ! -- complex set membership case using simple membership operations). -- N_In -- Sloc points to IN --- 3655,3669 ---- -- to deal with, and diagnose a simple expression other than a name for -- the right operand. This simplifies error recovery in the parser. ! -- The Alternatives field below is present only if there is more ! -- than one Membership_Choice present (which is legitimate only in ! -- Ada 2012 mode) in which case Right_Opnd is Empty, and Alternatives ! -- contains the list of choices. In the tree passed to the back end, ! -- Alternatives is always No_List, and Right_Opnd is set (i.e. the ! -- expansion circuitry expands out the complex set membership case ! -- using simple membership operations). ! -- Should we rename Alternatives here to Membership_Choices ??? -- N_In -- Sloc points to IN *************** package Sinfo is *** 3724,3729 **** --- 3844,3869 ---- -- point operands if the Treat_Fixed_As_Integer flag is set and will -- thus treat these nodes in identical manner, ignoring small values. + --------------------------------- + -- 4.5.9 Quantified Expression -- + --------------------------------- + + -- QUANTIFIED_EXPRESSION ::= + -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE + -- | for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE + -- + -- QUANTIFIER ::= all | some + + -- At most one of (Iterator_Specification, Loop_Parameter_Specification) + -- is present at a time, in which case the other one is empty. + + -- N_Quantified_Expression + -- Sloc points to FOR + -- Iterator_Specification (Node2) + -- Loop_Parameter_Specification (Node4) + -- Condition (Node1) + -- All_Present (Flag15) + -------------------------- -- 4.6 Type Conversion -- -------------------------- *************** package Sinfo is *** 3890,3895 **** --- 4030,4039 ---- -- Identifier (Node1) direct name of statement identifier -- Exception_Junk (Flag8-Sem) + -- Note: Before Ada 2012, a label is always followed by a statement, + -- and this is true in the tree even in Ada 2012 mode (the parser + -- inserts a null statement marked with Comes_From_Source False). + ------------------------------- -- 5.1 Statement Identifier -- ------------------------------- *************** package Sinfo is *** 3916,3921 **** --- 4060,4066 ---- -- Backwards_OK (Flag6-Sem) -- No_Ctrl_Actions (Flag7-Sem) -- Componentwise_Assignment (Flag14-Sem) + -- Suppress_Assignment_Checks (Flag18-Sem) -- Note: if a range check is required, then the Do_Range_Check flag -- is set in the Expression (right hand side), with the check being *************** package Sinfo is *** 3985,3990 **** --- 4130,4140 ---- -- Alternatives (List4) -- End_Span (Uint5) (set to No_Uint if expander generated) + -- Note: Before Ada 2012, a pragma in a statement sequence is always + -- followed by a statement, and this is true in the tree even in Ada + -- 2012 mode (the parser inserts a null statement marked with the flag + -- Comes_From_Source False). + ------------------------------------- -- 5.4 Case Statement Alternative -- ------------------------------------- *************** package Sinfo is *** 4034,4045 **** -- Is_Null_Loop (Flag16) -- Suppress_Loop_Warnings (Flag17) -------------------------- -- 5.5 Iteration Scheme -- -------------------------- -- ITERATION_SCHEME ::= ! -- while CONDITION | for LOOP_PARAMETER_SPECIFICATION -- Gigi restriction: This expander ensures that the type of the -- Condition field is always Standard.Boolean, even if the type --- 4184,4208 ---- -- Is_Null_Loop (Flag16) -- Suppress_Loop_Warnings (Flag17) + -- Note: the parser fills in the Identifier field if there is an + -- explicit loop identifier. Otherwise the parser leaves this field + -- set to Empty, and then the semantic processing for a loop statement + -- creates an identifier, setting the Has_Created_Identifier flag to + -- True. So after semantic analysis, the Identifier is always set, + -- referencing an identifier whose entity has an Ekind of E_Loop. + -------------------------- -- 5.5 Iteration Scheme -- -------------------------- -- ITERATION_SCHEME ::= ! -- while CONDITION ! -- | for LOOP_PARAMETER_SPECIFICATION ! -- | for ITERATOR_SPECIFICATION ! ! -- At most one of (Iterator_Specification, Loop_Parameter_Specification) ! -- is present at a time, in which case the other one is empty. Both are ! -- empty in the case of a WHILE loop. -- Gigi restriction: This expander ensures that the type of the -- Condition field is always Standard.Boolean, even if the type *************** package Sinfo is *** 4049,4054 **** --- 4212,4218 ---- -- Sloc points to WHILE or FOR -- Condition (Node1) (set to Empty if FOR case) -- Condition_Actions (List3-Sem) + -- Iterator_Specification (Node2) (set to Empty if WHILE case) -- Loop_Parameter_Specification (Node4) (set to Empty if WHILE case) --------------------------------------- *************** package Sinfo is *** 4064,4069 **** --- 4228,4251 ---- -- Reverse_Present (Flag15) -- Discrete_Subtype_Definition (Node4) + ---------------------------------- + -- 5.5.1 Iterator specification -- + ---------------------------------- + + -- ITERATOR_SPECIFICATION ::= + -- DEFINING_IDENTIFIER in [reverse] NAME + -- | DEFINING_IDENTIFIER [: SUBTYPE_INDICATION] of [reverse] NAME + + -- N_Iterator_Specification + -- Sloc points to defining identifier + -- Defining_Identifier (Node1) + -- Name (Node2) + -- Reverse_Present (Flag15) + -- Of_Present (Flag16) + -- Subtype_Indication (Node5) + + -- Note: The Of_Present flag distinguishes the two forms + -------------------------- -- 5.6 Block Statement -- -------------------------- *************** package Sinfo is *** 4122,4128 **** -- N_Exit_Statement -- Sloc points to EXIT -- Name (Node2) (set to Empty if no loop name present) ! -- Condition (Node1) (set to Empty if no when part present) ------------------------- -- 5.9 Goto Statement -- --- 4304,4311 ---- -- N_Exit_Statement -- Sloc points to EXIT -- Name (Node2) (set to Empty if no loop name present) ! -- Condition (Node1) (set to Empty if no WHEN part present) ! -- Next_Exit_Statement (Node3-Sem): Next exit on chain ------------------------- -- 5.9 Goto Statement -- *************** package Sinfo is *** 4139,4145 **** -- 6.1 Subprogram Declaration -- --------------------------------- ! -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION; -- N_Subprogram_Declaration -- Sloc points to FUNCTION or PROCEDURE --- 4322,4330 ---- -- 6.1 Subprogram Declaration -- --------------------------------- ! -- SUBPROGRAM_DECLARATION ::= ! -- SUBPROGRAM_SPECIFICATION ! -- [ASPECT_SPECIFICATIONS]; -- N_Subprogram_Declaration -- Sloc points to FUNCTION or PROCEDURE *************** package Sinfo is *** 4153,4159 **** ------------------------------------------ -- ABSTRACT_SUBPROGRAM_DECLARATION ::= ! -- SUBPROGRAM_SPECIFICATION is abstract; -- N_Abstract_Subprogram_Declaration -- Sloc points to ABSTRACT --- 4338,4345 ---- ------------------------------------------ -- ABSTRACT_SUBPROGRAM_DECLARATION ::= ! -- SUBPROGRAM_SPECIFICATION is abstract ! -- [ASPECT_SPECIFICATIONS]; -- N_Abstract_Subprogram_Declaration -- Sloc points to ABSTRACT *************** package Sinfo is *** 4382,4393 **** -- Acts_As_Spec (Flag4-Sem) -- Bad_Is_Detected (Flag15) used only by parser -- Do_Storage_Check (Flag17-Sem) ! -- Has_Priority_Pragma (Flag6-Sem) -- Is_Protected_Subprogram_Body (Flag7-Sem) -- Is_Entry_Barrier_Function (Flag8-Sem) -- Is_Task_Master (Flag5-Sem) -- Was_Originally_Stub (Flag13-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem) ----------------------------------- -- 6.4 Procedure Call Statement -- --- 4568,4595 ---- -- Acts_As_Spec (Flag4-Sem) -- Bad_Is_Detected (Flag15) used only by parser -- Do_Storage_Check (Flag17-Sem) ! -- Has_Pragma_Priority (Flag6-Sem) -- Is_Protected_Subprogram_Body (Flag7-Sem) -- Is_Entry_Barrier_Function (Flag8-Sem) -- Is_Task_Master (Flag5-Sem) -- Was_Originally_Stub (Flag13-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- Has_Pragma_CPU (Flag14-Sem) + + ------------------------------ + -- Parameterized Expression -- + ------------------------------ + + -- This is an Ada 2012 extension, we put it here for now, to be labeled + -- and put in its proper section when we know exactly where that is! + + -- PARAMETERIZED_EXPRESSION ::= + -- FUNCTION SPECIFICATION IS (EXPRESSION); + + -- N_Parameterized_Expression + -- Sloc points to FUNCTION + -- Specification (Node1) + -- Expression (Node3) ----------------------------------- -- 6.4 Procedure Call Statement -- *************** package Sinfo is *** 4533,4541 **** --- 4735,4746 ---- -- By_Ref (Flag5-Sem) -- Note: Return_Statement_Entity points to an E_Return_Statement. + -- Note that Return_Object_Declarations is a list containing the -- N_Object_Declaration -- see comment on this field above. + -- The declared object will have Is_Return_Object = True. + -- There is no such syntactic category as return_object_declaration -- in the RM. Return_Object_Declarations represents this portion of -- the syntax for EXTENDED_RETURN_STATEMENT: *************** package Sinfo is *** 4552,4558 **** -- 7.1 Package Declaration -- ------------------------------ ! -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; -- Note: the activation chain entity for a package spec is used for -- all tasks declared in the package spec, or in the package body. --- 4757,4765 ---- -- 7.1 Package Declaration -- ------------------------------ ! -- PACKAGE_DECLARATION ::= ! -- PACKAGE_SPECIFICATION ! -- [ASPECT_SPECIFICATIONS]; -- Note: the activation chain entity for a package spec is used for -- all tasks declared in the package spec, or in the package body. *************** package Sinfo is *** 4677,4691 **** -- 8.4 Use Type Clause -- -------------------------- ! -- USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK}; -- Note: use type clause is not permitted in Ada 83 mode -- N_Use_Type_Clause -- Sloc points to USE -- Subtype_Marks (List2) -- Next_Use_Clause (Node3-Sem) -- Hidden_By_Use_Clause (Elist4-Sem) ------------------------------- -- 8.5 Renaming Declaration -- --- 4884,4901 ---- -- 8.4 Use Type Clause -- -------------------------- ! -- USE_TYPE_CLAUSE ::= use [ALL] type SUBTYPE_MARK {, SUBTYPE_MARK}; -- Note: use type clause is not permitted in Ada 83 mode + -- Note: the ALL keyword can appear only in Ada 2012 mode + -- N_Use_Type_Clause -- Sloc points to USE -- Subtype_Marks (List2) -- Next_Use_Clause (Node3-Sem) -- Hidden_By_Use_Clause (Elist4-Sem) + -- All_Present (Flag15) ------------------------------- -- 8.5 Renaming Declaration -- *************** package Sinfo is *** 4798,4804 **** -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- N_Task_Type_Declaration -- Sloc points to TASK --- 5008,5015 ---- -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- [is [new INTERFACE_LIST with] TASK_DEFINITION] ! -- [ASPECT_SPECIFICATIONS]; -- N_Task_Type_Declaration -- Sloc points to TASK *************** package Sinfo is *** 4815,4821 **** -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER ! -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- N_Single_Task_Declaration -- Sloc points to TASK --- 5026,5033 ---- -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER ! -- [is [new INTERFACE_LIST with] TASK_DEFINITION] ! -- [ASPECT_SPECIFICATIONS]; -- N_Single_Task_Declaration -- Sloc points to TASK *************** package Sinfo is *** 4841,4851 **** -- Visible_Declarations (List2) -- Private_Declarations (List3) (set to No_List if no private part) -- End_Label (Node4) ! -- Has_Priority_Pragma (Flag6-Sem) -- Has_Storage_Size_Pragma (Flag5-Sem) -- Has_Task_Info_Pragma (Flag7-Sem) -- Has_Task_Name_Pragma (Flag8-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem) -------------------- -- 9.1 Task Item -- --- 5053,5064 ---- -- Visible_Declarations (List2) -- Private_Declarations (List3) (set to No_List if no private part) -- End_Label (Node4) ! -- Has_Pragma_Priority (Flag6-Sem) -- Has_Storage_Size_Pragma (Flag5-Sem) -- Has_Task_Info_Pragma (Flag7-Sem) -- Has_Task_Name_Pragma (Flag8-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- Has_Pragma_CPU (Flag14-Sem) -------------------- -- 9.1 Task Item -- *************** package Sinfo is *** 4882,4888 **** -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; -- Note: protected type declarations are not permitted in Ada 83 mode --- 5095,5102 ---- -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] ! -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION ! -- {ASPECT_SPECIFICATIONS]; -- Note: protected type declarations are not permitted in Ada 83 mode *************** package Sinfo is *** 4901,4907 **** -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER ! -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; -- Note: single protected declarations are not allowed in Ada 83 mode --- 5115,5122 ---- -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER ! -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION ! -- [ASPECT_SPECIFICATIONS]; -- Note: single protected declarations are not allowed in Ada 83 mode *************** package Sinfo is *** 4926,4932 **** -- Visible_Declarations (List2) -- Private_Declarations (List3) (set to No_List if no private part) -- End_Label (Node4) ! -- Has_Priority_Pragma (Flag6-Sem) ------------------------------------------ -- 9.4 Protected Operation Declaration -- --- 5141,5147 ---- -- Visible_Declarations (List2) -- Private_Declarations (List3) (set to No_List if no private part) -- End_Label (Node4) ! -- Has_Pragma_Priority (Flag6-Sem) ------------------------------------------ -- 9.4 Protected Operation Declaration -- *************** package Sinfo is *** 5425,5432 **** -- the library item. -- To deal with all these problems, we create an auxiliary node for ! -- a compilation unit, referenced from the N_Compilation_Unit node ! -- that contains these three items. -- N_Compilation_Unit -- Sloc points to first token of defining unit name --- 5640,5647 ---- -- the library item. -- To deal with all these problems, we create an auxiliary node for ! -- a compilation unit, referenced from the N_Compilation_Unit node, ! -- that contains these items. -- N_Compilation_Unit -- Sloc points to first token of defining unit name *************** package Sinfo is *** 5440,5445 **** --- 5655,5661 ---- -- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec -- Context_Pending (Flag16-Sem) -- First_Inlined_Subprogram (Node3-Sem) + -- Has_Pragma_Suppress_All (Flag14-Sem) -- N_Compilation_Unit_Aux -- Sloc is a copy of the Sloc from the N_Compilation_Unit node *************** package Sinfo is *** 5447,5452 **** --- 5663,5669 ---- -- Actions (List1) (set to No_List if no actions) -- Pragmas_After (List5) pragmas after unit (set to No_List if none) -- Config_Pragmas (List4) config pragmas (set to Empty_List if none) + -- Default_Storage_Pool (Node3-Sem) -------------------------- -- 10.1.1 Library Item -- *************** package Sinfo is *** 5530,5535 **** --- 5747,5753 ---- -- N_With_Clause -- Sloc points to first token of library unit name + -- Withed_Body (Node1-Sem) -- Name (Node2) -- Next_Implicit_With (Node3-Sem) -- Library_Unit (Node4-Sem) *************** package Sinfo is *** 5543,5549 **** -- Elaborate_Desirable (Flag11-Sem) -- Private_Present (Flag15) set if with_clause has private keyword -- Implicit_With (Flag16-Sem) ! -- Limited_Present (Flag17) set if LIMITED is present -- Limited_View_Installed (Flag18-Sem) -- Unreferenced_In_Spec (Flag7-Sem) -- No_Entities_Ref_In_Spec (Flag8-Sem) --- 5761,5767 ---- -- Elaborate_Desirable (Flag11-Sem) -- Private_Present (Flag15) set if with_clause has private keyword -- Implicit_With (Flag16-Sem) ! -- Limited_Present (Flag17) set if LIMITED is present -- Limited_View_Installed (Flag18-Sem) -- Unreferenced_In_Spec (Flag7-Sem) -- No_Entities_Ref_In_Spec (Flag8-Sem) *************** package Sinfo is *** 5641,5647 **** -- 11.1 Exception Declaration -- --------------------------------- ! -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception; -- For consistency with object declarations etc., the parser converts -- the case of multiple identifiers being declared to a series of --- 5859,5866 ---- -- 11.1 Exception Declaration -- --------------------------------- ! -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception ! -- [ASPECT_SPECIFICATIONS]; -- For consistency with object declarations etc., the parser converts -- the case of multiple identifiers being declared to a series of *************** package Sinfo is *** 5810,5816 **** --------------------------------------- -- GENERIC_PACKAGE_DECLARATION ::= ! -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION; -- Note: when we do generics right, the Activation_Chain_Entity entry -- for this node can be removed (since the expander won't see generic --- 6029,6036 ---- --------------------------------------- -- GENERIC_PACKAGE_DECLARATION ::= ! -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION ! -- [ASPECT_SPECIFICATIONS]; -- Note: when we do generics right, the Activation_Chain_Entity entry -- for this node can be removed (since the expander won't see generic *************** package Sinfo is *** 5849,5861 **** -- GENERIC_INSTANTIATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is ! -- new generic_package_NAME [GENERIC_ACTUAL_PART]; -- | [[not] overriding] -- procedure DEFINING_PROGRAM_UNIT_NAME is ! -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; -- | [[not] overriding] -- function DEFINING_DESIGNATOR is ! -- new generic_function_NAME [GENERIC_ACTUAL_PART]; -- N_Package_Instantiation -- Sloc points to PACKAGE --- 6069,6084 ---- -- GENERIC_INSTANTIATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is ! -- new generic_package_NAME [GENERIC_ACTUAL_PART] ! -- [ASPECT_SPECIFICATIONS]; -- | [[not] overriding] -- procedure DEFINING_PROGRAM_UNIT_NAME is ! -- new generic_procedure_NAME [GENERIC_ACTUAL_PART] ! -- [ASPECT_SPECIFICATIONS]; -- | [[not] overriding] -- function DEFINING_DESIGNATOR is ! -- new generic_function_NAME [GENERIC_ACTUAL_PART] ! -- [ASPECT_SPECIFICATIONS]; -- N_Package_Instantiation -- Sloc points to PACKAGE *************** package Sinfo is *** 5939,5947 **** -- FORMAL_OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : ! -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : ! -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION]; -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive declarations were given with --- 6162,6172 ---- -- FORMAL_OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : ! -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION] ! -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : ! -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION] ! -- [ASPECT_SPECIFICATIONS]; -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive declarations were given with *************** package Sinfo is *** 5969,5975 **** -- FORMAL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] ! -- is FORMAL_TYPE_DEFINITION; -- N_Formal_Type_Declaration -- Sloc points to TYPE --- 6194,6201 ---- -- FORMAL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] ! -- is FORMAL_TYPE_DEFINITION ! -- [ASPECT_SPECIFICATIONS]; -- N_Formal_Type_Declaration -- Sloc points to TYPE *************** package Sinfo is *** 6116,6122 **** -------------------------------------------------- -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= ! -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT]; -- N_Formal_Concrete_Subprogram_Declaration -- Sloc points to WITH --- 6342,6349 ---- -------------------------------------------------- -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= ! -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT] ! -- [ASPECT_SPECIFICATIONS]; -- N_Formal_Concrete_Subprogram_Declaration -- Sloc points to WITH *************** package Sinfo is *** 6132,6138 **** -------------------------------------------------- -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= ! -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT]; -- N_Formal_Abstract_Subprogram_Declaration -- Sloc points to WITH --- 6359,6366 ---- -------------------------------------------------- -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= ! -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT] ! -- [ASPECT_SPECIFICATIONS]; -- N_Formal_Abstract_Subprogram_Declaration -- Sloc points to WITH *************** package Sinfo is *** 6166,6172 **** -- FORMAL_PACKAGE_DECLARATION ::= -- with package DEFINING_IDENTIFIER ! -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART; -- Note: formal package declarations not allowed in Ada 83 mode --- 6394,6401 ---- -- FORMAL_PACKAGE_DECLARATION ::= -- with package DEFINING_IDENTIFIER ! -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART ! -- [ASPECT_SPECIFICATIONS]; -- Note: formal package declarations not allowed in Ada 83 mode *************** package Sinfo is *** 6266,6273 **** --- 6495,6556 ---- -- Next_Rep_Item (Node5-Sem) -- From_At_Mod (Flag4-Sem) -- Check_Address_Alignment (Flag11-Sem) + -- From_Aspect_Specification (Flag13-Sem) + -- Is_Delayed_Aspect (Flag14-Sem) -- Address_Warning_Posted (Flag18-Sem) + -- Note: if From_Aspect_Specification is set, then Sloc points to the + -- aspect name, and Entity is resolved already to reference the entity + -- to which the aspect applies. + + ----------------------------------- + -- 13.3.1 Aspect Specifications -- + ----------------------------------- + + -- We modify the RM grammar here, the RM grammar is: + + -- ASPECT_SPECIFICATION ::= + -- with ASPECT_MARK [=> ASPECT_DEFINITION] {. + -- ASPECT_MARK [=> ASPECT_DEFINITION] } + + -- ASPECT_MARK ::= aspect_IDENTIFIER['Class] + + -- ASPECT_DEFINITION ::= NAME | EXPRESSION + + -- That's inconvenient, since there is no non-terminal name for a single + -- entry in the list of aspects. So we use this grammar instead: + + -- ASPECT_SPECIFICATIONS ::= + -- with ASPECT_SPECIFICATION {, ASPECT_SPECIFICATION} + + -- ASPECT_SPECIFICATION => + -- ASPECT_MARK [=> ASPECT_DEFINITION] + + -- ASPECT_MARK ::= aspect_IDENTIFIER['Class] + + -- ASPECT_DEFINITION ::= NAME | EXPRESSION + + -- See separate package Aspects for details on the incorporation of + -- these nodes into the tree, and how aspect specifications for a given + -- declaration node are associated with that node. + + -- N_Aspect_Specification + -- Sloc points to aspect identifier + -- Identifier (Node1) aspect identifier + -- Aspect_Rep_Item (Node2-Sem) + -- Expression (Node3) Aspect_Definition (set to Empty if none) + -- Entity (Node4-Sem) entity to which the aspect applies + -- Class_Present (Flag6) Set if 'Class present + -- Next_Rep_Item (Node5-Sem) + -- Split_PPC (Flag17) Set if split pre/post attribute + + -- Note: Aspect_Specification is an Ada 2012 feature + + -- Note: When a Pre or Post aspect specification is processed, it is + -- broken into AND THEN sections. The left most section has Split_PPC + -- set to False, indicating that it is the original specification (e.g. + -- for posting errors). For the other sections, Split_PPC is set True. + --------------------------------------------- -- 13.4 Enumeration representation clause -- --------------------------------------------- *************** package Sinfo is *** 6509,6518 **** -- reconstructed tree printed by Sprint, and the node descriptions here -- show this syntax. ! -- Note: Conditional_Expression is in this section for historical reasons. ! -- We will move it to its appropriate place when it is officially approved ! -- as an extension (and then we will know what the exact grammar and place ! -- in the Reference Manual is!) ---------------------------- -- Conditional Expression -- --- 6792,6837 ---- -- reconstructed tree printed by Sprint, and the node descriptions here -- show this syntax. ! -- Note: Case_Expression and Conditional_Expression is in this section for ! -- now, since they are extensions. We will move them to their appropriate ! -- places when they are officially approved as extensions (and then we will ! -- know what the exact grammar and place in the Reference Manual is!) ! ! --------------------- ! -- Case Expression -- ! --------------------- ! ! -- CASE_EXPRESSION ::= ! -- case EXPRESSION is ! -- CASE_EXPRESSION_ALTERNATIVE ! -- {CASE_EXPRESSION_ALTERNATIVE} ! ! -- Note that the Alternatives cannot include pragmas (this contrasts ! -- with the situation of case statements where pragmas are allowed). ! ! -- N_Case_Expression ! -- Sloc points to CASE ! -- Expression (Node3) ! -- Alternatives (List4) ! ! --------------------------------- ! -- Case Expression Alternative -- ! --------------------------------- ! ! -- CASE_STATEMENT_ALTERNATIVE ::= ! -- when DISCRETE_CHOICE_LIST => ! -- EXPRESSION ! ! -- N_Case_Expression_Alternative ! -- Sloc points to WHEN ! -- Actions (List1) ! -- Discrete_Choices (List4) ! -- Expression (Node3) ! ! -- Note: The Actions field temporarily holds any actions associated with ! -- evaluation of the Expression. During expansion of the case expression ! -- these actions are wrapped into an N_Expressions_With_Actions node ! -- replacing the original expression. ---------------------------- -- Conditional Expression -- *************** package Sinfo is *** 6540,6546 **** -- And we add the additional constructs ! -- PRIMARY ::= ( CONDITIONAL_EXPRESION ) -- PRAGMA_ARGUMENT_ASSOCIATION ::= CONDITIONAL_EXPRESSION -- Note: if we have (IF x1 THEN x2 ELSIF x3 THEN x4 ELSE x5) then it --- 6859,6865 ---- -- And we add the additional constructs ! -- PRIMARY ::= ( CONDITIONAL_EXPRESSION ) -- PRAGMA_ARGUMENT_ASSOCIATION ::= CONDITIONAL_EXPRESSION -- Note: if we have (IF x1 THEN x2 ELSIF x3 THEN x4 ELSE x5) then it *************** package Sinfo is *** 6583,6588 **** --- 6902,6947 ---- -- Has_Private_View (Flag11-Sem) set in generic units. -- plus fields for expression + ----------------------------- + -- Expression with Actions -- + ----------------------------- + + -- This node is created by the analyzer/expander to handle some + -- expansion cases, notably short circuit forms where there are + -- actions associated with the right hand operand. + + -- The N_Expression_With_Actions node represents an expression with + -- an associated set of actions (which are executable statements and + -- declarations, as might occur in a handled statement sequence). + + -- The required semantics is that the set of actions is executed in + -- the order in which it appears just before the expression is + -- evaluated (and these actions must only be executed if the value + -- of the expression is evaluated). The node is considered to be + -- a subexpression, whose value is the value of the Expression after + -- executing all the actions. + + -- Note: if the actions contain declarations, then these declarations + -- maybe referenced with in the expression. It is thus appropriate for + -- the back end to create a scope that encompasses the construct (any + -- declarations within the actions will definitely not be referenced + -- once elaboration of the construct is completed). + + -- Sprint syntax: do + -- action; + -- action; + -- ... + -- action; + -- in expression end + + -- N_Expression_With_Actions + -- Actions (List1) + -- Expression (Node3) + -- plus fields for expression + + -- Note: the actions list is always non-null, since we would + -- never have created this node if there weren't some actions. + -------------------- -- Free Statement -- -------------------- *************** package Sinfo is *** 6883,6916 **** -- Meanwhile these nodes should be considered in experimental form, and -- should be ignored by all code generating back ends. ??? - -- N_SCIL_Dispatch_Table_Object_Init - -- Sloc references a declaration node containing a dispatch table - -- SCIL_Related_Node (Node1-Sem) - -- SCIL_Entity (Node4-Sem) - -- N_SCIL_Dispatch_Table_Tag_Init -- Sloc references a node for a tag initialization - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Entity (Node4-Sem) -- N_SCIL_Dispatching_Call -- Sloc references the node of a dispatching call - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Target_Prim (Node2-Sem) -- SCIL_Entity (Node4-Sem) -- SCIL_Controlling_Tag (Node5-Sem) -- N_SCIL_Membership_Test -- Sloc references the node of a membership test - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Tag_Value (Node5-Sem) -- SCIL_Entity (Node4-Sem) - -- N_SCIL_Tag_Init - -- Sloc references the node of a tag component initialization - -- SCIL_Related_Node (Node1-Sem) - -- SCIL_Entity (Node4-Sem) - --------------------- -- Subprogram_Info -- --------------------- --- 7242,7262 ---- *************** package Sinfo is *** 7045,7054 **** -------------------------- -- The following is the definition of the Node_Kind type. As previously ! -- discussed, this is separated off to allow rearrangement of the order ! -- to facilitate definition of subtype ranges. The comments show the ! -- subtype classes which apply to each set of node kinds. The first ! -- entry in the comment characterizes the following list of nodes. type Node_Kind is ( N_Unused_At_Start, --- 7391,7400 ---- -------------------------- -- The following is the definition of the Node_Kind type. As previously ! -- discussed, this is separated off to allow rearrangement of the order to ! -- facilitate definition of subtype ranges. The comments show the subtype ! -- classes which apply to each set of node kinds. The first entry in the ! -- comment characterizes the following list of nodes. type Node_Kind is ( N_Unused_At_Start, *************** package Sinfo is *** 7167,7178 **** --- 7513,7526 ---- N_Conditional_Expression, N_Explicit_Dereference, + N_Expression_With_Actions, N_Function_Call, N_Indexed_Component, N_Integer_Literal, N_Null, N_Procedure_Call_Statement, N_Qualified_Expression, + N_Quantified_Expression, -- N_Raise_xxx_Error, N_Subexpr, N_Has_Etype *************** package Sinfo is *** 7184,7189 **** --- 7532,7538 ---- N_Aggregate, N_Allocator, + N_Case_Expression, N_Extension_Aggregate, N_Range, N_Real_Literal, *************** package Sinfo is *** 7208,7215 **** --- 7557,7566 ---- N_Formal_Type_Declaration, N_Full_Type_Declaration, N_Incomplete_Type_Declaration, + N_Iterator_Specification, N_Loop_Parameter_Specification, N_Object_Declaration, + N_Parameterized_Expression, N_Protected_Type_Declaration, N_Private_Extension_Declaration, N_Private_Type_Declaration, *************** package Sinfo is *** 7350,7360 **** -- SCIL nodes - N_SCIL_Dispatch_Table_Object_Init, N_SCIL_Dispatch_Table_Tag_Init, N_SCIL_Dispatching_Call, N_SCIL_Membership_Test, - N_SCIL_Tag_Init, -- Other nodes (not part of any subtype class) --- 7701,7709 ---- *************** package Sinfo is *** 7362,7367 **** --- 7711,7718 ---- N_Abstract_Subprogram_Declaration, N_Access_Definition, N_Access_To_Object_Definition, + N_Aspect_Specification, + N_Case_Expression_Alternative, N_Case_Statement_Alternative, N_Compilation_Unit, N_Compilation_Unit_Aux, *************** package Sinfo is *** 7487,7493 **** N_Expanded_Name .. N_Attribute_Reference; -- Nodes that have Entity fields ! -- Warning: DOES NOT INCLUDE N_Freeze_Entity! subtype N_Has_Etype is Node_Kind range N_Error .. --- 7838,7845 ---- N_Expanded_Name .. N_Attribute_Reference; -- Nodes that have Entity fields ! -- Warning: DOES NOT INCLUDE N_Freeze_Entity, N_Aspect_Specification, ! -- or N_Attribute_Definition_Clause. subtype N_Has_Etype is Node_Kind range N_Error .. *************** package Sinfo is *** 7567,7574 **** N_Or_Else; subtype N_SCIL_Node is Node_Kind range ! N_SCIL_Dispatch_Table_Object_Init .. ! N_SCIL_Tag_Init; subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range N_Abort_Statement .. --- 7919,7926 ---- N_Or_Else; subtype N_SCIL_Node is Node_Kind range ! N_SCIL_Dispatch_Table_Tag_Init .. ! N_SCIL_Membership_Test; subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range N_Abort_Statement .. *************** package Sinfo is *** 7679,7684 **** --- 8031,8042 ---- function Array_Aggregate (N : Node_Id) return Node_Id; -- Node3 + function Aspect_Cancel + (N : Node_Id) return Boolean; -- Flag11 + + function Aspect_Rep_Item + (N : Node_Id) return Node_Id; -- Node2 + function Assignment_OK (N : Node_Id) return Boolean; -- Flag15 *************** package Sinfo is *** 7727,7732 **** --- 8085,8093 ---- function Choices (N : Node_Id) return List_Id; -- List1 + function Class_Present + (N : Node_Id) return Boolean; -- Flag6 + function Coextensions (N : Node_Id) return Elist_Id; -- Elist4 *************** package Sinfo is *** 7820,7825 **** --- 8181,8189 ---- function Default_Expression (N : Node_Id) return Node_Id; -- Node5 + function Default_Storage_Pool + (N : Node_Id) return Node_Id; -- Node3 + function Default_Name (N : Node_Id) return Node_Id; -- Node2 *************** package Sinfo is *** 8000,8005 **** --- 8364,8372 ---- function Forwards_OK (N : Node_Id) return Boolean; -- Flag5 + function From_Aspect_Specification + (N : Node_Id) return Boolean; -- Flag13 + function From_At_End (N : Node_Id) return Boolean; -- Flag4 *************** package Sinfo is *** 8045,8053 **** function Has_No_Elaboration_Code (N : Node_Id) return Boolean; -- Flag17 ! function Has_Priority_Pragma (N : Node_Id) return Boolean; -- Flag6 function Has_Private_View (N : Node_Id) return Boolean; -- Flag11 --- 8412,8426 ---- function Has_No_Elaboration_Code (N : Node_Id) return Boolean; -- Flag17 ! function Has_Pragma_CPU ! (N : Node_Id) return Boolean; -- Flag14 ! ! function Has_Pragma_Priority (N : Node_Id) return Boolean; -- Flag6 + function Has_Pragma_Suppress_All + (N : Node_Id) return Boolean; -- Flag14 + function Has_Private_View (N : Node_Id) return Boolean; -- Flag11 *************** package Sinfo is *** 8090,8101 **** --- 8463,8480 ---- function Implicit_With (N : Node_Id) return Boolean; -- Flag16 + function Import_Interface_Present + (N : Node_Id) return Boolean; -- Flag16 + function In_Present (N : Node_Id) return Boolean; -- Flag15 function Includes_Infinities (N : Node_Id) return Boolean; -- Flag11 + function Inherited_Discriminant + (N : Node_Id) return Boolean; -- Flag13 + function Instance_Spec (N : Node_Id) return Node_Id; -- Node5 *************** package Sinfo is *** 8117,8122 **** --- 8496,8504 ---- function Is_Controlling_Actual (N : Node_Id) return Boolean; -- Flag16 + function Is_Delayed_Aspect + (N : Node_Id) return Boolean; -- Flag14 + function Is_Dynamic_Coextension (N : Node_Id) return Boolean; -- Flag18 *************** package Sinfo is *** 8168,8173 **** --- 8550,8558 ---- function Iteration_Scheme (N : Node_Id) return Node_Id; -- Node2 + function Iterator_Specification + (N : Node_Id) return Node_Id; -- Node2 + function Itype (N : Node_Id) return Entity_Id; -- Node1 *************** package Sinfo is *** 8240,8245 **** --- 8625,8633 ---- function Next_Entity (N : Node_Id) return Node_Id; -- Node2 + function Next_Exit_Statement + (N : Node_Id) return Node_Id; -- Node3 + function Next_Implicit_With (N : Node_Id) return Node_Id; -- Node3 *************** package Sinfo is *** 8285,8290 **** --- 8673,8681 ---- function Object_Definition (N : Node_Id) return Node_Id; -- Node4 + function Of_Present + (N : Node_Id) return Boolean; -- Flag16 + function Original_Discriminant (N : Node_Id) return Node_Id; -- Node2 *************** package Sinfo is *** 8411,8419 **** function SCIL_Entity (N : Node_Id) return Node_Id; -- Node4 - function SCIL_Related_Node - (N : Node_Id) return Node_Id; -- Node1 - function SCIL_Tag_Value (N : Node_Id) return Node_Id; -- Node5 --- 8802,8807 ---- *************** package Sinfo is *** 8441,8446 **** --- 8829,8837 ---- function Specification (N : Node_Id) return Node_Id; -- Node1 + function Split_PPC + (N : Node_Id) return Boolean; -- Flag17 + function Statements (N : Node_Id) return List_Id; -- List3 *************** package Sinfo is *** 8462,8467 **** --- 8853,8861 ---- function Subtype_Marks (N : Node_Id) return List_Id; -- List2 + function Suppress_Assignment_Checks + (N : Node_Id) return Boolean; -- Flag18 + function Suppress_Loop_Warnings (N : Node_Id) return Boolean; -- Flag17 *************** package Sinfo is *** 8522,8527 **** --- 8916,8924 ---- function Was_Originally_Stub (N : Node_Id) return Boolean; -- Flag13 + function Withed_Body + (N : Node_Id) return Node_Id; -- Node1 + function Zero_Cost_Handling (N : Node_Id) return Boolean; -- Flag5 *************** package Sinfo is *** 8600,8605 **** --- 8997,9008 ---- procedure Set_Array_Aggregate (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Aspect_Cancel + (N : Node_Id; Val : Boolean := True); -- Flag11 + + procedure Set_Aspect_Rep_Item + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Assignment_OK (N : Node_Id; Val : Boolean := True); -- Flag15 *************** package Sinfo is *** 8645,8656 **** procedure Set_Choice_Parameter (N : Node_Id; Val : Node_Id); -- Node2 - procedure Set_Coextensions - (N : Node_Id; Val : Elist_Id); -- Elist4 - procedure Set_Choices (N : Node_Id; Val : List_Id); -- List1 procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True); -- Flag18 --- 9048,9062 ---- procedure Set_Choice_Parameter (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Choices (N : Node_Id; Val : List_Id); -- List1 + procedure Set_Class_Present + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Coextensions + (N : Node_Id; Val : Elist_Id); -- Elist4 + procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True); -- Flag18 *************** package Sinfo is *** 8741,8746 **** --- 9147,9155 ---- procedure Set_Default_Expression (N : Node_Id; Val : Node_Id); -- Node5 + procedure Set_Default_Storage_Pool + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Default_Name (N : Node_Id; Val : Node_Id); -- Node2 *************** package Sinfo is *** 8921,8926 **** --- 9330,9338 ---- procedure Set_From_At_Mod (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_From_Aspect_Specification + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_From_At_End (N : Node_Id; Val : Boolean := True); -- Flag4 *************** package Sinfo is *** 8963,8971 **** procedure Set_Has_No_Elaboration_Code (N : Node_Id; Val : Boolean := True); -- Flag17 ! procedure Set_Has_Priority_Pragma (N : Node_Id; Val : Boolean := True); -- Flag6 procedure Set_Has_Private_View (N : Node_Id; Val : Boolean := True); -- Flag11 --- 9375,9389 ---- procedure Set_Has_No_Elaboration_Code (N : Node_Id; Val : Boolean := True); -- Flag17 ! procedure Set_Has_Pragma_CPU ! (N : Node_Id; Val : Boolean := True); -- Flag14 ! ! procedure Set_Has_Pragma_Priority (N : Node_Id; Val : Boolean := True); -- Flag6 + procedure Set_Has_Pragma_Suppress_All + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Has_Private_View (N : Node_Id; Val : Boolean := True); -- Flag11 *************** package Sinfo is *** 9008,9019 **** --- 9426,9443 ---- procedure Set_Implicit_With (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_In_Present (N : Node_Id; Val : Boolean := True); -- Flag15 procedure Set_Includes_Infinities (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id); -- Node5 *************** package Sinfo is *** 9035,9040 **** --- 9459,9467 ---- procedure Set_Is_Controlling_Actual (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Is_Delayed_Aspect + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True); -- Flag18 *************** package Sinfo is *** 9086,9091 **** --- 9513,9521 ---- procedure Set_Iteration_Scheme (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Iterator_Specification + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Itype (N : Node_Id; Val : Entity_Id); -- Node1 *************** package Sinfo is *** 9158,9163 **** --- 9588,9596 ---- procedure Set_Next_Entity (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Next_Implicit_With (N : Node_Id; Val : Node_Id); -- Node3 *************** package Sinfo is *** 9203,9208 **** --- 9636,9644 ---- procedure Set_Object_Definition (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_Of_Present + (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Original_Discriminant (N : Node_Id; Val : Node_Id); -- Node2 *************** package Sinfo is *** 9329,9337 **** procedure Set_SCIL_Entity (N : Node_Id; Val : Node_Id); -- Node4 - procedure Set_SCIL_Related_Node - (N : Node_Id; Val : Node_Id); -- Node1 - procedure Set_SCIL_Tag_Value (N : Node_Id; Val : Node_Id); -- Node5 --- 9765,9770 ---- *************** package Sinfo is *** 9359,9364 **** --- 9792,9800 ---- procedure Set_Specification (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Split_PPC + (N : Node_Id; Val : Boolean); -- Flag17 + procedure Set_Statements (N : Node_Id; Val : List_Id); -- List3 *************** package Sinfo is *** 9380,9385 **** --- 9816,9824 ---- procedure Set_Subtype_Marks (N : Node_Id; Val : List_Id); -- List2 + procedure Set_Suppress_Assignment_Checks + (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Suppress_Loop_Warnings (N : Node_Id; Val : Boolean := True); -- Flag17 *************** package Sinfo is *** 9440,9445 **** --- 9879,9887 ---- procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Withed_Body + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Zero_Cost_Handling (N : Node_Id; Val : Boolean := True); -- Flag5 *************** package Sinfo is *** 9454,9473 **** procedure Next_Rep_Item (N : in out Node_Id); procedure Next_Use_Clause (N : in out Node_Id); ! -------------------------------------- ! -- Logical Access to End_Span Field -- ! -------------------------------------- function End_Location (N : Node_Id) return Source_Ptr; ! -- N is an N_If_Statement or N_Case_Statement node, and this ! -- function returns the location of the IF token in the END IF ! -- sequence by translating the value of the End_Span field. procedure Set_End_Location (N : Node_Id; S : Source_Ptr); ! -- N is an N_If_Statement or N_Case_Statement node. This procedure ! -- sets the End_Span field to correspond to the given value S. In ! -- other words, End_Span is set to the difference between S and ! -- Sloc (N), the starting location. -------------------------------- -- Node_Kind Membership Tests -- --- 9896,9920 ---- procedure Next_Rep_Item (N : in out Node_Id); procedure Next_Use_Clause (N : in out Node_Id); ! ------------------------------------------- ! -- Miscellaneous Tree Access Subprograms -- ! ------------------------------------------- function End_Location (N : Node_Id) return Source_Ptr; ! -- N is an N_If_Statement or N_Case_Statement node, and this function ! -- returns the location of the IF token in the END IF sequence by ! -- translating the value of the End_Span field. procedure Set_End_Location (N : Node_Id; S : Source_Ptr); ! -- N is an N_If_Statement or N_Case_Statement node. This procedure sets ! -- the End_Span field to correspond to the given value S. In other words, ! -- End_Span is set to the difference between S and Sloc (N), the starting ! -- location. ! ! function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; ! -- Given an argument to a pragma Arg, this function returns the expression ! -- for the argument. This is Arg itself, or, in the case where Arg is a ! -- pragma argument association node, the expression from this node. -------------------------------- -- Node_Kind Membership Tests -- *************** package Sinfo is *** 10119,10124 **** --- 10566,10578 ---- 4 => True, -- Subtype_Mark (Node4) 5 => False), -- Etype (Node5-Sem) + N_Quantified_Expression => + (1 => True, -- Condition (Node1) + 2 => True, -- Iterator_Specification + 3 => False, -- unused + 4 => True, -- Loop_Parameter_Specification (Node4) + 5 => False), -- Etype (Node5-Sem) + N_Allocator => (1 => False, -- Storage_Pool (Node1-Sem) 2 => False, -- Procedure_To_Call (Node2-Sem) *************** package Sinfo is *** 10161,10166 **** --- 10615,10634 ---- 4 => False, -- unused 5 => False), -- unused + N_Case_Expression => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Alternatives (List4) + 5 => False), -- unused + + N_Case_Expression_Alternative => + (1 => False, -- Actions (List1-Sem) + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => True, -- Expression (Node4) + 5 => False), -- unused + N_Case_Statement => (1 => False, -- unused 2 => False, -- unused *************** package Sinfo is *** 10184,10190 **** N_Iteration_Scheme => (1 => True, -- Condition (Node1) ! 2 => False, -- unused 3 => False, -- Condition_Actions (List3-Sem) 4 => True, -- Loop_Parameter_Specification (Node4) 5 => False), -- unused --- 10652,10658 ---- N_Iteration_Scheme => (1 => True, -- Condition (Node1) ! 2 => True, -- Iterator_Specification (Node2) 3 => False, -- Condition_Actions (List3-Sem) 4 => True, -- Loop_Parameter_Specification (Node4) 5 => False), -- unused *************** package Sinfo is *** 10196,10201 **** --- 10664,10676 ---- 4 => True, -- Discrete_Subtype_Definition (Node4) 5 => False), -- unused + N_Iterator_Specification => + (1 => True, -- Defining_Identifier (Node1) + 2 => True, -- Name (Node2) + 3 => False, -- Unused + 4 => False, -- Unused + 5 => True), -- Subtype_Indication (Node5) + N_Block_Statement => (1 => True, -- Identifier (Node1) 2 => True, -- Declarations (List2) *************** package Sinfo is *** 10287,10292 **** --- 10762,10774 ---- 4 => True, -- Handled_Statement_Sequence (Node4) 5 => False), -- Corresponding_Spec (Node5-Sem) + N_Parameterized_Expression => + (1 => True, -- Specification (Node1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + N_Procedure_Call_Statement => (1 => False, -- Controlling_Argument (Node1-Sem) 2 => True, -- Name (Node2) *************** package Sinfo is *** 10626,10632 **** N_Compilation_Unit_Aux => (1 => True, -- Actions (List1) 2 => True, -- Declarations (List2) ! 3 => False, -- unused 4 => True, -- Config_Pragmas (List4) 5 => True), -- Pragmas_After (List5) --- 11108,11114 ---- N_Compilation_Unit_Aux => (1 => True, -- Actions (List1) 2 => True, -- Declarations (List2) ! 3 => False, -- Default_Storage_Pool (Node3) 4 => True, -- Config_Pragmas (List4) 5 => True), -- Pragmas_After (List5) *************** package Sinfo is *** 10840,10845 **** --- 11322,11334 ---- 4 => False, -- unused 5 => False), -- Next_Rep_Item (Node5-Sem) + N_Aspect_Specification => + (1 => True, -- Identifier (Node1) + 2 => False, -- Aspect_Rep_Item (Node2-Sem) + 3 => True, -- Expression (Node3) + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Next_Rep_Item (Node5-Sem) + N_Enumeration_Representation_Clause => (1 => True, -- Identifier (Node1) 2 => False, -- unused *************** package Sinfo is *** 10938,10943 **** --- 11427,11439 ---- 4 => False, -- Entity (Node4-Sem) 5 => False), -- Etype (Node5-Sem) + N_Expression_With_Actions => + (1 => True, -- Actions (List1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + N_Free_Statement => (1 => False, -- Storage_Pool (Node1-Sem) 2 => False, -- Procedure_To_Call (Node2-Sem) *************** package Sinfo is *** 11064,11108 **** 4 => False, -- unused 5 => False), -- unused - -- End of inserted output from makeisf program - -- Entries for SCIL nodes - N_SCIL_Dispatch_Table_Object_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) - 2 => False, -- unused - 3 => False, -- unused - 4 => False, -- SCIL_Entity (Node4-Sem) - 5 => False), -- unused - N_SCIL_Dispatch_Table_Tag_Init => ! (1 => False, -- SCIL_Related_Node (Node1-Sem) 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- unused N_SCIL_Dispatching_Call => ! (1 => False, -- SCIL_Related_Node (Node1-Sem) 2 => False, -- SCIL_Target_Prim (Node2-Sem) 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Controlling_Tag (Node5-Sem) N_SCIL_Membership_Test => ! (1 => False, -- SCIL_Related_Node (Node1-Sem) 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Tag_Value (Node5-Sem) - N_SCIL_Tag_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) - 2 => False, -- unused - 3 => False, -- unused - 4 => False, -- SCIL_Entity (Node4-Sem) - 5 => False), -- unused - -- Entries for Empty, Error and Unused. Even thought these have a Chars -- field for debugging purposes, they are not really syntactic fields, so -- we mark all fields as unused. --- 11560,11588 ---- 4 => False, -- unused 5 => False), -- unused -- Entries for SCIL nodes N_SCIL_Dispatch_Table_Tag_Init => ! (1 => False, -- unused 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- unused N_SCIL_Dispatching_Call => ! (1 => False, -- unused 2 => False, -- SCIL_Target_Prim (Node2-Sem) 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Controlling_Tag (Node5-Sem) N_SCIL_Membership_Test => ! (1 => False, -- unused 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Tag_Value (Node5-Sem) -- Entries for Empty, Error and Unused. Even thought these have a Chars -- field for debugging purposes, they are not really syntactic fields, so -- we mark all fields as unused. *************** package Sinfo is *** 11160,11165 **** --- 11640,11647 ---- pragma Inline (Alternatives); pragma Inline (Ancestor_Part); pragma Inline (Array_Aggregate); + pragma Inline (Aspect_Cancel); + pragma Inline (Aspect_Rep_Item); pragma Inline (Assignment_OK); pragma Inline (Associated_Node); pragma Inline (At_End_Proc); *************** package Sinfo is *** 11176,11181 **** --- 11658,11664 ---- pragma Inline (Check_Address_Alignment); pragma Inline (Choice_Parameter); pragma Inline (Choices); + pragma Inline (Class_Present); pragma Inline (Coextensions); pragma Inline (Comes_From_Extended_Return_Statement); pragma Inline (Compile_Time_Known_Aggregate); *************** package Sinfo is *** 11207,11212 **** --- 11690,11696 ---- pragma Inline (Debug_Statement); pragma Inline (Declarations); pragma Inline (Default_Expression); + pragma Inline (Default_Storage_Pool); pragma Inline (Default_Name); pragma Inline (Defining_Identifier); pragma Inline (Defining_Unit_Name); *************** package Sinfo is *** 11267,11272 **** --- 11751,11757 ---- pragma Inline (Float_Truncate); pragma Inline (Formal_Type_Definition); pragma Inline (Forwards_OK); + pragma Inline (From_Aspect_Specification); pragma Inline (From_At_End); pragma Inline (From_At_Mod); pragma Inline (From_Default); *************** package Sinfo is *** 11283,11289 **** pragma Inline (Has_Local_Raise); pragma Inline (Has_Self_Reference); pragma Inline (Has_No_Elaboration_Code); ! pragma Inline (Has_Priority_Pragma); pragma Inline (Has_Private_View); pragma Inline (Has_Relative_Deadline_Pragma); pragma Inline (Has_Storage_Size_Pragma); --- 11768,11776 ---- pragma Inline (Has_Local_Raise); pragma Inline (Has_Self_Reference); pragma Inline (Has_No_Elaboration_Code); ! pragma Inline (Has_Pragma_CPU); ! pragma Inline (Has_Pragma_Priority); ! pragma Inline (Has_Pragma_Suppress_All); pragma Inline (Has_Private_View); pragma Inline (Has_Relative_Deadline_Pragma); pragma Inline (Has_Storage_Size_Pragma); *************** package Sinfo is *** 11298,11311 **** --- 11785,11802 ---- pragma Inline (Interface_List); pragma Inline (Interface_Present); pragma Inline (Includes_Infinities); + pragma Inline (Import_Interface_Present); pragma Inline (In_Present); + pragma Inline (Inherited_Discriminant); pragma Inline (Instance_Spec); pragma Inline (Intval); + pragma Inline (Iterator_Specification); pragma Inline (Is_Accessibility_Actual); pragma Inline (Is_Asynchronous_Call_Block); pragma Inline (Is_Component_Left_Opnd); pragma Inline (Is_Component_Right_Opnd); pragma Inline (Is_Controlling_Actual); + pragma Inline (Is_Delayed_Aspect); pragma Inline (Is_Dynamic_Coextension); pragma Inline (Is_Elsif); pragma Inline (Is_Entry_Barrier_Function); *************** package Sinfo is *** 11347,11352 **** --- 11838,11844 ---- pragma Inline (Name); pragma Inline (Names); pragma Inline (Next_Entity); + pragma Inline (Next_Exit_Statement); pragma Inline (Next_Implicit_With); pragma Inline (Next_Named_Actual); pragma Inline (Next_Pragma); *************** package Sinfo is *** 11362,11367 **** --- 11854,11860 ---- pragma Inline (Null_Exclusion_In_Return_Present); pragma Inline (Null_Record_Present); pragma Inline (Object_Definition); + pragma Inline (Of_Present); pragma Inline (Original_Discriminant); pragma Inline (Original_Entity); pragma Inline (Others_Discrete_Choices); *************** package Sinfo is *** 11404,11410 **** pragma Inline (Rounded_Result); pragma Inline (SCIL_Controlling_Tag); pragma Inline (SCIL_Entity); - pragma Inline (SCIL_Related_Node); pragma Inline (SCIL_Tag_Value); pragma Inline (SCIL_Target_Prim); pragma Inline (Scope); --- 11897,11902 ---- *************** package Sinfo is *** 11414,11419 **** --- 11906,11912 ---- pragma Inline (Shift_Count_OK); pragma Inline (Source_Type); pragma Inline (Specification); + pragma Inline (Split_PPC); pragma Inline (Statements); pragma Inline (Static_Processing_OK); pragma Inline (Storage_Pool); *************** package Sinfo is *** 11421,11426 **** --- 11914,11920 ---- pragma Inline (Subtype_Indication); pragma Inline (Subtype_Mark); pragma Inline (Subtype_Marks); + pragma Inline (Suppress_Assignment_Checks); pragma Inline (Suppress_Loop_Warnings); pragma Inline (Synchronized_Present); pragma Inline (Tagged_Present); *************** package Sinfo is *** 11441,11446 **** --- 11935,11941 ---- pragma Inline (Variants); pragma Inline (Visible_Declarations); pragma Inline (Was_Originally_Stub); + pragma Inline (Withed_Body); pragma Inline (Zero_Cost_Handling); pragma Inline (Set_ABE_Is_Certain); *************** package Sinfo is *** 11464,11469 **** --- 11959,11966 ---- pragma Inline (Set_Alternatives); pragma Inline (Set_Ancestor_Part); pragma Inline (Set_Array_Aggregate); + pragma Inline (Set_Aspect_Cancel); + pragma Inline (Set_Aspect_Rep_Item); pragma Inline (Set_Assignment_OK); pragma Inline (Set_Associated_Node); pragma Inline (Set_At_End_Proc); *************** package Sinfo is *** 11480,11485 **** --- 11977,11983 ---- pragma Inline (Set_Check_Address_Alignment); pragma Inline (Set_Choice_Parameter); pragma Inline (Set_Choices); + pragma Inline (Set_Class_Present); pragma Inline (Set_Coextensions); pragma Inline (Set_Comes_From_Extended_Return_Statement); pragma Inline (Set_Compile_Time_Known_Aggregate); *************** package Sinfo is *** 11511,11516 **** --- 12009,12015 ---- pragma Inline (Set_Debug_Statement); pragma Inline (Set_Declarations); pragma Inline (Set_Default_Expression); + pragma Inline (Set_Default_Storage_Pool); pragma Inline (Set_Default_Name); pragma Inline (Set_Defining_Identifier); pragma Inline (Set_Defining_Unit_Name); *************** package Sinfo is *** 11570,11575 **** --- 12069,12075 ---- pragma Inline (Set_Float_Truncate); pragma Inline (Set_Formal_Type_Definition); pragma Inline (Set_Forwards_OK); + pragma Inline (Set_From_Aspect_Specification); pragma Inline (Set_From_At_End); pragma Inline (Set_From_At_Mod); pragma Inline (Set_From_Default); *************** package Sinfo is *** 11585,11591 **** pragma Inline (Set_Has_Local_Raise); pragma Inline (Set_Has_Dynamic_Range_Check); pragma Inline (Set_Has_No_Elaboration_Code); ! pragma Inline (Set_Has_Priority_Pragma); pragma Inline (Set_Has_Private_View); pragma Inline (Set_Has_Relative_Deadline_Pragma); pragma Inline (Set_Has_Storage_Size_Pragma); --- 12085,12093 ---- pragma Inline (Set_Has_Local_Raise); pragma Inline (Set_Has_Dynamic_Range_Check); pragma Inline (Set_Has_No_Elaboration_Code); ! pragma Inline (Set_Has_Pragma_CPU); ! pragma Inline (Set_Has_Pragma_Priority); ! pragma Inline (Set_Has_Pragma_Suppress_All); pragma Inline (Set_Has_Private_View); pragma Inline (Set_Has_Relative_Deadline_Pragma); pragma Inline (Set_Has_Storage_Size_Pragma); *************** package Sinfo is *** 11600,11613 **** --- 12102,12119 ---- pragma Inline (Set_Includes_Infinities); pragma Inline (Set_Interface_List); pragma Inline (Set_Interface_Present); + pragma Inline (Set_Import_Interface_Present); pragma Inline (Set_In_Present); + pragma Inline (Set_Inherited_Discriminant); pragma Inline (Set_Instance_Spec); pragma Inline (Set_Intval); + pragma Inline (Set_Iterator_Specification); pragma Inline (Set_Is_Accessibility_Actual); pragma Inline (Set_Is_Asynchronous_Call_Block); pragma Inline (Set_Is_Component_Left_Opnd); pragma Inline (Set_Is_Component_Right_Opnd); pragma Inline (Set_Is_Controlling_Actual); + pragma Inline (Set_Is_Delayed_Aspect); pragma Inline (Set_Is_Dynamic_Coextension); pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Entry_Barrier_Function); *************** package Sinfo is *** 11650,11655 **** --- 12156,12162 ---- pragma Inline (Set_Name); pragma Inline (Set_Names); pragma Inline (Set_Next_Entity); + pragma Inline (Set_Next_Exit_Statement); pragma Inline (Set_Next_Implicit_With); pragma Inline (Set_Next_Named_Actual); pragma Inline (Set_Next_Pragma); *************** package Sinfo is *** 11665,11670 **** --- 12172,12178 ---- pragma Inline (Set_Null_Exclusion_In_Return_Present); pragma Inline (Set_Null_Record_Present); pragma Inline (Set_Object_Definition); + pragma Inline (Set_Of_Present); pragma Inline (Set_Original_Discriminant); pragma Inline (Set_Original_Entity); pragma Inline (Set_Others_Discrete_Choices); *************** package Sinfo is *** 11706,11712 **** pragma Inline (Set_Rounded_Result); pragma Inline (Set_SCIL_Controlling_Tag); pragma Inline (Set_SCIL_Entity); - pragma Inline (Set_SCIL_Related_Node); pragma Inline (Set_SCIL_Tag_Value); pragma Inline (Set_SCIL_Target_Prim); pragma Inline (Set_Scope); --- 12214,12219 ---- *************** package Sinfo is *** 11716,11721 **** --- 12223,12229 ---- pragma Inline (Set_Shift_Count_OK); pragma Inline (Set_Source_Type); pragma Inline (Set_Specification); + pragma Inline (Set_Split_PPC); pragma Inline (Set_Statements); pragma Inline (Set_Static_Processing_OK); pragma Inline (Set_Storage_Pool); *************** package Sinfo is *** 11723,11728 **** --- 12231,12237 ---- pragma Inline (Set_Subtype_Indication); pragma Inline (Set_Subtype_Mark); pragma Inline (Set_Subtype_Marks); + pragma Inline (Set_Suppress_Assignment_Checks); pragma Inline (Set_Suppress_Loop_Warnings); pragma Inline (Set_Synchronized_Present); pragma Inline (Set_Tagged_Present); *************** package Sinfo is *** 11743,11748 **** --- 12252,12258 ---- pragma Inline (Set_Variants); pragma Inline (Set_Visible_Declarations); pragma Inline (Set_Was_Originally_Stub); + pragma Inline (Set_Withed_Body); pragma Inline (Set_Zero_Cost_Handling); N_Simple_Return_Statement : constant Node_Kind := N_Return_Statement; diff -Nrcpad gcc-4.5.2/gcc/ada/sinput-c.adb gcc-4.6.0/gcc/ada/sinput-c.adb *** gcc-4.5.2/gcc/ada/sinput-c.adb Wed Jul 22 10:25:32 2009 --- gcc-4.6.0/gcc/ada/sinput-c.adb Tue Jun 22 13:26:32 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with System; use System; *** 28,34 **** --- 28,37 ---- with Ada.Unchecked_Conversion; + pragma Warnings (Off); + -- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; + pragma Warnings (On); package body Sinput.C is diff -Nrcpad gcc-4.5.2/gcc/ada/sinput-l.adb gcc-4.6.0/gcc/ada/sinput-l.adb *** gcc-4.5.2/gcc/ada/sinput-l.adb Wed Jul 22 10:25:32 2009 --- gcc-4.6.0/gcc/ada/sinput-l.adb Mon Oct 4 13:38:32 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Einfo; use Einfo; *** 30,35 **** --- 30,36 ---- with Errout; use Errout; with Fname; use Fname; with Hostparm; + with Lib; use Lib; with Opt; use Opt; with Osint; use Osint; with Output; use Output; *************** package body Sinput.L is *** 530,541 **** Save_Style_Check := Opt.Style_Check; Opt.Style_Check := False; ! -- Make sure that there will be no check of pragma Restrictions ! -- for obsolescent features while preprocessing the source. - Scn.Set_Obsolescent_Check (False); Preprocess (Modified); - Scn.Set_Obsolescent_Check (True); -- Reset the scanner to its standard behavior, and restore the -- Style_Checks flag. --- 531,539 ---- Save_Style_Check := Opt.Style_Check; Opt.Style_Check := False; ! -- The actual preprocessing step Preprocess (Modified); -- Reset the scanner to its standard behavior, and restore the -- Style_Checks flag. *************** package body Sinput.L is *** 555,563 **** else -- Output the result of the preprocessing, if requested and ! -- the source has been modified by the preprocessing. ! if Generate_Processed_File and then Modified then declare FD : File_Descriptor; NB : Integer; --- 553,570 ---- else -- Output the result of the preprocessing, if requested and ! -- the source has been modified by the preprocessing. Only ! -- do that for the main unit (spec, body and subunits). ! if Generate_Processed_File ! and then Modified ! and then ! ((Compiler_State = Parsing ! and then Parsing_Main_Extended_Source) ! or else ! (Compiler_State = Analyzing ! and then Analysing_Subunit_Of_Main)) ! then declare FD : File_Descriptor; NB : Integer; *************** package body Sinput.L is *** 594,603 **** if not Status then Errout.Error_Msg ! ("could not write processed file """ & Name_Buffer (1 .. Name_Len) & '"', Lo); - return No_Source_File; end if; end; end if; --- 601,609 ---- if not Status then Errout.Error_Msg ! ("?could not write processed file """ & Name_Buffer (1 .. Name_Len) & '"', Lo); end if; end; end if; diff -Nrcpad gcc-4.5.2/gcc/ada/sinput-p.adb gcc-4.6.0/gcc/ada/sinput-p.adb *** gcc-4.5.2/gcc/ada/sinput-p.adb Thu Apr 16 10:58:48 2009 --- gcc-4.6.0/gcc/ada/sinput-p.adb Thu Sep 9 13:50:19 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sinput.P is *** 151,156 **** --- 151,162 ---- function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is begin + -- Nothing to do if X is no source file, so simply return False + + if X = No_Source_File then + return False; + end if; + Prj.Err.Scanner.Initialize_Scanner (X); -- No error for special characters that are used for preprocessing diff -Nrcpad gcc-4.5.2/gcc/ada/sinput-p.ads gcc-4.6.0/gcc/ada/sinput-p.ads *** gcc-4.5.2/gcc/ada/sinput-p.ads Wed Apr 15 12:57:34 2009 --- gcc-4.6.0/gcc/ada/sinput-p.ads Thu Sep 9 13:53:19 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sinput.P is *** 54,60 **** -- the file cannot possibly be a legal subunit. This function does NOT do a -- complete parse of the file, or build a tree. It is used in gnatmake and -- gprbuild to decide if a body without a spec in a project file needs to ! -- be compiled or not. type Saved_Project_Scan_State is limited private; -- Used to save project scan state in following two routines --- 54,60 ---- -- the file cannot possibly be a legal subunit. This function does NOT do a -- complete parse of the file, or build a tree. It is used in gnatmake and -- gprbuild to decide if a body without a spec in a project file needs to ! -- be compiled or not. Returns False if X = No_Source_File. type Saved_Project_Scan_State is limited private; -- Used to save project scan state in following two routines diff -Nrcpad gcc-4.5.2/gcc/ada/sinput.adb gcc-4.6.0/gcc/ada/sinput.adb *** gcc-4.5.2/gcc/ada/sinput.adb Wed Jan 27 11:37:20 2010 --- gcc-4.6.0/gcc/ada/sinput.adb Tue Oct 12 11:00:42 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Sinput is *** 227,234 **** Get_Name_String_And_Append (Reference_Name (Get_Source_File_Index (Ptr))); Add_Char_To_Name_Buffer (':'); ! Add_Nat_To_Name_Buffer ! (Nat (Get_Logical_Line_Number (Ptr))); Ptr := Instantiation_Location (Ptr); exit when Ptr = No_Location; --- 227,233 ---- Get_Name_String_And_Append (Reference_Name (Get_Source_File_Index (Ptr))); Add_Char_To_Name_Buffer (':'); ! Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr))); Ptr := Instantiation_Location (Ptr); exit when Ptr = No_Location; *************** package body Sinput is *** 239,244 **** --- 238,250 ---- return; end Build_Location_String; + function Build_Location_String (Loc : Source_Ptr) return String is + begin + Name_Len := 0; + Build_Location_String (Loc); + return Name_Buffer (1 .. Name_Len); + end Build_Location_String; + ----------------------- -- Get_Column_Number -- ----------------------- *************** package body Sinput is *** 299,304 **** --- 305,323 ---- end if; end Get_Logical_Line_Number; + --------------------------------- + -- Get_Logical_Line_Number_Img -- + --------------------------------- + + function Get_Logical_Line_Number_Img + (P : Source_Ptr) return String + is + begin + Name_Len := 0; + Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P))); + return Name_Buffer (1 .. Name_Len); + end Get_Logical_Line_Number_Img; + ------------------------------ -- Get_Physical_Line_Number -- ------------------------------ *************** package body Sinput is *** 792,799 **** else -- Free the buffer, we use Free here, because we used malloc -- or realloc directly to allocate the tables. That is ! -- because we were playing the big array trick. We need to ! -- suppress the warning for freeing from an empty pool! -- We have to recreate a proper pointer to the actual array -- from the zero origin pointer stored in the source table. --- 811,817 ---- else -- Free the buffer, we use Free here, because we used malloc -- or realloc directly to allocate the tables. That is ! -- because we were playing the big array trick. -- We have to recreate a proper pointer to the actual array -- from the zero origin pointer stored in the source table. *************** package body Sinput is *** 801,809 **** Tmp1 := To_Source_Buffer_Ptr (S.Source_Text (S.Source_First)'Address); - pragma Warnings (Off); Free_Ptr (Tmp1); - pragma Warnings (On); if S.Lines_Table /= null then Memory.Free (To_Address (S.Lines_Table)); --- 819,825 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/sinput.ads gcc-4.6.0/gcc/ada/sinput.ads *** gcc-4.5.2/gcc/ada/sinput.ads Wed Jan 27 11:37:20 2010 --- gcc-4.6.0/gcc/ada/sinput.ads Tue Oct 12 11:00:42 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Sinput is *** 471,476 **** --- 471,480 ---- -- ASCII.NUL, with Name_Length indicating the length not including the -- terminating Nul. + function Build_Location_String (Loc : Source_Ptr) return String; + -- Functional form returning a string, which does not include a terminating + -- null character. The contents of Name_Buffer is destroyed. + function Get_Column_Number (P : Source_Ptr) return Column_Number; -- The ones-origin column number of the specified Source_Ptr value is -- determined and returned. Tab characters if present are assumed to *************** package Sinput is *** 487,492 **** --- 491,501 ---- -- reference pragmas have been encountered, the value returned is -- the same as the physical line number. + function Get_Logical_Line_Number_Img + (P : Source_Ptr) return String; + -- Same as above function, but returns the line number as a string of + -- decimal digits, with no leading space. Destroys Name_Buffer. + function Get_Physical_Line_Number (P : Source_Ptr) return Physical_Line_Number; -- The line number of the specified source position is obtained by diff -Nrcpad gcc-4.5.2/gcc/ada/snames.adb-tmpl gcc-4.6.0/gcc/ada/snames.adb-tmpl *** gcc-4.5.2/gcc/ada/snames.adb-tmpl Fri Apr 10 14:08:58 2009 --- gcc-4.6.0/gcc/ada/snames.adb-tmpl Mon Oct 11 09:20:53 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Snames is *** 368,374 **** return Get_Name_Table_Byte (N) /= 0 and then (Ada_Version >= Ada_95 or else N not in Ada_95_Reserved_Words) ! and then (Ada_Version >= Ada_05 or else N not in Ada_2005_Reserved_Words); end Is_Keyword_Name; --- 368,374 ---- return Get_Name_Table_Byte (N) /= 0 and then (Ada_Version >= Ada_95 or else N not in Ada_95_Reserved_Words) ! and then (Ada_Version >= Ada_2005 or else N not in Ada_2005_Reserved_Words); end Is_Keyword_Name; diff -Nrcpad gcc-4.5.2/gcc/ada/snames.ads-tmpl gcc-4.6.0/gcc/ada/snames.ads-tmpl *** gcc-4.5.2/gcc/ada/snames.ads-tmpl Wed Jan 27 13:29:52 2010 --- gcc-4.6.0/gcc/ada/snames.ads-tmpl Fri Oct 22 10:00:18 2010 *************** *** 6,12 **** -- -- -- T e m p l a t e -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- T e m p l a t e -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Namet; use Namet; *** 34,40 **** package Snames is -- This package contains definitions of standard names (i.e. entries in the ! -- Names table) that are used throughout the GNAT compiler). It also contains -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. --- 34,40 ---- package Snames is -- This package contains definitions of standard names (i.e. entries in the ! -- Names table) that are used throughout the GNAT compiler. It also contains -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. *************** package Snames is *** 134,139 **** --- 134,145 ---- Name_Space : constant Name_Id := N + $; Name_Time : constant Name_Id := N + $; + -- Names of aspects for which there are no matching pragmas or attributes + -- so that they need to be included for aspect specification use. + + Name_Post : constant Name_Id := N + $; + Name_Pre : constant Name_Id := N + $; + -- Some special names used by the expander. Note that the lower case u's -- at the start of these names get translated to extra underscores. These -- names are only referenced internally by expander generated code. *************** package Snames is *** 145,150 **** --- 151,157 ---- Name_uChain : constant Name_Id := N + $; Name_uClean : constant Name_Id := N + $; Name_uController : constant Name_Id := N + $; + Name_uCPU : constant Name_Id := N + $; Name_uEntry_Bodies : constant Name_Id := N + $; Name_uExpunge : constant Name_Id := N + $; Name_uFinal_List : constant Name_Id := N + $; *************** package Snames is *** 312,320 **** -- may be found in the appropriate section in unit Sem_Prag in file -- sem-prag.adb, and they are documented in the GNAT reference manual. ! -- The entries marked Ada05 are Ada 2005 pragmas. They are implemented in ! -- Ada 83 and Ada 95 mode as well, where they are technically considered to ! -- be implementation dependent pragmas. -- The entries marked VMS are VMS specific pragmas that are recognized -- only in OpenVMS versions of GNAT. They are ignored in other versions --- 319,331 ---- -- may be found in the appropriate section in unit Sem_Prag in file -- sem-prag.adb, and they are documented in the GNAT reference manual. ! -- The entries marked Ada 05 are Ada 2005 pragmas. They are implemented ! -- in Ada 83 and Ada 95 mode as well, where they are technically considered ! -- to be implementation dependent pragmas. ! ! -- The entries marked Ada 12 are Ada 2012 pragmas. They are implemented ! -- in Ada 83, Ada 95, and Ada 2005 mode as well, where they are technically ! -- considered to be implementation dependent pragmas. -- The entries marked VMS are VMS specific pragmas that are recognized -- only in OpenVMS versions of GNAT. They are ignored in other versions *************** package Snames is *** 334,339 **** --- 345,352 ---- Name_Ada_95 : constant Name_Id := N + $; -- GNAT Name_Ada_05 : constant Name_Id := N + $; -- GNAT Name_Ada_2005 : constant Name_Id := N + $; -- GNAT + Name_Ada_12 : constant Name_Id := N + $; -- GNAT + Name_Ada_2012 : constant Name_Id := N + $; -- GNAT Name_Assertion_Policy : constant Name_Id := N + $; -- Ada 05 Name_Assume_No_Invalid_Values : constant Name_Id := N + $; -- GNAT Name_C_Pass_By_Copy : constant Name_Id := N + $; -- GNAT *************** package Snames is *** 346,351 **** --- 359,365 ---- Name_Convention_Identifier : constant Name_Id := N + $; -- GNAT Name_Debug_Policy : constant Name_Id := N + $; -- GNAT Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05 + Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12 Name_Discard_Names : constant Name_Id := N + $; Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT Name_Eliminate : constant Name_Id := N + $; -- GNAT *************** package Snames is *** 384,389 **** --- 398,404 ---- Name_Restriction_Warnings : constant Name_Id := N + $; -- GNAT Name_Reviewable : constant Name_Id := N + $; Name_Short_Circuit_And_Or : constant Name_Id := N + $; -- GNAT + Name_Short_Descriptors : constant Name_Id := N + $; -- GNAT Name_Source_File_Name : constant Name_Id := N + $; -- GNAT Name_Source_File_Name_Project : constant Name_Id := N + $; -- GNAT Name_Style_Checks : constant Name_Id := N + $; -- GNAT *************** package Snames is *** 404,410 **** Name_All_Calls_Remote : constant Name_Id := N + $; Name_Annotate : constant Name_Id := N + $; -- GNAT ! -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is -- included in the definition of the type Pragma_Id, and the -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize --- 419,425 ---- Name_All_Calls_Remote : constant Name_Id := N + $; Name_Annotate : constant Name_Id := N + $; -- GNAT ! -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is -- included in the definition of the type Pragma_Id, and the -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize *************** package Snames is *** 427,432 **** --- 442,448 ---- Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT + Name_CPU : constant Name_Id := N + $; -- Ada 12 Name_Debug : constant Name_Id := N + $; -- GNAT Name_Dimension : constant Name_Id := N + $; -- GNAT Name_Elaborate : constant Name_Id := N + $; -- Ada 83 *************** package Snames is *** 442,461 **** Name_External : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT Name_Ident : constant Name_Id := N + $; -- VMS ! Name_Implemented_By_Entry : constant Name_Id := N + $; -- Ada 05 Name_Import : constant Name_Id := N + $; Name_Import_Exception : constant Name_Id := N + $; -- VMS Name_Import_Function : constant Name_Id := N + $; -- GNAT Name_Import_Object : constant Name_Id := N + $; -- GNAT Name_Import_Procedure : constant Name_Id := N + $; -- GNAT Name_Import_Valued_Procedure : constant Name_Id := N + $; -- GNAT Name_Inline : constant Name_Id := N + $; Name_Inline_Always : constant Name_Id := N + $; -- GNAT Name_Inline_Generic : constant Name_Id := N + $; -- GNAT Name_Inspection_Point : constant Name_Id := N + $; -- Note: Interface is not in this list because its name -- GNAT ! -- matches an Ada 2005 keyword. However it is included in -- the definition of the type Attribute_Id, and the functions -- Get_Pragma_Id and Is_Pragma_Id correctly recognize and -- process Name_Storage_Size. --- 458,479 ---- Name_External : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT Name_Ident : constant Name_Id := N + $; -- VMS ! Name_Implemented : constant Name_Id := N + $; -- Ada 12 Name_Import : constant Name_Id := N + $; Name_Import_Exception : constant Name_Id := N + $; -- VMS Name_Import_Function : constant Name_Id := N + $; -- GNAT Name_Import_Object : constant Name_Id := N + $; -- GNAT Name_Import_Procedure : constant Name_Id := N + $; -- GNAT Name_Import_Valued_Procedure : constant Name_Id := N + $; -- GNAT + Name_Independent : constant Name_Id := N + $; -- Ada 12 + Name_Independent_Components : constant Name_Id := N + $; -- Ada 12 Name_Inline : constant Name_Id := N + $; Name_Inline_Always : constant Name_Id := N + $; -- GNAT Name_Inline_Generic : constant Name_Id := N + $; -- GNAT Name_Inspection_Point : constant Name_Id := N + $; -- Note: Interface is not in this list because its name -- GNAT ! -- matches an Ada 05 keyword. However it is included in -- the definition of the type Attribute_Id, and the functions -- Get_Pragma_Id and Is_Pragma_Id correctly recognize and -- process Name_Storage_Size. *************** package Snames is *** 463,468 **** --- 481,487 ---- Name_Interface_Name : constant Name_Id := N + $; -- GNAT Name_Interrupt_Handler : constant Name_Id := N + $; Name_Interrupt_Priority : constant Name_Id := N + $; + Name_Invariant : constant Name_Id := N + $; -- GNAT Name_Java_Constructor : constant Name_Id := N + $; -- GNAT Name_Java_Interface : constant Name_Id := N + $; -- GNAT Name_Keep_Names : constant Name_Id := N + $; -- GNAT *************** package Snames is *** 481,491 **** --- 500,512 ---- Name_No_Return : constant Name_Id := N + $; -- Ada 05 Name_Obsolescent : constant Name_Id := N + $; -- GNAT Name_Optimize : constant Name_Id := N + $; + Name_Ordered : constant Name_Id := N + $; -- GNAT Name_Pack : constant Name_Id := N + $; Name_Page : constant Name_Id := N + $; Name_Passive : constant Name_Id := N + $; -- GNAT Name_Postcondition : constant Name_Id := N + $; -- GNAT Name_Precondition : constant Name_Id := N + $; -- GNAT + Name_Predicate : constant Name_Id := N + $; -- GNAT Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05 Name_Preelaborate : constant Name_Id := N + $; Name_Preelaborate_05 : constant Name_Id := N + $; -- GNAT *************** package Snames is *** 590,595 **** --- 611,619 ---- Name_Attribute_Name : constant Name_Id := N + $; Name_Body_File_Name : constant Name_Id := N + $; Name_Boolean_Entry_Barriers : constant Name_Id := N + $; + Name_By_Any : constant Name_Id := N + $; + Name_By_Entry : constant Name_Id := N + $; + Name_By_Protected_Procedure : constant Name_Id := N + $; Name_Casing : constant Name_Id := N + $; Name_Code : constant Name_Id := N + $; Name_Component : constant Name_Id := N + $; *************** package Snames is *** 740,745 **** --- 764,770 ---- Name_Machine_Rounds : constant Name_Id := N + $; Name_Machine_Size : constant Name_Id := N + $; -- GNAT Name_Mantissa : constant Name_Id := N + $; -- Ada 83 + Name_Max_Alignment_For_Allocation : constant Name_Id := N + $; -- Ada 12 Name_Max_Size_In_Storage_Elements : constant Name_Id := N + $; Name_Maximum_Alignment : constant Name_Id := N + $; -- GNAT Name_Mechanism_Code : constant Name_Id := N + $; -- GNAT *************** package Snames is *** 760,765 **** --- 785,791 ---- Name_Priority : constant Name_Id := N + $; -- Ada 05 Name_Range : constant Name_Id := N + $; Name_Range_Length : constant Name_Id := N + $; -- GNAT + Name_Ref : constant Name_Id := N + $; -- GNAT Name_Result : constant Name_Id := N + $; -- GNAT Name_Round : constant Name_Id := N + $; Name_Safe_Emax : constant Name_Id := N + $; -- Ada 83 *************** package Snames is *** 780,785 **** --- 806,812 ---- Name_Terminated : constant Name_Id := N + $; Name_To_Address : constant Name_Id := N + $; -- GNAT Name_Type_Class : constant Name_Id := N + $; -- GNAT + Name_Type_Key : constant Name_Id := N + $; -- GNAT Name_UET_Address : constant Name_Id := N + $; -- GNAT Name_Unbiased_Rounding : constant Name_Id := N + $; Name_Unchecked_Access : constant Name_Id := N + $; *************** package Snames is *** 910,915 **** --- 937,946 ---- -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Mod, Range). + -- Note: Name_Some is here even though for now we do not treat it as being + -- reserved. We treat it instead as an unreserved keyword. This may change + -- in the future, but in any case it belongs in the following list. + Name_Abort : constant Name_Id := N + $; Name_Abs : constant Name_Id := N + $; Name_Accept : constant Name_Id := N + $; *************** package Snames is *** 958,963 **** --- 989,995 ---- Name_Reverse : constant Name_Id := N + $; Name_Select : constant Name_Id := N + $; Name_Separate : constant Name_Id := N + $; + Name_Some : constant Name_Id := N + $; Name_Subtype : constant Name_Id := N + $; Name_Task : constant Name_Id := N + $; Name_Terminate : constant Name_Id := N + $; *************** package Snames is *** 1056,1061 **** --- 1088,1094 ---- Name_Executable : constant Name_Id := N + $; Name_Executable_Suffix : constant Name_Id := N + $; Name_Extends : constant Name_Id := N + $; + Name_External_As_List : constant Name_Id := N + $; Name_Externally_Built : constant Name_Id := N + $; Name_Finder : constant Name_Id := N + $; Name_Global_Compilation_Switches : constant Name_Id := N + $; *************** package Snames is *** 1065,1070 **** --- 1098,1104 ---- Name_Gnatstub : constant Name_Id := N + $; Name_Gnu : constant Name_Id := N + $; Name_Ide : constant Name_Id := N + $; + Name_Ignore_Source_Sub_Dirs : constant Name_Id := N + $; Name_Implementation : constant Name_Id := N + $; Name_Implementation_Exceptions : constant Name_Id := N + $; Name_Implementation_Suffix : constant Name_Id := N + $; *************** package Snames is *** 1073,1079 **** --- 1107,1115 ---- Name_Include_Path_File : constant Name_Id := N + $; Name_Inherit_Source_Path : constant Name_Id := N + $; Name_Languages : constant Name_Id := N + $; + Name_Leading_Library_Options : constant Name_Id := N + $; Name_Leading_Required_Switches : constant Name_Id := N + $; + Name_Leading_Switches : constant Name_Id := N + $; Name_Library : constant Name_Id := N + $; Name_Library_Ali_Dir : constant Name_Id := N + $; Name_Library_Auto_Init : constant Name_Id := N + $; *************** package Snames is *** 1127,1132 **** --- 1163,1170 ---- Name_Prefix : constant Name_Id := N + $; Name_Project : constant Name_Id := N + $; Name_Project_Dir : constant Name_Id := N + $; + Name_Project_Files : constant Name_Id := N + $; + Name_Project_Path : constant Name_Id := N + $; Name_Response_File_Format : constant Name_Id := N + $; Name_Response_File_Switches : constant Name_Id := N + $; Name_Roots : constant Name_Id := N + $; -- GPR *************** package Snames is *** 1160,1166 **** Name_Unaligned_Valid : constant Name_Id := N + $; ! -- Ada 2005 reserved words First_2005_Reserved_Word : constant Name_Id := N + $; Name_Interface : constant Name_Id := N + $; --- 1198,1212 ---- Name_Unaligned_Valid : constant Name_Id := N + $; ! -- Names used to implement iterators over predefined containers ! ! Name_Cursor : constant Name_Id := N + $; ! Name_Element : constant Name_Id := N + $; ! Name_Element_Type : constant Name_Id := N + $; ! Name_No_Element : constant Name_Id := N + $; ! Name_Previous : constant Name_Id := N + $; ! ! -- Ada 05 reserved words First_2005_Reserved_Word : constant Name_Id := N + $; Name_Interface : constant Name_Id := N + $; *************** package Snames is *** 1250,1255 **** --- 1296,1302 ---- Attribute_Machine_Rounds, Attribute_Machine_Size, Attribute_Mantissa, + Attribute_Max_Alignment_For_Allocation, Attribute_Max_Size_In_Storage_Elements, Attribute_Maximum_Alignment, Attribute_Mechanism_Code, *************** package Snames is *** 1270,1275 **** --- 1317,1323 ---- Attribute_Priority, Attribute_Range, Attribute_Range_Length, + Attribute_Ref, Attribute_Result, Attribute_Round, Attribute_Safe_Emax, *************** package Snames is *** 1290,1295 **** --- 1338,1344 ---- Attribute_Terminated, Attribute_To_Address, Attribute_Type_Class, + Attribute_Type_Key, Attribute_UET_Address, Attribute_Unbiased_Rounding, Attribute_Unchecked_Access, *************** package Snames is *** 1416,1421 **** --- 1465,1472 ---- Pragma_Ada_95, Pragma_Ada_05, Pragma_Ada_2005, + Pragma_Ada_12, + Pragma_Ada_2012, Pragma_Assertion_Policy, Pragma_Assume_No_Invalid_Values, Pragma_C_Pass_By_Copy, *************** package Snames is *** 1428,1433 **** --- 1479,1485 ---- Pragma_Convention_Identifier, Pragma_Debug_Policy, Pragma_Detect_Blocking, + Pragma_Default_Storage_Pool, Pragma_Discard_Names, Pragma_Elaboration_Checks, Pragma_Eliminate, *************** package Snames is *** 1459,1464 **** --- 1511,1517 ---- Pragma_Restriction_Warnings, Pragma_Reviewable, Pragma_Short_Circuit_And_Or, + Pragma_Short_Descriptors, Pragma_Source_File_Name, Pragma_Source_File_Name_Project, Pragma_Style_Checks, *************** package Snames is *** 1494,1499 **** --- 1547,1553 ---- Pragma_CPP_Constructor, Pragma_CPP_Virtual, Pragma_CPP_Vtable, + Pragma_CPU, Pragma_Debug, Pragma_Dimension, Pragma_Elaborate, *************** package Snames is *** 1509,1521 **** Pragma_External, Pragma_Finalize_Storage_Only, Pragma_Ident, ! Pragma_Implemented_By_Entry, Pragma_Import, Pragma_Import_Exception, Pragma_Import_Function, Pragma_Import_Object, Pragma_Import_Procedure, Pragma_Import_Valued_Procedure, Pragma_Inline, Pragma_Inline_Always, Pragma_Inline_Generic, --- 1563,1577 ---- Pragma_External, Pragma_Finalize_Storage_Only, Pragma_Ident, ! Pragma_Implemented, Pragma_Import, Pragma_Import_Exception, Pragma_Import_Function, Pragma_Import_Object, Pragma_Import_Procedure, Pragma_Import_Valued_Procedure, + Pragma_Independent, + Pragma_Independent_Components, Pragma_Inline, Pragma_Inline_Always, Pragma_Inline_Generic, *************** package Snames is *** 1523,1528 **** --- 1579,1585 ---- Pragma_Interface_Name, Pragma_Interrupt_Handler, Pragma_Interrupt_Priority, + Pragma_Invariant, Pragma_Java_Constructor, Pragma_Java_Interface, Pragma_Keep_Names, *************** package Snames is *** 1541,1551 **** --- 1598,1610 ---- Pragma_No_Return, Pragma_Obsolescent, Pragma_Optimize, + Pragma_Ordered, Pragma_Pack, Pragma_Page, Pragma_Passive, Pragma_Postcondition, Pragma_Precondition, + Pragma_Predicate, Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Preelaborate_05, *************** package Snames is *** 1690,1698 **** -- call this function with a name that is not the name of a attribute. function Get_Convention_Id (N : Name_Id) return Convention_Id; ! -- Returns Id of language convention corresponding to given name. It is an ! -- to call this function with a name that is not the name of a convention, ! -- or one previously given in a call to Record_Convention_Identifier. function Get_Convention_Name (C : Convention_Id) return Name_Id; -- Returns the name of language convention corresponding to given --- 1749,1758 ---- -- call this function with a name that is not the name of a attribute. function Get_Convention_Id (N : Name_Id) return Convention_Id; ! -- Returns Id of language convention corresponding to given name. It is ! -- an error to call this function with a name that is not the name of a ! -- convention, or one that has been previously recorded using a call to ! -- Record_Convention_Identifier. function Get_Convention_Name (C : Convention_Id) return Name_Id; -- Returns the name of language convention corresponding to given diff -Nrcpad gcc-4.5.2/gcc/ada/socket.c gcc-4.6.0/gcc/ada/socket.c *** gcc-4.5.2/gcc/ada/socket.c Mon Nov 30 10:38:23 2009 --- gcc-4.6.0/gcc/ada/socket.c Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** * * * C Implementation File * * * ! * Copyright (C) 2003-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- * --- 6,12 ---- * * * C Implementation File * * * ! * Copyright (C) 2003-2010, 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- * *************** *** 32,57 **** /* This file provides a portable binding to the sockets API */ #include "gsocket.h" #ifdef VMS /* * For VMS, gsocket.h can't include sockets-related DEC C header files * when building the runtime (because these files are in a DEC C text library ! * (DECC$RTLDEF.TLB) not accessable to GCC). So, we generate a separate header * file along with s-oscons.ads and include it here. */ # include "s-oscons.h" /* ! * We also need the declaration of struct servent, which s-oscons can't ! * provide, so we copy it manually here. This needs to be kept in synch * with the definition of that structure in the DEC C headers, which * hopefully won't change frequently. */ struct servent { ! char *s_name; /* official service name */ ! char **s_aliases; /* alias list */ ! int s_port; /* port # */ ! char *s_proto; /* protocol to use */ }; #endif --- 32,69 ---- /* This file provides a portable binding to the sockets API */ #include "gsocket.h" + #ifdef VMS /* * For VMS, gsocket.h can't include sockets-related DEC C header files * when building the runtime (because these files are in a DEC C text library ! * (DECC$RTLDEF.TLB) not accessible to GCC). So, we generate a separate header * file along with s-oscons.ads and include it here. */ # include "s-oscons.h" /* ! * We also need the declaration of struct hostent/servent, which s-oscons ! * can't provide, so we copy it manually here. This needs to be kept in synch * with the definition of that structure in the DEC C headers, which * hopefully won't change frequently. */ + typedef char *__netdb_char_ptr __attribute__ (( mode (SI) )); + typedef __netdb_char_ptr *__netdb_char_ptr_ptr __attribute__ (( mode (SI) )); + + struct hostent { + __netdb_char_ptr h_name; + __netdb_char_ptr_ptr h_aliases; + int h_addrtype; + int h_length; + __netdb_char_ptr_ptr h_addr_list; + }; + struct servent { ! __netdb_char_ptr s_name; ! __netdb_char_ptr_ptr s_aliases; ! int s_port; ! __netdb_char_ptr s_proto; }; #endif *************** extern void __gnat_remove_socket_from_se *** 87,101 **** extern void __gnat_reset_socket_set (fd_set *); extern int __gnat_get_h_errno (void); extern int __gnat_socket_ioctl (int, int, int *); extern char * __gnat_servent_s_name (struct servent *); ! extern char ** __gnat_servent_s_aliases (struct servent *); ! extern int __gnat_servent_s_port (struct servent *); extern char * __gnat_servent_s_proto (struct servent *); ! extern void __gnat_servent_set_s_name (struct servent *, char *); ! extern void __gnat_servent_set_s_aliases (struct servent *, char **); ! extern void __gnat_servent_set_s_port (struct servent *, int); ! extern void __gnat_servent_set_s_proto (struct servent *, char *); ! #if defined (__vxworks) || defined (_WIN32) extern int __gnat_inet_pton (int, const char *, void *); #endif --- 99,117 ---- extern void __gnat_reset_socket_set (fd_set *); extern int __gnat_get_h_errno (void); extern int __gnat_socket_ioctl (int, int, int *); + extern char * __gnat_servent_s_name (struct servent *); ! extern char * __gnat_servent_s_alias (struct servent *, int index); ! extern unsigned short __gnat_servent_s_port (struct servent *); extern char * __gnat_servent_s_proto (struct servent *); ! ! extern char * __gnat_hostent_h_name (struct hostent *); ! extern char * __gnat_hostent_h_alias (struct hostent *, int); ! extern int __gnat_hostent_h_addrtype (struct hostent *); ! extern int __gnat_hostent_h_length (struct hostent *); ! extern char * __gnat_hostent_h_addr (struct hostent *, int); ! ! #ifndef HAVE_INET_PTON extern int __gnat_inet_pton (int, const char *, void *); #endif *************** __gnat_close_signalling_fd (int sig) { *** 164,239 **** #endif /* ! * GetXXXbyYYY wrappers ! * These functions are used by the default implementation of g-socthi, ! * and also by the Windows version. * ! * They can be used for any platform that either provides an intrinsically ! * task safe implementation of getXXXbyYYY, or a reentrant variant ! * getXXXbyYYY_r. Otherwise, a task safe wrapper, including proper mutual ! * exclusion if appropriate, must be implemented in the target specific ! * version of g-socthi. */ ! #ifdef HAVE_THREAD_SAFE_GETxxxBYyyy ! int ! __gnat_safe_gethostbyname (const char *name, ! struct hostent *ret, char *buf, size_t buflen, ! int *h_errnop) ! { ! struct hostent *rh; ! rh = gethostbyname (name); ! if (rh == NULL) { ! *h_errnop = h_errno; ! return -1; ! } ! *ret = *rh; ! *h_errnop = 0; ! return 0; ! } ! ! int ! __gnat_safe_gethostbyaddr (const char *addr, int len, int type, ! struct hostent *ret, char *buf, size_t buflen, ! int *h_errnop) ! { ! struct hostent *rh; ! rh = gethostbyaddr (addr, len, type); ! if (rh == NULL) { ! *h_errnop = h_errno; ! return -1; ! } ! *ret = *rh; ! *h_errnop = 0; ! return 0; ! } ! ! int ! __gnat_safe_getservbyname (const char *name, const char *proto, ! struct servent *ret, char *buf, size_t buflen) ! { ! struct servent *rh; ! rh = getservbyname (name, proto); ! if (rh == NULL) ! return -1; ! *ret = *rh; ! return 0; ! } ! ! int ! __gnat_safe_getservbyport (int port, const char *proto, ! struct servent *ret, char *buf, size_t buflen) ! { ! struct servent *rh; ! rh = getservbyport (port, proto); ! if (rh == NULL) ! return -1; ! *ret = *rh; ! return 0; ! } ! #elif HAVE_GETxxxBYyyy_R int ! __gnat_safe_gethostbyname (const char *name, struct hostent *ret, char *buf, size_t buflen, int *h_errnop) { --- 180,207 ---- #endif /* ! * Handling of gethostbyname, gethostbyaddr, getservbyname and getservbyport ! * ========================================================================= * ! * This module exposes __gnat_getXXXbyYYY operations with the same signature ! * as the reentrant variant getXXXbyYYY_r. ! * ! * On platforms where getXXXbyYYY is intrinsically reentrant, the provided user ! * buffer argument is ignored. ! * ! * When getXXXbyYYY is not reentrant but getXXXbyYYY_r exists, the latter is ! * used, and the provided buffer argument must point to a valid, thread-local ! * buffer (usually on the caller's stack). ! * ! * When getXXXbyYYY is not reentrant and no reentrant getXXXbyYYY_r variant ! * is available, the non-reentrant getXXXbyYYY is called, the provided user ! * buffer is ignored, and the caller is expected to take care of mutual ! * exclusion. */ ! #ifdef HAVE_GETxxxBYyyy_R int ! __gnat_gethostbyname (const char *name, struct hostent *ret, char *buf, size_t buflen, int *h_errnop) { *************** __gnat_safe_gethostbyname (const char *n *** 250,256 **** } int ! __gnat_safe_gethostbyaddr (const char *addr, int len, int type, struct hostent *ret, char *buf, size_t buflen, int *h_errnop) { --- 218,224 ---- } int ! __gnat_gethostbyaddr (const char *addr, int len, int type, struct hostent *ret, char *buf, size_t buflen, int *h_errnop) { *************** __gnat_safe_gethostbyaddr (const char *a *** 267,273 **** } int ! __gnat_safe_getservbyname (const char *name, const char *proto, struct servent *ret, char *buf, size_t buflen) { struct servent *rh; --- 235,241 ---- } int ! __gnat_getservbyname (const char *name, const char *proto, struct servent *ret, char *buf, size_t buflen) { struct servent *rh; *************** __gnat_safe_getservbyname (const char *n *** 283,289 **** } int ! __gnat_safe_getservbyport (int port, const char *proto, struct servent *ret, char *buf, size_t buflen) { struct servent *rh; --- 251,257 ---- } int ! __gnat_getservbyport (int port, const char *proto, struct servent *ret, char *buf, size_t buflen) { struct servent *rh; *************** __gnat_safe_getservbyport (int port, con *** 297,302 **** --- 265,394 ---- ri = (rh == NULL) ? -1 : 0; return ri; } + #elif defined (__vxworks) + static char vxw_h_name[MAXHOSTNAMELEN + 1]; + static char *vxw_h_aliases[1] = { NULL }; + static int vxw_h_addr; + static char *vxw_h_addr_list[2] = { (char*) &vxw_h_addr, NULL }; + + int + __gnat_gethostbyname (const char *name, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) + { + vxw_h_addr = hostGetByName (name); + if (vxw_h_addr == ERROR) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + ret->h_name = name; + ret->h_aliases = &vxw_h_aliases; + ret->h_addrtype = AF_INET; + ret->h_length = 4; + ret->h_addr_list = &vxw_h_addr_list; + return 0; + } + + int + __gnat_gethostbyaddr (const char *addr, int len, int type, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) + { + if (type != AF_INET) { + *h_errnop = EAFNOSUPPORT; + return -1; + } + + if (addr == NULL || len != 4) { + *h_errnop = EINVAL; + return -1; + } + + if (hostGetByAddr (*(int*)addr, &vxw_h_name) != OK) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + + vxw_h_addr = addr; + + ret->h_name = &vxw_h_name; + ret->h_aliases = &vxw_h_aliases; + ret->h_addrtype = AF_INET; + ret->h_length = 4; + ret->h_addr_list = &vxw_h_addr_list; + } + + int + __gnat_getservbyname (const char *name, const char *proto, + struct servent *ret, char *buf, size_t buflen) + { + /* Not available under VxWorks */ + return -1; + } + + int + __gnat_getservbyport (int port, const char *proto, + struct servent *ret, char *buf, size_t buflen) + { + /* Not available under VxWorks */ + return -1; + } + #else + int + __gnat_gethostbyname (const char *name, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) + { + struct hostent *rh; + rh = gethostbyname (name); + if (rh == NULL) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + *ret = *rh; + *h_errnop = 0; + return 0; + } + + int + __gnat_gethostbyaddr (const char *addr, int len, int type, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) + { + struct hostent *rh; + rh = gethostbyaddr (addr, len, type); + if (rh == NULL) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + *ret = *rh; + *h_errnop = 0; + return 0; + } + + int + __gnat_getservbyname (const char *name, const char *proto, + struct servent *ret, char *buf, size_t buflen) + { + struct servent *rh; + rh = getservbyname (name, proto); + if (rh == NULL) + return -1; + *ret = *rh; + return 0; + } + + int + __gnat_getservbyport (int port, const char *proto, + struct servent *ret, char *buf, size_t buflen) + { + struct servent *rh; + rh = getservbyport (port, proto); + if (rh == NULL) + return -1; + *ret = *rh; + return 0; + } #endif /* Find the largest socket in the socket set SET. This is needed for *************** int *** 437,442 **** --- 529,540 ---- __gnat_socket_ioctl (int fd, int req, int *arg) { #if defined (_WIN32) return ioctlsocket (fd, req, arg); + #elif defined (__APPLE__) + /* + * On Darwin, req is an unsigned long, and we want to convert without sign + * extension to get the proper bit pattern in the case of a 64 bit kernel. + */ + return ioctl (fd, (unsigned int) req, arg); #else return ioctl (fd, req, arg); #endif *************** __gnat_inet_pton (int af, const char *sr *** 510,515 **** --- 608,637 ---- #endif /* + * Accessor functions for struct hostent. + */ + + char * __gnat_hostent_h_name (struct hostent * h) { + return h->h_name; + } + + char * __gnat_hostent_h_alias (struct hostent * h, int index) { + return h->h_aliases[index]; + } + + int __gnat_hostent_h_addrtype (struct hostent * h) { + return h->h_addrtype; + } + + int __gnat_hostent_h_length (struct hostent * h) { + return h->h_length; + } + + char * __gnat_hostent_h_addr (struct hostent * h, int index) { + return h->h_addr_list[index]; + } + + /* * Accessor functions for struct servent. * * These are needed because servent has different representations on different *************** __gnat_inet_pton (int af, const char *sr *** 539,559 **** * }; */ - /* Getters */ - char * __gnat_servent_s_name (struct servent * s) { return s->s_name; } ! char ** ! __gnat_servent_s_aliases (struct servent * s) { ! return s->s_aliases; } ! int __gnat_servent_s_port (struct servent * s) { return s->s_port; --- 661,679 ---- * }; */ char * __gnat_servent_s_name (struct servent * s) { return s->s_name; } ! char * ! __gnat_servent_s_alias (struct servent * s, int index) { ! return s->s_aliases[index]; } ! unsigned short __gnat_servent_s_port (struct servent * s) { return s->s_port; *************** __gnat_servent_s_proto (struct servent * *** 565,596 **** return s->s_proto; } - /* Setters */ - - void - __gnat_servent_set_s_name (struct servent * s, char * s_name) - { - s->s_name = s_name; - } - - void - __gnat_servent_set_s_aliases (struct servent * s, char ** s_aliases) - { - s->s_aliases = s_aliases; - } - - void - __gnat_servent_set_s_port (struct servent * s, int s_port) - { - s->s_port = s_port; - } - - void - __gnat_servent_set_s_proto (struct servent * s, char * s_proto) - { - s->s_proto = s_proto; - } - #else # warning Sockets are not supported on this platform #endif /* defined(HAVE_SOCKETS) */ --- 685,690 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/sprint.adb gcc-4.6.0/gcc/ada/sprint.adb *** gcc-4.5.2/gcc/ada/sprint.adb Mon Nov 30 11:55:21 2009 --- gcc-4.6.0/gcc/ada/sprint.adb Fri Oct 22 10:09:51 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; with Csets; use Csets; *************** package body Sprint is *** 65,71 **** -- Set True if the -gnatdo (dump original tree) flag is set Dump_Generated_Only : Boolean; ! -- Set True if the -gnatG (dump generated tree) debug flag is set -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD). Dump_Freeze_Null : Boolean; --- 66,72 ---- -- Set True if the -gnatdo (dump original tree) flag is set Dump_Generated_Only : Boolean; ! -- Set True if the -gnatdG (dump generated tree) debug flag is set -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD). Dump_Freeze_Null : Boolean; *************** package body Sprint is *** 182,187 **** --- 183,194 ---- procedure Sprint_And_List (List : List_Id); -- Print the given list with items separated by vertical "and" + procedure Sprint_Aspect_Specifications (Node : Node_Id); + -- Node is a declaration node that has aspect specifications (Has_Aspects + -- flag set True). It is called after outputting the terminating semicolon + -- for the related node. The effect is to remove the semicolon and print + -- the aspect specifications, followed by a terminating semicolon. + procedure Sprint_Bar_List (List : List_Id); -- Print the given list with items separated by vertical bars *************** package body Sprint is *** 403,409 **** procedure pg (Arg : Union_Id) is begin Dump_Generated_Only := True; ! Dump_Original_Only := False; Current_Source_File := No_Source_File; if Arg in List_Range then --- 410,417 ---- procedure pg (Arg : Union_Id) is begin Dump_Generated_Only := True; ! Dump_Original_Only := False; ! Dump_Freeze_Null := True; Current_Source_File := No_Source_File; if Arg in List_Range then *************** package body Sprint is *** 618,623 **** --- 626,670 ---- end if; end Sprint_And_List; + ---------------------------------- + -- Sprint_Aspect_Specifications -- + ---------------------------------- + + procedure Sprint_Aspect_Specifications (Node : Node_Id) is + AS : constant List_Id := Aspect_Specifications (Node); + A : Node_Id; + + begin + Write_Erase_Char (';'); + Indent := Indent + 2; + Write_Indent; + Write_Str ("with "); + Indent := Indent + 5; + + A := First (AS); + loop + Sprint_Node (Identifier (A)); + + if Class_Present (A) then + Write_Str ("'Class"); + end if; + + if Present (Expression (A)) then + Write_Str (" => "); + Sprint_Node (Expression (A)); + end if; + + Next (A); + + exit when No (A); + Write_Char (','); + Write_Indent; + end loop; + + Indent := Indent - 7; + Write_Char (';'); + end Sprint_Aspect_Specifications; + --------------------- -- Sprint_Bar_List -- --------------------- *************** package body Sprint is *** 800,806 **** -- Select print circuit based on node kind case Nkind (Node) is - when N_Abort_Statement => Write_Indent_Str_Sloc ("abort "); Sprint_Comma_List (Names (Node)); --- 847,852 ---- *************** package body Sprint is *** 998,1009 **** Write_Str_Sloc (" and then "); Sprint_Right_Opnd (Node); ! when N_At_Clause => ! Write_Indent_Str_Sloc ("for "); ! Write_Id (Identifier (Node)); ! Write_Str_With_Col_Check (" use at "); ! Sprint_Node (Expression (Node)); ! Write_Char (';'); when N_Assignment_Statement => Write_Indent; --- 1044,1051 ---- Write_Str_Sloc (" and then "); Sprint_Right_Opnd (Node); ! when N_Aspect_Specification => ! raise Program_Error; when N_Assignment_Statement => Write_Indent; *************** package body Sprint is *** 1025,1030 **** --- 1067,1079 ---- Sprint_Node (Abortable_Part (Node)); Write_Indent_Str ("end select;"); + when N_At_Clause => + Write_Indent_Str_Sloc ("for "); + Write_Id (Identifier (Node)); + Write_Str_With_Col_Check (" use at "); + Sprint_Node (Expression (Node)); + Write_Char (';'); + when N_Attribute_Definition_Clause => Write_Indent_Str_Sloc ("for "); Sprint_Node (Name (Node)); *************** package body Sprint is *** 1083,1088 **** --- 1132,1163 ---- Write_Char (';'); + when N_Case_Expression => + declare + Alt : Node_Id; + + begin + Write_Str_With_Col_Check_Sloc ("(case "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" is"); + + Alt := First (Alternatives (Node)); + loop + Sprint_Node (Alt); + Next (Alt); + exit when No (Alt); + Write_Char (','); + end loop; + + Write_Char (')'); + end; + + when N_Case_Expression_Alternative => + Write_Str_With_Col_Check (" when "); + Sprint_Bar_List (Discrete_Choices (Node)); + Write_Str (" => "); + Sprint_Node (Expression (Node)); + when N_Case_Statement => Write_Indent_Str_Sloc ("case "); Sprint_Node (Expression (Node)); *************** package body Sprint is *** 1224,1237 **** declare Condition : constant Node_Id := First (Expressions (Node)); Then_Expr : constant Node_Id := Next (Condition); ! Else_Expr : constant Node_Id := Next (Then_Expr); begin Write_Str_With_Col_Check_Sloc ("(if "); Sprint_Node (Condition); Write_Str_With_Col_Check (" then "); ! Sprint_Node (Then_Expr); ! Write_Str_With_Col_Check (" else "); ! Sprint_Node (Else_Expr); Write_Char (')'); end; --- 1299,1318 ---- declare Condition : constant Node_Id := First (Expressions (Node)); Then_Expr : constant Node_Id := Next (Condition); ! begin Write_Str_With_Col_Check_Sloc ("(if "); Sprint_Node (Condition); Write_Str_With_Col_Check (" then "); ! ! -- Defense against junk here! ! ! if Present (Then_Expr) then ! Sprint_Node (Then_Expr); ! Write_Str_With_Col_Check (" else "); ! Sprint_Node (Next (Then_Expr)); ! end if; ! Write_Char (')'); end; *************** package body Sprint is *** 1299,1305 **** Write_Str_With_Col_Check ("abstract "); end if; ! Write_Str_With_Col_Check_Sloc ("new "); -- Ada 2005 (AI-231) --- 1380,1386 ---- Write_Str_With_Col_Check ("abstract "); end if; ! Write_Str_With_Col_Check ("new "); -- Ada 2005 (AI-231) *************** package body Sprint is *** 1508,1513 **** --- 1589,1607 ---- Write_Char_Sloc ('.'); Write_Str_Sloc ("all"); + when N_Expression_With_Actions => + Indent_Begin; + Write_Indent_Str_Sloc ("do "); + Indent_Begin; + Sprint_Node_List (Actions (Node)); + Indent_End; + Write_Indent; + Write_Str_With_Col_Check_Sloc ("in "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" end"); + Indent_End; + Write_Indent; + when N_Extended_Return_Statement => Write_Indent_Str_Sloc ("return "); Sprint_Node_List (Return_Object_Declarations (Node)); *************** package body Sprint is *** 1901,1911 **** Sprint_Node (Condition (Node)); else Write_Str_With_Col_Check_Sloc ("for "); ! Sprint_Node (Loop_Parameter_Specification (Node)); end if; Write_Char (' '); when N_Itype_Reference => Write_Indent_Str_Sloc ("reference "); Write_Id (Itype (Node)); --- 1995,2031 ---- Sprint_Node (Condition (Node)); else Write_Str_With_Col_Check_Sloc ("for "); ! ! if Present (Iterator_Specification (Node)) then ! Sprint_Node (Iterator_Specification (Node)); ! else ! Sprint_Node (Loop_Parameter_Specification (Node)); ! end if; end if; Write_Char (' '); + when N_Iterator_Specification => + Set_Debug_Sloc; + Write_Id (Defining_Identifier (Node)); + + if Present (Subtype_Indication (Node)) then + Write_Str_With_Col_Check (" : "); + Sprint_Node (Subtype_Indication (Node)); + end if; + + if Of_Present (Node) then + Write_Str_With_Col_Check (" of "); + else + Write_Str_With_Col_Check (" in "); + end if; + + if Reverse_Present (Node) then + Write_Str_With_Col_Check ("reverse "); + end if; + + Sprint_Node (Name (Node)); + when N_Itype_Reference => Write_Indent_Str_Sloc ("reference "); Write_Id (Itype (Node)); *************** package body Sprint is *** 2342,2347 **** --- 2462,2478 ---- Write_Str (", "); end if; + when N_Parameterized_Expression => + Write_Indent; + Sprint_Node_Sloc (Specification (Node)); + + Write_Str (" is"); + Indent_Begin; + Write_Indent; + Sprint_Node (Expression (Node)); + Write_Char (';'); + Indent_End; + when N_Pop_Constraint_Error_Label => Write_Indent_Str ("%pop_constraint_error_label"); *************** package body Sprint is *** 2351,2356 **** --- 2482,2529 ---- when N_Pop_Storage_Error_Label => Write_Indent_Str ("%pop_storage_error_label"); + when N_Private_Extension_Declaration => + Write_Indent_Str_Sloc ("type "); + Write_Id (Defining_Identifier (Node)); + + if Present (Discriminant_Specifications (Node)) then + Write_Discr_Specs (Node); + elsif Unknown_Discriminants_Present (Node) then + Write_Str_With_Col_Check ("(<>)"); + end if; + + Write_Str_With_Col_Check (" is new "); + Sprint_Node (Subtype_Indication (Node)); + + if Present (Interface_List (Node)) then + Write_Str_With_Col_Check (" and "); + Sprint_And_List (Interface_List (Node)); + end if; + + Write_Str_With_Col_Check (" with private;"); + + when N_Private_Type_Declaration => + Write_Indent_Str_Sloc ("type "); + Write_Id (Defining_Identifier (Node)); + + if Present (Discriminant_Specifications (Node)) then + Write_Discr_Specs (Node); + elsif Unknown_Discriminants_Present (Node) then + Write_Str_With_Col_Check ("(<>)"); + end if; + + Write_Str (" is "); + + if Tagged_Present (Node) then + Write_Str_With_Col_Check ("tagged "); + end if; + + if Limited_Present (Node) then + Write_Str_With_Col_Check ("limited "); + end if; + + Write_Str_With_Col_Check ("private;"); + when N_Push_Constraint_Error_Label => Write_Indent_Str ("%push_constraint_error_label ("); *************** package body Sprint is *** 2399,2446 **** Sprint_Node (Expression (Node)); - when N_Private_Type_Declaration => - Write_Indent_Str_Sloc ("type "); - Write_Id (Defining_Identifier (Node)); - - if Present (Discriminant_Specifications (Node)) then - Write_Discr_Specs (Node); - elsif Unknown_Discriminants_Present (Node) then - Write_Str_With_Col_Check ("(<>)"); - end if; - - Write_Str (" is "); - - if Tagged_Present (Node) then - Write_Str_With_Col_Check ("tagged "); - end if; - - if Limited_Present (Node) then - Write_Str_With_Col_Check ("limited "); - end if; - - Write_Str_With_Col_Check ("private;"); - - when N_Private_Extension_Declaration => - Write_Indent_Str_Sloc ("type "); - Write_Id (Defining_Identifier (Node)); - - if Present (Discriminant_Specifications (Node)) then - Write_Discr_Specs (Node); - elsif Unknown_Discriminants_Present (Node) then - Write_Str_With_Col_Check ("(<>)"); - end if; - - Write_Str_With_Col_Check (" is new "); - Sprint_Node (Subtype_Indication (Node)); - - if Present (Interface_List (Node)) then - Write_Str_With_Col_Check (" and "); - Sprint_And_List (Interface_List (Node)); - end if; - - Write_Str_With_Col_Check (" with private;"); - when N_Procedure_Call_Statement => Write_Indent; Set_Debug_Sloc; --- 2572,2577 ---- *************** package body Sprint is *** 2521,2526 **** --- 2652,2670 ---- Write_Char (')'); end if; + when N_Quantified_Expression => + Write_Str (" for"); + + if All_Present (Node) then + Write_Str (" all "); + else + Write_Str (" some "); + end if; + + Sprint_Node (Loop_Parameter_Specification (Node)); + Write_Str (" => "); + Sprint_Node (Condition (Node)); + when N_Raise_Constraint_Error => -- This node can be used either as a subexpression or as a *************** package body Sprint is *** 2643,2651 **** -- Doc of this extended syntax belongs in sinfo.ads and/or -- sprint.ads ??? - when N_SCIL_Dispatch_Table_Object_Init => - Write_Indent_Str ("[N_SCIL_Dispatch_Table_Object_Init]"); - when N_SCIL_Dispatch_Table_Tag_Init => Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); --- 2787,2792 ---- *************** package body Sprint is *** 2655,2663 **** when N_SCIL_Membership_Test => Write_Indent_Str ("[N_SCIL_Membership_Test]"); - when N_SCIL_Tag_Init => - Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); - when N_Simple_Return_Statement => if Present (Expression (Node)) then Write_Indent_Str_Sloc ("return "); --- 2796,2801 ---- *************** package body Sprint is *** 2745,2751 **** end if; Write_Indent; ! Sprint_Node_Sloc (Specification (Node)); Write_Str (" is"); Sprint_Indented_List (Declarations (Node)); --- 2883,2895 ---- end if; Write_Indent; ! ! if Present (Corresponding_Spec (Node)) then ! Sprint_Node_Sloc (Parent (Corresponding_Spec (Node))); ! else ! Sprint_Node_Sloc (Specification (Node)); ! end if; ! Write_Str (" is"); Sprint_Indented_List (Declarations (Node)); *************** package body Sprint is *** 2873,2879 **** when N_Terminate_Alternative => Sprint_Node_List (Pragmas_Before (Node)); - Write_Indent; if Present (Condition (Node)) then --- 3017,3022 ---- *************** package body Sprint is *** 3031,3039 **** Write_Char (';'); end if; end if; - end case; if Nkind (Node) in N_Subexpr and then Do_Range_Check (Node) then --- 3174,3185 ---- Write_Char (';'); end if; end if; end case; + if Has_Aspects (Node) then + Sprint_Aspect_Specifications (Node); + end if; + if Nkind (Node) in N_Subexpr and then Do_Range_Check (Node) then *************** package body Sprint is *** 3427,3437 **** end if; -- Case of selector of an expanded name where the expanded name ! -- has an associated entity, output this entity. elsif Nkind (Parent (N)) = N_Expanded_Name and then Selector_Name (Parent (N)) = N ! and then Present (Entity (Parent (N))) then Write_Id (Entity (Parent (N))); --- 3573,3585 ---- end if; -- Case of selector of an expanded name where the expanded name ! -- has an associated entity, output this entity. Check that the ! -- entity or associated node is of the right kind, see above. elsif Nkind (Parent (N)) = N_Expanded_Name and then Selector_Name (Parent (N)) = N ! and then Present (Entity_Or_Associated_Node (Parent (N))) ! and then Nkind (Entity (Parent (N))) in N_Entity then Write_Id (Entity (Parent (N))); *************** package body Sprint is *** 3718,3729 **** when Access_Kind => Write_Header (Ekind (Typ) = E_Access_Type); Write_Str ("access "); if Is_Access_Constant (Typ) then Write_Str ("constant "); - elsif Can_Never_Be_Null (Typ) then - Write_Str ("not null "); end if; Write_Id (Directly_Designated_Type (Typ)); --- 3866,3880 ---- when Access_Kind => Write_Header (Ekind (Typ) = E_Access_Type); + + if Can_Never_Be_Null (Typ) then + Write_Str ("not null "); + end if; + Write_Str ("access "); if Is_Access_Constant (Typ) then Write_Str ("constant "); end if; Write_Id (Directly_Designated_Type (Typ)); *************** package body Sprint is *** 4322,4333 **** procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is D : constant Uint := Denominator (U); N : constant Uint := Numerator (U); - begin ! Col_Check ! (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); Set_Debug_Sloc; ! UR_Write (U); end Write_Ureal_With_Col_Check_Sloc; end Sprint; --- 4473,4482 ---- procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is D : constant Uint := Denominator (U); N : constant Uint := Numerator (U); begin ! Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); Set_Debug_Sloc; ! UR_Write (U, Brackets => True); end Write_Ureal_With_Col_Check_Sloc; end Sprint; diff -Nrcpad gcc-4.5.2/gcc/ada/sprint.ads gcc-4.6.0/gcc/ada/sprint.ads *** gcc-4.5.2/gcc/ada/sprint.ads Mon Jul 20 13:06:01 2009 --- gcc-4.6.0/gcc/ada/sprint.ads Fri Sep 10 11:01:37 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 32,37 **** --- 32,38 ---- -- tree may either blow up on a debugging check, or list incorrect source. with Types; use Types; + package Sprint is ----------------------- *************** package Sprint is *** 53,60 **** -- Convert wi Rounded_Result target@(source) -- Divide wi Treat_Fixed_As_Integer x #/ y -- Divide wi Rounded_Result x @/ y -- Expression with range check {expression} - -- Operator with range check {operator} (e.g. {+}) -- Free statement free expr [storage_pool = xxx] -- Freeze entity with freeze actions freeze entityname [ actions ] -- Implicit call to run time routine $routine-name --- 54,61 ---- -- Convert wi Rounded_Result target@(source) -- Divide wi Treat_Fixed_As_Integer x #/ y -- Divide wi Rounded_Result x @/ y + -- Expression with actions do action; .. action; in expr end -- Expression with range check {expression} -- Free statement free expr [storage_pool = xxx] -- Freeze entity with freeze actions freeze entityname [ actions ] -- Implicit call to run time routine $routine-name *************** package Sprint is *** 69,80 **** -- Multiple concatenation expr && expr && expr ... && expr -- Multiply wi Treat_Fixed_As_Integer x #* y -- Multiply wi Rounded_Result x @* y -- Others choice for cleanup when all others -- Pop exception label %pop_xxx_exception_label -- Push exception label %push_xxx_exception_label (label) -- Raise xxx error [xxx_error [when cond]] -- Raise xxx error with msg [xxx_error [when cond], "msg"] ! -- Rational literal See UR_Write for details -- Rem wi Treat_Fixed_As_Integer x #rem y -- Reference expression'reference -- Shift nodes shift_name!(expr, count) --- 70,82 ---- -- Multiple concatenation expr && expr && expr ... && expr -- Multiply wi Treat_Fixed_As_Integer x #* y -- Multiply wi Rounded_Result x @* y + -- Operator with range check {operator} (e.g. {+}) -- Others choice for cleanup when all others -- Pop exception label %pop_xxx_exception_label -- Push exception label %push_xxx_exception_label (label) -- Raise xxx error [xxx_error [when cond]] -- Raise xxx error with msg [xxx_error [when cond], "msg"] ! -- Rational literal [expression] -- Rem wi Treat_Fixed_As_Integer x #rem y -- Reference expression'reference -- Shift nodes shift_name!(expr, count) diff -Nrcpad gcc-4.5.2/gcc/ada/stand.ads gcc-4.6.0/gcc/ada/stand.ads *** gcc-4.5.2/gcc/ada/stand.ads Fri Apr 17 13:07:12 2009 --- gcc-4.6.0/gcc/ada/stand.ads Fri Oct 22 10:00:18 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Stand is *** 413,421 **** Universal_Real : Entity_Id; -- Entity for universal real type. The bounds of this type correspond to ! -- to the largest supported real type (i.e. Long_Long_Real). It is the -- type used for runtime calculations in type universal real. Note that ! -- this type is always IEEE format, even if Long_Long_Real is Vax_Float -- (and in that case the bounds don't correspond exactly). Universal_Fixed : Entity_Id; --- 413,421 ---- Universal_Real : Entity_Id; -- Entity for universal real type. The bounds of this type correspond to ! -- to the largest supported real type (i.e. Long_Long_Float). It is the -- type used for runtime calculations in type universal real. Note that ! -- this type is always IEEE format, even if Long_Long_Float is Vax_Float -- (and in that case the bounds don't correspond exactly). Universal_Fixed : Entity_Id; diff -Nrcpad gcc-4.5.2/gcc/ada/style.adb gcc-4.6.0/gcc/ada/style.adb *** gcc-4.5.2/gcc/ada/style.adb Thu Apr 9 12:29:20 2009 --- gcc-4.6.0/gcc/ada/style.adb Fri Jun 18 12:14:52 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Style is *** 78,88 **** begin if Style_Check_Array_Attribute_Index then if D = 1 and then Present (E1) then ! Error_Msg_N ("(style) index number not allowed for one dimensional array", E1); elsif D > 1 and then No (E1) then ! Error_Msg_N ("(style) index number required for multi-dimensional array", N); end if; --- 78,88 ---- begin if Style_Check_Array_Attribute_Index then if D = 1 and then Present (E1) then ! Error_Msg_N -- CODEFIX ("(style) index number not allowed for one dimensional array", E1); elsif D > 1 and then No (E1) then ! Error_Msg_N -- CODEFIX ("(style) index number required for multi-dimensional array", N); end if; *************** package body Style is *** 161,167 **** then Error_Msg_Node_1 := Def; Error_Msg_Sloc := Sloc (Def); ! Error_Msg ("(style) bad casing of & declared#", Sref); return; --- 161,167 ---- then Error_Msg_Node_1 := Def; Error_Msg_Sloc := Sloc (Def); ! Error_Msg -- CODEFIX ("(style) bad casing of & declared#", Sref); return; *************** package body Style is *** 222,228 **** String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)); Set_Casing (Cas); Error_Msg_Name_1 := Name_Enter; ! Error_Msg_N ("(style) bad casing of %% declared in Standard", Ref); end if; end if; --- 222,228 ---- String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)); Set_Casing (Cas); Error_Msg_Name_1 := Name_Enter; ! Error_Msg_N -- CODEFIX ("(style) bad casing of %% declared in Standard", Ref); end if; end if; *************** package body Style is *** 243,252 **** if Style_Check_Missing_Overriding and then Comes_From_Source (N) then if Nkind (N) = N_Subprogram_Body then ! Error_Msg_N ("(style) missing OVERRIDING indicator in body of%", N); else ! Error_Msg_N ("(style) missing OVERRIDING indicator in declaration of%", N); end if; end if; --- 243,252 ---- if Style_Check_Missing_Overriding and then Comes_From_Source (N) then if Nkind (N) = N_Subprogram_Body then ! Error_Msg_N -- CODEFIX ("(style) missing OVERRIDING indicator in body of%", N); else ! Error_Msg_N -- CODEFIX ("(style) missing OVERRIDING indicator in declaration of%", N); end if; end if; *************** package body Style is *** 259,265 **** procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is begin if Style_Check_Order_Subprograms then ! Error_Msg_N ("(style) subprogram body& not in alphabetical order", Name); end if; end Subprogram_Not_In_Alpha_Order; --- 259,265 ---- procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is begin if Style_Check_Order_Subprograms then ! Error_Msg_N -- CODEFIX ("(style) subprogram body& not in alphabetical order", Name); end if; end Subprogram_Not_In_Alpha_Order; diff -Nrcpad gcc-4.5.2/gcc/ada/style.ads gcc-4.6.0/gcc/ada/style.ads *** gcc-4.5.2/gcc/ada/style.ads Wed Jul 22 10:25:57 2009 --- gcc-4.6.0/gcc/ada/style.ads Thu Sep 9 10:32:50 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- diff -Nrcpad gcc-4.5.2/gcc/ada/styleg.adb gcc-4.6.0/gcc/ada/styleg.adb *** gcc-4.5.2/gcc/ada/styleg.adb Wed Oct 28 14:22:09 2009 --- gcc-4.6.0/gcc/ada/styleg.adb Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Styleg is *** 201,207 **** end if; end OK_Boolean_Operand; ! -- Start of processig for Check_Boolean_Operator begin if Style_Check_Boolean_And_Or and then Comes_From_Source (Node) --- 201,208 ---- end if; end OK_Boolean_Operand; ! -- Start of processing for Check_Boolean_Operator ! begin if Style_Check_Boolean_And_Or and then Comes_From_Source (Node) *************** package body Styleg is *** 237,245 **** -- Otherwise we have an error elsif Nkind (Orig) = N_Op_And then ! Error_Msg ("(style) `AND THEN` required", Sloc (Orig)); else ! Error_Msg ("(style) `OR ELSE` required", Sloc (Orig)); end if; end; end if; --- 238,248 ---- -- Otherwise we have an error elsif Nkind (Orig) = N_Op_And then ! Error_Msg -- CODEFIX ! ("(style) `AND THEN` required", Sloc (Orig)); else ! Error_Msg -- CODEFIX ! ("(style) `OR ELSE` required", Sloc (Orig)); end if; end; end if; *************** package body Styleg is *** 434,440 **** if Scan_Ptr > Source_First (Current_Source_File) and then Source (Scan_Ptr - 1) > ' ' then ! Error_Msg_S ("(style) space required"); end if; end if; --- 437,444 ---- if Scan_Ptr > Source_First (Current_Source_File) and then Source (Scan_Ptr - 1) > ' ' then ! Error_Msg_S -- CODEFIX ! ("(style) space required"); end if; end if; *************** package body Styleg is *** 447,453 **** if Source (Scan_Ptr + 2) > ' ' and then not Is_Special_Character (Source (Scan_Ptr + 2)) then ! Error_Msg ("(style) space required", Scan_Ptr + 2); end if; end if; --- 451,458 ---- if Source (Scan_Ptr + 2) > ' ' and then not Is_Special_Character (Source (Scan_Ptr + 2)) then ! Error_Msg -- CODEFIX ! ("(style) space required", Scan_Ptr + 2); end if; end if; *************** package body Styleg is *** 505,511 **** if Is_Box_Comment then Error_Space_Required (Scan_Ptr + 2); else ! Error_Msg ("(style) two spaces required", Scan_Ptr + 2); end if; return; --- 510,517 ---- if Is_Box_Comment then Error_Space_Required (Scan_Ptr + 2); else ! Error_Msg -- CODEFIX ! ("(style) two spaces required", Scan_Ptr + 2); end if; return; *************** package body Styleg is *** 558,569 **** -- We expect one blank line, from the EOF, but no more than one if Blank_Lines = 2 then ! Error_Msg ("(style) blank line not allowed at end of file", Blank_Line_Location); elsif Blank_Lines >= 3 then ! Error_Msg ("(style) blank lines not allowed at end of file", Blank_Line_Location); end if; --- 564,575 ---- -- We expect one blank line, from the EOF, but no more than one if Blank_Lines = 2 then ! Error_Msg -- CODEFIX ("(style) blank line not allowed at end of file", Blank_Line_Location); elsif Blank_Lines >= 3 then ! Error_Msg -- CODEFIX ("(style) blank lines not allowed at end of file", Blank_Line_Location); end if; *************** package body Styleg is *** 590,596 **** procedure Check_HT is begin if Style_Check_Horizontal_Tabs then ! Error_Msg_S ("(style) horizontal tab not allowed"); end if; end Check_HT; --- 596,603 ---- procedure Check_HT is begin if Style_Check_Horizontal_Tabs then ! Error_Msg_S -- CODEFIX ! ("(style) horizontal tab not allowed"); end if; end Check_HT; *************** package body Styleg is *** 608,614 **** if Token_Ptr = First_Non_Blank_Location and then Start_Column rem Style_Check_Indentation /= 0 then ! Error_Msg_SC ("(style) bad indentation"); end if; end if; end Check_Indentation; --- 615,622 ---- if Token_Ptr = First_Non_Blank_Location and then Start_Column rem Style_Check_Indentation /= 0 then ! Error_Msg_SC -- CODEFIX ! ("(style) bad indentation"); end if; end if; end Check_Indentation; *************** package body Styleg is *** 682,690 **** if Style_Check_Form_Feeds then if Source (Scan_Ptr) = ASCII.FF then ! Error_Msg_S ("(style) form feed not allowed"); elsif Source (Scan_Ptr) = ASCII.VT then ! Error_Msg_S ("(style) vertical tab not allowed"); end if; end if; --- 690,700 ---- if Style_Check_Form_Feeds then if Source (Scan_Ptr) = ASCII.FF then ! Error_Msg_S -- CODEFIX ! ("(style) form feed not allowed"); elsif Source (Scan_Ptr) = ASCII.VT then ! Error_Msg_S -- CODEFIX ! ("(style) vertical tab not allowed"); end if; end if; *************** package body Styleg is *** 717,723 **** -- Issue message for blanks at end of line if option enabled if Style_Check_Blanks_At_End and then L < Len then ! Error_Msg ("(style) trailing spaces not permitted", S); end if; --- 727,733 ---- -- Issue message for blanks at end of line if option enabled if Style_Check_Blanks_At_End and then L < Len then ! Error_Msg -- CODEFIX ("(style) trailing spaces not permitted", S); end if; *************** package body Styleg is *** 913,919 **** else if Token = Tok_Then then ! Error_Msg ("(style) no statements may follow THEN on same line", S); else Error_Msg --- 923,929 ---- else if Token = Tok_Then then ! Error_Msg -- CODEFIX ("(style) no statements may follow THEN on same line", S); else Error_Msg *************** package body Styleg is *** 977,983 **** procedure Check_Xtra_Parens (Loc : Source_Ptr) is begin if Style_Check_Xtra_Parens then ! Error_Msg ("redundant parentheses?", Loc); end if; end Check_Xtra_Parens; --- 987,994 ---- procedure Check_Xtra_Parens (Loc : Source_Ptr) is begin if Style_Check_Xtra_Parens then ! Error_Msg -- CODEFIX ! ("redundant parentheses?", Loc); end if; end Check_Xtra_Parens; *************** package body Styleg is *** 996,1002 **** procedure Error_Space_Not_Allowed (S : Source_Ptr) is begin ! Error_Msg ("(style) space not allowed", S); end Error_Space_Not_Allowed; -------------------------- --- 1007,1014 ---- procedure Error_Space_Not_Allowed (S : Source_Ptr) is begin ! Error_Msg -- CODEFIX ! ("(style) space not allowed", S); end Error_Space_Not_Allowed; -------------------------- *************** package body Styleg is *** 1005,1011 **** procedure Error_Space_Required (S : Source_Ptr) is begin ! Error_Msg ("(style) space required", S); end Error_Space_Required; -------------------- --- 1017,1024 ---- procedure Error_Space_Required (S : Source_Ptr) is begin ! Error_Msg -- CODEFIX ! ("(style) space required", S); end Error_Space_Required; -------------------- *************** package body Styleg is *** 1037,1043 **** begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; ! Error_Msg_SP ("(style) `END &` required"); end if; end No_End_Name; --- 1050,1057 ---- begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; ! Error_Msg_SP -- CODEFIX ! ("(style) `END &` required"); end if; end No_End_Name; *************** package body Styleg is *** 1052,1058 **** begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; ! Error_Msg_SP ("(style) `EXIT &` required"); end if; end No_Exit_Name; --- 1066,1073 ---- begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; ! Error_Msg_SP -- CODEFIX ! ("(style) `EXIT &` required"); end if; end No_Exit_Name; *************** package body Styleg is *** 1067,1073 **** procedure Non_Lower_Case_Keyword is begin if Style_Check_Keyword_Casing then ! Error_Msg_SC -- CODEIX ("(style) reserved words must be all lower case"); end if; end Non_Lower_Case_Keyword; --- 1082,1088 ---- procedure Non_Lower_Case_Keyword is begin if Style_Check_Keyword_Casing then ! Error_Msg_SC -- CODEFIX ("(style) reserved words must be all lower case"); end if; end Non_Lower_Case_Keyword; diff -Nrcpad gcc-4.5.2/gcc/ada/styleg.ads gcc-4.6.0/gcc/ada/styleg.ads *** gcc-4.5.2/gcc/ada/styleg.ads Wed Jul 22 10:25:57 2009 --- gcc-4.6.0/gcc/ada/styleg.ads Thu Sep 9 10:32:50 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- diff -Nrcpad gcc-4.5.2/gcc/ada/stylesw.adb gcc-4.6.0/gcc/ada/stylesw.adb *** gcc-4.5.2/gcc/ada/stylesw.adb Wed Jul 22 13:16:44 2009 --- gcc-4.6.0/gcc/ada/stylesw.adb Thu Sep 9 10:32:50 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Stylesw is *** 59,64 **** --- 59,69 ---- "u" & -- check no unnecessary blank lines "x"; -- check extra parentheses around conditionals + -- Note: we intend GNAT_Style to also include the following, but we do + -- not yet have the whole tool suite clean with respect to this. + + -- "B" & -- check boolean operators + ------------------------------- -- Reset_Style_Check_Options -- ------------------------------- diff -Nrcpad gcc-4.5.2/gcc/ada/stylesw.ads gcc-4.6.0/gcc/ada/stylesw.ads *** gcc-4.5.2/gcc/ada/stylesw.ads Wed Jul 22 10:25:57 2009 --- gcc-4.6.0/gcc/ada/stylesw.ads Thu Sep 9 10:32:50 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- diff -Nrcpad gcc-4.5.2/gcc/ada/switch-b.adb gcc-4.6.0/gcc/ada/switch-b.adb *** gcc-4.5.2/gcc/ada/switch-b.adb Thu Apr 9 10:38:54 2009 --- gcc-4.6.0/gcc/ada/switch-b.adb Wed Jun 23 06:11:20 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2010, 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- -- *************** *** 23,31 **** -- -- ------------------------------------------------------------------------------ ! with Debug; use Debug; ! with Osint; use Osint; ! with Opt; use Opt; with System.WCh_Con; use System.WCh_Con; --- 23,32 ---- -- -- ------------------------------------------------------------------------------ ! with Debug; use Debug; ! with Osint; use Osint; ! with Opt; use Opt; ! with Output; use Output; with System.WCh_Con; use System.WCh_Con; *************** package body Switch.B is *** 40,48 **** Ptr : Integer := Switch_Chars'First; C : Character := ' '; function Get_Stack_Size (S : Character) return Int; ! -- Used for -d and -D to scan stack size including handling k/m. ! -- S is set to 'd' or 'D' to indicate the switch being scanned. -------------------- -- Get_Stack_Size -- --- 41,75 ---- Ptr : Integer := Switch_Chars'First; C : Character := ' '; + function Get_Optional_Filename return String_Ptr; + -- If current character is '=', return a newly allocated string that + -- contains the remainder of the current switch (after the '='), else + -- return null. + function Get_Stack_Size (S : Character) return Int; ! -- Used for -d and -D to scan stack size including handling k/m. S is ! -- set to 'd' or 'D' to indicate the switch being scanned. ! ! --------------------------- ! -- Get_Optional_Filename -- ! --------------------------- ! ! function Get_Optional_Filename return String_Ptr is ! Result : String_Ptr; ! ! begin ! if Ptr <= Max and then Switch_Chars (Ptr) = '=' then ! if Ptr = Max then ! Bad_Switch (Switch_Chars); ! else ! Result := new String'(Switch_Chars (Ptr + 1 .. Max)); ! Ptr := Max + 1; ! return Result; ! end if; ! end if; ! ! return null; ! end Get_Optional_Filename; -------------------- -- Get_Stack_Size -- *************** package body Switch.B is *** 61,71 **** pragma Unsuppress (Overflow_Check); begin ! -- Check for additional character 'k' (for kilobytes) or 'm' ! -- (for Megabytes), but only if we have not reached the end ! -- of the switch string. Note that if this appears before the ! -- end of the string we will get an error when we test to make ! -- sure that the string is exhausted (at the end of the case). if Ptr <= Max then if Switch_Chars (Ptr) = 'k' then --- 88,98 ---- pragma Unsuppress (Overflow_Check); begin ! -- Check for additional character 'k' (for kilobytes) or 'm' (for ! -- Megabytes), but only if we have not reached the end of the ! -- switch string. Note that if this appears before the end of the ! -- string we will get an error when we test to make sure that the ! -- string is exhausted (at the end of the case). if Ptr <= Max then if Switch_Chars (Ptr) = 'k' then *************** package body Switch.B is *** 97,104 **** Ptr := Ptr + 1; end if; ! -- A little check, "gnat" at the start of a switch is not allowed ! -- except for the compiler if Switch_Chars'Last >= Ptr + 3 and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" --- 124,131 ---- Ptr := Ptr + 1; end if; ! -- A little check, "gnat" at the start of a switch is not allowed except ! -- for the compiler if Switch_Chars'Last >= Ptr + 3 and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" *************** package body Switch.B is *** 124,130 **** when 'A' => Ptr := Ptr + 1; ! Ada_Bind_File := True; -- Processing for b switch --- 151,158 ---- when 'A' => Ptr := Ptr + 1; ! Output_ALI_List := True; ! ALI_List_Filename := Get_Optional_Filename; -- Processing for b switch *************** package body Switch.B is *** 136,151 **** when 'c' => Ptr := Ptr + 1; - Check_Only := True; -- Processing for C switch when 'C' => Ptr := Ptr + 1; - Ada_Bind_File := False; -- Processing for d switch when 'd' => --- 164,179 ---- when 'c' => Ptr := Ptr + 1; Check_Only := True; -- Processing for C switch when 'C' => Ptr := Ptr + 1; Ada_Bind_File := False; + Write_Line ("warning: gnatbind switch -C is obsolescent"); + -- Processing for d switch when 'd' => *************** package body Switch.B is *** 243,248 **** --- 271,290 ---- Ptr := Ptr + 1; Usage_Requested := True; + -- Processing for H switch + + when 'H' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Scan_Nat (Switch_Chars, Max, Ptr, Heap_Size, C); + + if Heap_Size /= 32 and then Heap_Size /= 64 then + Bad_Switch (Switch_Chars); + end if; + -- Processing for i switch when 'i' => *************** package body Switch.B is *** 253,259 **** Ptr := Ptr + 1; C := Switch_Chars (Ptr); ! if C in '1' .. '5' or else C = '8' or else C = 'p' or else C = 'f' --- 295,301 ---- Ptr := Ptr + 1; C := Switch_Chars (Ptr); ! if C in '1' .. '5' or else C = '8' or else C = 'p' or else C = 'f' *************** package body Switch.B is *** 305,311 **** if Output_File_Name_Present then Osint.Fail ("duplicate -o switch"); - else Output_File_Name_Present := True; end if; --- 347,352 ---- *************** package body Switch.B is *** 315,320 **** --- 356,362 ---- when 'O' => Ptr := Ptr + 1; Output_Object_List := True; + Object_List_Filename := Get_Optional_Filename; -- Processing for p switch *************** package body Switch.B is *** 338,344 **** when 'R' => Ptr := Ptr + 1; - Check_Only := True; List_Closure := True; -- Processing for s switch --- 380,385 ---- *************** package body Switch.B is *** 400,406 **** Ptr := Ptr + 1; case Switch_Chars (Ptr) is - when 'e' => Warning_Mode := Treat_As_Error; --- 441,446 ---- *************** package body Switch.B is *** 433,440 **** Wide_Character_Encoding_Method_Specified := True; Upper_Half_Encoding := ! Wide_Character_Encoding_Method in ! WC_Upper_Half_Encoding_Method; Ptr := Ptr + 1; --- 473,479 ---- Wide_Character_Encoding_Method_Specified := True; Upper_Half_Encoding := ! Wide_Character_Encoding_Method in WC_Upper_Half_Encoding_Method; Ptr := Ptr + 1; *************** package body Switch.B is *** 486,492 **** Osint.Fail ("missing path for --RTS"); else ! -- valid --RTS switch Opt.No_Stdinc := True; Opt.RTS_Switch := True; --- 525,531 ---- Osint.Fail ("missing path for --RTS"); else ! -- Valid --RTS switch Opt.No_Stdinc := True; Opt.RTS_Switch := True; *************** package body Switch.B is *** 508,515 **** Lib_Path_Name /= null then -- Set the RTS_*_Path_Name variables, so that the ! -- correct directories will be set when ! -- Osint.Add_Default_Search_Dirs will be called later. RTS_Src_Path_Name := Src_Path_Name; RTS_Lib_Path_Name := Lib_Path_Name; --- 547,554 ---- Lib_Path_Name /= null then -- Set the RTS_*_Path_Name variables, so that the ! -- correct directories will be set when a subsequent ! -- call Osint.Add_Default_Search_Dirs is made. RTS_Src_Path_Name := Src_Path_Name; RTS_Lib_Path_Name := Lib_Path_Name; diff -Nrcpad gcc-4.5.2/gcc/ada/switch-c.adb gcc-4.6.0/gcc/ada/switch-c.adb *** gcc-4.5.2/gcc/ada/switch-c.adb Tue Jan 26 13:49:56 2010 --- gcc-4.6.0/gcc/ada/switch-c.adb Tue Oct 26 13:00:05 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2010, 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- -- *************** with Validsw; use Validsw; *** 32,39 **** with Sem_Warn; use Sem_Warn; with Stylesw; use Stylesw; ! with System.OS_Lib; use System.OS_Lib; ! with System.WCh_Con; use System.WCh_Con; package body Switch.C is --- 32,38 ---- with Sem_Warn; use Sem_Warn; with Stylesw; use Stylesw; ! with System.Strings; with System.WCh_Con; use System.WCh_Con; package body Switch.C is *************** package body Switch.C is *** 41,51 **** RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= flag ----------------------------- -- Scan_Front_End_Switches -- ----------------------------- ! procedure Scan_Front_End_Switches (Switch_Chars : String) is First_Switch : Boolean := True; -- False for all but first switch --- 40,64 ---- RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= flag + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean; + -- This function is called from Scan_Front_End_Switches. It determines if + -- the switch currently being scanned is followed by a switch of the form + -- "-gnat-" & C, where C is the argument. If so, then True is returned, + -- and Scan_Front_End_Switches will cancel the effect of the switch. If + -- no such switch is found, False is returned. + ----------------------------- -- Scan_Front_End_Switches -- ----------------------------- ! procedure Scan_Front_End_Switches ! (Switch_Chars : String; ! Args : Argument_List; ! Arg_Rank : Positive) ! is First_Switch : Boolean := True; -- False for all but first switch *************** package body Switch.C is *** 232,238 **** when 'C' => Ptr := Ptr + 1; ! CodePeer_Mode := True; -- Processing for d switch --- 245,263 ---- when 'C' => Ptr := Ptr + 1; ! ! if not CodePeer_Mode then ! CodePeer_Mode := True; ! ! -- Suppress compiler warnings by default, since what we are ! -- interested in here is what CodePeer can find out. Note ! -- that if -gnatwxxx is specified after -gnatC on the ! -- command line, we do not want to override this setting in ! -- Adjust_Global_Switches, and assume that the user wants to ! -- get both warnings from GNAT and CodePeer messages. ! ! Warning_Mode := Suppress; ! end if; -- Processing for d switch *************** package body Switch.C is *** 397,402 **** --- 422,433 ---- ("-gnateD" & Switch_Chars (Ptr .. Max)); Ptr := Max + 1; + -- -gnateE (extra exception information) + + when 'E' => + Exception_Extra_Info := True; + Ptr := Ptr + 1; + -- -gnatef (full source path for brief error messages) when 'f' => *************** package body Switch.C is *** 464,469 **** --- 495,505 ---- Ptr := Max + 1; + -- -gnateP (Treat pragma Pure/Preelaborate errs as warnings) + + when 'P' => + Treat_Categorization_Errors_As_Warnings := True; + -- -gnatez (final delimiter of explicit switches) -- All switches that come after -gnatez have been added by *************** package body Switch.C is *** 519,529 **** System_Extend_Unit := Empty; Warning_Mode := Treat_As_Error; ! -- Set Ada 2005 mode explicitly. We don't want to rely on the -- implicit setting here, since for example, we want -- Preelaborate_05 treated as Preelaborate ! Ada_Version := Ada_05; Ada_Version_Explicit := Ada_Version; -- Set default warnings and style checks for -gnatg --- 555,565 ---- System_Extend_Unit := Empty; Warning_Mode := Treat_As_Error; ! -- Set Ada 2012 mode explicitly. We don't want to rely on the -- implicit setting here, since for example, we want -- Preelaborate_05 treated as Preelaborate ! Ada_Version := Ada_2012; Ada_Version_Explicit := Ada_Version; -- Set default warnings and style checks for -gnatg *************** package body Switch.C is *** 662,681 **** when 'p' => Ptr := Ptr + 1; ! -- Set all specific options as well as All_Checks in the ! -- Suppress_Options array, excluding Elaboration_Check, since ! -- this is treated specially because we do not want -gnatp to ! -- disable static elaboration processing. ! for J in Suppress_Options'Range loop ! if J /= Elaboration_Check then ! Suppress_Options (J) := True; ! end if; ! end loop; ! Validity_Checks_On := False; ! Opt.Suppress_Checks := True; ! Opt.Enable_Overflow_Checks := False; -- Processing for P switch --- 698,724 ---- when 'p' => Ptr := Ptr + 1; ! -- Skip processing if cancelled by subsequent -gnat-p ! if Switch_Subsequently_Cancelled ("p", Args, Arg_Rank) then ! Store_Switch := False; ! else ! -- Set all specific options as well as All_Checks in the ! -- Suppress_Options array, excluding Elaboration_Check, ! -- since this is treated specially because we do not want ! -- -gnatp to disable static elaboration processing. ! ! for J in Suppress_Options'Range loop ! if J /= Elaboration_Check then ! Suppress_Options (J) := True; ! end if; ! end loop; ! ! Validity_Checks_On := False; ! Opt.Suppress_Checks := True; ! Opt.Enable_Overflow_Checks := False; ! end if; -- Processing for P switch *************** package body Switch.C is *** 882,888 **** when 'X' => Ptr := Ptr + 1; ! Extensions_Allowed := True; -- Processing for y switch --- 925,933 ---- when 'X' => Ptr := Ptr + 1; ! Extensions_Allowed := True; ! Ada_Version := Ada_Version_Type'Last; ! Ada_Version_Explicit := Ada_Version_Type'Last; -- Processing for y switch *************** package body Switch.C is *** 933,938 **** --- 978,984 ---- -- Processing for z switch when 'z' => + -- -gnatz must be the first and only switch in Switch_Chars, -- and is a two-letter switch. *************** package body Switch.C is *** 1023,1037 **** Bad_Switch ("-gnat0" & Switch_Chars (Ptr .. Max)); else Ptr := Ptr + 1; ! Ada_Version := Ada_05; Ada_Version_Explicit := Ada_Version; end if; ! -- Ignore extra switch character - when '/' | '-' => Ptr := Ptr + 1; -- Anything else is an error (illegal switch character) when others => --- 1069,1140 ---- Bad_Switch ("-gnat0" & Switch_Chars (Ptr .. Max)); else Ptr := Ptr + 1; ! Ada_Version := Ada_2005; Ada_Version_Explicit := Ada_Version; end if; ! -- Processing for 12 switch ! ! when '1' => ! if Ptr = Max then ! Bad_Switch ("-gnat1"); ! end if; Ptr := Ptr + 1; + if Switch_Chars (Ptr) /= '2' then + Bad_Switch ("-gnat1" & Switch_Chars (Ptr .. Max)); + else + Ptr := Ptr + 1; + Ada_Version := Ada_2012; + Ada_Version_Explicit := Ada_Version; + end if; + + -- Processing for 2005 and 2012 switches + + when '2' => + if Ptr > Max - 3 then + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Max)); + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2005" then + Ada_Version := Ada_2005; + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then + Ada_Version := Ada_2012; + + else + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3)); + end if; + + Ada_Version_Explicit := Ada_Version; + Ptr := Ptr + 4; + + -- Switch cancellation, currently only -gnat-p is allowed. + -- All we do here is the error checking, since the actual + -- processing for switch cancellation is done by calls to + -- Switch_Subsequently_Cancelled at the appropriate point. + + when '-' => + + -- Simple ignore -gnat-p + + if Switch_Chars = "-gnat-p" then + return; + + -- Any other occurrence of minus is ignored. This is for + -- maximum compatibility with previous version which ignored + -- all occurrences of minus. + + else + Store_Switch := False; + Ptr := Ptr + 1; + end if; + + -- We ignore '/' in switches, this is historical, still needed??? + + when '/' => + Store_Switch := False; + -- Anything else is an error (illegal switch character) when others => *************** package body Switch.C is *** 1048,1051 **** --- 1151,1179 ---- end if; end Scan_Front_End_Switches; + ----------------------------------- + -- Switch_Subsequently_Cancelled -- + ----------------------------------- + + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean + is + use type System.Strings.String_Access; + + begin + -- Loop through arguments following the current one + + for Arg in Arg_Rank + 1 .. Args'Last loop + if Args (Arg).all = "-gnat-" & C then + return True; + end if; + end loop; + + -- No match found, not cancelled + + return False; + end Switch_Subsequently_Cancelled; + end Switch.C; diff -Nrcpad gcc-4.5.2/gcc/ada/switch-c.ads gcc-4.6.0/gcc/ada/switch-c.ads *** gcc-4.5.2/gcc/ada/switch-c.ads Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/switch-c.ads Thu Jun 17 09:06:41 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-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- -- *************** *** 29,43 **** -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. package Switch.C is ! procedure Scan_Front_End_Switches (Switch_Chars : String); -- Procedures to scan out front end switches stored in the given string. -- The first character is known to be a valid switch character, and there -- are no blanks or other switch terminator characters in the string, so -- the entire string should consist of valid switch characters, except that -- an optional terminating NUL character is allowed. A bad switch causes -- a fatal error exit and control does not return. The call also sets ! -- Usage_Requested to True if a ? switch is encountered. end Switch.C; --- 29,52 ---- -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. + with System.OS_Lib; use System.OS_Lib; + package Switch.C is ! procedure Scan_Front_End_Switches ! (Switch_Chars : String; ! Args : Argument_List; ! Arg_Rank : Positive); -- Procedures to scan out front end switches stored in the given string. -- The first character is known to be a valid switch character, and there -- are no blanks or other switch terminator characters in the string, so -- the entire string should consist of valid switch characters, except that -- an optional terminating NUL character is allowed. A bad switch causes -- a fatal error exit and control does not return. The call also sets ! -- Usage_Requested to True if a switch -gnath is encountered. ! -- ! -- Args is the full list of command line arguments. Arg_Rank is the ! -- position of the switch in Args. It is used for certain switches -gnatx ! -- to check if a subsequent switch -gnat-x cancels the switch -gnatx. end Switch.C; diff -Nrcpad gcc-4.5.2/gcc/ada/switch-m.adb gcc-4.6.0/gcc/ada/switch-m.adb *** gcc-4.5.2/gcc/ada/switch-m.adb Fri Oct 30 13:27:40 2009 --- gcc-4.6.0/gcc/ada/switch-m.adb Tue Oct 12 13:05:11 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2001-2010, 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- -- *************** with Makeutl; use Makeutl; *** 28,36 **** with Osint; use Osint; with Opt; use Opt; with Prj; use Prj; ! with Prj.Ext; use Prj.Ext; with Table; package body Switch.M is package Normalized_Switches is new Table.Table --- 28,38 ---- with Osint; use Osint; with Opt; use Opt; with Prj; use Prj; ! with Prj.Env; use Prj.Env; with Table; + with System.Multiprocessors; use System.Multiprocessors; + package body Switch.M is package Normalized_Switches is new Table.Table *************** package body Switch.M is *** 71,77 **** procedure Add_Switch_Component (S : String); -- Add a new String_Access component in Switches. If a string equal -- to S is already stored in the table Normalized_Switches, use it. ! -- Other wise add a new component to the table. -------------------------- -- Add_Switch_Component -- --- 73,79 ---- procedure Add_Switch_Component (S : String); -- Add a new String_Access component in Switches. If a string equal -- to S is already stored in the table Normalized_Switches, use it. ! -- Otherwise add a new component to the table. -------------------------- -- Add_Switch_Component -- *************** package body Switch.M is *** 215,224 **** -- One-letter switches ! when 'a' | 'A' | 'b' | 'c' | 'D' | 'E' | 'f' | ! 'F' | 'g' | 'h' | 'H' | 'k' | 'l' | 'L' | 'n' | 'N' | ! 'o' | 'O' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 't' | ! 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => Storing (First_Stored) := C; Add_Switch_Component (Storing (Storing'First .. First_Stored)); --- 217,226 ---- -- One-letter switches ! when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | ! 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'n' | 'N' | ! 'o' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | ! 't' | 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => Storing (First_Stored) := C; Add_Switch_Component (Storing (Storing'First .. First_Stored)); *************** package body Switch.M is *** 226,235 **** -- One-letter switches followed by a positive number ! when 'm' | 'T' => Storing (First_Stored) := C; Last_Stored := First_Stored; loop Ptr := Ptr + 1; exit when Ptr > Max --- 228,241 ---- -- One-letter switches followed by a positive number ! when 'D' | 'G' | 'j' | 'k' | 'm' | 'T' => Storing (First_Stored) := C; Last_Stored := First_Stored; + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + loop Ptr := Ptr + 1; exit when Ptr > Max *************** package body Switch.M is *** 268,330 **** when 'e' => ! -- Store -gnateD, -gnatep= and -gnateG in the ALI file. ! -- The other -gnate switches do not need to be stored. Storing (First_Stored) := 'e'; Ptr := Ptr + 1; ! if Ptr > Max ! or else (Switch_Chars (Ptr) /= 'D' ! and then Switch_Chars (Ptr) /= 'G' ! and then Switch_Chars (Ptr) /= 'p') ! then Last := 0; return; - end if; ! -- Processing for -gnateD ! if Switch_Chars (Ptr) = 'D' then ! Storing (First_Stored + 1 .. ! First_Stored + Max - Ptr + 1) := ! Switch_Chars (Ptr .. Max); ! Add_Switch_Component ! (Storing (Storing'First .. ! First_Stored + Max - Ptr + 1)); ! -- Processing for -gnatep= ! elsif Switch_Chars (Ptr) = 'p' then ! Ptr := Ptr + 1; ! if Ptr = Max then ! Last := 0; ! return; ! end if; ! if Switch_Chars (Ptr) = '=' then ! Ptr := Ptr + 1; ! end if; ! -- To normalize, always put a '=' after -gnatep. ! -- Because that could lengthen the switch string, ! -- declare a local variable. ! declare ! To_Store : String (1 .. Max - Ptr + 9); ! begin ! To_Store (1 .. 8) := "-gnatep="; ! To_Store (9 .. Max - Ptr + 9) := ! Switch_Chars (Ptr .. Max); ! Add_Switch_Component (To_Store); ! end; ! elsif Switch_Chars (Ptr) = 'G' then ! Add_Switch_Component ("-gnateG"); ! end if; ! return; when 'i' => Storing (First_Stored) := 'i'; --- 274,366 ---- when 'e' => ! -- Some of the gnate... switches are not stored Storing (First_Stored) := 'e'; Ptr := Ptr + 1; ! if Ptr > Max then Last := 0; return; ! else ! case Switch_Chars (Ptr) is ! when 'D' => ! Storing (First_Stored + 1 .. ! First_Stored + Max - Ptr + 1) := ! Switch_Chars (Ptr .. Max); ! Add_Switch_Component ! (Storing (Storing'First .. ! First_Stored + Max - Ptr + 1)); ! Ptr := Max + 1; ! when 'G' => ! Ptr := Ptr + 1; ! Add_Switch_Component ("-gnateG"); ! when 'I' => ! Ptr := Ptr + 1; ! declare ! First : constant Positive := Ptr - 1; ! begin ! if Ptr <= Max and then ! Switch_Chars (Ptr) = '=' ! then ! Ptr := Ptr + 1; ! end if; ! while Ptr <= Max and then ! Switch_Chars (Ptr) in '0' .. '9' ! loop ! Ptr := Ptr + 1; ! end loop; ! Storing (First_Stored + 1 .. ! First_Stored + Ptr - First) := ! Switch_Chars (First .. Ptr - 1); ! Add_Switch_Component ! (Storing (Storing'First .. ! First_Stored + Ptr - First)); ! end; ! when 'p' => ! Ptr := Ptr + 1; ! if Ptr = Max then ! Last := 0; ! return; ! end if; ! if Switch_Chars (Ptr) = '=' then ! Ptr := Ptr + 1; ! end if; ! ! -- To normalize, always put a '=' after ! -- -gnatep. Because that could lengthen the ! -- switch string, declare a local variable. ! ! declare ! To_Store : String (1 .. Max - Ptr + 9); ! begin ! To_Store (1 .. 8) := "-gnatep="; ! To_Store (9 .. Max - Ptr + 9) := ! Switch_Chars (Ptr .. Max); ! Add_Switch_Component (To_Store); ! end; ! ! return; ! ! when 'S' => ! Ptr := Ptr + 1; ! Add_Switch_Component ("-gnateS"); ! ! when others => ! Last := 0; ! return; ! end case; ! end if; when 'i' => Storing (First_Stored) := 'i'; *************** package body Switch.M is *** 355,360 **** --- 391,410 ---- return; end if; + -- -gnatl may be -gnatl= + + when 'l' => + Ptr := Ptr + 1; + + if Ptr > Max or else Switch_Chars (Ptr) /= '=' then + Add_Switch_Component ("-gnatl"); + + else + Add_Switch_Component + ("-gnatl" & Switch_Chars (Ptr .. Max)); + return; + end if; + -- -gnatR may be followed by '0', '1', '2' or '3', -- then by 's' *************** package body Switch.M is *** 390,395 **** --- 440,465 ---- Add_Switch_Component (Storing (Storing'First .. Last_Stored)); + -- -gnatWx, x = 'h'. 'u', 's', 'e', '8' or 'b' + + when 'W' => + Storing (First_Stored) := 'W'; + Ptr := Ptr + 1; + + if Ptr <= Max then + case Switch_Chars (Ptr) is + when 'h' | 'u' | 's' | 'e' | '8' | 'b' => + Storing (First_Stored + 1) := Switch_Chars (Ptr); + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 1)); + Ptr := Ptr + 1; + + when others => + Last := 0; + return; + end case; + end if; + -- Multiple switches when 'V' | 'w' | 'y' => *************** package body Switch.M is *** 584,597 **** (Switch_Chars'First + Subdirs_Option'Length .. Switch_Chars'Last)); elsif Switch_Chars (Ptr) = '-' then Bad_Switch (Switch_Chars); elsif Switch_Chars'Length > 3 and then Switch_Chars (Ptr .. Ptr + 1) = "aP" then ! Add_Search_Project_Directory ! (Project_Node_Tree, Switch_Chars (Ptr + 2 .. Switch_Chars'Last)); elsif C = 'v' and then Switch_Chars'Length = 3 then --- 654,673 ---- (Switch_Chars'First + Subdirs_Option'Length .. Switch_Chars'Last)); + elsif Switch_Chars = Makeutl.Unchecked_Shared_Lib_Imports then + Opt.Unchecked_Shared_Lib_Imports := True; + + elsif Switch_Chars = Makeutl.Single_Compile_Per_Obj_Dir_Switch then + Opt.One_Compilation_Per_Obj_Dir := True; + elsif Switch_Chars (Ptr) = '-' then Bad_Switch (Switch_Chars); elsif Switch_Chars'Length > 3 and then Switch_Chars (Ptr .. Ptr + 1) = "aP" then ! Add_Directories ! (Project_Node_Tree.Project_Path, Switch_Chars (Ptr + 2 .. Switch_Chars'Last)); elsif C = 'v' and then Switch_Chars'Length = 3 then *************** package body Switch.M is *** 677,690 **** Ptr := Ptr + 1; declare ! Max_Proc : Pos; begin ! Scan_Pos (Switch_Chars, Max, Ptr, Max_Proc, C); if Ptr <= Max then Bad_Switch (Switch_Chars); else Maximum_Processes := Positive (Max_Proc); end if; end; --- 753,775 ---- Ptr := Ptr + 1; declare ! Max_Proc : Nat; ! begin ! Scan_Nat (Switch_Chars, Max, Ptr, Max_Proc, C); if Ptr <= Max then Bad_Switch (Switch_Chars); else + if Max_Proc = 0 then + Max_Proc := Nat (Number_Of_CPUs); + + if Max_Proc = 0 then + Max_Proc := 1; + end if; + end if; + Maximum_Processes := Positive (Max_Proc); end if; end; *************** package body Switch.M is *** 739,745 **** -- Processing for C switch when 'C' => ! Create_Mapping_File := True; -- Processing for D switch --- 824,830 ---- -- Processing for C switch when 'C' => ! Opt.Create_Mapping_File := True; -- Processing for D switch *************** package body Switch.M is *** 839,844 **** --- 924,930 ---- when 'x' => External_Unit_Compilation_Allowed := True; + Use_Include_Path_File := True; -- Processing for z switch diff -Nrcpad gcc-4.5.2/gcc/ada/switch-m.ads gcc-4.6.0/gcc/ada/switch-m.ads *** gcc-4.5.2/gcc/ada/switch-m.ads Mon Nov 30 09:36:20 2009 --- gcc-4.6.0/gcc/ada/switch-m.ads Tue Jun 22 13:26:32 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2001-2010, 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- -- *************** *** 29,35 **** --- 29,39 ---- -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. + pragma Warnings (Off); + -- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; + pragma Warnings (On); + with Prj.Tree; package Switch.M is diff -Nrcpad gcc-4.5.2/gcc/ada/switch.ads gcc-4.6.0/gcc/ada/switch.ads *** gcc-4.5.2/gcc/ada/switch.ads Sun May 24 09:14:53 2009 --- gcc-4.6.0/gcc/ada/switch.ads Mon Dec 20 07:26:57 2010 *************** package Switch is *** 75,81 **** function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean; -- Returns True iff Switch_Chars represents an internal GCC switch to be -- followed by a single argument, such as -dumpbase, --param or -auxbase. ! -- Eventhough passed by the "gcc" driver, these need not be stored in ALI -- files and may safely be ignored by non GCC back-ends. function Switch_Last (Switch_Chars : String) return Natural; --- 75,81 ---- function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean; -- Returns True iff Switch_Chars represents an internal GCC switch to be -- followed by a single argument, such as -dumpbase, --param or -auxbase. ! -- Even though passed by the "gcc" driver, these need not be stored in ALI -- files and may safely be ignored by non GCC back-ends. function Switch_Last (Switch_Chars : String) return Natural; *************** private *** 98,104 **** -- Returns True if an integer is at the current scan location or an equal -- sign. This is used as a guard for calling Scan_Nat. Switch_Chars is the -- string containing the switch, and Ptr points just past the switch ! -- character. Max is the maximum alllowed value of Ptr. procedure Scan_Nat (Switch_Chars : String; --- 98,104 ---- -- Returns True if an integer is at the current scan location or an equal -- sign. This is used as a guard for calling Scan_Nat. Switch_Chars is the -- string containing the switch, and Ptr points just past the switch ! -- character. Max is the maximum allowed value of Ptr. procedure Scan_Nat (Switch_Chars : String; *************** private *** 109,115 **** -- Scan natural integer parameter for switch. On entry, Ptr points just -- past the switch character, on exit it points past the last digit of the -- integer value. Max is the maximum allowed value of Ptr, so the scan is ! -- restricted to Switch_Chars (Ptr .. Max). It is posssible for Ptr to be -- one greater than Max on return if the entire string is digits. Scan_Nat -- will skip an optional equal sign if it is present. Nat_Present must be -- True, or an error will be signalled. --- 109,115 ---- -- Scan natural integer parameter for switch. On entry, Ptr points just -- past the switch character, on exit it points past the last digit of the -- integer value. Max is the maximum allowed value of Ptr, so the scan is ! -- restricted to Switch_Chars (Ptr .. Max). It is possible for Ptr to be -- one greater than Max on return if the entire string is digits. Scan_Nat -- will skip an optional equal sign if it is present. Nat_Present must be -- True, or an error will be signalled. diff -Nrcpad gcc-4.5.2/gcc/ada/symbols-processing-vms-alpha.adb gcc-4.6.0/gcc/ada/symbols-processing-vms-alpha.adb *** gcc-4.5.2/gcc/ada/symbols-processing-vms-alpha.adb Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/symbols-processing-vms-alpha.adb Fri Sep 10 13:29:36 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2007, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 2003-2010, 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- -- *************** package body Processing is *** 31,50 **** type Number is mod 2**16; -- 16 bits unsigned number for number of characters GSD : constant Number := 10; -- Code for the Global Symbol Definition section C_SYM : constant Number := 1; -- Code for a Symbol subsection ! V_DEF_Mask : constant Number := 2**1; ! V_NORM_Mask : constant Number := 2**6; B : Byte; Number_Of_Characters : Natural := 0; -- The number of characters of each section -- The following variables are used by procedure Process when reading an -- object file. --- 31,60 ---- type Number is mod 2**16; -- 16 bits unsigned number for number of characters + EMH : constant Number := 8; + -- Code for the Module Header section + GSD : constant Number := 10; -- Code for the Global Symbol Definition section C_SYM : constant Number := 1; -- Code for a Symbol subsection ! V_DEF_Mask : constant Number := 2 ** 1; ! V_NORM_Mask : constant Number := 2 ** 6; ! -- Comments ??? B : Byte; Number_Of_Characters : Natural := 0; -- The number of characters of each section + Native_Format : Boolean; + -- True if records are decoded by the system (like on VMS) + + Has_Pad : Boolean; + -- If true, a pad byte must be skipped before reading the next record + -- The following variables are used by procedure Process when reading an -- object file. *************** package body Processing is *** 114,138 **** Success := True; -- Get the different sections one by one from the object file while not End_Of_File (File) loop Get (Code); Get (Number_Of_Characters); Number_Of_Characters := Number_Of_Characters - 4; -- If this is not a Global Symbol Definition section, skip to the -- next section. if Code /= GSD then - for J in 1 .. Number_Of_Characters loop Read (File, B); end loop; else - -- Skip over the next 4 bytes Get (Dummy); --- 124,205 ---- Success := True; + -- Check the file format in case of cross-tool + + Get (Code); + Get (Number_Of_Characters); + Get (Dummy); + + if Code = Dummy and then Number_Of_Characters = Natural (EMH) then + + -- Looks like a cross tool + + Native_Format := False; + Number_Of_Characters := Natural (Dummy) - 4; + Has_Pad := (Number_Of_Characters mod 2) = 1; + + elsif Code = EMH then + Native_Format := True; + Number_Of_Characters := Number_Of_Characters - 6; + Has_Pad := False; + + else + Put_Line ("file """ & Object_File & """ is not an object file"); + Close (File); + Success := False; + return; + end if; + + -- Skip the EMH section + + for J in 1 .. Number_Of_Characters loop + Read (File, B); + end loop; + -- Get the different sections one by one from the object file while not End_Of_File (File) loop + if not Native_Format then + + -- Skip pad byte if present + + if Has_Pad then + Get (B); + end if; + + -- Skip record length + + Get (Dummy); + end if; + Get (Code); Get (Number_Of_Characters); + + if not Native_Format then + if Natural (Dummy) /= Number_Of_Characters then + + -- Format error + + raise Constraint_Error; + end if; + + Has_Pad := (Number_Of_Characters mod 2) = 1; + end if; + + -- The header is 4 bytes length + Number_Of_Characters := Number_Of_Characters - 4; -- If this is not a Global Symbol Definition section, skip to the -- next section. if Code /= GSD then for J in 1 .. Number_Of_Characters loop Read (File, B); end loop; else -- Skip over the next 4 bytes Get (Dummy); *************** package body Processing is *** 149,158 **** Number_Of_Characters := Number_Of_Characters - 8; Nchars := Nchars - 8; ! -- If this is a symbol and the V_DEF flag is set, get the ! -- symbol. if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then -- First, reach the symbol length for J in 1 .. 25 loop --- 216,225 ---- Number_Of_Characters := Number_Of_Characters - 8; Nchars := Nchars - 8; ! -- If this is a symbol and the V_DEF flag is set, get symbol if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then + -- First, reach the symbol length for J in 1 .. 25 loop *************** package body Processing is *** 169,174 **** --- 236,242 ---- for J in 1 .. Nchars loop Read (File, B); Number_Of_Characters := Number_Of_Characters - 1; + if Length > 0 then LSymb := LSymb + 1; Symbol (LSymb) := B; *************** package body Processing is *** 204,210 **** if (Flags and V_NORM_Mask) = 0 then S_Data.Kind := Data; - else S_Data.Kind := Proc; end if; --- 272,277 ---- *************** package body Processing is *** 225,231 **** end loop; end if; ! -- Exit the GSD section when number of characters reaches 0 exit when Number_Of_Characters = 0; end loop; --- 292,298 ---- end loop; end if; ! -- Exit the GSD section when number of characters reaches zero exit when Number_Of_Characters = 0; end loop; diff -Nrcpad gcc-4.5.2/gcc/ada/sysdep.c gcc-4.6.0/gcc/ada/sysdep.c *** gcc-4.5.2/gcc/ada/sysdep.c Tue Jan 26 09:42:04 2010 --- gcc-4.6.0/gcc/ada/sysdep.c Mon Dec 20 07:26:57 2010 *************** *** 6,12 **** * * * C Implementation File * * * ! * 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- * --- 6,12 ---- * * * C Implementation File * * * ! * Copyright (C) 1992-2010, 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- * *************** *** 34,40 **** #ifdef __vxworks #include "ioLib.h" ! #if ! defined (__VXWORKSMILS__) #include "dosFsLib.h" #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) --- 34,40 ---- #ifdef __vxworks #include "ioLib.h" ! #if ! defined (VTHREADS) #include "dosFsLib.h" #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) *************** extern struct tm *localtime_r(const time *** 158,164 **** */ ! #if defined(WINNT) || defined (MSDOS) || defined (__EMX__) static const char *mode_read_text = "rt"; static const char *mode_write_text = "wt"; static const char *mode_append_text = "at"; --- 158,164 ---- */ ! #if defined(WINNT) static const char *mode_read_text = "rt"; static const char *mode_write_text = "wt"; static const char *mode_append_text = "at"; *************** winflush_nt (void) *** 235,241 **** /* Does nothing as there is no problem under NT. */ } ! #else static void winflush_init (void); --- 235,241 ---- /* Does nothing as there is no problem under NT. */ } ! #else /* !RTX */ static void winflush_init (void); *************** __gnat_is_windows_xp (void) *** 301,309 **** return is_win_xp; } ! #endif ! #endif #else --- 301,327 ---- return is_win_xp; } ! #endif /* !RTX */ ! /* Get the bounds of the stack. The stack pointer is supposed to be ! initialized to BASE when a thread is created and the stack can be extended ! to LIMIT before reaching a guard page. ! Note: for the main thread, the system automatically extend the stack, so ! LIMIT is only the current limit. */ ! ! void ! __gnat_get_stack_bounds (void **base, void **limit) ! { ! NT_TIB *tib; ! ! /* We know that the first field of the TEB is the TIB. */ ! tib = (NT_TIB *)NtCurrentTeb (); ! ! *base = tib->StackBase; ! *limit = tib->StackLimit; ! } ! ! #endif /* !__MINGW32__ */ #else *************** __gnat_ttyname (int filedes) *** 345,351 **** } #endif ! #if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ --- 363,369 ---- } #endif ! #if defined (linux) || defined (sun) || defined (sgi) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ *************** getc_immediate_common (FILE *stream, *** 403,409 **** int *avail, int waiting) { ! #if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) \ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ --- 421,427 ---- int *avail, int waiting) { ! #if defined (linux) || defined (sun) || defined (sgi) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) \ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ *************** getc_immediate_common (FILE *stream, *** 424,430 **** /* Set RAW mode, with no echo */ termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON & ~ECHO; ! #if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ --- 442,448 ---- /* Set RAW mode, with no echo */ termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON & ~ECHO; ! #if defined(linux) || defined (sun) || defined (sgi) \ || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ *************** getc_immediate_common (FILE *stream, *** 433,450 **** /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for a character forever. This doesn't seem to effect Ctrl-Z or ! Ctrl-C processing except on OS/2 where Ctrl-C won't work right ! unless we do a read loop. Luckily we can delay a bit between ! iterations. If not waiting (i.e. Get_Immediate (Char, Available)), don't wait for anything but timeout immediately. */ - #ifdef __EMX__ - termios_rec.c_cc[VMIN] = 0; - termios_rec.c_cc[VTIME] = waiting; - #else termios_rec.c_cc[VMIN] = waiting; termios_rec.c_cc[VTIME] = 0; #endif - #endif tcsetattr (fd, TCSANOW, &termios_rec); while (! good_one) --- 451,462 ---- /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for a character forever. This doesn't seem to effect Ctrl-Z or ! Ctrl-C processing. ! If not waiting (i.e. Get_Immediate (Char, Available)), don't wait for anything but timeout immediately. */ termios_rec.c_cc[VMIN] = waiting; termios_rec.c_cc[VTIME] = 0; #endif tcsetattr (fd, TCSANOW, &termios_rec); while (! good_one) *************** long __gnat_invalid_tzoff = 259273; *** 720,726 **** /* Definition of __gnat_localtime_r used by a-calend.adb */ ! #if defined (__EMX__) || defined (__MINGW32__) #ifdef CERT --- 732,738 ---- /* Definition of __gnat_localtime_r used by a-calend.adb */ ! #if defined (__MINGW32__) #ifdef CERT *************** extern void (*Unlock_Task) (void); *** 743,749 **** #endif ! /* Reentrant localtime for Windows and OS/2. */ extern void __gnat_localtime_tzoff (const time_t *, long *); --- 755,761 ---- #endif ! /* Reentrant localtime for Windows. */ extern void __gnat_localtime_tzoff (const time_t *, long *); *************** __gnat_localtime_tzoff (const time_t *ti *** 838,848 **** #else ! /* VMS does not need __gnat_locatime_tzoff */ #if defined (VMS) ! /* Other targets except Lynx, VMS and Windows provide a standard locatime_r */ #else --- 850,860 ---- #else ! /* VMS does not need __gnat_localtime_tzoff */ #if defined (VMS) ! /* Other targets except Lynx, VMS and Windows provide a standard localtime_r */ #else *************** __gnat_get_task_options (void) *** 965,971 **** /* Force VX_FP_TASK because it is almost always required */ options |= VX_FP_TASK; ! #if defined (__SPE__) options |= VX_SPE_TASK; #endif --- 977,983 ---- /* Force VX_FP_TASK because it is almost always required */ options |= VX_FP_TASK; ! #if defined (__SPE__) && (! defined (__VXWORKSMILS__)) options |= VX_SPE_TASK; #endif *************** __gnat_is_file_not_found_error (int errn *** 987,993 **** /* In the case of VxWorks, we also have to take into account various * filesystem-specific variants of this error. */ ! #if ! defined (__VXWORKSMILS__) case S_dosFsLib_FILE_NOT_FOUND: #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) --- 999,1005 ---- /* In the case of VxWorks, we also have to take into account various * filesystem-specific variants of this error. */ ! #if ! defined (VTHREADS) case S_dosFsLib_FILE_NOT_FOUND: #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) diff -Nrcpad gcc-4.5.2/gcc/ada/system-vms-ia64.ads gcc-4.6.0/gcc/ada/system-vms-ia64.ads *** gcc-4.5.2/gcc/ada/system-vms-ia64.ads Fri Apr 10 15:57:48 2009 --- gcc-4.6.0/gcc/ada/system-vms-ia64.ads Tue Jun 22 17:11:54 2010 *************** *** 7,13 **** -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** private *** 239,245 **** -- Special VMS Interfaces -- ---------------------------- ! procedure Lib_Stop (I : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma --- 239,245 ---- -- Special VMS Interfaces -- ---------------------------- ! procedure Lib_Stop (Cond_Value : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma *************** private *** 251,254 **** --- 251,257 ---- -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + end System; diff -Nrcpad gcc-4.5.2/gcc/ada/system-vms-zcx.ads gcc-4.6.0/gcc/ada/system-vms-zcx.ads *** gcc-4.5.2/gcc/ada/system-vms-zcx.ads Fri Apr 10 15:57:48 2009 --- gcc-4.6.0/gcc/ada/system-vms-zcx.ads Thu Jan 1 00:00:00 1970 *************** *** 1,232 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT RUN-TIME COMPONENTS -- - -- -- - -- S Y S T E M -- - -- -- - -- S p e c -- - -- (OpenVMS GCC_ZCX DEC Threads Version) -- - -- -- - -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- - -- -- - -- This specification is derived from the Ada Reference Manual for use with -- - -- GNAT. The copyright notice above, and the license provisions that follow -- - -- apply solely to the contents of the part following the private keyword. -- - -- -- - -- 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. -- - -- -- - -- As a special exception under Section 7 of GPL version 3, you are granted -- - -- additional permissions described in the GCC Runtime Library Exception, -- - -- version 3.1, as published by the Free Software Foundation. -- - -- -- - -- You should have received a copy of the GNU General Public License and -- - -- a copy of the GCC Runtime Library Exception along with this program; -- - -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- - -- . -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - - private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - end System; --- 0 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/system-vms.ads gcc-4.6.0/gcc/ada/system-vms.ads *** gcc-4.5.2/gcc/ada/system-vms.ads Fri Apr 10 15:57:48 2009 --- gcc-4.6.0/gcc/ada/system-vms.ads Thu Jan 1 00:00:00 1970 *************** *** 1,237 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT RUN-TIME COMPONENTS -- - -- -- - -- S Y S T E M -- - -- -- - -- S p e c -- - -- (OpenVMS DEC Threads Version) -- - -- -- - -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- - -- -- - -- This specification is derived from the Ada Reference Manual for use with -- - -- GNAT. The copyright notice above, and the license provisions that follow -- - -- apply solely to the contents of the part following the private keyword. -- - -- -- - -- 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. -- - -- -- - -- As a special exception under Section 7 of GPL version 3, you are granted -- - -- additional permissions described in the GCC Runtime Library Exception, -- - -- version 3.1, as published by the Free Software Foundation. -- - -- -- - -- You should have received a copy of the GNU General Public License and -- - -- a copy of the GCC Runtime Library Exception along with this program; -- - -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- - -- . -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - - private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := False; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - ADA_GNAT : constant Boolean := True; - pragma Export_Object (ADA_GNAT, "ADA$GNAT"); - -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. - -- Do not remove! - - end System; --- 0 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/system-vms_64.ads gcc-4.6.0/gcc/ada/system-vms_64.ads *** gcc-4.5.2/gcc/ada/system-vms_64.ads Fri Apr 10 15:57:48 2009 --- gcc-4.6.0/gcc/ada/system-vms_64.ads Tue Jun 22 17:11:54 2010 *************** *** 7,13 **** -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- --- 7,13 ---- -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- ! -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- *************** private *** 239,245 **** -- Special VMS Interfaces -- ---------------------------- ! procedure Lib_Stop (I : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma --- 239,245 ---- -- Special VMS Interfaces -- ---------------------------- ! procedure Lib_Stop (Cond_Value : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma *************** private *** 251,254 **** --- 251,257 ---- -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + end System; diff -Nrcpad gcc-4.5.2/gcc/ada/targext.c gcc-4.6.0/gcc/ada/targext.c *** gcc-4.5.2/gcc/ada/targext.c Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/targext.c Wed Jan 26 22:10:23 2011 *************** *** 6,12 **** * * * C Implementation File * * * ! * Copyright (C) 2005-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- * --- 6,12 ---- * * * C Implementation File * * * ! * Copyright (C) 2005-2011, 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- * *************** *** 33,39 **** --- 33,45 ---- /* extension for object and executable files. It is used by the compiler, */ /* binder and tools. */ + #ifdef IN_RTS + #include "tconfig.h" + #include "tsystem.h" + #else + #include "config.h" #include "system.h" + #endif #include "coretypes.h" #include "tm.h" diff -Nrcpad gcc-4.5.2/gcc/ada/targparm.ads gcc-4.6.0/gcc/ada/targparm.ads *** gcc-4.5.2/gcc/ada/targparm.ads Wed May 6 15:15:25 2009 --- gcc-4.6.0/gcc/ada/targparm.ads Thu Oct 7 12:59:00 2010 *************** package Targparm is *** 157,163 **** Run_Time_Name_On_Target : Name_Id := No_Name; -- Set to appropriate names table entry Id value if a Run_Time_Name -- string constant is defined in system.ads. This name is used only ! -- for the configurable run-time case, and is used to parametrize -- messages that complain about non-supported run-time features. -- The name should contain only letters A-Z, digits 1-9, spaces, -- and underscores. --- 157,163 ---- Run_Time_Name_On_Target : Name_Id := No_Name; -- Set to appropriate names table entry Id value if a Run_Time_Name -- string constant is defined in system.ads. This name is used only ! -- for the configurable run-time case, and is used to parameterize -- messages that complain about non-supported run-time features. -- The name should contain only letters A-Z, digits 1-9, spaces, -- and underscores. diff -Nrcpad gcc-4.5.2/gcc/ada/tb-alvxw.c gcc-4.6.0/gcc/ada/tb-alvxw.c *** gcc-4.5.2/gcc/ada/tb-alvxw.c Fri Apr 6 09:43:23 2007 --- gcc-4.6.0/gcc/ada/tb-alvxw.c Mon Dec 20 07:26:57 2010 *************** heuristic_proc_desc (CORE_ADDR start_pc, *** 564,570 **** So we recognize only a few registers (t7, t9, ra) within the procedure prologue as valid return address registers. If we encounter a return instruction, we extract the ! the return address register from it. FIXME: Rewriting GDB to access the procedure descriptors, e.g. via the minimal symbol table, might obviate this hack. */ --- 564,570 ---- So we recognize only a few registers (t7, t9, ra) within the procedure prologue as valid return address registers. If we encounter a return instruction, we extract the ! return address register from it. FIXME: Rewriting GDB to access the procedure descriptors, e.g. via the minimal symbol table, might obviate this hack. */ diff -Nrcpad gcc-4.5.2/gcc/ada/tbuild.adb gcc-4.6.0/gcc/ada/tbuild.adb *** gcc-4.5.2/gcc/ada/tbuild.adb Wed Oct 28 13:50:10 2009 --- gcc-4.6.0/gcc/ada/tbuild.adb Fri Oct 22 09:28:24 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with Sem_Aux; use Sem_Aux; *** 36,42 **** with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; ! with Uintp; use Uintp; package body Tbuild is --- 36,42 ---- with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; ! with Urealp; use Urealp; package body Tbuild is *************** package body Tbuild is *** 198,203 **** --- 198,237 ---- New_Reference_To (First_Tag_Component (Full_Type), Loc))); end Make_DT_Access; + ------------------------ + -- Make_Float_Literal -- + ------------------------ + + function Make_Float_Literal + (Loc : Source_Ptr; + Radix : Uint; + Significand : Uint; + Exponent : Uint) return Node_Id + is + begin + if Radix = 2 and then abs Significand /= 1 then + return + Make_Float_Literal + (Loc, Uint_16, + Significand * Radix**(Exponent mod 4), + Exponent / 4); + + else + declare + N : constant Node_Id := New_Node (N_Real_Literal, Loc); + + begin + Set_Realval (N, + UR_From_Components + (Num => abs Significand, + Den => -Exponent, + Rbase => UI_To_Int (Radix), + Negative => Significand < 0)); + return N; + end; + end if; + end Make_Float_Literal; + ------------------------------------- -- Make_Implicit_Exception_Handler -- ------------------------------------- *************** package body Tbuild is *** 442,450 **** function Make_Temporary (Loc : Source_Ptr; Id : Character; ! Related_Node : Node_Id := Empty) return Node_Id is ! Temp : constant Node_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id)); begin --- 476,484 ---- function Make_Temporary (Loc : Source_Ptr; Id : Character; ! Related_Node : Node_Id := Empty) return Entity_Id is ! Temp : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id)); begin *************** package body Tbuild is *** 659,665 **** -- We don't really need these shift operators, since they never -- appear as operators in the source, but the path of least ! -- resistance is to put them in (the aggregate must be complete) N_Op_Rotate_Left => Name_Rotate_Left, N_Op_Rotate_Right => Name_Rotate_Right, --- 693,699 ---- -- We don't really need these shift operators, since they never -- appear as operators in the source, but the path of least ! -- resistance is to put them in (the aggregate must be complete). N_Op_Rotate_Left => Name_Rotate_Left, N_Op_Rotate_Right => Name_Rotate_Right, *************** package body Tbuild is *** 686,692 **** Loc : Source_Ptr) return Node_Id is Occurrence : Node_Id; - begin Occurrence := New_Node (N_Identifier, Loc); Set_Chars (Occurrence, Chars (Def_Id)); --- 720,725 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/tbuild.ads gcc-4.6.0/gcc/ada/tbuild.ads *** gcc-4.5.2/gcc/ada/tbuild.ads Wed Oct 28 13:31:51 2009 --- gcc-4.6.0/gcc/ada/tbuild.ads Fri Oct 22 09:28:24 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,34 **** -- -- ------------------------------------------------------------------------------ ! -- This package contains various utility procedures to assist in ! -- building specific types of tree nodes. with Namet; use Namet; with Sinfo; use Sinfo; with Types; use Types; package Tbuild is --- 23,35 ---- -- -- ------------------------------------------------------------------------------ ! -- This package contains various utility procedures to assist in building ! -- specific types of tree nodes. with Namet; use Namet; with Sinfo; use Sinfo; with Types; use Types; + with Uintp; use Uintp; package Tbuild is *************** package Tbuild is *** 75,80 **** --- 76,89 ---- -- Create an access to the Dispatch Table by using the Tag field of a -- tagged record : Acc_Dt (Rec.tag).all + function Make_Float_Literal + (Loc : Source_Ptr; + Radix : Uint; + Significand : Uint; + Exponent : Uint) return Node_Id; + -- Create a real literal for the floating point expression value + -- Significand * Radix ** Exponent. Radix must be greater than 1. + function Make_Implicit_Exception_Handler (Sloc : Source_Ptr; Choice_Parameter : Node_Id := Empty; *************** package Tbuild is *** 167,196 **** Condition : Node_Id := Empty; Reason : RT_Exception_Code) return Node_Id; pragma Inline (Make_Raise_Storage_Error); ! -- A convenient form of Make_Raise_Storage_Error where the Reason ! -- is given simply as an enumeration value, rather than a Uint code. function Make_String_Literal (Sloc : Source_Ptr; Strval : String) return Node_Id; ! -- A convenient form of Make_String_Literal, where the string value ! -- is given as a normal string instead of a String_Id value. function Make_Temporary (Loc : Source_Ptr; Id : Character; ! Related_Node : Node_Id := Empty) return Node_Id; ! -- Create a defining identifier to capture the value of an expression ! -- or aggregate, and link it to the expression that it replaces, in ! -- order to provide better CodePeer reports. The defining identifier ! -- name is obtained by Make_Internal_Name (Id). function Make_Unsuppress_Block (Loc : Source_Ptr; Check : Name_Id; Stmts : List_Id) return Node_Id; ! -- Build a block with a pragma Suppress on 'Check'. Stmts is the ! -- statements list that needs protection against the check function New_Constraint_Error (Loc : Source_Ptr) return Node_Id; -- This function builds a tree corresponding to the Ada statement --- 176,214 ---- Condition : Node_Id := Empty; Reason : RT_Exception_Code) return Node_Id; pragma Inline (Make_Raise_Storage_Error); ! -- A convenient form of Make_Raise_Storage_Error where the Reason is given ! -- simply as an enumeration value, rather than a Uint code. function Make_String_Literal (Sloc : Source_Ptr; Strval : String) return Node_Id; ! -- A convenient form of Make_String_Literal, where the string value is ! -- given as a normal string instead of a String_Id value. function Make_Temporary (Loc : Source_Ptr; Id : Character; ! Related_Node : Node_Id := Empty) return Entity_Id; ! -- This function should be used for all cases where a defining identifier ! -- is to be built with a name to be obtained by New_Internal_Name (here Id ! -- is the character passed as the argument to New_Internal_Name). Loc is ! -- the location for the Sloc value of the resulting Entity. Note that this ! -- can be used for all kinds of temporary defining identifiers used in ! -- expansion (objects, subtypes, functions etc). ! -- ! -- Related_Node is used when the defining identifier is for an object that ! -- captures the value of an expression (e.g. an aggregate). It should be ! -- set whenever possible to point to the expression that is being captured. ! -- This is provided to get better error messages, e.g. from CodePeer. ! -- ! -- Make_Temp_Id would probably be a better name for this function??? function Make_Unsuppress_Block (Loc : Source_Ptr; Check : Name_Id; Stmts : List_Id) return Node_Id; ! -- Build a block with a pragma Suppress on 'Check'. Stmts is the statements ! -- list that needs protection against the check function New_Constraint_Error (Loc : Source_Ptr) return Node_Id; -- This function builds a tree corresponding to the Ada statement *************** package Tbuild is *** 268,273 **** --- 286,294 ---- -- if the identical unit is compiled with a semantically consistent set -- of sources, the numbers will be consistent. This means that it is fine -- to use these as public symbols. + -- + -- Note: Nearly all uses of this function are via calls to Make_Temporary, + -- but there are just a few cases where it is called directly. function New_Occurrence_Of (Def_Id : Entity_Id; *************** package Tbuild is *** 281,288 **** function New_Reference_To (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id; ! -- This is like New_Occurrence_Of, but it does not set the Etype field. ! -- It is used from the expander, where Etype fields are generally not set, -- since they are set when the expanded tree is reanalyzed. function New_Suffixed_Name --- 302,309 ---- function New_Reference_To (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id; ! -- This is like New_Occurrence_Of, but it does not set the Etype field. It ! -- is used from the expander, where Etype fields are generally not set, -- since they are set when the expanded tree is reanalyzed. function New_Suffixed_Name *************** package Tbuild is *** 295,307 **** -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; ! -- Like Convert_To, except that a conversion node is always generated, ! -- and the Conversion_OK flag is set on this conversion node. function Unchecked_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; ! -- Like Convert_To, but if a conversion is actually needed, constructs ! -- an N_Unchecked_Type_Conversion node to do the required conversion. end Tbuild; --- 316,328 ---- -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; ! -- Like Convert_To, except that a conversion node is always generated, and ! -- the Conversion_OK flag is set on this conversion node. function Unchecked_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; ! -- Like Convert_To, but if a conversion is actually needed, constructs an ! -- N_Unchecked_Type_Conversion node to do the required conversion. end Tbuild; diff -Nrcpad gcc-4.5.2/gcc/ada/tempdir.ads gcc-4.6.0/gcc/ada/tempdir.ads *** gcc-4.5.2/gcc/ada/tempdir.ads Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/tempdir.ads Tue Jun 22 12:57:07 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2007, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2010, 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- -- *************** *** 30,36 **** with Namet; use Namet; ! with System.OS_Lib; use System.OS_Lib; package Tempdir is --- 30,36 ---- with Namet; use Namet; ! with GNAT.OS_Lib; use GNAT.OS_Lib; package Tempdir is diff -Nrcpad gcc-4.5.2/gcc/ada/tracebak.c gcc-4.6.0/gcc/ada/tracebak.c *** gcc-4.5.2/gcc/ada/tracebak.c Sat Jul 4 10:11:57 2009 --- gcc-4.6.0/gcc/ada/tracebak.c Sat Aug 21 13:25:33 2010 *************** *** 6,12 **** * * * C Implementation File * * * ! * Copyright (C) 2000-2009, AdaCore * * * * 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- * --- 6,12 ---- * * * C Implementation File * * * ! * Copyright (C) 2000-2010, AdaCore * * * * 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- * *************** struct layout *** 303,309 **** --- 303,316 ---- #define IS_BAD_PTR(ptr) 0 #endif + /* Starting with GCC 4.6, -fomit-frame-pointer is turned on by default for + 32-bit x86/Linux as well and DWARF 2 unwind tables are emitted instead. + See the x86-64 case below for the drawbacks with this approach. */ + #if defined (linux) && (__GNUC__ * 10 + __GNUC_MINOR__ > 45) + #define USE_GCC_UNWINDER + #else #define USE_GENERIC_UNWINDER + #endif struct layout { *************** __gnat_backtrace (void **array, *** 435,441 **** { struct layout *current; void *top_frame; ! void *top_stack; int cnt = 0; if (FORCE_CALL) --- 442,448 ---- { struct layout *current; void *top_frame; ! void *top_stack ATTRIBUTE_UNUSED; int cnt = 0; if (FORCE_CALL) *************** __gnat_backtrace (void **array, *** 486,493 **** #else ! /* No target specific implementation and neither USE_GCC_UNWINDER not ! USE_GCC_UNWINDER defined. */ /*------------------------------* *-- The dummy implementation --* --- 493,500 ---- #else ! /* No target specific implementation and neither USE_GCC_UNWINDER nor ! USE_GENERIC_UNWINDER defined. */ /*------------------------------* *-- The dummy implementation --* diff -Nrcpad gcc-4.5.2/gcc/ada/tree_gen.adb gcc-4.6.0/gcc/ada/tree_gen.adb *** gcc-4.5.2/gcc/ada/tree_gen.adb Tue Apr 8 06:45:25 2008 --- gcc-4.6.0/gcc/ada/tree_gen.adb Mon Oct 11 15:47:23 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,29 **** --- 23,31 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; with Atree; + with Debug; with Elists; with Fname; with Lib; *************** begin *** 50,55 **** --- 52,64 ---- if Opt.Tree_Output then Osint.C.Tree_Create; Opt.Tree_Write; + + -- For now, only write aspect specifications hash table if -gnatd.A set + + if Debug.Debug_Flag_Dot_AA then + Aspects.Tree_Write; + end if; + Atree.Tree_Write; Elists.Tree_Write; Fname.Tree_Write; diff -Nrcpad gcc-4.5.2/gcc/ada/tree_in.adb gcc-4.6.0/gcc/ada/tree_in.adb *** gcc-4.5.2/gcc/ada/tree_in.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/tree_in.adb Mon Oct 11 15:47:23 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 29,36 **** --- 29,38 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; with Atree; with Csets; + with Debug; with Elists; with Fname; with Lib; *************** procedure Tree_In (Desc : File_Descripto *** 50,55 **** --- 52,64 ---- begin Tree_IO.Tree_Read_Initialize (Desc); Opt.Tree_Read; + + -- For now, only read aspect specifications hash table if -gnatd.A is set + + if Debug.Debug_Flag_Dot_AA then + Aspects.Tree_Read; + end if; + Atree.Tree_Read; Elists.Tree_Read; Fname.Tree_Read; diff -Nrcpad gcc-4.5.2/gcc/ada/tree_io.ads gcc-4.6.0/gcc/ada/tree_io.ads *** gcc-4.5.2/gcc/ada/tree_io.ads Wed Jul 15 10:15:49 2009 --- gcc-4.6.0/gcc/ada/tree_io.ads Tue Jun 22 13:26:32 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 34,43 **** -- create and close routines are elsewhere (in Osint in the compiler, and in -- the tree read driver for the tree read interface). ! with Types; use Types; ! with System; use System; with System.OS_Lib; use System.OS_Lib; package Tree_IO is --- 34,46 ---- -- create and close routines are elsewhere (in Osint in the compiler, and in -- the tree read driver for the tree read interface). ! with Types; use Types; ! with System; use System; ! pragma Warnings (Off); ! -- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; + pragma Warnings (On); package Tree_IO is diff -Nrcpad gcc-4.5.2/gcc/ada/treepr.adb gcc-4.6.0/gcc/ada/treepr.adb *** gcc-4.5.2/gcc/ada/treepr.adb Fri Jul 10 09:36:00 2009 --- gcc-4.6.0/gcc/ada/treepr.adb Tue Oct 19 10:37:41 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 23,28 **** --- 23,29 ---- -- -- ------------------------------------------------------------------------------ + with Aspects; use Aspects; with Atree; use Atree; with Csets; use Csets; with Debug; use Debug; *************** with Snames; use Snames; *** 38,43 **** --- 39,45 ---- with Sinput; use Sinput; with Stand; use Stand; with Stringt; use Stringt; + with SCIL_LL; use SCIL_LL; with Treeprs; use Treeprs; with Uintp; use Uintp; with Urealp; use Urealp; *************** package body Treepr is *** 626,631 **** --- 628,649 ---- Print_Eol; end if; + if Field_Present (Field28 (Ent)) then + Print_Str (Prefix); + Write_Field28_Name (Ent); + Write_Str (" = "); + Print_Field (Field28 (Ent)); + Print_Eol; + end if; + + if Field_Present (Field29 (Ent)) then + Print_Str (Prefix); + Write_Field29_Name (Ent); + Write_Str (" = "); + Print_Field (Field29 (Ent)); + Print_Eol; + end if; + Write_Entity_Flags (Ent, Prefix); end Print_Entity_Info; *************** package body Treepr is *** 1001,1006 **** --- 1019,1030 ---- Print_Eol; end if; + if Has_Aspects (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Has_Aspects = True"); + Print_Eol; + end if; + if Has_Dynamic_Range_Check (N) then Print_Str (Prefix_Str_Char); Print_Str ("Has_Dynamic_Range_Check = True"); *************** package body Treepr is *** 1090,1095 **** --- 1114,1123 ---- when F_Field5 => Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty); + -- Flag3 is obsolete, so this probably gets removed ??? + + when F_Flag3 => Field_To_Be_Printed := Has_Aspects (N); + when F_Flag4 => Field_To_Be_Printed := Flag4 (N); when F_Flag5 => Field_To_Be_Printed := Flag5 (N); when F_Flag6 => Field_To_Be_Printed := Flag6 (N); *************** package body Treepr is *** 1106,1117 **** when F_Flag17 => Field_To_Be_Printed := Flag17 (N); when F_Flag18 => Field_To_Be_Printed := Flag18 (N); ! -- Flag1,2,3 are no longer used when F_Flag1 => raise Program_Error; when F_Flag2 => raise Program_Error; - when F_Flag3 => raise Program_Error; - end case; -- Print field if it is to be printed --- 1134,1143 ---- when F_Flag17 => Field_To_Be_Printed := Flag17 (N); when F_Flag18 => Field_To_Be_Printed := Flag18 (N); ! -- Flag1,2 are no longer used when F_Flag1 => raise Program_Error; when F_Flag2 => raise Program_Error; end case; -- Print field if it is to be printed *************** package body Treepr is *** 1161,1171 **** when F_Flag17 => Print_Flag (Flag17 (N)); when F_Flag18 => Print_Flag (Flag18 (N)); ! -- Flag1,2,3 are no longer used when F_Flag1 => raise Program_Error; when F_Flag2 => raise Program_Error; ! when F_Flag3 => raise Program_Error; end case; Print_Eol; --- 1187,1200 ---- when F_Flag17 => Print_Flag (Flag17 (N)); when F_Flag18 => Print_Flag (Flag18 (N)); ! -- Flag1,2 are no longer used when F_Flag1 => raise Program_Error; when F_Flag2 => raise Program_Error; ! ! -- Not clear why we need the following ??? ! ! when F_Flag3 => Print_Flag (Has_Aspects (N)); end case; Print_Eol; *************** package body Treepr is *** 1179,1193 **** P := P + 1; end loop; end if; - end loop; -- Print entity information for entities if Nkind (N) in N_Entity then Print_Entity_Info (N, Prefix_Str_Char); end if; end Print_Node; --------------------- --- 1208,1238 ---- P := P + 1; end loop; end if; end loop; + -- Print aspects if present + + if Has_Aspects (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Aspect_Specifications = "); + Print_Field (Union_Id (Aspect_Specifications (N))); + Print_Eol; + end if; + -- Print entity information for entities if Nkind (N) in N_Entity then Print_Entity_Info (N, Prefix_Str_Char); end if; + -- Print the SCIL node (if available) + + if Present (Get_SCIL_Node (N)) then + Print_Str (Prefix_Str_Char); + Print_Str ("SCIL_Node = "); + Print_Node_Ref (Get_SCIL_Node (N)); + Print_Eol; + end if; end Print_Node; --------------------- *************** package body Treepr is *** 1890,1895 **** --- 1935,1944 ---- Visit_Descendent (Field4 (N)); Visit_Descendent (Field5 (N)); + if Has_Aspects (N) then + Visit_Descendent (Union_Id (Aspect_Specifications (N))); + end if; + -- Entity case else diff -Nrcpad gcc-4.5.2/gcc/ada/ttypef.ads gcc-4.6.0/gcc/ada/ttypef.ads *** gcc-4.5.2/gcc/ada/ttypef.ads Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/ttypef.ads Thu Jan 1 00:00:00 1970 *************** *** 1,204 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT COMPILER COMPONENTS -- - -- -- - -- T T Y P E F -- - -- -- - -- S p e c -- - -- -- - -- Copyright (C) 1992-2007, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This module contains values for the predefined floating-point attributes. - -- All references to these attribute values in a program being compiled must - -- use the values in this package, not the values returned by referencing - -- the corresponding attributes (since that would give host machine values). - -- Boolean-valued attributes are defined in System.Parameters, because they - -- need a finer control than what is provided by the formats described below. - - -- The codes for the eight floating-point formats supported are: - - -- IEEES - IEEE Single Float - -- IEEEL - IEEE Double Float - -- IEEEX - IEEE Double Extended Float - -- VAXFF - VAX F Float - -- VAXDF - VAX D Float - -- VAXGF - VAX G Float - -- AAMPS - AAMP 32-bit Float - -- AAMPL - AAMP 48-bit Float - - package Ttypef is - - ---------------------------------- - -- Universal Integer Attributes -- - ---------------------------------- - - -- Note that the constant declarations below specify values - -- using the Ada model, so IEEES_Machine_Emax does not specify - -- the IEEE definition of the single precision float type, - -- but the value of the Ada attribute which is one higher - -- as the binary point is at a different location. - - IEEES_Digits : constant := 6; - IEEEL_Digits : constant := 15; - IEEEX_Digits : constant := 18; - VAXFF_Digits : constant := 6; - VAXDF_Digits : constant := 9; - VAXGF_Digits : constant := 15; - AAMPS_Digits : constant := 6; - AAMPL_Digits : constant := 9; - - IEEES_Machine_Emax : constant := 128; - IEEEL_Machine_Emax : constant := 1024; - IEEEX_Machine_Emax : constant := 16384; - VAXFF_Machine_Emax : constant := 127; - VAXDF_Machine_Emax : constant := 127; - VAXGF_Machine_Emax : constant := 1023; - AAMPS_Machine_Emax : constant := 127; - AAMPL_Machine_Emax : constant := 127; - - IEEES_Machine_Emin : constant := -125; - IEEEL_Machine_Emin : constant := -1021; - IEEEX_Machine_Emin : constant := -16381; - VAXFF_Machine_Emin : constant := -127; - VAXDF_Machine_Emin : constant := -127; - VAXGF_Machine_Emin : constant := -1023; - AAMPS_Machine_Emin : constant := -127; - AAMPL_Machine_Emin : constant := -127; - - IEEES_Machine_Mantissa : constant := 24; - IEEEL_Machine_Mantissa : constant := 53; - IEEEX_Machine_Mantissa : constant := 64; - VAXFF_Machine_Mantissa : constant := 24; - VAXDF_Machine_Mantissa : constant := 56; - VAXGF_Machine_Mantissa : constant := 53; - AAMPS_Machine_Mantissa : constant := 24; - AAMPL_Machine_Mantissa : constant := 40; - - IEEES_Model_Emin : constant := -125; - IEEEL_Model_Emin : constant := -1021; - IEEEX_Model_Emin : constant := -16381; - VAXFF_Model_Emin : constant := -127; - VAXDF_Model_Emin : constant := -127; - VAXGF_Model_Emin : constant := -1023; - AAMPS_Model_Emin : constant := -127; - AAMPL_Model_Emin : constant := -127; - - IEEES_Model_Mantissa : constant := 24; - IEEEL_Model_Mantissa : constant := 53; - IEEEX_Model_Mantissa : constant := 64; - VAXFF_Model_Mantissa : constant := 24; - VAXDF_Model_Mantissa : constant := 56; - VAXGF_Model_Mantissa : constant := 53; - AAMPS_Model_Mantissa : constant := 24; - AAMPL_Model_Mantissa : constant := 40; - - IEEES_Safe_Emax : constant := 128; - IEEEL_Safe_Emax : constant := 1024; - IEEEX_Safe_Emax : constant := 16384; - VAXFF_Safe_Emax : constant := 127; - VAXDF_Safe_Emax : constant := 127; - VAXGF_Safe_Emax : constant := 1023; - AAMPS_Safe_Emax : constant := 127; - AAMPL_Safe_Emax : constant := 127; - - ------------------------------- - -- Universal Real Attributes -- - ------------------------------- - - IEEES_Model_Epsilon : constant := 2#1.0#E-23; - IEEEL_Model_Epsilon : constant := 2#1.0#E-52; - IEEEX_Model_Epsilon : constant := 2#1.0#E-63; - VAXFF_Model_Epsilon : constant := 16#0.1000_000#E-4; - VAXDF_Model_Epsilon : constant := 16#0.4000_0000_0000_000#E-7; - VAXGF_Model_Epsilon : constant := 16#0.4000_0000_0000_00#E-12; - AAMPS_Model_Epsilon : constant := 2#1.0#E-23; - AAMPL_Model_Epsilon : constant := 2#1.0#E-39; - - IEEES_Model_Small : constant := 2#1.0#E-126; - IEEEL_Model_Small : constant := 2#1.0#E-1022; - IEEEX_Model_Small : constant := 2#1.0#E-16381; - VAXFF_Model_Small : constant := 16#0.8000_000#E-21; - VAXDF_Model_Small : constant := 16#0.8000_0000_0000_000#E-31; - VAXGF_Model_Small : constant := 16#0.8000_0000_0000_00#E-51; - AAMPS_Model_Small : constant := 16#0.8000_000#E-21; - AAMPL_Model_Small : constant := 16#0.8000_0000_000#E-31; - - IEEES_Safe_First : constant := -16#0.FFFF_FF#E+32; - IEEEL_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256; - IEEEX_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096; - VAXFF_Safe_First : constant := -16#0.7FFF_FF8#E+32; - VAXDF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FC0#E+32; - VAXGF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E+256; - AAMPS_Safe_First : constant := -16#0.7FFF_FF8#E+32; - AAMPL_Safe_First : constant := -16#0.7FFF_FFFF_FF8#E+32; - - IEEES_Safe_Large : constant := 16#0.FFFF_FF#E+32; - IEEEL_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256; - IEEEX_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096; - VAXFF_Safe_Large : constant := 16#0.7FFF_FC0#E+32; - VAXDF_Safe_Large : constant := 16#0.7FFF_FFFF_0000_000#E+32; - VAXGF_Safe_Large : constant := 16#0.7FFF_FFFF_FFFF_F0#E+256; - AAMPS_Safe_Large : constant := 16#0.7FFF_FC0#E+32; - AAMPL_Safe_Large : constant := 16#0.7FFF_FFFF#E+32; - - IEEES_Safe_Last : constant := 16#0.FFFF_FF#E+32; - IEEEL_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256; - IEEEX_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096; - VAXFF_Safe_Last : constant := 16#0.7FFF_FF8#E+32; - VAXDF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32; - VAXGF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256; - AAMPS_Safe_Last : constant := 16#0.7FFF_FF8#E+32; - AAMPL_Safe_Last : constant := 16#0.7FFF_FFFF_FF8#E+32; - - IEEES_Safe_Small : constant := 2#1.0#E-126; - IEEEL_Safe_Small : constant := 2#1.0#E-1022; - IEEEX_Safe_Small : constant := 2#1.0#E-16381; - VAXFF_Safe_Small : constant := 16#0.1000_000#E-31; - VAXDF_Safe_Small : constant := 16#0.1000_0000_0000_000#E-31; - VAXGF_Safe_Small : constant := 16#0.1000_0000_0000_00#E-255; - AAMPS_Safe_Small : constant := 16#0.1000_000#E-31; - AAMPL_Safe_Small : constant := 16#0.1000_0000_000#E-31; - - ---------------------- - -- Typed Attributes -- - ---------------------- - - -- The attributes First and Last are typed attributes in Ada, and yield - -- values of the appropriate float type. However we still describe them - -- as universal real values in this file, since we are talking about the - -- target floating-point types, not the host floating-point types. - - IEEES_First : constant := -16#0.FFFF_FF#E+32; - IEEEL_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256; - IEEEX_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096; - VAXFF_First : constant := -16#0.7FFF_FF8#E+32; - VAXDF_First : constant := -16#0.7FFF_FFFF_FFFF_FF8#E+32; - VAXGF_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E+256; - AAMPS_First : constant := -16#0.7FFF_FF8#E+32; - AAMPL_First : constant := -16#0.7FFF_FFFF_FF8#E+32; - - IEEES_Last : constant := 16#0.FFFF_FF#E+32; - IEEEL_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256; - IEEEX_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096; - VAXFF_Last : constant := 16#0.7FFF_FF8#E+32; - VAXDF_Last : constant := 16#0.7FFF_FFFF_FFFF_FC0#E+32; - VAXGF_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256; - AAMPS_Last : constant := 16#0.7FFF_FF8#E+32; - AAMPL_Last : constant := 16#0.7FFF_FFFF_FF8#E+32; - - end Ttypef; --- 0 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/types.ads gcc-4.6.0/gcc/ada/types.ads *** gcc-4.5.2/gcc/ada/types.ads Wed Oct 28 13:50:10 2009 --- gcc-4.6.0/gcc/ada/types.ads Fri Oct 22 13:58:49 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Types is *** 59,67 **** type Int is range -2 ** 31 .. +2 ** 31 - 1; -- Signed 32-bit integer - type Dint is range -2 ** 63 .. +2 ** 63 - 1; - -- Double length (64-bit) integer - subtype Nat is Int range 0 .. Int'Last; -- Non-negative Int values --- 59,64 ---- *************** package Types is *** 125,132 **** subtype Big_String is String (Positive); type Big_String_Ptr is access all Big_String; ! for Big_String_Ptr'Storage_Size use 0; ! -- Virtual type for handling imported big strings function To_Big_String_Ptr is new Unchecked_Conversion (System.Address, Big_String_Ptr); --- 122,130 ---- subtype Big_String is String (Positive); type Big_String_Ptr is access all Big_String; ! -- Virtual type for handling imported big strings. Note that we should ! -- never have any allocators for this type, but we don't give a storage ! -- size of zero, since there are legitimate deallocations going on. function To_Big_String_Ptr is new Unchecked_Conversion (System.Address, Big_String_Ptr); *************** package Types is *** 200,212 **** -- Source_Buffer_Ptr, see Osint.Read_Source_File for details. type Source_Buffer_Ptr is access all Big_Source_Buffer; - for Source_Buffer_Ptr'Storage_Size use 0; -- Pointer to source buffer. We use virtual origin addressing for source -- buffers, with thin pointers. The pointer points to a virtual instance -- of type Big_Source_Buffer, where the actual type is in fact of type -- Source_Buffer. The address is adjusted so that the virtual origin -- addressing works correctly. See Osint.Read_Source_Buffer for further ! -- details. subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a --- 198,211 ---- -- Source_Buffer_Ptr, see Osint.Read_Source_File for details. type Source_Buffer_Ptr is access all Big_Source_Buffer; -- Pointer to source buffer. We use virtual origin addressing for source -- buffers, with thin pointers. The pointer points to a virtual instance -- of type Big_Source_Buffer, where the actual type is in fact of type -- Source_Buffer. The address is adjusted so that the virtual origin -- addressing works correctly. See Osint.Read_Source_Buffer for further ! -- details. Again, as for Big_String_Ptr, we should never allocate using ! -- this type, but we don't give a storage size clause of zero, since we ! -- may end up doing deallocations of instances allocated manually. subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a *************** package Types is *** 254,266 **** -- Universal integers (type Uint) -- Universal reals (type Ureal) ! -- In most contexts, the strongly typed interface determines which of ! -- these types is present. However, there are some situations (involving ! -- untyped traversals of the tree), where it is convenient to be easily ! -- able to distinguish these values. The underlying representation in all ! -- cases is an integer type Union_Id, and we ensure that the range of ! -- the various possible values for each of the above types is disjoint ! -- so that this distinction is possible. type Union_Id is new Int; -- The type in the tree for a union of possible ID values --- 253,265 ---- -- Universal integers (type Uint) -- Universal reals (type Ureal) ! -- In most contexts, the strongly typed interface determines which of these ! -- types is present. However, there are some situations (involving untyped ! -- traversals of the tree), where it is convenient to be easily able to ! -- distinguish these values. The underlying representation in all cases is ! -- an integer type Union_Id, and we ensure that the range of the various ! -- possible values for each of the above types is disjoint so that this ! -- distinction is possible. type Union_Id is new Int; -- The type in the tree for a union of possible ID values *************** package Types is *** 348,363 **** -- lie in. Such tests appear only in the lowest level packages. subtype List_Range is Union_Id ! range List_Low_Bound .. List_High_Bound; subtype Node_Range is Union_Id ! range Node_Low_Bound .. Node_High_Bound; subtype Elist_Range is Union_Id ! range Elist_Low_Bound .. Elist_High_Bound; subtype Elmt_Range is Union_Id ! range Elmt_Low_Bound .. Elmt_High_Bound; subtype Names_Range is Union_Id range Names_Low_Bound .. Names_High_Bound; --- 347,362 ---- -- lie in. Such tests appear only in the lowest level packages. subtype List_Range is Union_Id ! range List_Low_Bound .. List_High_Bound; subtype Node_Range is Union_Id ! range Node_Low_Bound .. Node_High_Bound; subtype Elist_Range is Union_Id ! range Elist_Low_Bound .. Elist_High_Bound; subtype Elmt_Range is Union_Id ! range Elmt_Low_Bound .. Elmt_High_Bound; subtype Names_Range is Union_Id range Names_Low_Bound .. Names_High_Bound; *************** package Types is *** 369,391 **** range Uint_Low_Bound .. Uint_High_Bound; subtype Ureal_Range is Union_Id ! range Ureal_Low_Bound .. Ureal_High_Bound; ! ---------------------------- -- Types for Atree Package -- ! ---------------------------- -- Node_Id values are used to identify nodes in the tree. They are ! -- subscripts into the Node table declared in package Tree. Note that ! -- the special values Empty and Error are subscripts into this table, -- See package Atree for further details. type Node_Id is range Node_Low_Bound .. Node_High_Bound; -- Type used to identify nodes in the tree subtype Entity_Id is Node_Id; ! -- A synonym for node types, used in the entity package to refer to nodes ! -- that are entities (i.e. nodes with an Nkind of N_Defining_xxx) All such -- nodes are extended nodes and these are the only extended nodes, so that -- in practice entity and extended nodes are synonymous. --- 368,390 ---- range Uint_Low_Bound .. Uint_High_Bound; subtype Ureal_Range is Union_Id ! range Ureal_Low_Bound .. Ureal_High_Bound; ! ----------------------------- -- Types for Atree Package -- ! ----------------------------- -- Node_Id values are used to identify nodes in the tree. They are ! -- subscripts into the Nodes table declared in package Atree. Note that ! -- the special values Empty and Error are subscripts into this table. -- See package Atree for further details. type Node_Id is range Node_Low_Bound .. Node_High_Bound; -- Type used to identify nodes in the tree subtype Entity_Id is Node_Id; ! -- A synonym for node types, used in the Einfo package to refer to nodes ! -- that are entities (i.e. nodes with an Nkind of N_Defining_xxx). All such -- nodes are extended nodes and these are the only extended nodes, so that -- in practice entity and extended nodes are synonymous. *************** package Types is *** 402,413 **** Empty_List_Or_Node : constant := 0; -- This constant is used in situations (e.g. initializing empty fields) ! -- where the value set will be used to represent either an empty node ! -- or a non-existent list, depending on the context. Error : constant Node_Id := Node_Low_Bound + 1; ! -- Used to indicate that there was an error in the source program. A node ! -- is actually allocated at this address, so that Nkind (Error) = N_Error. Empty_Or_Error : constant Node_Id := Error; -- Since Empty and Error are the first two Node_Id values, the test for --- 401,412 ---- Empty_List_Or_Node : constant := 0; -- This constant is used in situations (e.g. initializing empty fields) ! -- where the value set will be used to represent either an empty node or ! -- a non-existent list, depending on the context. Error : constant Node_Id := Node_Low_Bound + 1; ! -- Used to indicate an error in the source program. A node is actually ! -- allocated with this Id value, so that Nkind (Error) = N_Error. Empty_Or_Error : constant Node_Id := Error; -- Since Empty and Error are the first two Node_Id values, the test for *************** package Types is *** 422,432 **** -- Types for Nlists Package -- ------------------------------ ! -- List_Id values are used to identify node lists in the tree. They are ! -- subscripts into the Lists table declared in package Tree. Note that the ! -- special value Error_List is a subscript in this table, but the value ! -- No_List is *not* a valid subscript, and any attempt to apply list ! -- operations to No_List will cause a (detected) error. type List_Id is range List_Low_Bound .. List_High_Bound; -- Type used to identify a node list --- 421,432 ---- -- Types for Nlists Package -- ------------------------------ ! -- List_Id values are used to identify node lists stored in the tree, so ! -- that each node can be on at most one such list (see package Nlists for ! -- further details). Note that the special value Error_List is a subscript ! -- in this table, but the value No_List is *not* a valid subscript, and any ! -- attempt to apply list operations to No_List will cause a (detected) ! -- error. type List_Id is range List_Low_Bound .. List_High_Bound; -- Type used to identify a node list *************** package Types is *** 449,472 **** -- Types for Elists Package -- ------------------------------ ! -- Element list Id values are used to identify element lists stored in the ! -- tree (see package Atree for further details). They are formed by adding ! -- a bias (Element_List_Bias) to subscript values in the same array that is ! -- used for node list headers. type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; -- Type used to identify an element list (Elist header table subscript) No_Elist : constant Elist_Id := Elist_Low_Bound; ! -- Used to indicate absence of an element list. Note that this is not ! -- an actual Elist header, so element list operations on this value ! -- are not valid. First_Elist_Id : constant Elist_Id := No_Elist + 1; -- Subscript of first allocated Elist header ! -- Element Id values are used to identify individual elements of an ! -- element list (see package Elists for further details). type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound; -- Type used to identify an element list --- 449,471 ---- -- Types for Elists Package -- ------------------------------ ! -- Element list Id values are used to identify element lists stored outside ! -- of the tree, allowing nodes to be members of more than one such list ! -- (see package Elists for further details). type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; -- Type used to identify an element list (Elist header table subscript) No_Elist : constant Elist_Id := Elist_Low_Bound; ! -- Used to indicate absence of an element list. Note that this is not an ! -- actual Elist header, so element list operations on this value are not ! -- valid. First_Elist_Id : constant Elist_Id := No_Elist + 1; -- Subscript of first allocated Elist header ! -- Element Id values are used to identify individual elements of an element ! -- list (see package Elists for further details). type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound; -- Type used to identify an element list *************** package Types is *** 482,492 **** ------------------------------- -- String_Id values are used to identify entries in the strings table. They ! -- are subscripts into the strings table defined in package Strings. -- Note that with only a few exceptions, which are clearly documented, the -- type String_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. type String_Id is range Strings_Low_Bound .. Strings_High_Bound; -- Type used to identify entries in the strings table --- 481,492 ---- ------------------------------- -- String_Id values are used to identify entries in the strings table. They ! -- are subscripts into the Strings table defined in package Stringt. -- Note that with only a few exceptions, which are clearly documented, the -- type String_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. + -- Doesn't this also apply to all other *_Id types??? type String_Id is range Strings_Low_Bound .. Strings_High_Bound; -- Type used to identify entries in the strings table *************** package Types is *** 505,514 **** -- The type Char is used for character data internally in the compiler, but -- character codes in the source are represented by the Char_Code type. -- Each character literal in the source is interpreted as being one of the ! -- 16#8000_0000 possible Wide_Wide_Character codes, and a unique Integer ! -- Value is assigned, corresponding to the UTF_32 value, which also ! -- corresponds to the POS value in the Wide_Wide_Character type, and also ! -- corresponds to the POS value in the Wide_Character and Character types -- for values that are in appropriate range. String literals are similarly -- interpreted as a sequence of such codes. --- 505,514 ---- -- The type Char is used for character data internally in the compiler, but -- character codes in the source are represented by the Char_Code type. -- Each character literal in the source is interpreted as being one of the ! -- 16#7FFF_FFFF# possible Wide_Wide_Character codes, and a unique Integer ! -- value is assigned, corresponding to the UTF-32 value, which also ! -- corresponds to the Pos value in the Wide_Wide_Character type, and also ! -- corresponds to the Pos value in the Wide_Character and Character types -- for values that are in appropriate range. String literals are similarly -- interpreted as a sequence of such codes. *************** package Types is *** 554,560 **** type Unit_Number_Type is new Int; -- Unit number. The main source is unit 0, and subsidiary sources have -- non-zero numbers starting with 1. Unit numbers are used to index the ! -- file table in Lib. Main_Unit : constant Unit_Number_Type := 0; -- Unit number value for main unit --- 554,560 ---- type Unit_Number_Type is new Int; -- Unit number. The main source is unit 0, and subsidiary sources have -- non-zero numbers starting with 1. Unit numbers are used to index the ! -- Units table in package Lib. Main_Unit : constant Unit_Number_Type := 0; -- Unit number value for main unit *************** package Types is *** 730,743 **** -- Parameter Mechanism Control -- --------------------------------- ! -- Function and parameter entities have a field that records the ! -- passing mechanism. See specification of Sem_Mech for full details. ! -- The following subtype is used to represent values of this type: subtype Mechanism_Type is Int range -18 .. Int'Last; ! -- Type used to represent a mechanism value. This is a subtype rather ! -- than a type to avoid some annoying processing problems with certain ! -- routines in Einfo (processing them to create the corresponding C). ------------------------------ -- Run-Time Exception Codes -- --- 730,743 ---- -- Parameter Mechanism Control -- --------------------------------- ! -- Function and parameter entities have a field that records the passing ! -- mechanism. See specification of Sem_Mech for full details. The following ! -- subtype is used to represent values of this type: subtype Mechanism_Type is Int range -18 .. Int'Last; ! -- Type used to represent a mechanism value. This is a subtype rather than ! -- a type to avoid some annoying processing problems with certain routines ! -- in Einfo (processing them to create the corresponding C). ------------------------------ -- Run-Time Exception Codes -- *************** package Types is *** 762,773 **** -- 1. Modify the type and subtype declarations below appropriately, -- keeping things in alphabetical order. ! -- 2. Modify the corresponding definitions in types.h, including ! -- the definition of last_reason_code. ! -- 3. Add a new routine in Ada.Exceptions with the appropriate call ! -- and static string constant. Note that there is more than one ! -- version of a-except.adb which must be modified. type RT_Exception_Code is (CE_Access_Check_Failed, -- 00 --- 762,773 ---- -- 1. Modify the type and subtype declarations below appropriately, -- keeping things in alphabetical order. ! -- 2. Modify the corresponding definitions in types.h, including the ! -- definition of last_reason_code. ! -- 3. Add a new routine in Ada.Exceptions with the appropriate call and ! -- static string constant. Note that there is more than one version ! -- of a-except.adb which must be modified. type RT_Exception_Code is (CE_Access_Check_Failed, -- 00 *************** package Types is *** 789,811 **** PE_Accessibility_Check_Failed, -- 15 PE_Address_Of_Intrinsic, -- 16 PE_All_Guards_Closed, -- 17 ! PE_Current_Task_In_Entry_Body, -- 18 ! PE_Duplicated_Entry_Address, -- 19 ! PE_Explicit_Raise, -- 20 ! PE_Finalize_Raised_Exception, -- 21 ! PE_Implicit_Return, -- 22 ! PE_Misaligned_Address_Value, -- 23 ! PE_Missing_Return, -- 24 ! PE_Overlaid_Controlled_Object, -- 25 ! PE_Potentially_Blocking_Operation, -- 26 ! PE_Stubbed_Subprogram_Called, -- 27 ! PE_Unchecked_Union_Restriction, -- 28 ! PE_Non_Transportable_Actual, -- 29 ! SE_Empty_Storage_Pool, -- 30 ! SE_Explicit_Raise, -- 31 ! SE_Infinite_Recursion, -- 32 ! SE_Object_Too_Large); -- 33 subtype RT_CE_Exceptions is RT_Exception_Code range CE_Access_Check_Failed .. --- 789,812 ---- PE_Accessibility_Check_Failed, -- 15 PE_Address_Of_Intrinsic, -- 16 PE_All_Guards_Closed, -- 17 ! PE_Bad_Predicated_Generic_Type, -- 18 ! PE_Current_Task_In_Entry_Body, -- 19 ! PE_Duplicated_Entry_Address, -- 20 ! PE_Explicit_Raise, -- 21 ! PE_Finalize_Raised_Exception, -- 22 ! PE_Implicit_Return, -- 23 ! PE_Misaligned_Address_Value, -- 24 ! PE_Missing_Return, -- 25 ! PE_Overlaid_Controlled_Object, -- 26 ! PE_Potentially_Blocking_Operation, -- 27 ! PE_Stubbed_Subprogram_Called, -- 28 ! PE_Unchecked_Union_Restriction, -- 29 ! PE_Non_Transportable_Actual, -- 30 ! SE_Empty_Storage_Pool, -- 31 ! SE_Explicit_Raise, -- 32 ! SE_Infinite_Recursion, -- 33 ! SE_Object_Too_Large); -- 34 subtype RT_CE_Exceptions is RT_Exception_Code range CE_Access_Check_Failed .. diff -Nrcpad gcc-4.5.2/gcc/ada/types.h gcc-4.6.0/gcc/ada/types.h *** gcc-4.5.2/gcc/ada/types.h Fri Apr 17 09:06:20 2009 --- gcc-4.6.0/gcc/ada/types.h Fri Oct 22 10:41:17 2010 *************** *** 6,12 **** * * * C Header File * * * ! * Copyright (C) 1992-2008, 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- * --- 6,12 ---- * * * C Header File * * * ! * Copyright (C) 1992-2010, 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- * *************** typedef Int Mechanism_Type; *** 361,382 **** #define PE_Accessibility_Check_Failed 15 #define PE_Address_Of_Intrinsic 16 #define PE_All_Guards_Closed 17 ! #define PE_Current_Task_In_Entry_Body 18 ! #define PE_Duplicated_Entry_Address 19 ! #define PE_Explicit_Raise 20 ! #define PE_Finalize_Raised_Exception 21 ! #define PE_Implicit_Return 22 ! #define PE_Misaligned_Address_Value 23 ! #define PE_Missing_Return 24 ! #define PE_Overlaid_Controlled_Object 25 ! #define PE_Potentially_Blocking_Operation 26 ! #define PE_Stubbed_Subprogram_Called 27 ! #define PE_Unchecked_Union_Restriction 28 ! #define PE_Non_Transportable_Actual 29 ! #define SE_Empty_Storage_Pool 30 ! #define SE_Explicit_Raise 31 ! #define SE_Infinite_Recursion 32 ! #define SE_Object_Too_Large 33 ! #define LAST_REASON_CODE 33 --- 361,383 ---- #define PE_Accessibility_Check_Failed 15 #define PE_Address_Of_Intrinsic 16 #define PE_All_Guards_Closed 17 ! #define PE_Bad_Attribute_For_Predicate 18 ! #define PE_Current_Task_In_Entry_Body 19 ! #define PE_Duplicated_Entry_Address 20 ! #define PE_Explicit_Raise 21 ! #define PE_Finalize_Raised_Exception 22 ! #define PE_Implicit_Return 23 ! #define PE_Misaligned_Address_Value 24 ! #define PE_Missing_Return 25 ! #define PE_Overlaid_Controlled_Object 26 ! #define PE_Potentially_Blocking_Operation 27 ! #define PE_Stubbed_Subprogram_Called 28 ! #define PE_Unchecked_Union_Restriction 29 ! #define PE_Non_Transportable_Actual 30 ! #define SE_Empty_Storage_Pool 31 ! #define SE_Explicit_Raise 32 ! #define SE_Infinite_Recursion 33 ! #define SE_Object_Too_Large 34 ! #define LAST_REASON_CODE 34 diff -Nrcpad gcc-4.5.2/gcc/ada/ug_words gcc-4.6.0/gcc/ada/ug_words *** gcc-4.5.2/gcc/ada/ug_words Wed Jul 22 15:56:47 2009 --- gcc-4.6.0/gcc/ada/ug_words Thu Oct 21 10:19:58 2010 *************** gnatfind ^ GNAT FIND *** 24,31 **** Gnatfind ^ GNAT FIND gnatkr ^ GNAT KRUNCH Gnatkr ^ GNAT KRUNCH - gnatlbr ^ GNAT LIBRARY - Gnatlbr ^ GNAT LIBRARY gnatlink ^ GNAT LINK Gnatlink ^ GNAT LINK gnatls ^ GNAT LIST --- 24,29 ---- *************** gcc -c ^ GNAT COMPILE *** 61,66 **** --- 59,65 ---- -gnatDG ^ /XDEBUG /EXPAND_SOURCEA -gnatD ^ /XDEBUG -gnatec ^ /CONFIGURATION_PRAGMAS_FILE + -gnateE ^ /EXTRA_EXCEPTION_INFORMATION -gnateD ^ /SYMBOL_PREPROCESSING -gnatef ^ /FULL_PATH_IN_BRIEF_MESSAGES -gnateG ^ /GENERATE_PROCESSED_SOURCE *************** gcc -c ^ GNAT COMPILE *** 85,90 **** --- 84,90 ---- -gnatN ^ /INLINE=FULL -gnato ^ /CHECKS=OVERFLOW -gnatp ^ /CHECKS=SUPPRESS_ALL + -gnat-p ^ /CHECKS=UNSUPPRESS_ALL -gnatP ^ /POLLING -gnatR ^ /REPRESENTATION_INFO -gnatR0 ^ /REPRESENTATION_INFO=NONE *************** gcc -c ^ GNAT COMPILE *** 139,144 **** --- 139,146 ---- -gnatwG ^ /WARNINGS=NOUNRECOGNIZED_PRAGMAS -gnatwh ^ /WARNINGS=HIDING -gnatwH ^ /WARNINGS=NOHIDING + -gnatw.h ^ /WARNINGS=AVOIDGAPS + -gnatw.H ^ /WARNINGS=NOAVOIDGAPS -gnatwi ^ /WARNINGS=IMPLEMENTATION -gnatwI ^ /WARNINGS=NOIMPLEMENTATION -gnatwj ^ /WARNINGS=OBSOLESCENT *************** gcc -c ^ GNAT COMPILE *** 160,165 **** --- 162,169 ---- -gnatwP ^ /WARNINGS=NOINEFFECTIVE_INLINE -gnatw.p ^ /WARNINGS=PARAMETER_ORDER -gnatw.P ^ /WARNINGS=NO_PARAMETER_ORDER + -gnatw.h ^ /WARNINGS=OVERRIDING_SIZE + -gnatw.H ^ /WARNINGS=NOOVERRIDING_SIZE -gnatwq ^ /WARNINGS=MISSING_PARENS -gnatwQ ^ /WARNINGS=NOMISSING_PARENS -gnatwr ^ /WARNINGS=REDUNDANT *************** gcc -c ^ GNAT COMPILE *** 169,174 **** --- 173,180 ---- -gnatwT ^ /WARNINGS=NODELETED_CODE -gnatwu ^ /WARNINGS=UNUSED -gnatwU ^ /WARNINGS=NOUNUSED + -gnatw.u ^ /WARNINGS=UNORDERED_ENUMERATIONS + -gnatw.U ^ /WARNINGS=NOUNORDERED_ENUMERATIONS -gnatwv ^ /WARNINGS=VARIABLES_UNINITIALIZED -gnatwV ^ /WARNINGS=NOVARIABLES_UNINITIALIZED -gnatww ^ /WARNINGS=LOWBOUND_ASSUMED *************** gcc -c ^ GNAT COMPILE *** 194,199 **** --- 200,208 ---- -gnat83 ^ /83 -gnat95 ^ /95 -gnat05 ^ /05 + -gnat2005 ^ /2005 + -gnat12 ^ /12 + -gnat2012 ^ /2012 -gnatx ^ /XREF=SUPPRESS -gnatX ^ /EXTENSIONS_ALLOWED --RTS ^ /RUNTIME_SYSTEM *************** stderr ^ SYS$ERROR *** 217,219 **** --- 226,230 ---- -O1 ^ /OPTIMIZE=SOME -O2 ^ /OPTIMIZE=ALL -O3 ^ /OPTIMIZE=INLINING + -H32 ^ /32_MALLOC + -H64 ^ /64_MALLOC diff -Nrcpad gcc-4.5.2/gcc/ada/uintp.adb gcc-4.6.0/gcc/ada/uintp.adb *** gcc-4.5.2/gcc/ada/uintp.adb Wed Jul 22 10:25:32 2009 --- gcc-4.6.0/gcc/ada/uintp.adb Thu Sep 9 10:39:19 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Uintp is *** 168,180 **** (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; ! Discard_Quotient : Boolean; ! Discard_Remainder : Boolean); ! -- Compute Euclidean division of Left by Right, and return Quotient and ! -- signed Remainder (Left rem Right). -- ! -- If Discard_Quotient is True, Quotient is left unchanged. ! -- If Discard_Remainder is True, Remainder is left unchanged. function Vector_To_Uint (In_Vec : UI_Vector; --- 168,182 ---- (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; ! Discard_Quotient : Boolean := False; ! Discard_Remainder : Boolean := False); ! -- Compute Euclidean division of Left by Right. If Discard_Quotient is ! -- False then the quotient is returned in Quotient (otherwise Quotient is ! -- set to No_Uint). If Discard_Remainder is False, then the remainder is ! -- returned in Remainder (otherwise Remainder is set to No_Uint). -- ! -- If Discard_Quotient is True, Quotient is set to No_Uint ! -- If Discard_Remainder is True, Remainder is set to No_Uint function Vector_To_Uint (In_Vec : UI_Vector; *************** package body Uintp is *** 239,245 **** function Hash_Num (F : Int) return Hnum is begin ! return Standard."mod" (F, Hnum'Range_Length); end Hash_Num; --------------- --- 241,247 ---- function Hash_Num (F : Int) return Hnum is begin ! return Types."mod" (F, Hnum'Range_Length); end Hash_Num; --------------- *************** package body Uintp is *** 1253,1259 **** UI_Div_Rem (Left, Right, Quotient, Remainder, - Discard_Quotient => False, Discard_Remainder => True); return Quotient; end UI_Div; --- 1255,1260 ---- *************** package body Uintp is *** 1266,1279 **** (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; ! Discard_Quotient : Boolean; ! Discard_Remainder : Boolean) is pragma Warnings (Off, Quotient); pragma Warnings (Off, Remainder); begin pragma Assert (Right /= Uint_0); -- Cases where both operands are represented directly if Direct (Left) and then Direct (Right) then --- 1267,1283 ---- (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; ! Discard_Quotient : Boolean := False; ! Discard_Remainder : Boolean := False) is pragma Warnings (Off, Quotient); pragma Warnings (Off, Remainder); begin pragma Assert (Right /= Uint_0); + Quotient := No_Uint; + Remainder := No_Uint; + -- Cases where both operands are represented directly if Direct (Left) and then Direct (Right) then *************** package body Uintp is *** 1345,1353 **** --- 1349,1359 ---- if not Discard_Quotient then Quotient := Uint_0; end if; + if not Discard_Remainder then Remainder := Left; end if; + return; end if; *************** package body Uintp is *** 1377,1382 **** --- 1383,1389 ---- if not Discard_Remainder then Remainder := UI_From_Int (Remainder_I); end if; + return; end; end if; *************** package body Uintp is *** 1679,1727 **** function UI_From_CC (Input : Char_Code) return Uint is begin ! return UI_From_Dint (Dint (Input)); end UI_From_CC; - ------------------ - -- UI_From_Dint -- - ------------------ - - function UI_From_Dint (Input : Dint) return Uint is - begin - - if Dint (Min_Direct) <= Input and then Input <= Dint (Max_Direct) then - return Uint (Dint (Uint_Direct_Bias) + Input); - - -- For values of larger magnitude, compute digits into a vector and call - -- Vector_To_Uint. - - else - declare - Max_For_Dint : constant := 5; - -- Base is defined so that 5 Uint digits is sufficient to hold the - -- largest possible Dint value. - - V : UI_Vector (1 .. Max_For_Dint); - - Temp_Integer : Dint; - - begin - for J in V'Range loop - V (J) := 0; - end loop; - - Temp_Integer := Input; - - for J in reverse V'Range loop - V (J) := Int (abs (Temp_Integer rem Dint (Base))); - Temp_Integer := Temp_Integer / Dint (Base); - end loop; - - return Vector_To_Uint (V, Input < Dint'(0)); - end; - end if; - end UI_From_Dint; - ----------------- -- UI_From_Int -- ----------------- --- 1686,1694 ---- function UI_From_CC (Input : Char_Code) return Uint is begin ! return UI_From_Int (Int (Input)); end UI_From_CC; ----------------- -- UI_From_Int -- ----------------- *************** package body Uintp is *** 1752,1766 **** V : UI_Vector (1 .. Max_For_Int); ! Temp_Integer : Int; begin - for J in V'Range loop - V (J) := 0; - end loop; - - Temp_Integer := Input; - for J in reverse V'Range loop V (J) := abs (Temp_Integer rem Base); Temp_Integer := Temp_Integer / Base; --- 1719,1727 ---- V : UI_Vector (1 .. Max_For_Int); ! Temp_Integer : Int := Input; begin for J in reverse V'Range loop V (J) := abs (Temp_Integer rem Base); Temp_Integer := Temp_Integer / Base; *************** package body Uintp is *** 2200,2210 **** Y := Uint_0; loop ! UI_Div_Rem ! (U, V, ! Quotient => Q, Remainder => R, ! Discard_Quotient => False, ! Discard_Remainder => False); U := V; V := R; --- 2161,2167 ---- Y := Uint_0; loop ! UI_Div_Rem (U, V, Quotient => Q, Remainder => R); U := V; V := R; *************** package body Uintp is *** 2241,2252 **** function UI_Mul (Left : Uint; Right : Uint) return Uint is begin ! -- Simple case of single length operands ! if Direct (Left) and then Direct (Right) then ! return ! UI_From_Dint ! (Dint (Direct_Val (Left)) * Dint (Direct_Val (Right))); end if; -- Otherwise we have the general case (Algorithm M in Knuth) --- 2198,2210 ---- function UI_Mul (Left : Uint; Right : Uint) return Uint is begin ! -- Case where product fits in the range of a 32-bit integer ! if Int (Left) <= Int (Uint_Max_Simple_Mul) ! and then ! Int (Right) <= Int (Uint_Max_Simple_Mul) ! then ! return UI_From_Int (Direct_Val (Left) * Direct_Val (Right)); end if; -- Otherwise we have the general case (Algorithm M in Knuth) *************** package body Uintp is *** 2569,2577 **** pragma Warnings (Off, Quotient); begin UI_Div_Rem ! (Left, Right, Quotient, Remainder, ! Discard_Quotient => True, ! Discard_Remainder => False); return Remainder; end; end UI_Rem; --- 2527,2533 ---- pragma Warnings (Off, Quotient); begin UI_Div_Rem ! (Left, Right, Quotient, Remainder, Discard_Quotient => True); return Remainder; end; end UI_Rem; diff -Nrcpad gcc-4.5.2/gcc/ada/uintp.ads gcc-4.6.0/gcc/ada/uintp.ads *** gcc-4.5.2/gcc/ada/uintp.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/uintp.ads Thu Oct 21 10:19:58 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Uintp is *** 233,241 **** -- given Modulo (uses Euclid's algorithm). Note: the call is considered -- to be erroneous (and the behavior is undefined) if n is not invertible. - function UI_From_Dint (Input : Dint) return Uint; - -- Converts Dint value to universal integer form - function UI_From_Int (Input : Int) return Uint; -- Converts Int value to universal integer form --- 233,238 ---- *************** package Uintp is *** 264,270 **** -- or decimal format. Auto, the default setting, lets the routine make -- a decision based on the value. ! UI_Image_Max : constant := 32; UI_Image_Buffer : String (1 .. UI_Image_Max); UI_Image_Length : Natural; -- Buffer used for UI_Image as described below --- 261,267 ---- -- or decimal format. Auto, the default setting, lets the routine make -- a decision based on the value. ! UI_Image_Max : constant := 48; -- Enough for a 128-bit number UI_Image_Buffer : String (1 .. UI_Image_Max); UI_Image_Length : Natural; -- Buffer used for UI_Image as described below *************** private *** 404,410 **** -- Base is defined to allow efficient execution of the primitive operations -- (a0, b0, c0) defined in the section "The Classical Algorithms" -- (sec. 4.3.1) of Donald Knuth's "The Art of Computer Programming", ! -- Vol. 2. These algorithms are used in this package. Base_Bits : constant := 15; -- Number of bits in base value --- 401,408 ---- -- Base is defined to allow efficient execution of the primitive operations -- (a0, b0, c0) defined in the section "The Classical Algorithms" -- (sec. 4.3.1) of Donald Knuth's "The Art of Computer Programming", ! -- Vol. 2. These algorithms are used in this package. In particular, ! -- the product of two single digits in this base fits in a 32-bit integer. Base_Bits : constant := 15; -- Number of bits in base value *************** private *** 470,475 **** --- 468,478 ---- Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80); Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128); + Uint_Max_Simple_Mul : constant := Uint_Direct_Bias + 2 ** 15; + -- If two values are directly represented and less than or equal to this + -- value, then we know the product fits in a 32-bit integer. This allows + -- UI_Mul to efficiently compute the product in this case. + type Save_Mark is record Save_Uint : Uint; Save_Udigit : Int; diff -Nrcpad gcc-4.5.2/gcc/ada/uintp.h gcc-4.6.0/gcc/ada/uintp.h *** gcc-4.5.2/gcc/ada/uintp.h Mon Sep 10 12:47:10 2007 --- gcc-4.6.0/gcc/ada/uintp.h Sat Apr 17 14:16:36 2010 *************** *** 6,12 **** * * * C Header File * * * ! * Copyright (C) 1992-2007, 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- * --- 6,12 ---- * * * C Header File * * * ! * Copyright (C) 1992-2010, 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- * *************** struct Uint_Entry *** 38,64 **** #define UI_Is_In_Int_Range uintp__ui_is_in_int_range extern Boolean UI_Is_In_Int_Range (Uint); ! /* Obtain Char_Code value from Uint input. Value must be in range. */ #define UI_To_CC uintp__ui_to_cc ! extern Char_Code UI_To_CC (Uint); ! /* Obtain Int value from Uint input. This will abort if the result is ! out of range. */ #define UI_To_Int uintp__ui_to_int extern Int UI_To_Int (Uint); /* Convert an Int into a Uint. */ #define UI_From_Int uintp__ui_from_int extern Uint UI_From_Int (int); ! /* Convert a Char_Code into a Uint. */ ! #define UI_From_CC uintp__ui_from_cc ! extern Uint UI_From_CC (Char_Code); ! /* Similarly, but return a GCC INTEGER_CST. Overflow is tested by the ! constant-folding used to build the node. TYPE is the GCC type of the ! resulting node. */ ! extern tree UI_To_gnu (Uint, tree); /* Universal integers are represented by the Uint type which is an index into the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an --- 38,83 ---- #define UI_Is_In_Int_Range uintp__ui_is_in_int_range extern Boolean UI_Is_In_Int_Range (Uint); ! /* Obtain Char_Code value from Uint input. Value must be in range. */ #define UI_To_CC uintp__ui_to_cc ! extern Char_Code UI_To_CC (Uint); ! /* Convert a Char_Code into a Uint. */ ! #define UI_From_CC uintp__ui_from_cc ! extern Uint UI_From_CC (Char_Code); ! ! /* Obtain Int value from Uint input. Abort if the result is out of range. */ #define UI_To_Int uintp__ui_to_int extern Int UI_To_Int (Uint); + /* Similarly, but return a GCC INTEGER_CST. */ + extern tree UI_To_gnu (Uint, tree); + /* Convert an Int into a Uint. */ #define UI_From_Int uintp__ui_from_int extern Uint UI_From_Int (int); ! /* Similarly, but take a GCC INTEGER_CST. */ ! extern Uint UI_From_gnu (tree); ! /* Uint values are represented as multiple precision integers stored in a ! multi-digit format using UI_Base as the base. This value is chosen so ! that the product UI_Base*UI_Base is within the range of Int values. */ ! #define UI_Base uintp__base ! extern const int UI_Base; ! ! /* Types for the fat pointer of Int vectors and the template it points to. */ ! typedef struct {int Low_Bound, High_Bound; } Vector_Template; ! typedef struct {const int *Array; Vector_Template *Bounds; } ! __attribute ((aligned (sizeof (char *) * 2))) Int_Vector; ! ! /* Create and return the Uint value from the Int vector. */ ! #define Vector_To_Uint uintp__vector_to_uint ! extern Uint Vector_To_Uint (Int_Vector, Boolean); ! ! /* Compare integer values for less than. */ ! #define UI_Lt uintp__ui_lt ! extern Boolean UI_Lt (Uint, Uint); /* Universal integers are represented by the Uint type which is an index into the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an *************** extern struct Uint_Entry *uintp__uints__ *** 75,80 **** #define Udigits_Ptr uintp__udigits__table extern int *uintp__udigits__table; - - #define Uint_0 (Uint_Direct_Bias + 0) - #define Uint_1 (Uint_Direct_Bias + 1) --- 94,96 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/uname.adb gcc-4.6.0/gcc/ada/uname.adb *** gcc-4.5.2/gcc/ada/uname.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/uname.adb Mon Oct 25 13:50:29 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- diff -Nrcpad gcc-4.5.2/gcc/ada/urealp.adb gcc-4.6.0/gcc/ada/urealp.adb *** gcc-4.5.2/gcc/ada/urealp.adb Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/urealp.adb Thu Oct 21 10:25:12 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package body Urealp is *** 44,50 **** Num : Uint; -- Numerator (always non-negative) ! Den : Uint; -- Denominator (always non-zero, always positive if base is zero) Rbase : Nat; --- 44,50 ---- Num : Uint; -- Numerator (always non-negative) ! Den : Uint; -- Denominator (always non-zero, always positive if base is zero) Rbase : Nat; *************** package body Urealp is *** 80,99 **** -- The following universal reals are the values returned by the constant -- functions. They are initialized by the initialization procedure. ! UR_0 : Ureal; ! UR_M_0 : Ureal; ! UR_Tenth : Ureal; ! UR_Half : Ureal; ! UR_1 : Ureal; ! UR_2 : Ureal; ! UR_10 : Ureal; ! UR_10_36 : Ureal; ! UR_M_10_36 : Ureal; ! UR_100 : Ureal; ! UR_2_128 : Ureal; ! UR_2_80 : Ureal; ! UR_2_M_128 : Ureal; ! UR_2_M_80 : Ureal; Num_Ureal_Constants : constant := 10; -- This is used for an assertion check in Tree_Read and Tree_Write to --- 80,99 ---- -- The following universal reals are the values returned by the constant -- functions. They are initialized by the initialization procedure. ! UR_0 : Ureal; ! UR_M_0 : Ureal; ! UR_Tenth : Ureal; ! UR_Half : Ureal; ! UR_1 : Ureal; ! UR_2 : Ureal; ! UR_10 : Ureal; ! UR_10_36 : Ureal; ! UR_M_10_36 : Ureal; ! UR_100 : Ureal; ! UR_2_128 : Ureal; ! UR_2_80 : Ureal; ! UR_2_M_128 : Ureal; ! UR_2_M_80 : Ureal; Num_Ureal_Constants : constant := 10; -- This is used for an assertion check in Tree_Read and Tree_Write to *************** package body Urealp is *** 134,151 **** -- Return true if the real quotient of Num / Den is an integer value function Normalize (Val : Ureal_Entry) return Ureal_Entry; ! -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a ! -- base value of 0). function Same (U1, U2 : Ureal) return Boolean; pragma Inline (Same); -- Determines if U1 and U2 are the same Ureal. Note that we cannot use ! -- the equals operator for this test, since that tests for equality, ! -- not identity. function Store_Ureal (Val : Ureal_Entry) return Ureal; ! -- This store a new entry in the universal reals table and return ! -- its index in the table. ------------------------- -- Decimal_Exponent_Hi -- --- 134,155 ---- -- Return true if the real quotient of Num / Den is an integer value function Normalize (Val : Ureal_Entry) return Ureal_Entry; ! -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a base ! -- value of 0). function Same (U1, U2 : Ureal) return Boolean; pragma Inline (Same); -- Determines if U1 and U2 are the same Ureal. Note that we cannot use ! -- the equals operator for this test, since that tests for equality, not ! -- identity. function Store_Ureal (Val : Ureal_Entry) return Ureal; ! -- This store a new entry in the universal reals table and return its index ! -- in the table. ! ! function Store_Ureal_Normalized (Val : Ureal_Entry) return Ureal; ! pragma Inline (Store_Ureal_Normalized); ! -- Like Store_Ureal, but normalizes its operand first. ------------------------- -- Decimal_Exponent_Hi -- *************** package body Urealp is *** 451,456 **** --- 455,469 ---- return Ureals.Last; end Store_Ureal; + ---------------------------- + -- Store_Ureal_Normalized -- + ---------------------------- + + function Store_Ureal_Normalized (Val : Ureal_Entry) return Ureal is + begin + return Store_Ureal (Normalize (Val)); + end Store_Ureal_Normalized; + --------------- -- Tree_Read -- --------------- *************** package body Urealp is *** 505,515 **** Val : constant Ureal_Entry := Ureals.Table (Real); begin ! return Store_Ureal ( ! (Num => Val.Num, ! Den => Val.Den, ! Rbase => Val.Rbase, ! Negative => False)); end UR_Abs; ------------ --- 518,528 ---- Val : constant Ureal_Entry := Ureals.Table (Real); begin ! return Store_Ureal ! ((Num => Val.Num, ! Den => Val.Den, ! Rbase => Val.Rbase, ! Negative => False)); end UR_Abs; ------------ *************** package body Urealp is *** 529,535 **** function UR_Add (Left : Ureal; Right : Ureal) return Ureal is Lval : Ureal_Entry := Ureals.Table (Left); Rval : Ureal_Entry := Ureals.Table (Right); - Num : Uint; begin --- 542,547 ---- *************** package body Urealp is *** 538,544 **** -- be negative, even though in stored entries this can never be so) if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then - declare Opd_Min, Opd_Max : Ureal_Entry; Exp_Min, Exp_Max : Uint; --- 550,555 ---- *************** package body Urealp is *** 568,585 **** Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num; if Num = 0 then ! return Store_Ureal ( ! (Num => Uint_0, ! Den => Uint_1, ! Rbase => 0, ! Negative => Lval.Negative)); else ! return Store_Ureal ( ! (Num => abs Num, ! Den => Exp_Max, ! Rbase => Lval.Rbase, ! Negative => (Num < 0))); end if; end; --- 579,596 ---- Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num; if Num = 0 then ! return Store_Ureal ! ((Num => Uint_0, ! Den => Uint_1, ! Rbase => 0, ! Negative => Lval.Negative)); else ! return Store_Ureal ! ((Num => abs Num, ! Den => Exp_Max, ! Rbase => Lval.Rbase, ! Negative => (Num < 0))); end if; end; *************** package body Urealp is *** 600,618 **** Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den); if Num = 0 then ! return Store_Ureal ( ! (Num => Uint_0, ! Den => Uint_1, ! Rbase => 0, ! Negative => Lval.Negative)); else ! return Store_Ureal ( ! Normalize ( ! (Num => abs Num, ! Den => Ln.Den * Rn.Den, ! Rbase => 0, ! Negative => (Num < 0)))); end if; end; end if; --- 611,628 ---- Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den); if Num = 0 then ! return Store_Ureal ! ((Num => Uint_0, ! Den => Uint_1, ! Rbase => 0, ! Negative => Lval.Negative)); else ! return Store_Ureal_Normalized ! ((Num => abs Num, ! Den => Ln.Den * Rn.Den, ! Rbase => 0, ! Negative => (Num < 0))); end if; end; end if; *************** package body Urealp is *** 624,630 **** function UR_Ceiling (Real : Ureal) return Uint is Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); - begin if Val.Negative then return UI_Negate (Val.Num / Val.Den); --- 634,639 ---- *************** package body Urealp is *** 656,711 **** pragma Assert (Rval.Num /= Uint_0); if Lval.Rbase = 0 then - if Rval.Rbase = 0 then ! return Store_Ureal ( ! Normalize ( ! (Num => Lval.Num * Rval.Den, ! Den => Lval.Den * Rval.Num, ! Rbase => 0, ! Negative => Rneg))); elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then ! return Store_Ureal ( ! (Num => Lval.Num / (Rval.Num * Lval.Den), ! Den => (-Rval.Den), ! Rbase => Rval.Rbase, ! Negative => Rneg)); elsif Rval.Den < 0 then ! return Store_Ureal ( ! Normalize ( ! (Num => Lval.Num, ! Den => Rval.Rbase ** (-Rval.Den) * ! Rval.Num * ! Lval.Den, ! Rbase => 0, ! Negative => Rneg))); else ! return Store_Ureal ( ! Normalize ( ! (Num => Lval.Num * Rval.Rbase ** Rval.Den, ! Den => Rval.Num * Lval.Den, ! Rbase => 0, ! Negative => Rneg))); end if; elsif Is_Integer (Lval.Num, Rval.Num) then - if Rval.Rbase = Lval.Rbase then ! return Store_Ureal ( ! (Num => Lval.Num / Rval.Num, ! Den => Lval.Den - Rval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Rval.Rbase = 0 then ! return Store_Ureal ( ! (Num => (Lval.Num / Rval.Num) * Rval.Den, ! Den => Lval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Rval.Den < 0 then declare --- 665,715 ---- pragma Assert (Rval.Num /= Uint_0); if Lval.Rbase = 0 then if Rval.Rbase = 0 then ! return Store_Ureal_Normalized ! ((Num => Lval.Num * Rval.Den, ! Den => Lval.Den * Rval.Num, ! Rbase => 0, ! Negative => Rneg)); elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then ! return Store_Ureal ! ((Num => Lval.Num / (Rval.Num * Lval.Den), ! Den => (-Rval.Den), ! Rbase => Rval.Rbase, ! Negative => Rneg)); elsif Rval.Den < 0 then ! return Store_Ureal_Normalized ! ((Num => Lval.Num, ! Den => Rval.Rbase ** (-Rval.Den) * ! Rval.Num * ! Lval.Den, ! Rbase => 0, ! Negative => Rneg)); else ! return Store_Ureal_Normalized ! ((Num => Lval.Num * Rval.Rbase ** Rval.Den, ! Den => Rval.Num * Lval.Den, ! Rbase => 0, ! Negative => Rneg)); end if; elsif Is_Integer (Lval.Num, Rval.Num) then if Rval.Rbase = Lval.Rbase then ! return Store_Ureal ! ((Num => Lval.Num / Rval.Num, ! Den => Lval.Den - Rval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Rval.Rbase = 0 then ! return Store_Ureal ! ((Num => (Lval.Num / Rval.Num) * Rval.Den, ! Den => Lval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Rval.Den < 0 then declare *************** package body Urealp is *** 721,740 **** (Rval.Rbase ** (-Rval.Den)); end if; ! return Store_Ureal ( ! (Num => Num, ! Den => Den, ! Rbase => 0, ! Negative => Rneg)); end; else ! return Store_Ureal ( ! (Num => (Lval.Num / Rval.Num) * ! (Rval.Rbase ** Rval.Den), ! Den => Lval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); end if; else --- 725,744 ---- (Rval.Rbase ** (-Rval.Den)); end if; ! return Store_Ureal ! ((Num => Num, ! Den => Den, ! Rbase => 0, ! Negative => Rneg)); end; else ! return Store_Ureal ! ((Num => (Lval.Num / Rval.Num) * ! (Rval.Rbase ** Rval.Den), ! Den => Lval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); end if; else *************** package body Urealp is *** 745,751 **** if Lval.Den < 0 then Num := Lval.Num * (Lval.Rbase ** (-Lval.Den)); Den := Rval.Num; - else Num := Lval.Num; Den := Rval.Num * (Lval.Rbase ** Lval.Den); --- 749,754 ---- *************** package body Urealp is *** 762,773 **** Num := Num * Rval.Den; end if; ! return Store_Ureal ( ! Normalize ( ! (Num => Num, ! Den => Den, ! Rbase => 0, ! Negative => Rneg))); end; end if; end UR_Div; --- 765,775 ---- Num := Num * Rval.Den; end if; ! return Store_Ureal_Normalized ! ((Num => Num, ! Den => Den, ! Rbase => 0, ! Negative => Rneg)); end; end if; end UR_Div; *************** package body Urealp is *** 814,824 **** if IBas <= 16 and then UR_From_Uint (IBas) = Bas then ! return Store_Ureal ( ! (Num => Uint_1, ! Den => -N, ! Rbase => UI_To_Int (UR_Trunc (Bas)), ! Negative => Neg)); -- If the exponent is negative then we raise the numerator and the -- denominator (after normalization) to the absolute value of the --- 816,826 ---- if IBas <= 16 and then UR_From_Uint (IBas) = Bas then ! return Store_Ureal ! ((Num => Uint_1, ! Den => -N, ! Rbase => UI_To_Int (UR_Trunc (Bas)), ! Negative => Neg)); -- If the exponent is negative then we raise the numerator and the -- denominator (after normalization) to the absolute value of the *************** package body Urealp is *** 829,839 **** pragma Assert (Val.Num /= 0); Val := Normalize (Val); ! return Store_Ureal ( ! (Num => Val.Den ** X, ! Den => Val.Num ** X, ! Rbase => 0, ! Negative => Neg)); -- If positive, we distinguish the case when the base is not zero, in -- which case the new denominator is just the product of the old one --- 831,841 ---- pragma Assert (Val.Num /= 0); Val := Normalize (Val); ! return Store_Ureal ! ((Num => Val.Den ** X, ! Den => Val.Num ** X, ! Rbase => 0, ! Negative => Neg)); -- If positive, we distinguish the case when the base is not zero, in -- which case the new denominator is just the product of the old one *************** package body Urealp is *** 842,862 **** else if Val.Rbase /= 0 then ! return Store_Ureal ( ! (Num => Val.Num ** X, ! Den => Val.Den * X, ! Rbase => Val.Rbase, ! Negative => Neg)); -- And when the base is zero, in which case we exponentiate -- the old denominator. else ! return Store_Ureal ( ! (Num => Val.Num ** X, ! Den => Val.Den ** X, ! Rbase => 0, ! Negative => Neg)); end if; end if; end UR_Exponentiate; --- 844,864 ---- else if Val.Rbase /= 0 then ! return Store_Ureal ! ((Num => Val.Num ** X, ! Den => Val.Den * X, ! Rbase => Val.Rbase, ! Negative => Neg)); -- And when the base is zero, in which case we exponentiate -- the old denominator. else ! return Store_Ureal ! ((Num => Val.Num ** X, ! Den => Val.Den ** X, ! Rbase => 0, ! Negative => Neg)); end if; end if; end UR_Exponentiate; *************** package body Urealp is *** 867,873 **** function UR_Floor (Real : Ureal) return Uint is Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); - begin if Val.Negative then return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den); --- 869,874 ---- *************** package body Urealp is *** 888,898 **** return Ureal is begin ! return Store_Ureal ( ! (Num => Num, ! Den => Den, ! Rbase => Rbase, ! Negative => Negative)); end UR_From_Components; ------------------ --- 889,899 ---- return Ureal is begin ! return Store_Ureal ! ((Num => Num, ! Den => Den, ! Rbase => Rbase, ! Negative => Negative)); end UR_From_Components; ------------------ *************** package body Urealp is *** 902,908 **** function UR_From_Uint (UI : Uint) return Ureal is begin return UR_From_Components ! (abs UI, Uint_1, Negative => (UI < 0)); end UR_From_Uint; ----------- --- 903,909 ---- function UR_From_Uint (UI : Uint) return Ureal is begin return UR_From_Components ! (abs UI, Uint_1, Negative => (UI < 0)); end UR_From_Uint; ----------- *************** package body Urealp is *** 1095,1161 **** begin if Lval.Rbase = 0 then if Rval.Rbase = 0 then ! return Store_Ureal ( ! Normalize ( ! (Num => Num, ! Den => Lval.Den * Rval.Den, ! Rbase => 0, ! Negative => Rneg))); elsif Is_Integer (Num, Lval.Den) then ! return Store_Ureal ( ! (Num => Num / Lval.Den, ! Den => Rval.Den, ! Rbase => Rval.Rbase, ! Negative => Rneg)); elsif Rval.Den < 0 then ! return Store_Ureal ( ! Normalize ( ! (Num => Num * (Rval.Rbase ** (-Rval.Den)), ! Den => Lval.Den, ! Rbase => 0, ! Negative => Rneg))); else ! return Store_Ureal ( ! Normalize ( ! (Num => Num, ! Den => Lval.Den * (Rval.Rbase ** Rval.Den), ! Rbase => 0, ! Negative => Rneg))); end if; elsif Lval.Rbase = Rval.Rbase then ! return Store_Ureal ( ! (Num => Num, ! Den => Lval.Den + Rval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Rval.Rbase = 0 then if Is_Integer (Num, Rval.Den) then ! return Store_Ureal ( ! (Num => Num / Rval.Den, ! Den => Lval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Lval.Den < 0 then ! return Store_Ureal ( ! Normalize ( ! (Num => Num * (Lval.Rbase ** (-Lval.Den)), ! Den => Rval.Den, ! Rbase => 0, ! Negative => Rneg))); else ! return Store_Ureal ( ! Normalize ( ! (Num => Num, ! Den => Rval.Den * (Lval.Rbase ** Lval.Den), ! Rbase => 0, ! Negative => Rneg))); end if; else --- 1096,1157 ---- begin if Lval.Rbase = 0 then if Rval.Rbase = 0 then ! return Store_Ureal_Normalized ! ((Num => Num, ! Den => Lval.Den * Rval.Den, ! Rbase => 0, ! Negative => Rneg)); elsif Is_Integer (Num, Lval.Den) then ! return Store_Ureal ! ((Num => Num / Lval.Den, ! Den => Rval.Den, ! Rbase => Rval.Rbase, ! Negative => Rneg)); elsif Rval.Den < 0 then ! return Store_Ureal_Normalized ! ((Num => Num * (Rval.Rbase ** (-Rval.Den)), ! Den => Lval.Den, ! Rbase => 0, ! Negative => Rneg)); else ! return Store_Ureal_Normalized ! ((Num => Num, ! Den => Lval.Den * (Rval.Rbase ** Rval.Den), ! Rbase => 0, ! Negative => Rneg)); end if; elsif Lval.Rbase = Rval.Rbase then ! return Store_Ureal ! ((Num => Num, ! Den => Lval.Den + Rval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Rval.Rbase = 0 then if Is_Integer (Num, Rval.Den) then ! return Store_Ureal ! ((Num => Num / Rval.Den, ! Den => Lval.Den, ! Rbase => Lval.Rbase, ! Negative => Rneg)); elsif Lval.Den < 0 then ! return Store_Ureal_Normalized ! ((Num => Num * (Lval.Rbase ** (-Lval.Den)), ! Den => Rval.Den, ! Rbase => 0, ! Negative => Rneg)); else ! return Store_Ureal_Normalized ! ((Num => Num, ! Den => Rval.Den * (Lval.Rbase ** Lval.Den), ! Rbase => 0, ! Negative => Rneg)); end if; else *************** package body Urealp is *** 1173,1184 **** Den := Den * (Rval.Rbase ** Rval.Den); end if; ! return Store_Ureal ( ! Normalize ( ! (Num => Num, ! Den => Den, ! Rbase => 0, ! Negative => Rneg))); end if; end UR_Mul; --- 1169,1179 ---- Den := Den * (Rval.Rbase ** Rval.Den); end if; ! return Store_Ureal_Normalized ! ((Num => Num, ! Den => Den, ! Rbase => 0, ! Negative => Rneg)); end if; end UR_Mul; *************** package body Urealp is *** 1228,1235 **** else Result := Rval.Negative /= Lval.Negative ! or else Rval.Num /= Lval.Num ! or else Rval.Den /= Lval.Den; Release (Imrk); Release (Rmrk); return Result; --- 1223,1230 ---- else Result := Rval.Negative /= Lval.Negative ! or else Rval.Num /= Lval.Num ! or else Rval.Den /= Lval.Den; Release (Imrk); Release (Rmrk); return Result; *************** package body Urealp is *** 1244,1254 **** function UR_Negate (Real : Ureal) return Ureal is begin ! return Store_Ureal ( ! (Num => Ureals.Table (Real).Num, ! Den => Ureals.Table (Real).Den, ! Rbase => Ureals.Table (Real).Rbase, ! Negative => not Ureals.Table (Real).Negative)); end UR_Negate; ------------ --- 1239,1249 ---- function UR_Negate (Real : Ureal) return Ureal is begin ! return Store_Ureal ! ((Num => Ureals.Table (Real).Num, ! Den => Ureals.Table (Real).Den, ! Rbase => Ureals.Table (Real).Rbase, ! Negative => not Ureals.Table (Real).Negative)); end UR_Negate; ------------ *************** package body Urealp is *** 1294,1300 **** function UR_Trunc (Real : Ureal) return Uint is Val : constant Ureal_Entry := Normalize (Ureals.Table (Real)); - begin if Val.Negative then return -(Val.Num / Val.Den); --- 1289,1294 ---- *************** package body Urealp is *** 1307,1338 **** -- UR_Write -- -------------- ! procedure UR_Write (Real : Ureal) is Val : constant Ureal_Entry := Ureals.Table (Real); begin -- If value is negative, we precede the constant by a minus sign - -- and add an extra layer of parentheses on the outside since the - -- minus sign is part of the value, not a negation operator. if Val.Negative then ! Write_Str ("(-"); end if; ! -- Constants in base 10 can be written in normal Ada literal style ! if Val.Rbase = 10 then ! UI_Write (Val.Num / 10); ! Write_Char ('.'); ! UI_Write (Val.Num mod 10); - if Val.Den /= 0 then Write_Char ('E'); ! UI_Write (1 - Val.Den); end if; ! -- Constants in a base other than 10 can still be easily written ! -- in normal Ada literal style if the numerator is one. elsif Val.Rbase /= 0 and then Val.Num = 1 then Write_Int (Val.Rbase); --- 1301,1444 ---- -- UR_Write -- -------------- ! procedure UR_Write (Real : Ureal; Brackets : Boolean := False) is Val : constant Ureal_Entry := Ureals.Table (Real); + T : Uint; begin -- If value is negative, we precede the constant by a minus sign if Val.Negative then ! Write_Char ('-'); end if; ! -- Zero is zero ! if Val.Num = 0 then ! Write_Str ("0.0"); ! ! -- For constants with a denominator of zero, the value is simply the ! -- numerator value, since we are dividing by base**0, which is 1. ! ! elsif Val.Den = 0 then ! UI_Write (Val.Num, Decimal); ! Write_Str (".0"); ! ! -- Small powers of 2 get written in decimal fixed-point format ! ! elsif Val.Rbase = 2 ! and then Val.Den <= 3 ! and then Val.Den >= -16 ! then ! if Val.Den = 1 then ! T := Val.Num * (10/2); ! UI_Write (T / 10, Decimal); ! Write_Char ('.'); ! UI_Write (T mod 10, Decimal); ! ! elsif Val.Den = 2 then ! T := Val.Num * (100/4); ! UI_Write (T / 100, Decimal); ! Write_Char ('.'); ! UI_Write (T mod 100 / 10, Decimal); ! ! if T mod 10 /= 0 then ! UI_Write (T mod 10, Decimal); ! end if; ! ! elsif Val.Den = 3 then ! T := Val.Num * (1000 / 8); ! UI_Write (T / 1000, Decimal); ! Write_Char ('.'); ! UI_Write (T mod 1000 / 100, Decimal); ! ! if T mod 100 /= 0 then ! UI_Write (T mod 100 / 10, Decimal); ! ! if T mod 10 /= 0 then ! UI_Write (T mod 10, Decimal); ! end if; ! end if; ! ! else ! UI_Write (Val.Num * (Uint_2 ** (-Val.Den)), Decimal); ! Write_Str (".0"); ! end if; ! ! -- Constants in base 10 or 16 can be written in normal Ada literal ! -- style, as long as they fit in the UI_Image_Buffer. Using hexadecimal ! -- notation, 4 bytes are required for the 16# # part, and every fifth ! -- character is an underscore. So, a buffer of size N has room for ! -- ((N - 4) - (N - 4) / 5) * 4 bits, ! -- or at least ! -- N * 16 / 5 - 12 bits. ! ! elsif (Val.Rbase = 10 or else Val.Rbase = 16) ! and then Num_Bits (Val.Num) < UI_Image_Buffer'Length * 16 / 5 - 12 ! then ! pragma Assert (Val.Den /= 0); ! ! -- Use fixed-point format for small scaling values ! ! if (Val.Rbase = 10 and then Val.Den < 0 and then Val.Den > -3) ! or else (Val.Rbase = 16 and then Val.Den = -1) ! then ! UI_Write (Val.Num * Val.Rbase**(-Val.Den), Decimal); ! Write_Str (".0"); ! ! -- Write hexadecimal constants in exponential notation with a zero ! -- unit digit. This matches the Ada canonical form for floating point ! -- numbers, and also ensures that the underscores end up in the ! -- correct place. ! ! elsif Val.Rbase = 16 then ! UI_Image (Val.Num, Hex); ! pragma Assert (Val.Rbase = 16); ! ! Write_Str ("16#0."); ! Write_Str (UI_Image_Buffer (4 .. UI_Image_Length)); ! ! -- For exponent, exclude 16# # and underscores from length ! ! UI_Image_Length := UI_Image_Length - 4; ! UI_Image_Length := UI_Image_Length - UI_Image_Length / 5; Write_Char ('E'); ! UI_Write (Int (UI_Image_Length) - Val.Den, Decimal); ! ! elsif Val.Den = 1 then ! UI_Write (Val.Num / 10, Decimal); ! Write_Char ('.'); ! UI_Write (Val.Num mod 10, Decimal); ! ! elsif Val.Den = 2 then ! UI_Write (Val.Num / 100, Decimal); ! Write_Char ('.'); ! UI_Write (Val.Num / 10 mod 10, Decimal); ! UI_Write (Val.Num mod 10, Decimal); ! ! -- Else use decimal exponential format ! ! else ! -- Write decimal constants with a non-zero unit digit. This ! -- matches usual scientific notation. ! ! UI_Image (Val.Num, Decimal); ! Write_Char (UI_Image_Buffer (1)); ! Write_Char ('.'); ! ! if UI_Image_Length = 1 then ! Write_Char ('0'); ! else ! Write_Str (UI_Image_Buffer (2 .. UI_Image_Length)); ! end if; ! ! Write_Char ('E'); ! UI_Write (Int (UI_Image_Length - 1) - Val.Den, Decimal); end if; ! -- Constants in a base other than 10 can still be easily written in ! -- normal Ada literal style if the numerator is one. elsif Val.Rbase /= 0 and then Val.Num = 1 then Write_Int (Val.Rbase); *************** package body Urealp is *** 1343,1390 **** -- of the following forms, depending on the sign of the number -- and the sign of the exponent (= minus denominator value) ! -- (numerator.0*base**exponent) ! -- (numerator.0*base**(-exponent)) elsif Val.Rbase /= 0 then ! Write_Char ('('); UI_Write (Val.Num, Decimal); ! Write_Str (".0*"); ! Write_Int (Val.Rbase); ! Write_Str ("**"); ! if Val.Den <= 0 then ! UI_Write (-Val.Den, Decimal); ! else ! Write_Str ("(-"); ! UI_Write (Val.Den, Decimal); ! Write_Char (')'); end if; ! Write_Char (')'); ! -- Rational constants with a denominator of 1 can be written as ! -- a real literal for the numerator integer. ! elsif Val.Den = 1 then ! UI_Write (Val.Num, Decimal); Write_Str (".0"); ! -- Non-based (rational) constants are written in (num/den) style else ! Write_Char ('('); UI_Write (Val.Num, Decimal); Write_Str (".0/"); UI_Write (Val.Den, Decimal); ! Write_Str (".0)"); ! end if; ! ! -- Add trailing paren for negative values ! if Val.Negative then ! Write_Char (')'); end if; end UR_Write; --- 1449,1508 ---- -- of the following forms, depending on the sign of the number -- and the sign of the exponent (= minus denominator value) ! -- numerator.0*base**exponent ! -- numerator.0*base**-exponent ! ! -- And of course an exponent of 0 can be omitted elsif Val.Rbase /= 0 then ! if Brackets then ! Write_Char ('['); ! end if; ! UI_Write (Val.Num, Decimal); ! Write_Str (".0"); ! if Val.Den /= 0 then ! Write_Char ('*'); ! Write_Int (Val.Rbase); ! Write_Str ("**"); ! if Val.Den <= 0 then ! UI_Write (-Val.Den, Decimal); ! else ! Write_Str ("(-"); ! UI_Write (Val.Den, Decimal); ! Write_Char (')'); ! end if; end if; ! if Brackets then ! Write_Char (']'); ! end if; ! -- Rationals where numerator is divisible by denominator can be output ! -- as literals after we do the division. This includes the common case ! -- where the denominator is 1. ! elsif Val.Num mod Val.Den = 0 then ! UI_Write (Val.Num / Val.Den, Decimal); Write_Str (".0"); ! -- Other non-based (rational) constants are written in num/den style else ! if Brackets then ! Write_Char ('['); ! end if; ! UI_Write (Val.Num, Decimal); Write_Str (".0/"); UI_Write (Val.Den, Decimal); ! Write_Str (".0"); ! if Brackets then ! Write_Char (']'); ! end if; end if; end UR_Write; diff -Nrcpad gcc-4.5.2/gcc/ada/urealp.ads gcc-4.6.0/gcc/ada/urealp.ads *** gcc-4.5.2/gcc/ada/urealp.ads Thu Apr 9 15:00:19 2009 --- gcc-4.6.0/gcc/ada/urealp.ads Fri Sep 10 11:01:37 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** package Urealp is *** 264,277 **** function UR_Is_Positive (Real : Ureal) return Boolean; -- Test if real value is greater than zero ! procedure UR_Write (Real : Ureal); ! -- Writes value of Real to standard output. Used only for debugging and ! -- tree/source output. If the result is easily representable as a standard ! -- Ada literal, it will be given that way, but as a result of evaluation ! -- of static expressions, it is possible to generate constants (e.g. 1/13) ! -- which have no such representation. In such cases (and in cases where it ! -- is too much work to figure out the Ada literal), the string that is ! -- output is of the form [numerator/denominator]. procedure pr (Real : Ureal); pragma Export (Ada, pr); --- 264,280 ---- function UR_Is_Positive (Real : Ureal) return Boolean; -- Test if real value is greater than zero ! procedure UR_Write (Real : Ureal; Brackets : Boolean := False); ! -- Writes value of Real to standard output. Used for debugging and ! -- tree/source output, and also for -gnatR representation output. If the ! -- result is easily representable as a standard Ada literal, it will be ! -- given that way, but as a result of evaluation of static expressions, it ! -- is possible to generate constants (e.g. 1/13) which have no such ! -- representation. In such cases (and in cases where it is too much work to ! -- figure out the Ada literal), the string that is output is of the form ! -- of some expression such as integer/integer, or integer*integer**integer. ! -- In the case where an expression is output, if Brackets is set to True, ! -- the expression is surrounded by square brackets. procedure pr (Real : Ureal); pragma Export (Ada, pr); diff -Nrcpad gcc-4.5.2/gcc/ada/usage.adb gcc-4.6.0/gcc/ada/usage.adb *** gcc-4.5.2/gcc/ada/usage.adb Tue Jan 26 14:02:25 2010 --- gcc-4.6.0/gcc/ada/usage.adb Tue Oct 26 12:45:45 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** begin *** 177,182 **** --- 177,187 ---- Write_Switch_Char ("eD?"); Write_Line ("Define or redefine preprocessing symbol, e.g. -gnateDsym=val"); + -- Line for -gnateE switch + + Write_Switch_Char ("eE"); + Write_Line ("Generate extra information in exception messages"); + -- Line for -gnatef switch Write_Switch_Char ("ef"); *************** begin *** 202,207 **** --- 207,217 ---- Write_Switch_Char ("ep=?"); Write_Line ("Specify preprocessing data file, e.g. -gnatep=prep.data"); + -- Line for -gnateP switch + + Write_Switch_Char ("eP"); + Write_Line ("Pure/Prelaborate errors generate warnings rather than errors"); + -- Line for -gnateS switch Write_Switch_Char ("eS"); *************** begin *** 279,285 **** -- Line for -gnatn switch Write_Switch_Char ("n"); ! Write_Line ("Inlining of subprograms (apply pragma Inline across units)"); -- Line for -gnatN switch --- 289,295 ---- -- Line for -gnatn switch Write_Switch_Char ("n"); ! Write_Line ("Enable pragma Inline (both within and across units)"); -- Line for -gnatN switch *************** begin *** 397,443 **** Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); ! Write_Line (" a turn on all optional info/warnings " & ! "(except dhl.ot.w)"); Write_Line (" A turn off all optional info/warnings"); ! Write_Line (" .a* turn on warnings for failing assertion"); Write_Line (" .A turn off warnings for failing assertion"); ! Write_Line (" b turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & "(not multiple of small)"); ! Write_Line (" .b* turn on warnings for biased representation"); Write_Line (" .B turn off warnings for biased representation"); ! Write_Line (" c turn on warnings for constant conditional"); Write_Line (" C* turn off warnings for constant conditional"); ! Write_Line (" .c turn on warnings for unrepped components"); Write_Line (" .C* turn off warnings for unrepped components"); Write_Line (" d turn on warnings for implicit dereference"); Write_Line (" D* turn off warnings for implicit dereference"); Write_Line (" e treat all warnings (but not info) as errors"); Write_Line (" .e turn on every optional info/warning " & "(no exceptions)"); ! Write_Line (" f turn on warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal"); ! Write_Line (" g* turn on warnings for unrecognized pragma"); Write_Line (" G turn off warnings for unrecognized pragma"); ! Write_Line (" h turn on warnings for hiding variable"); ! Write_Line (" H* turn off warnings for hiding variable"); ! Write_Line (" i* turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); Write_Line (" .i turn on warnings for overlapping actuals"); Write_Line (" .I* turn off warnings for overlapping actuals"); ! Write_Line (" j turn on warnings for obsolescent " & "(annex J) feature"); Write_Line (" J* turn off warnings for obsolescent " & "(annex J) feature"); ! Write_Line (" k turn on warnings on constant variable"); Write_Line (" K* turn off warnings on constant variable"); Write_Line (" l turn on warnings for missing " & "elaboration pragma"); Write_Line (" L* turn off warnings for missing " & "elaboration pragma"); ! Write_Line (" m turn on warnings for variable assigned " & "but not read"); Write_Line (" M* turn off warnings for variable assigned " & "but not read"); --- 407,456 ---- Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); ! Write_Line (" a turn on all info/warnings marked below with +"); Write_Line (" A turn off all optional info/warnings"); ! Write_Line (" .a*+ turn on warnings for failing assertion"); Write_Line (" .A turn off warnings for failing assertion"); ! Write_Line (" b+ turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & "(not multiple of small)"); ! Write_Line (" .b*+ turn on warnings for biased representation"); Write_Line (" .B turn off warnings for biased representation"); ! Write_Line (" c+ turn on warnings for constant conditional"); Write_Line (" C* turn off warnings for constant conditional"); ! Write_Line (" .c+ turn on warnings for unrepped components"); Write_Line (" .C* turn off warnings for unrepped components"); Write_Line (" d turn on warnings for implicit dereference"); Write_Line (" D* turn off warnings for implicit dereference"); Write_Line (" e treat all warnings (but not info) as errors"); Write_Line (" .e turn on every optional info/warning " & "(no exceptions)"); ! Write_Line (" f+ turn on warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal"); ! Write_Line (" g*+ turn on warnings for unrecognized pragma"); Write_Line (" G turn off warnings for unrecognized pragma"); ! Write_Line (" h turn on warnings for hiding declarations"); ! Write_Line (" H* turn off warnings for hiding declarations"); ! Write_Line (" .h turn on warnings for holes in records"); ! Write_Line (" .H* turn off warnings for holes in records"); ! Write_Line (" i*+ turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); Write_Line (" .i turn on warnings for overlapping actuals"); Write_Line (" .I* turn off warnings for overlapping actuals"); ! Write_Line (" j+ turn on warnings for obsolescent " & "(annex J) feature"); Write_Line (" J* turn off warnings for obsolescent " & "(annex J) feature"); ! Write_Line (" k+ turn on warnings on constant variable"); Write_Line (" K* turn off warnings on constant variable"); Write_Line (" l turn on warnings for missing " & "elaboration pragma"); Write_Line (" L* turn off warnings for missing " & "elaboration pragma"); ! Write_Line (" .l* turn on info messages for inherited aspects"); ! Write_Line (" .L turn off info messages for inherited aspects"); ! Write_Line (" m+ turn on warnings for variable assigned " & "but not read"); Write_Line (" M* turn off warnings for variable assigned " & "but not read"); *************** begin *** 450,496 **** "but not read"); Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); ! Write_Line (" p turn on warnings for ineffective pragma " & "Inline in frontend"); Write_Line (" P* turn off warnings for ineffective pragma " & "Inline in frontend"); ! Write_Line (" .p turn on warnings for suspicious parameter " & "order"); Write_Line (" .P* turn off warnings for suspicious parameter " & "order"); ! Write_Line (" q* turn on warnings for questionable " & "missing parenthesis"); Write_Line (" Q turn off warnings for questionable " & "missing parenthesis"); ! Write_Line (" r turn on warnings for redundant construct"); Write_Line (" R* turn off warnings for redundant construct"); ! Write_Line (" .r turn on warnings for object renaming function"); Write_Line (" .R* turn off warnings for object renaming function"); Write_Line (" s suppress all info/warnings"); Write_Line (" t turn on warnings for tracking deleted code"); Write_Line (" T* turn off warnings for tracking deleted code"); ! Write_Line (" u turn on warnings for unused entity"); Write_Line (" U* turn off warnings for unused entity"); ! Write_Line (" v* turn on warnings for unassigned variable"); Write_Line (" V turn off warnings for unassigned variable"); ! Write_Line (" .v* turn on info messages for reverse bit order"); Write_Line (" .V turn off info messages for reverse bit order"); ! Write_Line (" w* turn on warnings for wrong low bound assumption"); Write_Line (" W turn off warnings for wrong low bound " & "assumption"); Write_Line (" .w turn on warnings on pragma Warnings Off"); Write_Line (" .W* turn off warnings on pragma Warnings Off"); ! Write_Line (" x* turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); ! Write_Line (" .x turn on warnings for non-local exception"); Write_Line (" .X* turn off warnings for non-local exception"); ! Write_Line (" y* turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); ! Write_Line (" z* turn on warnings for suspicious " & "unchecked conversion"); Write_Line (" Z turn off warnings for suspicious " & "unchecked conversion"); Write_Line (" * indicates default in above list"); -- Line for -gnatW switch --- 463,514 ---- "but not read"); Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); ! Write_Line (" p+ turn on warnings for ineffective pragma " & "Inline in frontend"); Write_Line (" P* turn off warnings for ineffective pragma " & "Inline in frontend"); ! Write_Line (" .p+ turn on warnings for suspicious parameter " & "order"); Write_Line (" .P* turn off warnings for suspicious parameter " & "order"); ! Write_Line (" q*+ turn on warnings for questionable " & "missing parenthesis"); Write_Line (" Q turn off warnings for questionable " & "missing parenthesis"); ! Write_Line (" r+ turn on warnings for redundant construct"); Write_Line (" R* turn off warnings for redundant construct"); ! Write_Line (" .r+ turn on warnings for object renaming function"); Write_Line (" .R* turn off warnings for object renaming function"); Write_Line (" s suppress all info/warnings"); + Write_Line (" .s turn on warnings for overridden size clause"); + Write_Line (" .S* turn off warnings for overridden size clause"); Write_Line (" t turn on warnings for tracking deleted code"); Write_Line (" T* turn off warnings for tracking deleted code"); ! Write_Line (" u+ turn on warnings for unused entity"); Write_Line (" U* turn off warnings for unused entity"); ! Write_Line (" .u turn on warnings for unordered enumeration"); ! Write_Line (" .U* turn off warnings for unordered enumeration"); ! Write_Line (" v*+ turn on warnings for unassigned variable"); Write_Line (" V turn off warnings for unassigned variable"); ! Write_Line (" .v*+ turn on info messages for reverse bit order"); Write_Line (" .V turn off info messages for reverse bit order"); ! Write_Line (" w*+ turn on warnings for wrong low bound assumption"); Write_Line (" W turn off warnings for wrong low bound " & "assumption"); Write_Line (" .w turn on warnings on pragma Warnings Off"); Write_Line (" .W* turn off warnings on pragma Warnings Off"); ! Write_Line (" x*+ turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); ! Write_Line (" .x+ turn on warnings for non-local exception"); Write_Line (" .X* turn off warnings for non-local exception"); ! Write_Line (" y*+ turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); ! Write_Line (" z*+ turn on warnings for suspicious " & "unchecked conversion"); Write_Line (" Z turn off warnings for suspicious " & "unchecked conversion"); Write_Line (" * indicates default in above list"); + Write_Line (" + indicates warning flag included in -gnatwa"); -- Line for -gnatW switch *************** begin *** 592,601 **** Write_Switch_Char ("05"); ! if Ada_Version_Default = Ada_05 then Write_Line ("Ada 2005 mode (default)"); else ! Write_Line ("Allow Ada 2005 extensions"); end if; end Usage; --- 610,634 ---- Write_Switch_Char ("05"); ! if Ada_Version_Default = Ada_2005 then Write_Line ("Ada 2005 mode (default)"); else ! Write_Line ("Enforce Ada 2005 restrictions"); ! end if; ! ! -- Line for -gnat12 switch ! ! Write_Switch_Char ("12"); ! ! if Ada_Version_Default = Ada_2012 then ! Write_Line ("Ada 2012 mode (default)"); ! else ! Write_Line ("Allow Ada 2012 extensions"); end if; + -- Line for -gnat-p switch + + Write_Switch_Char ("-p"); + Write_Line ("Cancel effect of previous -gnatp switch"); + end Usage; diff -Nrcpad gcc-4.5.2/gcc/ada/vms_cmds.ads gcc-4.6.0/gcc/ada/vms_cmds.ads *** gcc-4.5.2/gcc/ada/vms_cmds.ads Thu Jan 1 00:00:00 1970 --- gcc-4.6.0/gcc/ada/vms_cmds.ads Fri Sep 10 10:41:02 2010 *************** *** 0 **** --- 1,52 ---- + ------------------------------------------------------------------------------ + -- -- + -- GNAT COMPILER COMPONENTS -- + -- -- + -- V M S _ C M D S -- + -- -- + -- S p e c -- + -- -- + -- Copyright (C) 2010, 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- -- + -- ware Foundation; either version 3, or (at your option) any later ver- -- + -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- + -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- + -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- + -- for more details. You should have received a copy of the GNU General -- + -- Public License distributed with GNAT; see file COPYING3. If not, go to -- + -- http://www.gnu.org/licenses for a complete copy of the license. -- + -- -- + -- GNAT was originally developed by the GNAT team at New York University. -- + -- Extensive contributions were provided by Ada Core Technologies Inc. -- + -- -- + ------------------------------------------------------------------------------ + + -- This package is part of the GNAT driver. It contains the declaration of + -- Command_Type which list all the commands supported by the gnat driver. + + package VMS_Cmds is + type Command_Type is + (Bind, + Chop, + Clean, + Compile, + Check, + Sync, + Elim, + Find, + Krunch, + Link, + List, + Make, + Metric, + Name, + Preprocess, + Pretty, + Shared, + Stack, + Stub, + Xref, + Undefined); + end VMS_Cmds; diff -Nrcpad gcc-4.5.2/gcc/ada/vms_conv.adb gcc-4.6.0/gcc/ada/vms_conv.adb *** gcc-4.5.2/gcc/ada/vms_conv.adb Wed Jul 22 10:25:32 2009 --- gcc-4.6.0/gcc/ada/vms_conv.adb Thu Sep 9 10:39:19 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1996-2010, 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- -- *************** package body VMS_Conv is *** 314,329 **** loop declare Dir : constant String_Access := ! String_Access (Get_Next_Dir_In_Path (Object_Dir_Name)); begin exit when Dir = null; Object_Dirs := Object_Dirs + 1; Object_Dir (Object_Dirs) := new String'("-L" & To_Canonical_Dir_Spec ! (To_Host_Dir_Spec ! (Normalize_Directory_Name (Dir.all).all, ! True).all, True).all); end; end loop; --- 314,329 ---- loop declare Dir : constant String_Access := ! Get_Next_Dir_In_Path (Object_Dir_Name); begin exit when Dir = null; Object_Dirs := Object_Dirs + 1; Object_Dir (Object_Dirs) := new String'("-L" & To_Canonical_Dir_Spec ! (To_Host_Dir_Spec ! (Normalize_Directory_Name (Dir.all).all, ! True).all, True).all); end; end loop; *************** package body VMS_Conv is *** 2274,2282 **** New_Line; while Commands /= null loop ! Put (Commands.Usage.all); ! Set_Col (53); ! Put_Line (Commands.Unix_String.all); Commands := Commands.Next; end loop; --- 2274,2288 ---- New_Line; while Commands /= null loop ! ! -- No usage for GNAT SYNC ! ! if Commands.Command /= Sync then ! Put (Commands.Usage.all); ! Set_Col (53); ! Put_Line (Commands.Unix_String.all); ! end if; ! Commands := Commands.Next; end loop; diff -Nrcpad gcc-4.5.2/gcc/ada/vms_conv.ads gcc-4.6.0/gcc/ada/vms_conv.ads *** gcc-4.5.2/gcc/ada/vms_conv.ads Sun Apr 13 18:03:09 2008 --- gcc-4.6.0/gcc/ada/vms_conv.ads Thu Sep 9 13:38:12 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2008, 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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 2003-2010, 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- -- *************** *** 30,35 **** --- 30,36 ---- with Table; with VMS_Data; use VMS_Data; + with VMS_Cmds; use VMS_Cmds; with GNAT.OS_Lib; use GNAT.OS_Lib; *************** package VMS_Conv is *** 92,120 **** type Parameter_Array is array (Natural range <>) of Parameter_Type; type Parameter_Ref is access all Parameter_Array; - type Command_Type is - (Bind, - Chop, - Clean, - Compile, - Check, - Sync, - Elim, - Find, - Krunch, - Link, - List, - Make, - Metric, - Name, - Preprocess, - Pretty, - Shared, - Stack, - Stub, - Xref, - Undefined); - type Alternate_Command is (Comp, Ls, Kr, Pp, Prep); -- Alternate command label for non VMS system use --- 93,98 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/vms_data.ads gcc-4.6.0/gcc/ada/vms_data.ads *** gcc-4.5.2/gcc/ada/vms_data.ads Mon Nov 30 16:31:31 2009 --- gcc-4.6.0/gcc/ada/vms_data.ads Tue Oct 26 10:51:36 2010 *************** *** 6,12 **** -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-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- -- --- 6,12 ---- -- -- -- S p e c -- -- -- ! -- Copyright (C) 1996-2010, 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- -- *************** package VMS_Data is *** 196,201 **** --- 196,209 ---- -- -- Add directories to the project search path. + S_Bind_ALI : aliased constant S := "/ALI_LIST " & + "-A"; + -- /NOALI_LIST (D) + -- /ALI_LIST + -- + -- Output full names of all the ALI files in the partition. The output is + -- written to SYS$OUTPUT. + S_Bind_Bind : aliased constant S := "/BIND_FILE=" & "ADA " & "-A " & *************** package VMS_Data is *** 345,350 **** --- 353,372 ---- -- -- The main program is not in Ada. + S_Bind_Alloc32 : aliased constant S := "/32_MALLOC " & + "-H32"; + -- /32_MALLOC + -- + -- Use 32-bit allocations for `__gnat_malloc' (and thus for + -- access types). + + S_Bind_Alloc64 : aliased constant S := "/64_MALLOC " & + "-H64"; + -- /64_MALLOC + -- + -- Use 64-bit allocations for `__gnat_malloc' (and thus for + -- access types). + S_Bind_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & "DEFAULT " & "-vP0 " & *************** package VMS_Data is *** 385,391 **** -- /NOOBJECT_LIST (D) -- /OBJECT_LIST -- ! -- Output full names of all the object files that must be linker to -- provide the Ada component of the program. The output is written to -- SYS$OUTPUT. --- 407,413 ---- -- /NOOBJECT_LIST (D) -- /OBJECT_LIST -- ! -- Output full names of all the object files that must be linked to -- provide the Ada component of the program. The output is written to -- SYS$OUTPUT. *************** package VMS_Data is *** 669,674 **** --- 691,697 ---- Bind_Switches : aliased constant Switches := (S_Bind_Add 'Access, + S_Bind_ALI 'Access, S_Bind_Bind 'Access, S_Bind_Build 'Access, S_Bind_Current 'Access, *************** package VMS_Data is *** 685,690 **** --- 708,715 ---- S_Bind_Library 'Access, S_Bind_Linker 'Access, S_Bind_Main 'Access, + S_Bind_Alloc32 'Access, + S_Bind_Alloc64 'Access, S_Bind_Mess 'Access, S_Bind_Nostinc 'Access, S_Bind_Nostlib 'Access, *************** package VMS_Data is *** 834,870 **** -- -- Duplicate all the output sent to Stderr into a log file. - S_Check_Sections : aliased constant S := "/SECTIONS=" & - "DEFAULT " & - "-s123 " & - "COMPILER_STYLE " & - "-s1 " & - "BY_RULES " & - "-s2 " & - "BY_FILES_BY_RULES " & - "-s3"; - -- /SECTIONS[=section-option, section-option, ...] - -- - -- Specify what sections should be included into the report file. - -- By default, all three section (diagnoses in the format corresponding - -- to compiler error and warning messages, diagnoses grouped by rules and - -- then - by files, diagnoses grouped by files and then - by rules) are - -- included in the report file. - -- - -- section-option may be one of the following: - -- - -- COMPILER_STYLE Include diagnostics in compile-style format - -- (diagnoses are grouped by files, for each file - -- they are ordered according to the references - -- into the source) - -- BY_RULES Include diagnostics grouped first by rules and - -- then by files - -- BY_FILES_BY_RULES Include diagnostics grouped first by files and - -- then by rules - -- - -- If one of these options is specified, then the report file contains - -- only sections set by these options - S_Check_Short : aliased constant S := "/SHORT " & "-s"; -- /NOSHORT (D) --- 859,864 ---- *************** package VMS_Data is *** 872,877 **** --- 866,879 ---- -- -- Generate a short form of the report file. + S_Check_Include : aliased constant S := "/INCLUDE_FILE=@" & + "--include-file=@"; + + -- /INCLUDE_FILE=filename + -- + -- Add the content of the specified text file to the generated report + -- file. + S_Check_Subdirs : aliased constant S := "/SUBDIRS=<" & "--subdirs=>"; -- /SUBDIRS=dir *************** package VMS_Data is *** 896,919 **** -- Specify the name of the output file. Check_Switches : aliased constant Switches := ! (S_Check_Add 'Access, ! S_Check_All 'Access, ! S_Diagnosis 'Access, ! S_Check_Ext 'Access, ! S_Check_Files 'Access, ! S_Check_Follow 'Access, ! S_Check_Help 'Access, ! S_Check_Locs 'Access, ! S_Check_Mess 'Access, ! S_Check_Project 'Access, ! S_Check_Quiet 'Access, ! S_Check_Time 'Access, ! S_Check_Log 'Access, ! S_Check_Sections 'Access, ! S_Check_Short 'Access, ! S_Check_Subdirs 'Access, ! S_Check_Verb 'Access, ! S_Check_Out 'Access); ---------------------------- -- Switches for GNAT CHOP -- --- 898,921 ---- -- Specify the name of the output file. Check_Switches : aliased constant Switches := ! (S_Check_Add 'Access, ! S_Check_All 'Access, ! S_Diagnosis 'Access, ! S_Check_Ext 'Access, ! S_Check_Files 'Access, ! S_Check_Follow 'Access, ! S_Check_Help 'Access, ! S_Check_Locs 'Access, ! S_Check_Mess 'Access, ! S_Check_Project'Access, ! S_Check_Quiet 'Access, ! S_Check_Time 'Access, ! S_Check_Log 'Access, ! S_Check_Short 'Access, ! S_Check_Include'Access, ! S_Check_Subdirs'Access, ! S_Check_Verb 'Access, ! S_Check_Out 'Access); ---------------------------- -- Switches for GNAT CHOP -- *************** package VMS_Data is *** 1168,1173 **** --- 1170,1182 ---- -- of the directory specified in the project file. If the subdirectory -- does not exist, it is created automatically. + S_Clean_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + S_Clean_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) *************** package VMS_Data is *** 1193,1199 **** S_Clean_Recurs 'Access, S_Clean_Search 'Access, S_Clean_Subdirs'Access, ! S_Clean_Verbose'Access); ------------------------------- -- Switches for GNAT COMPILE -- --- 1202,1209 ---- S_Clean_Recurs 'Access, S_Clean_Search 'Access, S_Clean_Subdirs'Access, ! S_Clean_Verbose'Access, ! S_Clean_USL 'Access); ------------------------------- -- Switches for GNAT COMPILE -- *************** package VMS_Data is *** 1233,1241 **** "-gnat05"; -- /05 (D) -- ! -- Allows GNAT to recognize all implemented proposed Ada 2005 -- extensions. See features file for list of implemented features. S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) --- 1243,1272 ---- "-gnat05"; -- /05 (D) -- ! -- Allows GNAT to recognize the full range of Ada 2005 constructs. ! ! S_GCC_Ada_2005 : aliased constant S := "/2005 " & ! "-gnat2005"; ! -- /05 (D) ! -- ! -- Allows GNAT to recognize the full range of Ada 2005 constructs. ! -- Equivalent to /05 (/2005 is the preferred usage). ! ! S_GCC_Ada_12 : aliased constant S := "/12 " & ! "-gnat12"; ! -- /05 (D) ! -- ! -- Allows GNAT to recognize all implemented proposed Ada 2012 -- extensions. See features file for list of implemented features. + S_GCC_Ada_2012 : aliased constant S := "/2012 " & + "-gnat2012"; + -- /05 (D) + -- + -- Allows GNAT to recognize all implemented proposed Ada 2012 + -- extensions. See features file for list of implemented features. + -- Equivalent to /12 (/2012 is the preferred usage). + S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & "-aP*"; -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) *************** package VMS_Data is *** 1276,1282 **** "STACK " & "-fstack-check " & "SUPPRESS_ALL " & ! "-gnatp"; -- /NOCHECKS -- /CHECKS[=(keyword[,...])] -- --- 1307,1315 ---- "STACK " & "-fstack-check " & "SUPPRESS_ALL " & ! "-gnatp " & ! "UNSUPPRESS_ALL " & ! "-gnat-p"; -- /NOCHECKS -- /CHECKS[=(keyword[,...])] -- *************** package VMS_Data is *** 1290,1336 **** -- You may specify one or more of the following keywords to the /CHECKS -- qualifier to modify this behavior: -- ! -- DEFAULT The behavior described above. This is the default ! -- if the /CHECKS qualifier is not present on the ! -- command line. Same as /NOCHECKS. -- ! -- OVERFLOW Enables overflow checking for integer operations and ! -- checks for access before elaboration on subprogram ! -- calls. This causes GNAT to generate slower and larger ! -- executable programs by adding code to check for both ! -- overflow and division by zero (resulting in raising ! -- "Constraint_Error" as required by Ada semantics). ! -- Similarly, GNAT does not generate elaboration check ! -- by default, and you must specify this keyword to ! -- enable them. -- ! -- Note that this keyword does not affect the code ! -- generated for any floating-point operations; it ! -- applies only to integer operations. For floating-point, ! -- GNAT has the "Machine_Overflows" attribute set to ! -- "False" and the normal mode of operation is to generate ! -- IEEE NaN and infinite values on overflow or invalid ! -- operations (such as dividing 0.0 by 0.0). -- ! -- ELABORATION Enables dynamic checks for access-before-elaboration ! -- on subprogram calls and generic instantiations. -- ! -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no ! -- effect and are ignored. This keyword causes "Assert" ! -- and "Debug" pragmas to be activated, as well as ! -- "Check", "Precondition" and "Postcondition" pragmas. -- ! -- SUPPRESS_ALL Suppress all runtime checks as though you have "pragma ! -- Suppress (all_checks)" in your source. Use this switch ! -- to improve the performance of the code at the expense ! -- of safety in the presence of invalid data or program ! -- bugs. -- ! -- DEFAULT Suppress the effect of any option OVERFLOW or ! -- ASSERTIONS. -- ! -- FULL (D) Similar to OVERFLOW, but suppress the effect of any ! -- option ELABORATION or SUPPRESS_ALL. -- -- These keywords only control the default setting of the checks. You -- may modify them using either "Suppress" (to remove checks) or --- 1323,1372 ---- -- You may specify one or more of the following keywords to the /CHECKS -- qualifier to modify this behavior: -- ! -- DEFAULT The behavior described above. This is the default ! -- if the /CHECKS qualifier is not present on the ! -- command line. Same as /NOCHECKS. -- ! -- OVERFLOW Enables overflow checking for integer operations and ! -- checks for access before elaboration on subprogram ! -- calls. This causes GNAT to generate slower and larger ! -- executable programs by adding code to check for both ! -- overflow and division by zero (resulting in raising ! -- "Constraint_Error" as required by Ada semantics). ! -- Similarly, GNAT does not generate elaboration check ! -- by default, and you must specify this keyword to ! -- enable them. -- ! -- Note that this keyword does not affect the code ! -- generated for any floating-point operations; it ! -- applies only to integer operations. For the case of ! -- floating-point, GNAT has the "Machine_Overflows" ! -- attribute set to "False" and the normal mode of ! -- operation is to generate IEEE NaN and infinite values ! -- on overflow or invalid operations (such as dividing ! -- 0.0 by 0.0). -- ! -- ELABORATION Enables dynamic checks for access-before-elaboration ! -- on subprogram calls and generic instantiations. -- ! -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no ! -- effect and are ignored. This keyword causes "Assert" ! -- and "Debug" pragmas to be activated, as well as ! -- "Check", "Precondition" and "Postcondition" pragmas. -- ! -- SUPPRESS_ALL Suppress all runtime checks as though you have ! -- "pragma Suppress (all_checks)" in your source. Use ! -- this switch to improve the performance of the code at ! -- the expense of safety in the presence of invalid data ! -- or program bugs. -- ! -- UNSUPPRESS_ALL Cancels effect of previous SUPPRESS_ALL. -- ! -- DEFAULT Suppress the effect of any option OVERFLOW or ! -- ASSERTIONS. ! -- ! -- FULL (D) Similar to OVERFLOW, but suppress the effect of any ! -- option ELABORATION or SUPPRESS_ALL. -- -- These keywords only control the default setting of the checks. You -- may modify them using either "Suppress" (to remove checks) or *************** package VMS_Data is *** 1507,1512 **** --- 1543,1557 ---- "-gnatm999999"; -- NODOC (see /ERROR_LIMIT) + S_GCC_Except : aliased constant S := "/EXTRA_EXCEPTION_INFORMATION " & + "-gnateE"; + -- /EXTRA_EXCEPTION_INFORMATION + -- + -- Generate extra information in exception messages, in particular + -- display extra column information and the value and range associated + -- with index and range check failures, and extra column information for + -- access checks. + S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " & "-gnatG"; -- /NOEXPAND_SOURCE (D) *************** package VMS_Data is *** 2206,2211 **** --- 2251,2263 ---- -- -- When looking for source files also look in directories specified. + S_GCC_Src_Info : aliased constant S := "/SRC_INFO=<" & + "--source-info=>"; + -- /SRC_INFO=source-info-file + -- + -- Specify a source info file to be read or written by the Project + -- Manager when project files are used. + S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" & "ALL_BUILTIN " & "-gnatyy " & *************** package VMS_Data is *** 2239,2248 **** "-gnaty-A " & "BLANKS " & "-gnatyb " & - "BOOLEAN_OPERATORS " & - "-gnatyB " & "NOBLANKS " & "-gnaty-b " & "COMMENTS " & "-gnatyc " & "NOCOMMENTS " & --- 2291,2302 ---- "-gnaty-A " & "BLANKS " & "-gnatyb " & "NOBLANKS " & "-gnaty-b " & + "BOOLEAN_OPERATORS " & + "-gnatyB " & + "NOBOOLEAN_OPERATORS " & + "-gnaty-B " & "COMMENTS " & "-gnatyc " & "NOCOMMENTS " & *************** package VMS_Data is *** 2738,2743 **** --- 2792,2804 ---- -- semantic analyzer is more likely to encounter some internal fatal -- error when given a syntactically invalid tree. + S_GCC_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + S_GCC_Units : aliased constant S := "/UNITS_LIST " & "-gnatu"; -- /NOUNITS_LIST (D) *************** package VMS_Data is *** 2913,2918 **** --- 2974,2983 ---- "-gnatwh " & "NOHIDING " & "-gnatwH " & + "AVOIDGAPS " & + "-gnatw.h " & + "NOAVOIDGAPS " & + "-gnatw.H " & "IMPLEMENTATION " & "-gnatwi " & "NOIMPLEMENTATION " & *************** package VMS_Data is *** 2969,2974 **** --- 3034,3043 ---- "-gnatw.R " & "SUPPRESS " & "-gnatws " & + "OVERRIDING_SIZE " & + "-gnatw.s " & + "NOOVERRIDING_SIZE " & + "-gnatw.S " & "DELETED_CODE " & "-gnatwt " & "NODELETED_CODE " & *************** package VMS_Data is *** 2979,2984 **** --- 3048,3057 ---- "-gnatwu " & "NOUNUSED " & "-gnatwU " & + "UNORDERED_ENUMERATIONS " & + "-gnatw.u " & + "NOUNORDERED_ENUMERATIONS " & + "-gnatw.U " & "VARIABLES_UNINITIALIZED " & "-gnatwv " & "NOVARIABLES_UNINITIALIZED " & *************** package VMS_Data is *** 3438,3443 **** --- 3511,3519 ---- (S_GCC_Ada_83 'Access, S_GCC_Ada_95 'Access, S_GCC_Ada_05 'Access, + S_GCC_Ada_2005'Access, + S_GCC_Ada_12 'Access, + S_GCC_Ada_2012'Access, S_GCC_Add 'Access, S_GCC_Asm 'Access, S_GCC_AValid 'Access, *************** package VMS_Data is *** 3455,3460 **** --- 3531,3537 ---- S_GCC_ErrorX 'Access, S_GCC_Expand 'Access, S_GCC_Lexpand 'Access, + S_GCC_Except 'Access, S_GCC_Extend 'Access, S_GCC_Ext 'Access, S_GCC_File 'Access, *************** package VMS_Data is *** 3498,3503 **** --- 3575,3581 ---- S_GCC_RTS 'Access, S_GCC_SCO 'Access, S_GCC_Search 'Access, + S_GCC_Src_Info'Access, S_GCC_Style 'Access, S_GCC_StyleX 'Access, S_GCC_Subdirs 'Access, *************** package VMS_Data is *** 3507,3512 **** --- 3585,3591 ---- S_GCC_Trace 'Access, S_GCC_Tree 'Access, S_GCC_Trys 'Access, + S_GCC_USL 'Access, S_GCC_Units 'Access, S_GCC_Unique 'Access, S_GCC_Upcase 'Access, *************** package VMS_Data is *** 3615,3620 **** --- 3694,3713 ---- -- HIGH A great number of messages are output, most of them not -- being useful for the user. + S_Elim_Nodisp : aliased constant S := "/NO_DISPATCH " & + "--no-elim-dispatch"; + -- /NONO_DISPATCH (D) + -- /NO_DISPATCH + -- + -- Do not generate pragmas for dispatching operations. + + S_Elim_Ignore : aliased constant S := "/IGNORE=@" & + "--ignore=@"; + -- /IGNORE=filename + -- + -- Do not generate pragmas for subprograms declared in the sources + -- listed in a specified file + S_Elim_Project : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename *************** package VMS_Data is *** 3624,3630 **** -- gnatelim. The source directories to be searched will be communicated -- to gnatelim through logical name ADA_PRJ_INCLUDE_FILE. ! S_Elim_Quiet : aliased constant S := "/QUIET " & "-q"; -- /NOQUIET (D) -- /QUIET --- 3717,3723 ---- -- gnatelim. The source directories to be searched will be communicated -- to gnatelim through logical name ADA_PRJ_INCLUDE_FILE. ! S_Elim_Quiet : aliased constant S := "/QUIET " & "-q"; -- /NOQUIET (D) -- /QUIET *************** package VMS_Data is *** 3633,3638 **** --- 3726,3773 ---- -- the number of program units left to be processed. This option turns -- this trace off. + S_Elim_Files : aliased constant S := "/FILES=@" & + "-files=@"; + + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Elim_Log : aliased constant S := "/LOG " & + "-l"; + -- /NOLOG (D) + -- /LOG + -- + -- Duplicate all the output sent to Stderr into a default log file. + + S_Elim_Logfile : aliased constant S := "/LOGFILE=@" & + "-l@"; + + -- /LOGFILE=logfilename + -- + -- Duplicate all the output sent to Stderr into a specified log file. + + S_Elim_Main : aliased constant S := "/MAIN=@" & + "-main=@"; + + -- /MAIN=filename + -- + -- Specify the main subprogram of the partition to analyse. + + S_Elim_Out : aliased constant S := "/OUTPUT=@" & + "-o@"; + -- /OUTPUT=filename + -- + -- Specify the name of the output file. + + S_Elim_Time : aliased constant S := "/TIME " & + "-t"; + -- /NOTIME (D) + -- /TIME + -- + -- Print out execution time + S_Elim_Search : aliased constant S := "/SEARCH=*" & "-I*"; -- /SEARCH=(directory, ...) *************** package VMS_Data is *** 3657,3662 **** --- 3792,3810 ---- -- program units left, GNAT ELIM will output the name of the current unit -- being processed. + S_Elim_Warn : aliased constant S := "/WARNINGS=" & + "NORMAL " & + "-wn " & + "QUIET " & + "-ws"; + + -- /WARNINGS[=(keyword[,...])] + -- + -- The following keywords are supported: + -- + -- NORMAL (D) Print warning all the messages. + -- QUIET Some warning messages are suppressed + Elim_Switches : aliased constant Switches := (S_Elim_Add 'Access, S_Elim_All 'Access, *************** package VMS_Data is *** 3665,3678 **** S_Elim_Config 'Access, S_Elim_Current 'Access, S_Elim_Ext 'Access, S_Elim_Follow 'Access, S_Elim_GNATMAKE'Access, S_Elim_Mess 'Access, S_Elim_Project 'Access, S_Elim_Quiet 'Access, S_Elim_Search 'Access, S_Elim_Subdirs 'Access, ! S_Elim_Verb 'Access); ---------------------------- -- Switches for GNAT FIND -- --- 3813,3834 ---- S_Elim_Config 'Access, S_Elim_Current 'Access, S_Elim_Ext 'Access, + S_Elim_Files 'Access, S_Elim_Follow 'Access, S_Elim_GNATMAKE'Access, + S_Elim_Log 'Access, + S_Elim_Logfile 'Access, + S_Elim_Main 'Access, S_Elim_Mess 'Access, + S_Elim_Nodisp 'Access, + S_Elim_Out 'Access, S_Elim_Project 'Access, S_Elim_Quiet 'Access, S_Elim_Search 'Access, S_Elim_Subdirs 'Access, ! S_Elim_Time 'Access, ! S_Elim_Verb 'Access, ! S_Elim_Warn 'Access); ---------------------------- -- Switches for GNAT FIND -- *************** package VMS_Data is *** 4759,4764 **** --- 4915,4928 ---- -- -- Search the specified directories for both source and object files. + S_Make_Single : aliased constant S := "/SINGLE_COMPILE_PER_OBJ_DIR " & + "--single-compile-per-obj-dir"; + -- /NOSINGLE_COMPILE_PER_OBJ_DIR (D) + -- /SINGLE_COMPILE_PER_OBJ_DIR + -- + -- When project files are used, do not allow simultaneous compilations + -- for the same object directory. + S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" & "-aL*"; -- /SKIP_MISSING=(directory[,...]) *************** package VMS_Data is *** 4771,4776 **** --- 4935,4947 ---- -- -- When looking for source files also look in the specified directories. + S_Make_Src_Info : aliased constant S := "/SRC_INFO=<" & + "--source-info=>"; + -- /SRC_INFO=source-info-file + -- + -- Specify a source info file to be read or written by the Project + -- Manager when project files are used. + S_Make_Stand : aliased constant S := "/STANDARD_OUTPUT_FOR_COMMANDS " & "-eS"; -- /NOSTANDARD_OUTPUT_FOR_COMMANDS (D) *************** package VMS_Data is *** 4799,4804 **** --- 4970,4982 ---- -- For example, -O -O2 is different than -O2 -O, but -g -O is equivalent -- to -O -g. + S_Make_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + S_Make_Unique : aliased constant S := "/UNIQUE " & "-u"; -- /NOUNIQUE (D) *************** package VMS_Data is *** 4871,4881 **** --- 5049,5062 ---- S_Make_Reason 'Access, S_Make_RTS 'Access, S_Make_Search 'Access, + S_Make_Single 'Access, S_Make_Skip 'Access, S_Make_Source 'Access, + S_Make_Src_Info'Access, S_Make_Stand 'Access, S_Make_Subdirs 'Access, S_Make_Switch 'Access, + S_Make_USL 'Access, S_Make_Unique 'Access, S_Make_Use_Map 'Access, S_Make_Verbose 'Access); diff -Nrcpad gcc-4.5.2/gcc/ada/xeinfo.adb gcc-4.6.0/gcc/ada/xeinfo.adb *** gcc-4.5.2/gcc/ada/xeinfo.adb Sun Apr 13 18:03:09 2008 --- gcc-4.6.0/gcc/ada/xeinfo.adb Tue Oct 26 12:19:56 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** with GNAT.Spitbol; use *** 57,62 **** --- 57,64 ---- with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; + with CEinfo; + procedure XEinfo is package TB renames GNAT.Spitbol.Table_Boolean; *************** procedure XEinfo is *** 241,246 **** --- 243,253 ---- -- Start of processing for XEinfo begin + -- First run CEinfo to check for errors. Note that CEinfo is also a + -- stand-alone program that can be run separately. + + CEinfo; + Anchored_Mode := True; if Argument_Count > 0 then *************** begin *** 348,353 **** --- 355,361 ---- -- Case of type declaration elsif Match (Line, F_Typ) then + -- Process type declaration (must be enumeration type) Ctr := 0; *************** begin *** 371,376 **** --- 379,385 ---- end loop; -- Process function declarations + -- Note: Lastinlined used to control blank lines Put_Line (Ofile, ""); *************** begin *** 487,492 **** --- 496,504 ---- (Ofile, "/* End of einfo.h (C version of Einfo package specification) */"); + Close (InF); + Close (Ofile); + exception when Err => Put_Line (Standard_Error, Lineno & ". " & Line); diff -Nrcpad gcc-4.5.2/gcc/ada/xgnatugn.adb gcc-4.6.0/gcc/ada/xgnatugn.adb *** gcc-4.5.2/gcc/ada/xgnatugn.adb Mon Apr 14 09:39:39 2008 --- gcc-4.6.0/gcc/ada/xgnatugn.adb Tue Oct 5 09:16:23 2010 *************** procedure Xgnatugn is *** 127,133 **** -- line-oriented checks (length, character set, trailing spaces). procedure Put_Line (F : Sfile; S : String); - procedure Put_Line (F : Sfile; S : VString); -- Local version of Put_Line ensures Unix style line endings Number_Of_Warnings : Natural := 0; --- 127,132 ---- *************** procedure Xgnatugn is *** 369,379 **** Character'Write (Stream (F), ASCII.LF); end Put_Line; - procedure Put_Line (F : Sfile; S : VString) is - begin - Put_Line (F, To_String (S)); - end Put_Line; - ----------- -- Error -- ----------- --- 368,373 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/xoscons.adb gcc-4.6.0/gcc/ada/xoscons.adb *** gcc-4.5.2/gcc/ada/xoscons.adb Mon Nov 30 09:35:30 2009 --- gcc-4.6.0/gcc/ada/xoscons.adb Mon Dec 20 07:26:57 2010 *************** procedure XOSCons is *** 64,70 **** -- is not available in older base compilers. -- We need to deal with integer values that can be signed or unsigned, so ! -- we need to accomodate the maximum range of both cases. type Int_Value_Type is record Positive : Boolean; --- 64,70 ---- -- is not available in older base compilers. -- We need to deal with integer values that can be signed or unsigned, so ! -- we need to accommodate the maximum range of both cases. type Int_Value_Type is record Positive : Boolean; diff -Nrcpad gcc-4.5.2/gcc/ada/xr_tabls.adb gcc-4.6.0/gcc/ada/xr_tabls.adb *** gcc-4.5.2/gcc/ada/xr_tabls.adb Mon Jul 27 13:47:11 2009 --- gcc-4.6.0/gcc/ada/xr_tabls.adb Mon Oct 11 10:03:01 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2010, 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- -- *************** package body Xr_Tabls is *** 395,401 **** begin case Ref_Type is ! when 'b' | 'c' | 'm' | 'r' | 'R' | 'i' | ' ' | 'x' => null; when 'l' | 'w' => --- 395,402 ---- begin case Ref_Type is ! when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' | ! 's' | 'i' | ' ' | 'x' => null; when 'l' | 'w' => *************** package body Xr_Tabls is *** 419,425 **** (Symbol_Length => 0, Symbol => "", Key => new String'(Key), ! Decl => null, Is_Parameter => True, Decl_Type => ' ', Body_Ref => null, --- 420,431 ---- (Symbol_Length => 0, Symbol => "", Key => new String'(Key), ! Decl => new Reference_Record' ! (File => File_Ref, ! Line => Line, ! Column => Column, ! Source_Line => null, ! Next => null), Is_Parameter => True, Decl_Type => ' ', Body_Ref => null, *************** package body Xr_Tabls is *** 447,464 **** Source_Line => null, Next => null); ! -- We can insert the reference in the list directly, since all ! -- the references will appear only once in the ALI file ! -- corresponding to the file where they are referenced. ! -- This saves a lot of time compared to checking the list to check ! -- if it exists. case Ref_Type is when 'b' | 'c' => New_Ref.Next := Declaration.Body_Ref; Declaration.Body_Ref := New_Ref; ! when 'r' | 'R' | 'i' | 'l' | ' ' | 'x' | 'w' => New_Ref.Next := Declaration.Ref_Ref; Declaration.Ref_Ref := New_Ref; --- 453,469 ---- Source_Line => null, Next => null); ! -- We can insert the reference into the list directly, since all the ! -- references will appear only once in the ALI file corresponding to the ! -- file where they are referenced. This saves a lot of time compared to ! -- checking the list to check if it exists. case Ref_Type is when 'b' | 'c' => New_Ref.Next := Declaration.Body_Ref; Declaration.Body_Ref := New_Ref; ! when 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' => New_Ref.Next := Declaration.Ref_Ref; Declaration.Ref_Ref := New_Ref; diff -Nrcpad gcc-4.5.2/gcc/ada/xref_lib.adb gcc-4.6.0/gcc/ada/xref_lib.adb *** gcc-4.5.2/gcc/ada/xref_lib.adb Mon Aug 10 08:25:05 2009 --- gcc-4.6.0/gcc/ada/xref_lib.adb Tue Oct 12 12:51:37 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1998-2010, 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- -- *************** package body Xref_Lib is *** 231,237 **** Line_Start := Index (Entity (File_Start .. Entity'Last), ":"); ! -- Check if it was a disk:\directory item (for NT and OS/2) if File_Start = Line_Start - 1 and then Line_Start < Entity'Last --- 231,237 ---- Line_Start := Index (Entity (File_Start .. Entity'Last), ":"); ! -- Check if it was a disk:\directory item (for Windows) if File_Start = Line_Start - 1 and then Line_Start < Entity'Last *************** package body Xref_Lib is *** 508,513 **** --- 508,514 ---- when 'D' => return "decimal type"; when 'E' => return "enumeration type"; when 'F' => return "float type"; + when 'H' => return "abstract type"; when 'I' => return "integer type"; when 'M' => return "modular type"; when 'O' => return "fixed type"; *************** package body Xref_Lib is *** 517,530 **** when 'T' => return "task type"; when 'W' => return "protected type"; ! when 'a' => return "array type"; when 'b' => return Param_String & "boolean object"; when 'c' => return Param_String & "class-wide object"; when 'd' => return Param_String & "decimal object"; when 'e' => return Param_String & "enumeration object"; when 'f' => return Param_String & "float object"; - when 'h' => return "interface"; when 'i' => return Param_String & "integer object"; when 'm' => return Param_String & "modular object"; when 'o' => return Param_String & "fixed object"; when 'p' => return Param_String & "access object"; --- 518,531 ---- when 'T' => return "task type"; when 'W' => return "protected type"; ! when 'a' => return Param_String & "array object"; when 'b' => return Param_String & "boolean object"; when 'c' => return Param_String & "class-wide object"; when 'd' => return Param_String & "decimal object"; when 'e' => return Param_String & "enumeration object"; when 'f' => return Param_String & "float object"; when 'i' => return Param_String & "integer object"; + when 'j' => return Param_String & "class object"; when 'm' => return Param_String & "modular object"; when 'o' => return Param_String & "fixed object"; when 'p' => return Param_String & "access object"; *************** package body Xref_Lib is *** 535,540 **** --- 536,544 ---- when 'x' => return Param_String & "abstract procedure"; when 'y' => return Param_String & "abstract function"; + when 'h' => return "interface"; + when 'g' => return "macro"; + when 'J' => return "class"; when 'K' => return "package"; when 'k' => return "generic package"; when 'L' => return "statement label"; *************** package body Xref_Lib is *** 542,547 **** --- 546,552 ---- when 'N' => return "named number"; when 'n' => return "enumeration literal"; when 'q' => return "block label"; + when 'Q' => return "include file"; when 'U' => return "procedure"; when 'u' => return "generic procedure"; when 'V' => return "function"; *************** package body Xref_Lib is *** 550,555 **** --- 555,561 ---- when 'Y' => return "entry"; when '+' => return "private type"; + when '*' => return "private variable"; -- The above should be the only possibilities, but for this kind -- of informational output, we don't want to bomb if we find *************** package body Xref_Lib is *** 557,563 **** -- have an unknown Abbrev value when others => ! return "??? (" & Get_Type (Decl) & ")"; end case; end Get_Full_Type; --- 563,573 ---- -- have an unknown Abbrev value when others => ! if Is_Parameter (Decl) then ! return "parameter"; ! else ! return "??? (" & Get_Type (Decl) & ")"; ! end if; end case; end Get_Full_Type; *************** package body Xref_Lib is *** 1587,1594 **** File := Get_File_Ref (Arr (R)); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Arr (R), Full_Path_Name)); ! Write_Str (F.all & ' '); ! Free (F); end if; Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R))); --- 1597,1609 ---- File := Get_File_Ref (Arr (R)); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Arr (R), Full_Path_Name)); ! ! if F = null then ! Write_Str (" "); ! else ! Write_Str (F.all & ' '); ! Free (F); ! end if; end if; Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R))); *************** package body Xref_Lib is *** 1637,1644 **** Write_Str (" Decl: "); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Decl, Full_Path_Name)); ! Print80 (F.all & ' '); ! Free (F); Print_Ref (Get_Line (Decl), Get_Column (Decl)); Print_List --- 1652,1665 ---- Write_Str (" Decl: "); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Decl, Full_Path_Name)); ! ! if F = null then ! Print80 (" "); ! else ! Print80 (F.all & ' '); ! Free (F); ! end if; ! Print_Ref (Get_Line (Decl), Get_Column (Decl)); Print_List diff -Nrcpad gcc-4.5.2/gcc/ada/xsinfo.adb gcc-4.6.0/gcc/ada/xsinfo.adb *** gcc-4.5.2/gcc/ada/xsinfo.adb Sun Apr 13 18:03:09 2008 --- gcc-4.6.0/gcc/ada/xsinfo.adb Tue Oct 26 12:32:21 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** *** 35,44 **** -- sinfo.h Corresponding c header file - -- Note: this program assumes that sinfo.ads has passed the error checks - -- which are carried out by the CSinfo utility, so it does not duplicate - -- these checks and assumes the source is correct. - -- An optional argument allows the specification of an output file name to -- override the default sinfo.h file name for the generated output file. --- 35,40 ---- *************** with Ada.Text_IO; use *** 50,55 **** --- 46,53 ---- with GNAT.Spitbol; use GNAT.Spitbol; with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; + with CSinfo; + procedure XSinfo is Done : exception; *************** procedure XSinfo is *** 115,120 **** --- 113,123 ---- -- Start of processing for XSinfo begin + -- First run CSinfo to check for errors. Note that CSinfo is also a + -- stand-alone program that can be run separately. + + CSinfo; + Set_Exit_Status (1); Anchored_Mode := True; *************** begin *** 239,247 **** --- 242,254 ---- Getline; end loop; + -- Can't get here since above loop only left via raise + exception when Done => + Close (InS); Put_Line (Ofile, ""); + Close (Ofile); Set_Exit_Status (0); end XSinfo; diff -Nrcpad gcc-4.5.2/gcc/ada/xsnames.adb gcc-4.6.0/gcc/ada/xsnames.adb *** gcc-4.5.2/gcc/ada/xsnames.adb Tue May 27 08:50:31 2008 --- gcc-4.6.0/gcc/ada/xsnames.adb Thu Jan 1 00:00:00 1970 *************** *** 1,244 **** - ------------------------------------------------------------------------------ - -- -- - -- GNAT SYSTEM UTILITIES -- - -- -- - -- X S N A M E S -- - -- -- - -- B o d y -- - -- -- - -- Copyright (C) 1992-2008, 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- -- - -- ware Foundation; either version 3, or (at your option) any later ver- -- - -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- - -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- - -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- - -- for more details. You should have received a copy of the GNU General -- - -- Public License distributed with GNAT; see file COPYING3. If not, go to -- - -- http://www.gnu.org/licenses for a complete copy of the license. -- - -- -- - -- GNAT was originally developed by the GNAT team at New York University. -- - -- Extensive contributions were provided by Ada Core Technologies Inc. -- - -- -- - ------------------------------------------------------------------------------ - - -- This utility is used to make a new version of the Snames package when new - -- names are added to the spec, the existing versions of snames.ads and - -- snames.adb and snames.h are read, and updated to match the set of names in - -- snames.ads. The updated versions are written to snames.ns, snames.nb (new - -- spec/body), and snames.nh (new header file). - - with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; - with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; - with Ada.Strings.Maps; use Ada.Strings.Maps; - with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; - with Ada.Text_IO; use Ada.Text_IO; - - with GNAT.Spitbol; use GNAT.Spitbol; - with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; - - procedure XSnames is - - InB : File_Type; - InS : File_Type; - OutS : File_Type; - OutB : File_Type; - InH : File_Type; - OutH : File_Type; - - A, B : VString := Nul; - Line : VString := Nul; - Name : VString := Nul; - Name1 : VString := Nul; - Oval : VString := Nul; - Restl : VString := Nul; - - Tdigs : constant Pattern := Any (Decimal_Digit_Set) & - Any (Decimal_Digit_Set) & - Any (Decimal_Digit_Set); - - Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name - & Span (' ') * B - & ": constant Name_Id := N + " & Tdigs - & ';' & Rest * Restl; - - Get_Name : constant Pattern := "Name_" & Rest * Name1; - Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1); - Findu : constant Pattern := Span ('u') * A; - - Val : Natural; - - Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_"); - - M : Match_Result; - - type Header_Symbol is (None, Attr, Conv, Prag); - -- A symbol in the header file - - procedure Output_Header_Line (S : Header_Symbol); - -- Output header line - - Header_Attr : aliased String := "Attr"; - Header_Conv : aliased String := "Convention"; - Header_Prag : aliased String := "Pragma"; - -- Prefixes used in the header file - - type String_Ptr is access all String; - Header_Prefix : constant array (Header_Symbol) of String_Ptr := - (null, - Header_Attr'Access, - Header_Conv'Access, - Header_Prag'Access); - - -- Patterns used in the spec file - - Get_Attr : constant Pattern := Span (' ') & "Attribute_" - & Break (",)") * Name1; - Get_Conv : constant Pattern := Span (' ') & "Convention_" - & Break (",)") * Name1; - Get_Prag : constant Pattern := Span (' ') & "Pragma_" - & Break (",)") * Name1; - - type Header_Symbol_Counter is array (Header_Symbol) of Natural; - Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0); - - Header_Current_Symbol : Header_Symbol := None; - Header_Pending_Line : VString := Nul; - - ------------------------ - -- Output_Header_Line -- - ------------------------ - - procedure Output_Header_Line (S : Header_Symbol) is - begin - -- Skip all the #define for S-prefixed symbols in the header. - -- Of course we are making implicit assumptions: - -- (1) No newline between symbols with the same prefix. - -- (2) Prefix order is the same as in snames.ads. - - if Header_Current_Symbol /= S then - declare - Pat : constant String := "#define " & Header_Prefix (S).all; - In_Pat : Boolean := False; - - begin - if Header_Current_Symbol /= None then - Put_Line (OutH, Header_Pending_Line); - end if; - - loop - Line := Get_Line (InH); - - if Match (Line, Pat) then - In_Pat := True; - elsif In_Pat then - Header_Pending_Line := Line; - exit; - else - Put_Line (OutH, Line); - end if; - end loop; - - Header_Current_Symbol := S; - end; - end if; - - -- Now output the line - - Put_Line (OutH, "#define " & Header_Prefix (S).all - & "_" & Name1 & (30 - Length (Name1)) * ' ' - & Header_Counter (S)); - Header_Counter (S) := Header_Counter (S) + 1; - end Output_Header_Line; - - -- Start of processing for XSnames - - begin - Open (InB, In_File, "snames.adb"); - Open (InS, In_File, "snames.ads"); - Open (InH, In_File, "snames.h"); - - Create (OutS, Out_File, "snames.ns"); - Create (OutB, Out_File, "snames.nb"); - Create (OutH, Out_File, "snames.nh"); - - Anchored_Mode := True; - Val := 0; - - loop - Line := Get_Line (InB); - exit when Match (Line, " Preset_Names"); - Put_Line (OutB, Line); - end loop; - - Put_Line (OutB, Line); - - LoopN : while not End_Of_File (InS) loop - Line := Get_Line (InS); - - if not Match (Line, Name_Ref) then - Put_Line (OutS, Line); - - if Match (Line, Get_Attr) then - Output_Header_Line (Attr); - elsif Match (Line, Get_Conv) then - Output_Header_Line (Conv); - elsif Match (Line, Get_Prag) then - Output_Header_Line (Prag); - end if; - else - Oval := Lpad (V (Val), 3, '0'); - - if Match (Name, "Last_") then - Oval := Lpad (V (Val - 1), 3, '0'); - end if; - - Put_Line - (OutS, A & Name & B & ": constant Name_Id := N + " - & Oval & ';' & Restl); - - if Match (Name, Get_Name) then - Name := Name1; - Val := Val + 1; - - if Match (Name, Findu, M) then - Replace (M, Translate (A, Xlate_U_Und)); - Translate (Name, Lower_Case_Map); - - elsif not Match (Name, "Op_", "") then - Translate (Name, Lower_Case_Map); - - else - Name := 'O' & Translate (Name, Lower_Case_Map); - end if; - - if Name = "error" then - Name := V (""); - end if; - - if not Match (Name, Chk_Low) then - Put_Line (OutB, " """ & Name & "#"" &"); - end if; - end if; - end if; - end loop LoopN; - - loop - Line := Get_Line (InB); - exit when Match (Line, " ""#"";"); - end loop; - - Put_Line (OutB, Line); - - while not End_Of_File (InB) loop - Line := Get_Line (InB); - Put_Line (OutB, Line); - end loop; - - Put_Line (OutH, Header_Pending_Line); - while not End_Of_File (InH) loop - Line := Get_Line (InH); - Put_Line (OutH, Line); - end loop; - end XSnames; --- 0 ---- diff -Nrcpad gcc-4.5.2/gcc/ada/xtreeprs.adb gcc-4.6.0/gcc/ada/xtreeprs.adb *** gcc-4.5.2/gcc/ada/xtreeprs.adb Fri Feb 20 15:20:38 2009 --- gcc-4.6.0/gcc/ada/xtreeprs.adb Mon Oct 11 10:43:04 2010 *************** *** 6,12 **** -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2008, 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- -- --- 6,12 ---- -- -- -- B o d y -- -- -- ! -- Copyright (C) 1992-2010, 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- -- *************** begin *** 252,260 **** -- Field3 '%' -- Field4 '&' -- Field5 "'" - -- Flag1 "(" - -- Flag2 ")" - -- Flag3 '*' -- Flag4 '+' -- Flag5 ',' -- Flag6 '-' --- 252,257 ---- diff -Nrcpad gcc-4.5.2/gnattools/ChangeLog gcc-4.6.0/gnattools/ChangeLog *** gcc-4.5.2/gnattools/ChangeLog Thu Dec 16 12:30:12 2010 --- gcc-4.6.0/gnattools/ChangeLog Fri Mar 25 16:55:34 2011 *************** *** 1,14 **** ! 2010-12-16 Release Manager ! ! * GCC 4.5.2 released. ! ! 2010-07-31 Release Manager ! * GCC 4.5.1 released. ! 2010-04-14 Release Manager ! * GCC 4.5.0 released. 2010-01-09 Simon Wright --- 1,14 ---- ! 2011-03-25 Release Manager ! * GCC 4.6.0 released. ! 2010-11-20 Ralf Wildenhues ! PR other/46202 ! * Makefile.in (install-strip): New phony target. ! (check, installcheck, info, dvi, pdf, html, install) ! (install-info, install-pdf, install-html, mostlyclean) ! (clean, distclean, maintainer-clean): Mark phony. 2010-01-09 Simon Wright diff -Nrcpad gcc-4.5.2/gnattools/Makefile.in gcc-4.6.0/gnattools/Makefile.in *** gcc-4.5.2/gnattools/Makefile.in Thu Jul 30 22:33:49 2009 --- gcc-4.6.0/gnattools/Makefile.in Sat Nov 20 19:37:08 2010 *************** *** 1,5 **** # Makefile for gnattools ! # Copyright 2003, 2004, 2009 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by --- 1,5 ---- # Makefile for gnattools ! # Copyright 2003, 2004, 2009, 2010 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by *************** pdf: *** 274,291 **** --- 274,297 ---- # Build HTML (none here). html: + .PHONY: check installcheck info dvi pdf html + # Build TAGS (none here). TAGS: # Installation rules. install: + install-strip: install + install-info: install-pdf: install-html: + .PHONY: install install-strip install-info install-pdf install-html + # Cleaning rules. mostlyclean: *************** distclean: *** 296,301 **** --- 302,309 ---- maintainer-clean: + .PHONY: mostlyclean clean distclean maintainer-clean + # Rules for rebuilding this Makefile. Makefile: $(srcdir)/Makefile.in config.status CONFIG_FILES=$@ ; \ diff -Nrcpad gcc-4.5.2/libada/ChangeLog gcc-4.6.0/libada/ChangeLog *** gcc-4.5.2/libada/ChangeLog Thu Dec 16 12:31:11 2010 --- gcc-4.6.0/libada/ChangeLog Fri Mar 25 16:55:47 2011 *************** *** 1,14 **** ! 2010-12-16 Release Manager ! ! * GCC 4.5.2 released. ! ! 2010-07-31 Release Manager ! * GCC 4.5.1 released. ! 2010-04-14 Release Manager ! * GCC 4.5.0 released. 2009-10-24 Eric Botcazou --- 1,14 ---- ! 2011-03-25 Release Manager ! * GCC 4.6.0 released. ! 2010-11-20 Ralf Wildenhues ! PR other/46202 ! * Makefile.in (install-strip): New phony target. ! (check, installcheck, info, dvi, pdf, html, install) ! (install-info, install-pdf, install-html, mostlyclean) ! (clean, distclean, maintainer-clean): Mark phony. 2009-10-24 Eric Botcazou diff -Nrcpad gcc-4.5.2/libada/Makefile.in gcc-4.6.0/libada/Makefile.in *** gcc-4.5.2/libada/Makefile.in Sat Oct 24 10:58:31 2009 --- gcc-4.6.0/libada/Makefile.in Sat Nov 20 19:37:08 2010 *************** *** 1,5 **** # Makefile for libada. ! # Copyright 2003, 2004, 2009 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by --- 1,5 ---- # Makefile for libada. ! # Copyright 2003, 2004, 2009, 2010 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by *************** *** 19,25 **** all: gnatlib $(MULTIDO) $(AM_MAKEFLAGS) DO=all multi-do # $(MAKE) ! .PHONY: all install ## Multilib support variables. MULTISRCTOP = --- 19,25 ---- all: gnatlib $(MULTIDO) $(AM_MAKEFLAGS) DO=all multi-do # $(MAKE) ! .PHONY: all ## Multilib support variables. MULTISRCTOP = *************** html: *** 144,159 **** --- 144,165 ---- # Build TAGS (none here). TAGS: + .PHONY: check installcheck info dvi pdf html + # Installation rules. install: install-gnatlib $(MULTIDO) $(AM_MAKEFLAGS) DO=install multi-do # $(MAKE) + install-strip: install + install-info: install-pdf: install-html: + .PHONY: install install-strip install-info install-pdf install-html + # Cleaning rules. mostlyclean: $(MULTICLEAN) $(AM_MAKEFLAGS) DO=mostlyclean multi-clean # $(MAKE) *************** distclean: *** 167,172 **** --- 173,180 ---- maintainer-clean: + .PHONY: mostlyclean clean distclean maintainer-clean + # Rules for rebuilding this Makefile. Makefile: $(srcdir)/Makefile.in config.status CONFIG_FILES=$@ ; \