diff options
| author | Ian Lance Taylor <iant@golang.org> | 2021-09-21 14:32:26 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2021-09-21 14:32:26 -0700 |
| commit | a5b5cabc91c38710adbe5c8a2b53882abe994441 (patch) | |
| tree | 66b099a6ebc2076ef353afa90d9703824d023812 /gcc/ada | |
| parent | a0791d0ed4f147ef347e83f4aedc7ad03f1a2008 (diff) | |
| parent | 09e18d113b3c3dae896ac1a8ad1e0087adbb153b (diff) | |
| download | gcc-a5b5cabc91c38710adbe5c8a2b53882abe994441.zip gcc-a5b5cabc91c38710adbe5c8a2b53882abe994441.tar.gz gcc-a5b5cabc91c38710adbe5c8a2b53882abe994441.tar.bz2 | |
Merge from trunk revision 09e18d113b3c3dae896ac1a8ad1e0087adbb153b.
Diffstat (limited to 'gcc/ada')
106 files changed, 4026 insertions, 3514 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 70aaabf..56d9baf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,339 @@ +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Has_Excluded_Declaration): Remove redundant guard; + the guarded code will call First on a No_List, which is + well-defined and gives Empty. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Has_Excluded_Declaration): Rename and reduce scope + of a local variable. + +2021-09-20 Bob Duff <duff@adacore.com> + + * uintp.ads, uintp.adb (Present, No): New functions for + comparing with No_Uint. + * checks.adb, einfo-utils.adb, exp_aggr.adb, exp_attr.adb, + exp_ch3.adb, exp_ch4.adb, exp_dbug.adb, exp_disp.adb, + exp_util.adb, repinfo.adb, repinfo-input.adb, scn.adb, + sem_attr.adb, sem_ch13.adb, sem_eval.adb, sem_util.adb, + sinfo-utils.adb, treepr.adb: Use Present (...) instead of "... + /= No_Uint", and No (...) instead of "... = No_Uint". + +2021-09-20 Claire Dross <dross@adacore.com> + + * libgnat/s-ficobl.ads: The entire package has a SPARK_Mode => + Off aspect. + +2021-09-20 Doug Rupp <rupp@adacore.com> + + * libgnat/a-calend.adb: Remove time_t, replace with OS_Time. + * libgnat/s-os_lib.ads: Fix comments regarding time_t conversion + functions to reflect the use of To_Ada in in Ada.Calendar + package body. + * sysdep.c (__gnat_localtime_tzoff): Use OS_Time instead of + time_t. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Actual): Remove + +2021-09-20 Bob Duff <duff@adacore.com> + + * einfo-utils.ads, einfo-utils.adb, fe.h, einfo.ads, + gen_il-fields.ads: Remove unused and no-longer-used routines. + Move related routines together. Rewrite incorrect + documentation, and documentation that will be incorrect when + e.g. Esize-related routines are fixed. Remove unused field + Normalized_Position_Max. + * cstand.adb, exp_pakd.adb, freeze.adb, + gen_il-gen-gen_entities.adb, itypes.adb, layout.adb, + sem_ch10.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, + sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, sem_prag.adb, + sem_util.adb, ttypes.ads: Update calls to routines removed from + or renamed in Einfo.Utils. + * uintp.ads (Upos): Fix this subtype, which was unintentionally + declared to include Uint_0. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch7.adb (Expand_N_Package_Declaration): Fix wording in + comment. + * exp_disp.adb (Mark_DT): Remove unnecessary initialization of + I_Depth. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb (Add_Contract_Item): Accept volatile-related + properties on constants. + (Analyze_Object_Contract): Check external properties on + constants; accept volatile constants. + (Check_Type_Or_Object_External_Properties): Replace "variable" + with "object" in error messages; replace Decl_Kind with a local + constant. + * sem_prag.adb (Analyze_Pragma): Accept volatile-related + properties on constants. + +2021-09-20 Pierre-Alexandre Bazin <bazin@adacore.com> + + * libgnat/a-strfix.adb ("*"): Added loop invariants and lemmas + for proof. + (Delete): Added assertions for proof, and conditions to avoid + overflow. + (Head): Added loop invariant. + (Insert): Same as Delete. + (Move): Declared with SPARK_Mode Off. + (Overwrite): Added assertions for proof, and conditions to avoid + overflow. + (Replace_Slice): Added assertions for proof, and conditions to + avoid overflow. + (Tail): Added loop invariant and avoided overflows. + (Translate): Added loop invariants. + (Trim): Ensured empty strings returned start at 1. + * libgnat/a-strfix.ads (Index): Rewrote contract cases for + easier proof. + (Index_Non_Blank): Separated the null string case. + (Count): Specified Mapping shouldn't be null. + (Find_Token): Specified Source'First should be Positive when no + From is given. + (Translate): Specified Mapping shouldn't be null. + ("*"): Rewrote postcondition for easier proof. + * libgnat/a-strsea.adb (Belongs): Added postcondition. + (Count): Rewrote loops and added loop invariants to avoid + overflows. + (Find_Token): Added loop invariants. + (Index): Rewrote loops to avoid overflows and added loop + invariants for proof. + (Index_Non_Blank): Added loop invariants. + (Is_Identity): New function isolated without SPARK_Mode. + * libgnat/a-strsea.ads: Fix starting comment as package is no + longer private. + (Match): Declared ghost expression function Match. + (Is_Identity): Described identity in the postcondition. + (Index, Index_Non_Blank, Count, Find_Token): Added contract from + a-strfix.ads. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Resolve_Aspect_Aggregate): Move comments after + specs; fix typo in header box; cleanup whitespace. + +2021-09-20 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-objrea.adb (Get_Load_Address): Return 0 for ELF. + +2021-09-20 Eric Botcazou <ebotcazou@adacore.com> + + * adaint.c (__gnat_get_executable_load_address): Add Win32 support. + * libgnat/s-objrea.ads (Get_Xcode_Bounds): Fix typo in comment. + (Object_File): Minor reformatting. + (ELF_Object_File): Uncomment predicate. + (PECOFF_Object_File): Likewise. + (XCOFF32_Object_File): Likewise. + * libgnat/s-objrea.adb: Minor reformatting throughout. + (Get_Load_Address): Implement for PE-COFF. + * libgnat/s-dwalin.ads: Remove clause for System.Storage_Elements + and use consistent wording in comments. + (Dwarf_Context): Set type of Low, High and Load_Address to Address. + * libgnat/s-dwalin.adb (Get_Load_Displacement): New function. + (Is_Inside): Call Get_Load_Displacement. + (Low_Address): Likewise. + (Open): Adjust to type change. + (Aranges_Lookup): Change type of Addr to Address. + (Read_Aranges_Entry): Likewise for Start and adjust. + (Enable_Cach): Adjust to type change. + (Symbolic_Address): Change type of Addr to Address. + (Symbolic_Traceback): Call Get_Load_Displacement. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * exp_disp.adb (Make_DT): Move call to Set_Has_Dispatch_Table, + so it is executed regardless of the Generate_SCIL mode. + +2021-09-20 Ed Schonberg <schonberg@adacore.com> + + * exp_util.ads (Force_Evaluation): Add formal parameter + Discr_Number, to indicate discriminant expression for which an + external name must be created. + (Remove_Side_Effects): Ditto. + * exp_util.adb (Force_Evaluation): Call Remove_Side_Effects with + added parameter. + (Remove_Side_Effects, Build_Temporary): If Discr_Number is + positive, create an external name with suffix DISCR and the + given discriminant number, analogous to what is done for + temporaries for array type bounds. + * sem_ch3.adb (Process_Discriminant_Expressions): If the + constraint is for an object or component declaration and the + corresponding entity may be visible in another unit, invoke + Force_Evaluation with the new parameter. + +2021-09-20 Arnaud Charlet <charlet@adacore.com> + + * gen_il-internals.ads (Invalid_Val): Remove, unused and + generates warnings. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb, exp_ch4.adb, exp_ch5.adb, sprint.adb: Refine + types of local constants. + +2021-09-20 Gary Dismukes <dismukes@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Fold + Preelaborable_Initialization attribute in cases where it hasn't + been folded by the analyzer. + * exp_disp.adb (Original_View_In_Visible_Part): This function is + removed and moved to sem_util.adb. + * sem_attr.adb (Attribute_22): Add + Attribute_Preelaborable_Initialization as an Ada 2022 attribute. + (Analyze_Attribute, Attribute_Preelaborable_Initialization): + Check that the prefix of the attribute is either a formal + private or derived type, or a composite type declared within the + visible part of a package or generic package. + (Eval_Attribute): Perform folding of + Preelaborable_Initialization attribute based on + Has_Preelaborable_Initialization applied to the prefix type. + * sem_ch3.adb (Resolve_Aspects): Add specialized code for + Preelaborable_Initialization used at the end of a package + visible part for setting Known_To_Have_Preelab_Init on types + that are specified with True or that have a conjunction of one + or more P_I attributes applied to formal types. + * sem_ch7.adb (Analyze_Package_Specification): On call to + Has_Preelaborable_Initialization, pass True for new formal + Formal_Types_Have_Preelab_Init, so that error checking treats + subcomponents that are declared within types in generics as + having preelaborable initialization when the subcomponents are + of formal types. + * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Add test for + P_I to prevent calling Make_Pragma_From_Boolean_Aspect, since + this aspect is handled specially and the + Known_To_Have_Preelab_Init flag will get set on types that have + the aspect by other means. + (Analyze_Aspect_Specifications.Analyze_One_Aspect): Add test for + Aspect_Preelaborable_Initialization for allowing the aspect to + be specified on formal type declarations. + (Is_Operational_Item): Treat Attribute_Put_Image as an + operational attribute. The need for this was encountered while + working on these changes. + * sem_util.ads (Has_Preelaborable_Initialization): Add + Formal_Types_Have_Preelab_Init as a new formal parameter that + defaults to False. + (Is_Conjunction_Of_Formal_Preelab_Init_Attributes): New + function. + (Original_View_In_Visible_Part): Moved here from exp_disp.adb, + so it can be called by Analyze_Attribute. + * sem_util.adb (Has_Preelaborable_Initialization): Return True + for formal private and derived types when new formal + Formal_Types_Have_Preelab_Init is True, and pass along the + Formal_Types_Have_Preelab_Init flag in the array component case. + (Check_Components): Pass along Formal_Types_Have_Preelab_Init + flag on call to Has_Preelaborable_Initialization. + (Is_Conjunction_Of_Formal_Preelab_Init_Attributes): New function + that returns True when passed an expression that includes one or + more attributes for Preelaborable_Initialization applied to + prefixes that denote formal types. + (Is_Formal_Preelab_Init_Attribute): New utility function nested + within Is_Conjunction_Of_Formal_Preelab_Init_Attributes that + determines whether a node is a P_I attribute applied to a + generic formal type. + (Original_View_In_Visible_Part): Moved here from exp_util.adb, + so it can be called by Analyze_Attribute. + * snames.ads-tmpl: Add note near the start of spec giving + details about what needs to be done when adding a name that + corresponds to both an attribute and a pragma. Delete existing + occurrence of Name_Preelaborable_Initialization, and add a note + comment in the list of Name_* constants at that place, + indicating that it's included in type Pragma_Id, etc., echoing + other such comments for names that are both an attribute and a + pragma. Insert Name_Preelaborable_Initialization in the + alphabetized set of Name_* constants corresponding to + attributes (between First_Attribute_Name and + Last_Attribute_Name). + (type Attribute_Id): Add new literal + Attribute_Preelaborable_Initialization. + (type Pragma_Id): Move Pragma_Preelaborable_Initialization from + its current position to the end of the type, in the special set + of pragma literals that have corresponding atttributes. Add to + accompanying comment, indicating that functions Get_Pragma_Id + and Is_Pragma_Name need to be updated when adding a pragma + literal to the special set. + * snames.adb-tmpl (Get_Pragma_Id): Add case alternative for + Pragma_Preelaborable_Initialization. + (Is_Pragma_Name): Add test for + Name_Preelaborable_Initialization. + +2021-09-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_ch4.adb (Finc_Non_Universal_Interpretations): Fix check. + +2021-09-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Build_Discriminant_Constraints): Exit once a + first discriminant is found and the Discrim_Present flag is set. + +2021-09-20 Bob Duff <duff@adacore.com> + + * gnat1drv.adb (Gnat1drv): Avoid calling List_Rep_Info in + Generate_SCIL and GNATprove_Mode. + * repinfo.adb (List_Common_Type_Info): Fix comment. + +2021-09-20 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-dwalin.ads: Remove clause for Ada.Exceptions.Traceback, + add clause for System.Traceback_Entries and alphabetize. + (AET): Delete. + (STE): New package renaming. + (Symbolic_Traceback): Adjust. + * libgnat/s-dwalin.adb: Remove clauses for Ada.Exceptions.Traceback + and System.Traceback_Entries. + (Symbolic_Traceback): Adjust. + +2021-09-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_ch4.adb (Find_Non_Universal_Interpretations): Check if + types are compatible before adding interpretation. + +2021-09-20 Justin Squirek <squirek@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): Add guard to protect + against calculating accessibility levels against internal + compiler-generated types. + +2021-09-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_dim.adb (Dimensions_Msg_Of): Capitalize comment. + +2021-09-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * adabkend.adb (Scan_Back_End_Switches): Replace switch-scanning + logic with call to Backend_Utils.Scan_Common_Back_End_Switches. + * back_end.adb (Scan_Back_End_Switches): Replace switch-scanning + logic with call to Backend_Utils.Scan_Common_Back_End_Switches. + * backend_utils.adb: New file. + * backend_utils.ads: New file. + * gcc-interface/Make-lang.in: Add ada/backend_utils.o. + +2021-09-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * atree.adb (Get_32_Bit_Field): Declare result before returning. + +2021-09-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_ch7.adb (Expand_N_Package_Body): Replace + Build_And_Insert_Cuda_Initialization with Expand_CUDA_Package. + * gnat_cuda.adb (Expand_CUDA_Package): New procedure. + (Build_And_Insert_Cuda_Initialization): Make internal. + * gnat_cuda.ads (Expand_CUDA_Package): New procedure. + (Build_And_Insert_Cuda_Initialization): Remove from spec. + +2021-09-20 Ghjuvan Lacambre <lacambre@adacore.com> + + * usage.adb (Usage): Update -gnatw.c messages. + +2021-09-20 Eric Botcazou <ebotcazou@adacore.com> + + * sem_aux.adb (Is_By_Reference_Type): Do not test Error_Posted. + 2021-09-15 Alexandre Oliva <oliva@adacore.com> * gcc-interface/utils.c: Include opts.h. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index fb851a6..db21f01 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -162,6 +162,7 @@ GNATRTL_NONTASKING_OBJS= \ a-coormu$(objext) \ a-coorse$(objext) \ a-coprnu$(objext) \ + a-costso$(objext) \ a-coteio$(objext) \ a-crbltr$(objext) \ a-crbtgk$(objext) \ @@ -1195,136 +1196,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe endif endif -# PowerPC and e500v2 VxWorks 653 -ifeq ($(strip $(filter-out powerpc% wrs vxworksae vxworksaespe,$(target_cpu) $(target_vendor) $(target_os))),) - - ifeq ($(strip $(filter-out e500%, $(target_alias))),) - ARCH_STR=e500 - # gcc config translates the target e500v2-wrs-vxworks to - # powerpc-wrs-vxworksspe. Let's keep the original alias here when - # generating s-oscons.ads. - target=$(target_alias) - else - ARCH_STR=ppc - endif - - # target pairs for vthreads runtime - LIBGNAT_TARGET_PAIRS = \ - a-elchha.adb<libgnat/a-elchha__vxworks-ppc-full.adb \ - a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ - a-naliop.ads<libgnat/a-naliop__nolibm.ads \ - a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ - a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ - g-io.adb<hie/g-io__vxworks-cert.adb \ - s-dorepr.adb<libgnat/s-dorepr__fma.adb \ - s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ - s-interr.adb<libgnarl/s-interr__vxworks.adb \ - s-intman.ads<libgnarl/s-intman__vxworks.ads \ - s-intman.adb<libgnarl/s-intman__vxworks.adb \ - s-osinte.adb<libgnarl/s-osinte__vxworks.adb \ - s-osinte.ads<libgnarl/s-osinte__vxworks.ads \ - s-osprim.adb<libgnat/s-osprim__vxworks.adb \ - s-parame.ads<libgnat/s-parame__ae653.ads \ - s-parame.adb<libgnat/s-parame__vxworks.adb \ - s-taprop.adb<libgnarl/s-taprop__vxworks.adb \ - s-tasinf.ads<libgnarl/s-tasinf__vxworks.ads \ - s-taspri.ads<libgnarl/s-taspri__vxworks.ads \ - s-tpopsp.adb<libgnarl/s-tpopsp__vxworks.adb \ - s-vxwext.adb<libgnarl/s-vxwext__noints.adb \ - s-vxwext.ads<libgnarl/s-vxwext__vthreads.ads \ - s-vxwork.ads<libgnarl/s-vxwork__ppc.ads \ - $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_BUILTINS_TARGET_PAIRS) \ - system.ads<libgnat/system-vxworks-$(ARCH_STR)-vthread.ads - - EH_MECHANISM=-gcc - - TOOLS_TARGET_PAIRS=indepsw.adb<indepsw-gnu.adb - - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o - EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o - - EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o - EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS) - - # Extra pairs for the vthreads runtime - ifeq ($(strip $(filter-out vthreads,$(THREAD_KIND))),) - LIBGNAT_TARGET_PAIRS += \ - s-thread.adb<libgnat/s-thread__ae653.adb \ - s-osvers.ads<libgnat/s-osvers__vxworks-653.ads \ - $(DUMMY_SOCKETS_TARGET_PAIRS) - - GNATRTL_SOCKETS_OBJS = - EXTRA_GNATRTL_NONTASKING_OBJS += s-thread.o s-osvers.o - else - LIBGNAT_TARGET_PAIRS += \ - g-socthi.ads<libgnat/g-socthi__vxworks.ads \ - g-socthi.adb<libgnat/g-socthi__vxworks.adb \ - g-sopowa.adb<libgnat/g-sopowa__posix.adb \ - g-stsifd.adb<libgnat/g-stsifd__sockets.adb - endif - -endif - -# VxWorksae / VxWorks 653 for x86 (vxsim) - ?? VxWorks mils not implemented -ifeq ($(strip $(filter-out %86 wrs vxworksae,$(target_cpu) $(target_vendor) $(target_os))),) - # target pairs for kernel + vthreads runtime - LIBGNAT_TARGET_PAIRS = \ - a-elchha.adb<libgnat/a-elchha__vxworks-ppc-full.adb \ - a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ - a-naliop.ads<libgnat/a-naliop__nolibm.ads \ - a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ - a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ - g-io.adb<hie/g-io__vxworks-cert.adb \ - s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ - s-interr.adb<libgnarl/s-interr__vxworks.adb \ - s-intman.ads<libgnarl/s-intman__vxworks.ads \ - s-intman.adb<libgnarl/s-intman__vxworks.adb \ - s-osinte.adb<libgnarl/s-osinte__vxworks.adb \ - s-osinte.ads<libgnarl/s-osinte__vxworks.ads \ - s-osprim.adb<libgnat/s-osprim__vxworks.adb \ - s-parame.ads<libgnat/s-parame__ae653.ads \ - s-parame.adb<libgnat/s-parame__vxworks.adb \ - s-taprop.adb<libgnarl/s-taprop__vxworks.adb \ - s-tasinf.ads<libgnarl/s-tasinf__vxworks.ads \ - s-taspri.ads<libgnarl/s-taspri__vxworks.ads \ - s-tpopsp.adb<libgnarl/s-tpopsp__vxworks.adb \ - s-vxwext.adb<libgnarl/s-vxwext__noints.adb \ - s-vxwext.ads<libgnarl/s-vxwext__vthreads.ads \ - s-vxwork.ads<libgnarl/s-vxwork__x86.ads \ - system.ads<libgnat/system-vxworks-x86-vthread.ads \ - $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_BUILTINS_TARGET_PAIRS) - - EH_MECHANISM=-gcc - - TOOLS_TARGET_PAIRS=indepsw.adb<indepsw-gnu.adb - - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o - EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o - - EXTRA_LIBGNAT_OBJS+=vx_stack_info.o - GNATRTL_SOCKETS_OBJS = - - # Extra pairs for the vthreads runtime - ifeq ($(strip $(filter-out vthreads,$(THREAD_KIND))),) - LIBGNAT_TARGET_PAIRS += \ - s-thread.adb<libgnat/s-thread__ae653.adb \ - s-osvers.ads<libgnat/s-osvers__vxworks-653.ads \ - $(DUMMY_SOCKETS_TARGET_PAIRS) - - GNATRTL_SOCKETS_OBJS = - EXTRA_GNATRTL_NONTASKING_OBJS += s-thread.o s-osvers.o - else - LIBGNAT_TARGET_PAIRS += \ - g-socthi.ads<libgnat/g-socthi__vxworks.ads \ - g-socthi.adb<libgnat/g-socthi__vxworks.adb \ - g-sopowa.adb<libgnat/g-sopowa__posix.adb \ - g-stsifd.adb<libgnat/g-stsifd__sockets.adb - endif - -endif - # x86/x86_64 VxWorks ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(target_vendor) $(target_os))),) @@ -2195,6 +2066,11 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),) EH_MECHANISM=-gcc endif + ifeq ($(strip $(filter-out aarch64%,$(target_cpu))),) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + ifeq ($(strip $(filter-out aarch64% riscv%,$(target_cpu))),) LIBGNAT_TARGET_PAIRS += a-nallfl.ads<libgnat/a-nallfl__wraplf.ads endif diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb index 2ad58ef..118ca95 100644 --- a/gcc/ada/adabkend.adb +++ b/gcc/ada/adabkend.adb @@ -22,15 +22,16 @@ -- This is the version of the Back_End package for back ends written in Ada -with Atree; use Atree; +with Atree; use Atree; +with Backend_Utils; use Backend_Utils; with Debug; with Lib; -with Opt; use Opt; -with Output; use Output; -with Osint; use Osint; -with Osint.C; use Osint.C; -with Switch.C; use Switch.C; -with Types; use Types; +with Opt; use Opt; +with Output; use Output; +with Osint; use Osint; +with Osint.C; use Osint.C; +with Switch.C; use Switch.C; +with Types; use Types; with System.OS_Lib; use System.OS_Lib; @@ -182,48 +183,11 @@ package body Adabkend is return; - -- Special check, the back-end switch -fno-inline also sets the - -- front end flags to entirely inhibit all inlining. So we store it - -- and set the appropriate flags. - - elsif Switch_Chars (First .. Last) = "fno-inline" then - Lib.Store_Compilation_Switch (Switch_Chars); - Opt.Disable_FE_Inline := True; - return; - - -- Similar processing for -fpreserve-control-flow - - elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then - Lib.Store_Compilation_Switch (Switch_Chars); - Opt.Suppress_Control_Flow_Optimizations := True; - return; - - -- Recognize -gxxx switches - - elsif Switch_Chars (First) = 'g' then - Debugger_Level := 2; - - if First < Last then - case Switch_Chars (First + 1) is - when '0' => - Debugger_Level := 0; - when '1' => - Debugger_Level := 1; - when '2' => - Debugger_Level := 2; - when '3' => - Debugger_Level := 3; - when others => - null; - end case; - end if; - - elsif Switch_Chars (First .. Last) = "S" then - Generate_Asm := True; - -- Ignore all other back-end switches - elsif Is_Back_End_Switch (Switch_Chars) then + elsif Scan_Common_Back_End_Switch (Switch_Chars) + or else Is_Back_End_Switch (Switch_Chars) + then null; -- Give error for junk switch diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 06a4895..d4445f0 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -3542,6 +3542,9 @@ __gnat_get_executable_load_address (void) return (const void *)map->l_addr; +#elif defined (_WIN32) + return GetModuleHandle (NULL); + #else return NULL; #endif diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index c7e295b..540d4ff 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -513,8 +513,13 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_32_Bit, Field_Type); + + Result : constant Field_Type := Cast (Get_32_Bit_Val (N, Offset)); + -- Note: declaring Result here instead of directly returning + -- Cast (...) helps CodePeer understand that there are no issues + -- around uninitialized variables. begin - return Cast (Get_32_Bit_Val (N, Offset)); + return Result; end Get_32_Bit_Field; function Get_32_Bit_Field_With_Default @@ -1823,7 +1828,7 @@ package body Atree is function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is begin - pragma Assert (Atree.Present (N)); + pragma Assert (Present (N)); if Is_List_Member (N) then return Parent (List_Containing (N)); @@ -2146,7 +2151,7 @@ package body Atree is procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is begin - pragma Assert (Atree.Present (N)); + pragma Assert (Present (N)); pragma Assert (not In_List (N)); Set_Link (N, Union_Id (Val)); end Set_Parent; diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index 42d837d..abbd5ed 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -25,23 +25,24 @@ -- This is the version of the Back_End package for GCC back ends -with Atree; use Atree; -with Debug; use Debug; -with Elists; use Elists; -with Errout; use Errout; -with Lib; use Lib; -with Osint; use Osint; -with Opt; use Opt; -with Osint.C; use Osint.C; -with Namet; use Namet; -with Nlists; use Nlists; -with Stand; use Stand; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Switch; use Switch; -with Switch.C; use Switch.C; -with System; use System; -with Types; use Types; +with Atree; use Atree; +with Backend_Utils; use Backend_Utils; +with Debug; use Debug; +with Elists; use Elists; +with Errout; use Errout; +with Lib; use Lib; +with Osint; use Osint; +with Opt; use Opt; +with Osint.C; use Osint.C; +with Namet; use Namet; +with Nlists; use Nlists; +with Stand; use Stand; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Switch; use Switch; +with Switch.C; use Switch.C; +with System; use System; +with Types; use Types; with System.OS_Lib; use System.OS_Lib; @@ -266,52 +267,20 @@ package body Back_End is -- specific switches that the Ada front-end knows about. else - Store_Compilation_Switch (Switch_Chars); - - -- For gcc back ends, -fno-inline disables Inline pragmas only, - -- not Inline_Always to remain consistent with the always_inline - -- attribute behavior. - - if Switch_Chars (First .. Last) = "fno-inline" then - Opt.Disable_FE_Inline := True; - - -- Back end switch -fpreserve-control-flow also sets the front end - -- flag that inhibits improper control flow transformations. - - elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then - Opt.Suppress_Control_Flow_Optimizations := True; - - -- Back end switch -fdiagnostics-format=json tells the frontend to - -- output its error and warning messages in the same format GCC - -- uses when passed -fdiagnostics-format=json. - - elsif Switch_Chars (First .. Last) = "fdiagnostics-format=json" - then - Opt.JSON_Output := True; - - -- Back end switch -fdump-scos, which exists primarily for C, is - -- also accepted for Ada as a synonym of -gnateS. - - elsif Switch_Chars (First .. Last) = "fdump-scos" then - Opt.Generate_SCO := True; - Opt.Generate_SCO_Instance_Table := True; - - elsif Switch_Chars (First) = 'g' then - Debugger_Level := 2; - - if First < Last then - case Switch_Chars (First + 1) is - when '0' => - Debugger_Level := 0; - when '1' => - Debugger_Level := 1; - when '2' => - Debugger_Level := 2; - when '3' => - Debugger_Level := 3; - when others => - null; - end case; + + if not Scan_Common_Back_End_Switch (Switch_Chars) then + + -- Store compilation switch, as Scan_Common_Back_End_Switch + -- only stores switches it recognizes. + + Store_Compilation_Switch (Switch_Chars); + + -- Back end switch -fdump-scos, which exists primarily for C, + -- is also accepted for Ada as a synonym of -gnateS. + + if Switch_Chars (First .. Last) = "fdump-scos" then + Opt.Generate_SCO := True; + Opt.Generate_SCO_Instance_Table := True; end if; end if; end if; diff --git a/gcc/ada/backend_utils.adb b/gcc/ada/backend_utils.adb new file mode 100644 index 0000000..6f492fd --- /dev/null +++ b/gcc/ada/backend_utils.adb @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B A C K E N D _ U T I L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2021-2021, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +with Lib; +with Opt; use Opt; +with Switch; use Switch; + +package body Backend_Utils is + + --------------------------------- + -- Scan_Common_Back_End_Switch -- + --------------------------------- + + function Scan_Common_Back_End_Switch (Switch_Chars : String) return Boolean + is + First : constant Positive := Switch_Chars'First + 1; + Last : constant Natural := Switch_Last (Switch_Chars); + begin + + -- Recognize -gxxx switches + + if Switch_Chars (First) = 'g' then + Debugger_Level := 2; + + if First < Last then + case Switch_Chars (First + 1) is + when '0' => + Debugger_Level := 0; + when '1' => + Debugger_Level := 1; + when '2' => + Debugger_Level := 2; + when '3' => + Debugger_Level := 3; + when others => + null; + end case; + end if; + + -- Back end switch -fdiagnostics-format=json tells the frontend to + -- output its error and warning messages in the same format GCC + -- uses when passed -fdiagnostics-format=json. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=json" then + Opt.JSON_Output := True; + + -- Back-end switch -fno-inline also sets the front end flags to entirely + -- inhibit all inlining. So we store it and set the appropriate + -- flags. + -- For gcc back ends, -fno-inline disables Inline pragmas only, + -- not Inline_Always to remain consistent with the always_inline + -- attribute behavior. + + elsif Switch_Chars (First .. Last) = "fno-inline" then + Opt.Disable_FE_Inline := True; + + -- Back end switch -fpreserve-control-flow also sets the front end + -- flag that inhibits improper control flow transformations. + + elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then + Opt.Suppress_Control_Flow_Optimizations := True; + + elsif Switch_Chars (First .. Last) = "S" then + Generate_Asm := True; + + else + return False; + end if; + + Lib.Store_Compilation_Switch (Switch_Chars); + return True; + end Scan_Common_Back_End_Switch; + +end Backend_Utils; diff --git a/gcc/ada/backend_utils.ads b/gcc/ada/backend_utils.ads new file mode 100644 index 0000000..71321ef --- /dev/null +++ b/gcc/ada/backend_utils.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B A C K E N D _ U T I L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021-2021, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Procedures and functions used by both the Adabkend and Back_End packages. + +package Backend_Utils is + + function Scan_Common_Back_End_Switch (Switch_Chars : String) return Boolean; + -- Scan back-end switches which are common to all back-ends and have an + -- effect in the front-end. Call Store_Compilation_Switch and return True + -- if Switch_Chars is recognized as a common back end switch. Return False + -- otherwise. + +end Backend_Utils; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 0014f6a..049038b 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -588,6 +588,27 @@ package body Bindgen is WBI (""); end if; + -- Import the default stack object if a size has been provided to the + -- binder. + + if Opt.Default_Stack_Size /= Opt.No_Stack_Size then + WBI (" Default_Stack_Size : Integer;"); + WBI (" pragma Import (C, Default_Stack_Size, " & + """__gl_default_stack_size"");"); + end if; + + -- Initialize stack limit variable of the environment task if the + -- stack check method is stack limit and stack check is enabled. + + if Stack_Check_Limits_On_Target + and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) + then + WBI (""); + WBI (" procedure Initialize_Stack_Limit;"); + WBI (" pragma Import (C, Initialize_Stack_Limit, " & + """__gnat_initialize_stack_limit"");"); + end if; + if System_Secondary_Stack_Package_In_Closure then -- System.Secondary_Stack is in the closure of the program -- because the program uses the secondary stack or the restricted @@ -619,6 +640,15 @@ package body Bindgen is WBI (" begin"); + -- Set the default stack size if provided to the binder + + if Opt.Default_Stack_Size /= Opt.No_Stack_Size then + Set_String (" Default_Stack_Size := "); + Set_Int (Default_Stack_Size); + Set_String (";"); + Write_Statement_Buffer; + end if; + if Main_Priority /= No_Main_Priority then Set_String (" Main_Priority := "); Set_Int (Main_Priority); @@ -643,6 +673,7 @@ package body Bindgen is end if; if Main_Priority = No_Main_Priority + and then Opt.Default_Stack_Size = Opt.No_Stack_Size and then Main_CPU = No_Main_CPU and then not System_Tasking_Restricted_Stages_Used then diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index cebeac5..8f5c0b0 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6892,6 +6892,7 @@ package body Checks is elsif Is_Known_Valid (Typ) then if Is_Entity_Name (Expr) and then Ekind (Entity (Expr)) = E_Variable + and then Known_Esize (Entity (Expr)) and then Esize (Entity (Expr)) > Esize (Typ) then return False; @@ -9059,7 +9060,7 @@ package body Checks is function In_Result_Range return Boolean is begin - if Lo = No_Uint or else Hi = No_Uint then + if No (Lo) or else No (Hi) then return False; elsif Is_OK_Static_Subtype (Etype (N)) then @@ -9080,7 +9081,7 @@ package body Checks is procedure Max (A : in out Uint; B : Uint) is begin - if A = No_Uint or else B > A then + if No (A) or else B > A then A := B; end if; end Max; @@ -9091,7 +9092,7 @@ package body Checks is procedure Min (A : in out Uint; B : Uint) is begin - if A = No_Uint or else B < A then + if No (A) or else B < A then A := B; end if; end Min; @@ -9197,14 +9198,14 @@ package body Checks is Minimize_Eliminate_Overflows (Then_DE, Lo, Hi, Top_Level => False); - if Lo = No_Uint then + if No (Lo) then Bignum_Operands := True; end if; Minimize_Eliminate_Overflows (Else_DE, Rlo, Rhi, Top_Level => False); - if Rlo = No_Uint then + if No (Rlo) then Bignum_Operands := True; else Long_Long_Integer_Operands := @@ -9279,7 +9280,7 @@ package body Checks is Minimize_Eliminate_Overflows (Aexp, Lo, Hi, Top_Level => False); - if Lo = No_Uint then + if No (Lo) then Bignum_Operands := True; elsif Etype (Aexp) = LLIB then Long_Long_Integer_Operands := True; @@ -9368,7 +9369,7 @@ package body Checks is -- numbers at compile time for very little gain (the number of cases -- in which we could slip back from bignum mode is small). - if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then + if No (Rlo) or else (Binary and then No (Llo)) then Lo := No_Uint; Hi := No_Uint; Bignum_Operands := True; @@ -9441,7 +9442,7 @@ package body Checks is -- 0 .. 1, but the cases are rare and it is not worth the effort. -- Failing to do this switching back is only an efficiency issue. - elsif Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then + elsif No (Lo) or else Lo < LLLo or else Hi > LLHi then -- OK, we are definitely outside the range of Long_Long_Integer. The -- question is whether to move to Bignum mode, or stay in the domain @@ -11306,7 +11307,7 @@ package body Checks is renames Alignment_Warnings.Table (J); begin if Known_Alignment (AWR.E) - and then ((AWR.A /= No_Uint + and then ((Present (AWR.A) and then AWR.A mod Alignment (AWR.E) = 0) or else (Present (AWR.P) and then Has_Compatible_Alignment diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index d096cbb..e37e092 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -144,7 +144,13 @@ package body Contracts is -- Part_Of if Ekind (Id) = E_Constant then - if Prag_Nam = Name_Part_Of then + if Prag_Nam in Name_Async_Readers + | Name_Async_Writers + | Name_Effective_Reads + | Name_Effective_Writes + | Name_No_Caching + | Name_Part_Of + then Add_Classification; -- The pragma is not a proper contract item @@ -778,25 +784,9 @@ package body Contracts is procedure Check_Type_Or_Object_External_Properties (Type_Or_Obj_Id : Entity_Id) is - function Decl_Kind (Is_Type : Boolean; - Object_Kind : String) return String; - -- Returns "type" or Object_Kind, depending on Is_Type - - --------------- - -- Decl_Kind -- - --------------- - - function Decl_Kind (Is_Type : Boolean; - Object_Kind : String) return String is - begin - if Is_Type then - return "type"; - else - return Object_Kind; - end if; - end Decl_Kind; - Is_Type_Id : constant Boolean := Is_Type (Type_Or_Obj_Id); + Decl_Kind : constant String := + (if Is_Type_Id then "type" else "object"); -- Local variables @@ -923,8 +913,7 @@ package body Contracts is if not Is_Library_Level_Entity (Type_Or_Obj_Id) then Error_Msg_N ("effectively volatile " - & Decl_Kind (Is_Type => Is_Type_Id, - Object_Kind => "variable") + & Decl_Kind & " & must be declared at library level " & "(SPARK RM 7.1.3(3))", Type_Or_Obj_Id); @@ -935,10 +924,7 @@ package body Contracts is and then not Is_Protected_Type (Obj_Typ) then Error_Msg_N - ("discriminated " - & Decl_Kind (Is_Type => Is_Type_Id, - Object_Kind => "object") - & " & cannot be volatile", + ("discriminated " & Decl_Kind & " & cannot be volatile", Type_Or_Obj_Id); end if; @@ -1019,7 +1005,7 @@ package body Contracts is Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; -- Save the SPARK_Mode-related data to restore on exit - NC_Val : Boolean := False; + NC_Val : Boolean; Items : Node_Id; Prag : Node_Id; Ref_Elmt : Elmt_Id; @@ -1056,6 +1042,19 @@ package body Contracts is Set_SPARK_Mode (Obj_Id); end if; + -- Checks related to external properties, same for constants and + -- variables. + + Check_Type_Or_Object_External_Properties (Type_Or_Obj_Id => Obj_Id); + + -- Analyze the non-external volatility property No_Caching + + Prag := Get_Pragma (Obj_Id, Pragma_No_Caching); + + if Present (Prag) then + Analyze_External_Property_In_Decl_Part (Prag, NC_Val); + end if; + -- Constant-related checks if Ekind (Obj_Id) = E_Constant then @@ -1071,35 +1070,10 @@ package body Contracts is Check_Missing_Part_Of (Obj_Id); end if; - -- A constant cannot be effectively volatile (SPARK RM 7.1.3(4)). - -- This check is relevant only when SPARK_Mode is on, as it is not - -- a standard Ada legality rule. Internally-generated constants that - -- map generic formals to actuals in instantiations are allowed to - -- be volatile. - - if SPARK_Mode = On - and then Comes_From_Source (Obj_Id) - and then Is_Effectively_Volatile (Obj_Id) - and then No (Corresponding_Generic_Association (Parent (Obj_Id))) - then - Error_Msg_N ("constant cannot be volatile", Obj_Id); - end if; - -- Variable-related checks else pragma Assert (Ekind (Obj_Id) = E_Variable); - Check_Type_Or_Object_External_Properties - (Type_Or_Obj_Id => Obj_Id); - - -- Analyze the non-external volatility property No_Caching - - Prag := Get_Pragma (Obj_Id, Pragma_No_Caching); - - if Present (Prag) then - Analyze_External_Property_In_Decl_Part (Prag, NC_Val); - end if; - -- The anonymous object created for a single task type carries -- pragmas Depends and Global of the type. diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 44cb69c..409944c 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -205,7 +205,7 @@ package body CStand is Mutate_Ekind (E, E_Floating_Point_Type); Set_Etype (E, E); - Init_Digits_Value (E, Digs); + Set_Digits_Value (E, UI_From_Int (Digs)); Set_Float_Rep (E, Rep); Init_Size (E, Siz); Set_Elem_Alignment (E, Align); @@ -578,6 +578,8 @@ package body CStand is Set_Has_Pragma_Pack (String_Type, True); end Pack_String_Type; + Char_Size : constant Unat := UI_From_Int (Standard_Character_Size); + -- Start of processing for Create_Standard begin @@ -652,8 +654,8 @@ package body CStand is Mutate_Ekind (Standard_Boolean, E_Enumeration_Type); Set_First_Literal (Standard_Boolean, Standard_False); Set_Etype (Standard_Boolean, Standard_Boolean); - Init_Esize (Standard_Boolean, Standard_Character_Size); - Init_RM_Size (Standard_Boolean, 1); + Set_Esize (Standard_Boolean, Char_Size); + Set_RM_Size (Standard_Boolean, Uint_1); Set_Elem_Alignment (Standard_Boolean); Set_Is_Unsigned_Type (Standard_Boolean); @@ -757,8 +759,8 @@ package body CStand is Mutate_Ekind (Standard_Character, E_Enumeration_Type); Set_Etype (Standard_Character, Standard_Character); - Init_Esize (Standard_Character, Standard_Character_Size); - Init_RM_Size (Standard_Character, 8); + Set_Esize (Standard_Character, Char_Size); + Set_RM_Size (Standard_Character, Uint_8); Set_Elem_Alignment (Standard_Character); Set_Has_Pragma_Ordered (Standard_Character); @@ -912,7 +914,7 @@ package body CStand is Set_Etype (Standard_String, Standard_String); Set_Component_Type (Standard_String, Standard_Character); Set_Component_Size (Standard_String, Uint_8); - Init_Size_Align (Standard_String); + Reinit_Size_Align (Standard_String); Set_Alignment (Standard_String, Uint_1); Pack_String_Type (Standard_String); @@ -956,7 +958,7 @@ package body CStand is Set_Etype (Standard_Wide_String, Standard_Wide_String); Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); Set_Component_Size (Standard_Wide_String, Uint_16); - Init_Size_Align (Standard_Wide_String); + Reinit_Size_Align (Standard_Wide_String); Pack_String_Type (Standard_Wide_String); -- Set index type of Wide_String @@ -993,7 +995,7 @@ package body CStand is Set_Component_Type (Standard_Wide_Wide_String, Standard_Wide_Wide_Character); Set_Component_Size (Standard_Wide_Wide_String, Uint_32); - Init_Size_Align (Standard_Wide_Wide_String); + Reinit_Size_Align (Standard_Wide_Wide_String); Set_Is_Ada_2005_Only (Standard_Wide_Wide_String); Pack_String_Type (Standard_Wide_Wide_String); @@ -1009,10 +1011,10 @@ package body CStand is -- Setup entity for Natural - Mutate_Ekind (Standard_Natural, E_Signed_Integer_Subtype); - Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); - Init_Esize (Standard_Natural, Standard_Integer_Size); - Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1); + Mutate_Ekind (Standard_Natural, E_Signed_Integer_Subtype); + Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); + Set_Esize (Standard_Natural, UI_From_Int (Standard_Integer_Size)); + Set_RM_Size (Standard_Natural, UI_From_Int (Standard_Integer_Size - 1)); Set_Elem_Alignment (Standard_Natural); Set_Size_Known_At_Compile_Time (Standard_Natural); @@ -1024,10 +1026,11 @@ package body CStand is -- Setup entity for Positive - Mutate_Ekind (Standard_Positive, E_Signed_Integer_Subtype); - Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); - Init_Esize (Standard_Positive, Standard_Integer_Size); - Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1); + Mutate_Ekind (Standard_Positive, E_Signed_Integer_Subtype); + Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); + Set_Esize (Standard_Positive, UI_From_Int (Standard_Integer_Size)); + Set_RM_Size + (Standard_Positive, UI_From_Int (Standard_Integer_Size - 1)); Set_Elem_Alignment (Standard_Positive); Set_Size_Known_At_Compile_Time (Standard_Positive); @@ -1132,7 +1135,7 @@ package body CStand is Init_Size (Standard_A_String, System_Address_Size * 2); end if; - Init_Alignment (Standard_A_String); + pragma Assert (not Known_Alignment (Standard_A_String)); Set_Directly_Designated_Type (Standard_A_String, Standard_String); @@ -1156,14 +1159,14 @@ package body CStand is Mutate_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype); Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard); Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer)); - Init_Esize (Standard_Debug_Renaming_Type, 0); - Init_RM_Size (Standard_Debug_Renaming_Type, 0); + Set_Esize (Standard_Debug_Renaming_Type, Uint_0); + Set_RM_Size (Standard_Debug_Renaming_Type, Uint_0); Set_Size_Known_At_Compile_Time (Standard_Debug_Renaming_Type); - Set_Integer_Bounds (Standard_Debug_Renaming_Type, - Typ => Base_Type (Standard_Debug_Renaming_Type), + Set_Integer_Bounds (Standard_Debug_Renaming_Type, + Typ => Base_Type (Standard_Debug_Renaming_Type), Lb => Uint_1, Hb => Uint_0); - Set_Is_Constrained (Standard_Debug_Renaming_Type); + Set_Is_Constrained (Standard_Debug_Renaming_Type); Set_Has_Size_Clause (Standard_Debug_Renaming_Type); -- Note on type names. The type names for the following special types @@ -1186,8 +1189,8 @@ package body CStand is Mutate_Ekind (Any_Id, E_Variable); Set_Scope (Any_Id, Standard_Standard); Set_Etype (Any_Id, Any_Type); - Init_Esize (Any_Id); - Init_Alignment (Any_Id); + pragma Assert (not Known_Esize (Any_Id)); + pragma Assert (not Known_Alignment (Any_Id)); Any_Access := New_Standard_Entity ("an access type"); Mutate_Ekind (Any_Access, E_Access_Type); @@ -1204,8 +1207,8 @@ package body CStand is Set_Etype (Any_Character, Any_Character); Set_Is_Unsigned_Type (Any_Character); Set_Is_Character_Type (Any_Character); - Init_Esize (Any_Character, Standard_Character_Size); - Init_RM_Size (Any_Character, 8); + Set_Esize (Any_Character, Char_Size); + Set_RM_Size (Any_Character, Uint_8); Set_Elem_Alignment (Any_Character); Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); @@ -1214,15 +1217,15 @@ package body CStand is Set_Scope (Any_Array, Standard_Standard); Set_Etype (Any_Array, Any_Array); Set_Component_Type (Any_Array, Any_Character); - Init_Size_Align (Any_Array); + Reinit_Size_Align (Any_Array); Make_Dummy_Index (Any_Array); Any_Boolean := New_Standard_Entity ("a boolean type"); Mutate_Ekind (Any_Boolean, E_Enumeration_Type); Set_Scope (Any_Boolean, Standard_Standard); Set_Etype (Any_Boolean, Standard_Boolean); - Init_Esize (Any_Boolean, Standard_Character_Size); - Init_RM_Size (Any_Boolean, 1); + Set_Esize (Any_Boolean, Char_Size); + Set_RM_Size (Any_Boolean, Uint_1); Set_Elem_Alignment (Any_Boolean); Set_Is_Unsigned_Type (Any_Boolean); Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean)); @@ -1233,7 +1236,7 @@ package body CStand is Set_Etype (Any_Composite, Any_Composite); Set_Component_Size (Any_Composite, Uint_0); Set_Component_Type (Any_Composite, Standard_Integer); - Init_Size_Align (Any_Composite); + Reinit_Size_Align (Any_Composite); Any_Discrete := New_Standard_Entity ("a discrete type"); Mutate_Ekind (Any_Discrete, E_Signed_Integer_Type); @@ -1297,7 +1300,7 @@ package body CStand is Set_Scope (Any_String, Standard_Standard); Set_Etype (Any_String, Any_String); Set_Component_Type (Any_String, Any_Character); - Init_Size_Align (Any_String); + Reinit_Size_Align (Any_String); Make_Dummy_Index (Any_String); Raise_Type := New_Standard_Entity ("raise type"); @@ -1506,7 +1509,7 @@ package body CStand is Set_Scope (Standard_Exception_Type, Standard_Standard); Set_Stored_Constraint (Standard_Exception_Type, No_Elist); - Init_Size_Align (Standard_Exception_Type); + Set_RM_Size (Standard_Exception_Type, Uint_0); Set_Size_Known_At_Compile_Time (Standard_Exception_Type, True); @@ -1726,7 +1729,7 @@ package body CStand is Mutate_Ekind (Id, E_Component); Set_Etype (Id, Typ); Set_Scope (Id, Rec); - Init_Component_Location (Id); + Reinit_Component_Location (Id); Set_Original_Record_Component (Id, Id); Set_Is_Aliased (Id); Set_Is_Independent (Id); diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 4690c8f..15bd9e8 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -358,131 +358,179 @@ package body Einfo.Utils is return Ekind (Id) in Type_Kind; end Is_Type; - ----------------------------------- - -- Field Initialization Routines -- - ----------------------------------- + ------------------------------------------ + -- Type Representation Attribute Fields -- + ------------------------------------------ - procedure Init_Alignment (Id : E) is + function Known_Alignment (E : Entity_Id) return B is begin - Reinit_Field_To_Zero (Id, F_Alignment); - end Init_Alignment; + return not Field_Is_Initial_Zero (E, F_Alignment); + end Known_Alignment; - procedure Init_Alignment (Id : E; V : Int) is + procedure Reinit_Alignment (Id : E) is begin - Set_Alignment (Id, UI_From_Int (V)); - end Init_Alignment; + Reinit_Field_To_Zero (Id, F_Alignment); + end Reinit_Alignment; - procedure Init_Component_Bit_Offset (Id : E) is + procedure Copy_Alignment (To, From : E) is begin - Set_Component_Bit_Offset (Id, No_Uint); - end Init_Component_Bit_Offset; + if Known_Alignment (From) then + Set_Alignment (To, Alignment (From)); + else + Reinit_Alignment (To); + end if; + end Copy_Alignment; - procedure Init_Component_Bit_Offset (Id : E; V : Int) is + function Known_Component_Bit_Offset (E : Entity_Id) return B is begin - Set_Component_Bit_Offset (Id, UI_From_Int (V)); - end Init_Component_Bit_Offset; + return Present (Component_Bit_Offset (E)); + end Known_Component_Bit_Offset; - procedure Init_Component_Size (Id : E) is + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is begin - Set_Component_Size (Id, Uint_0); - end Init_Component_Size; + return Present (Component_Bit_Offset (E)) + and then Component_Bit_Offset (E) >= Uint_0; + end Known_Static_Component_Bit_Offset; - procedure Init_Component_Size (Id : E; V : Int) is + function Known_Component_Size (E : Entity_Id) return B is begin - Set_Component_Size (Id, UI_From_Int (V)); - end Init_Component_Size; + return Component_Size (E) /= Uint_0 + and then Present (Component_Size (E)); + end Known_Component_Size; - procedure Init_Digits_Value (Id : E) is + function Known_Static_Component_Size (E : Entity_Id) return B is begin - Set_Digits_Value (Id, Uint_0); - end Init_Digits_Value; + return Component_Size (E) > Uint_0; + end Known_Static_Component_Size; - procedure Init_Digits_Value (Id : E; V : Int) is + Use_New_Unknown_Rep : constant Boolean := False; + -- If False, we represent "unknown" as Uint_0, which is wrong. + -- We intend to make it True (and remove it), and represent + -- "unknown" as Field_Is_Initial_Zero. We also need to change + -- the type of Esize and RM_Size from Uint to Valid_Uint. + + function Known_Esize (E : Entity_Id) return B is begin - Set_Digits_Value (Id, UI_From_Int (V)); - end Init_Digits_Value; + if Use_New_Unknown_Rep then + return not Field_Is_Initial_Zero (E, F_Esize); + else + return Esize (E) /= Uint_0 + and then Present (Esize (E)); + end if; + end Known_Esize; - procedure Init_Esize (Id : E) is + function Known_Static_Esize (E : Entity_Id) return B is begin - Set_Esize (Id, Uint_0); - end Init_Esize; + return Known_Esize (E) + and then Esize (E) >= Uint_0 + and then not Is_Generic_Type (E); + end Known_Static_Esize; - procedure Init_Esize (Id : E; V : Int) is + procedure Reinit_Esize (Id : E) is begin - Set_Esize (Id, UI_From_Int (V)); - end Init_Esize; + if Use_New_Unknown_Rep then + Reinit_Field_To_Zero (Id, F_Esize); + else + Set_Esize (Id, Uint_0); + end if; + end Reinit_Esize; - procedure Init_Normalized_First_Bit (Id : E) is + procedure Copy_Esize (To, From : E) is begin - Set_Normalized_First_Bit (Id, No_Uint); - end Init_Normalized_First_Bit; + if Known_Esize (From) then + Set_Esize (To, Esize (From)); + else + Reinit_Esize (To); + end if; + end Copy_Esize; - procedure Init_Normalized_First_Bit (Id : E; V : Int) is + function Known_Normalized_First_Bit (E : Entity_Id) return B is begin - Set_Normalized_First_Bit (Id, UI_From_Int (V)); - end Init_Normalized_First_Bit; + return Present (Normalized_First_Bit (E)); + end Known_Normalized_First_Bit; - procedure Init_Normalized_Position (Id : E) is + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is begin - Set_Normalized_Position (Id, No_Uint); - end Init_Normalized_Position; + return Present (Normalized_First_Bit (E)) + and then Normalized_First_Bit (E) >= Uint_0; + end Known_Static_Normalized_First_Bit; - procedure Init_Normalized_Position (Id : E; V : Int) is + function Known_Normalized_Position (E : Entity_Id) return B is begin - Set_Normalized_Position (Id, UI_From_Int (V)); - end Init_Normalized_Position; + return Present (Normalized_Position (E)); + end Known_Normalized_Position; - procedure Init_Normalized_Position_Max (Id : E) is + function Known_Static_Normalized_Position (E : Entity_Id) return B is begin - Set_Normalized_Position_Max (Id, No_Uint); - end Init_Normalized_Position_Max; + return Present (Normalized_Position (E)) + and then Normalized_Position (E) >= Uint_0; + end Known_Static_Normalized_Position; - procedure Init_Normalized_Position_Max (Id : E; V : Int) is + function Known_RM_Size (E : Entity_Id) return B is begin - Set_Normalized_Position_Max (Id, UI_From_Int (V)); - end Init_Normalized_Position_Max; + if Use_New_Unknown_Rep then + return not Field_Is_Initial_Zero (E, F_RM_Size); + else + return Present (RM_Size (E)) + and then (RM_Size (E) /= Uint_0 + or else Is_Discrete_Type (E) + or else Is_Fixed_Point_Type (E)); + end if; + end Known_RM_Size; - procedure Init_RM_Size (Id : E) is + function Known_Static_RM_Size (E : Entity_Id) return B is begin - Set_RM_Size (Id, Uint_0); - end Init_RM_Size; + if Use_New_Unknown_Rep then + return Known_RM_Size (E) + and then RM_Size (E) >= Uint_0 + and then not Is_Generic_Type (E); + else + return (RM_Size (E) > Uint_0 + or else Is_Discrete_Type (E) + or else Is_Fixed_Point_Type (E)) + and then not Is_Generic_Type (E); + end if; + end Known_Static_RM_Size; - procedure Init_RM_Size (Id : E; V : Int) is + procedure Reinit_RM_Size (Id : E) is begin - Set_RM_Size (Id, UI_From_Int (V)); - end Init_RM_Size; + if Use_New_Unknown_Rep then + Reinit_Field_To_Zero (Id, F_RM_Size); + else + Set_RM_Size (Id, Uint_0); + end if; + end Reinit_RM_Size; - procedure Copy_Alignment (To, From : E) is + procedure Copy_RM_Size (To, From : E) is begin - if Known_Alignment (From) then - Set_Alignment (To, Alignment (From)); + if Known_RM_Size (From) then + Set_RM_Size (To, RM_Size (From)); else - Init_Alignment (To); + Reinit_RM_Size (To); end if; - end Copy_Alignment; + end Copy_RM_Size; - ----------------------------- - -- Init_Component_Location -- - ----------------------------- + ------------------------------- + -- Reinit_Component_Location -- + ------------------------------- - procedure Init_Component_Location (Id : E) is + procedure Reinit_Component_Location (Id : E) is begin - Set_Normalized_First_Bit (Id, No_Uint); - Set_Normalized_Position_Max (Id, No_Uint); + Set_Normalized_First_Bit (Id, No_Uint); Set_Component_Bit_Offset (Id, No_Uint); - Set_Esize (Id, Uint_0); + Reinit_Esize (Id); Set_Normalized_Position (Id, No_Uint); - end Init_Component_Location; + end Reinit_Component_Location; - ---------------------------- - -- Init_Object_Size_Align -- - ---------------------------- + ------------------------------ + -- Reinit_Object_Size_Align -- + ------------------------------ - procedure Init_Object_Size_Align (Id : E) is + procedure Reinit_Object_Size_Align (Id : E) is begin - Init_Esize (Id); - Init_Alignment (Id); - end Init_Object_Size_Align; + Reinit_Esize (Id); + Reinit_Alignment (Id); + end Reinit_Object_Size_Align; --------------- -- Init_Size -- @@ -491,120 +539,25 @@ package body Einfo.Utils is procedure Init_Size (Id : E; V : Int) is begin pragma Assert (Is_Type (Id)); - pragma Assert - (not Known_Esize (Id) or else Esize (Id) = V); - pragma Assert - (RM_Size (Id) = No_Uint - or else RM_Size (Id) = Uint_0 - or else RM_Size (Id) = V); + pragma Assert (not Known_Esize (Id) or else Esize (Id) = V); + if Use_New_Unknown_Rep then + pragma Assert (not Known_RM_Size (Id) or else RM_Size (Id) = V); + end if; Set_Esize (Id, UI_From_Int (V)); Set_RM_Size (Id, UI_From_Int (V)); end Init_Size; - --------------------- - -- Init_Size_Align -- - --------------------- + ----------------------- + -- Reinit_Size_Align -- + ----------------------- - procedure Init_Size_Align (Id : E) is + procedure Reinit_Size_Align (Id : E) is begin pragma Assert (Ekind (Id) in Type_Kind | E_Void); - Init_Esize (Id); - Init_RM_Size (Id); - Init_Alignment (Id); - end Init_Size_Align; - - ---------------------------------------------- - -- Type Representation Attribute Predicates -- - ---------------------------------------------- - - function Known_Alignment (E : Entity_Id) return B is - Result : constant B := not Field_Is_Initial_Zero (E, F_Alignment); - begin - return Result; - end Known_Alignment; - - function Known_Component_Bit_Offset (E : Entity_Id) return B is - begin - return Component_Bit_Offset (E) /= No_Uint; - end Known_Component_Bit_Offset; - - function Known_Component_Size (E : Entity_Id) return B is - begin - return Component_Size (E) /= Uint_0 - and then Component_Size (E) /= No_Uint; - end Known_Component_Size; - - function Known_Esize (E : Entity_Id) return B is - begin - return Esize (E) /= Uint_0 - and then Esize (E) /= No_Uint; - end Known_Esize; - - function Known_Normalized_First_Bit (E : Entity_Id) return B is - begin - return Normalized_First_Bit (E) /= No_Uint; - end Known_Normalized_First_Bit; - - function Known_Normalized_Position (E : Entity_Id) return B is - begin - return Normalized_Position (E) /= No_Uint; - end Known_Normalized_Position; - - function Known_Normalized_Position_Max (E : Entity_Id) return B is - begin - return Normalized_Position_Max (E) /= No_Uint; - end Known_Normalized_Position_Max; - - function Known_RM_Size (E : Entity_Id) return B is - begin - return RM_Size (E) /= No_Uint - and then (RM_Size (E) /= Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E)); - end Known_RM_Size; - - function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is - begin - return Component_Bit_Offset (E) /= No_Uint - and then Component_Bit_Offset (E) >= Uint_0; - end Known_Static_Component_Bit_Offset; - - function Known_Static_Component_Size (E : Entity_Id) return B is - begin - return Component_Size (E) > Uint_0; - end Known_Static_Component_Size; - - function Known_Static_Esize (E : Entity_Id) return B is - begin - return Esize (E) > Uint_0 - and then not Is_Generic_Type (E); - end Known_Static_Esize; - - function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is - begin - return Normalized_First_Bit (E) /= No_Uint - and then Normalized_First_Bit (E) >= Uint_0; - end Known_Static_Normalized_First_Bit; - - function Known_Static_Normalized_Position (E : Entity_Id) return B is - begin - return Normalized_Position (E) /= No_Uint - and then Normalized_Position (E) >= Uint_0; - end Known_Static_Normalized_Position; - - function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is - begin - return Normalized_Position_Max (E) /= No_Uint - and then Normalized_Position_Max (E) >= Uint_0; - end Known_Static_Normalized_Position_Max; - - function Known_Static_RM_Size (E : Entity_Id) return B is - begin - return (RM_Size (E) > Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E)) - and then not Is_Generic_Type (E); - end Known_Static_RM_Size; + Reinit_Esize (Id); + Reinit_RM_Size (Id); + Reinit_Alignment (Id); + end Reinit_Size_Align; -------------------- -- Address_Clause -- diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index a6517b9..4eca35e 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -310,75 +310,115 @@ package Einfo.Utils is pragma Inline (Type_High_Bound); pragma Inline (Type_Low_Bound); - ---------------------------------------------- - -- Type Representation Attribute Predicates -- - ---------------------------------------------- - - -- These predicates test the setting of the indicated attribute. The - -- Known predicate is True if and only if the value has been set. The - -- Known_Static predicate is True only if the value is set (Known) and is - -- set to a compile time known value. Note that in the case of Alignment - -- and Normalized_First_Bit, dynamic values are not possible, so we do not - -- need a separate Known_Static calls in these cases. The not set (unknown) - -- values are as follows: - - -- Alignment Uint_0 or No_Uint - -- Component_Size Uint_0 or No_Uint - -- Component_Bit_Offset No_Uint - -- Digits_Value Uint_0 or No_Uint - -- Esize Uint_0 or No_Uint - -- Normalized_First_Bit No_Uint - -- Normalized_Position No_Uint - -- Normalized_Position_Max No_Uint - -- RM_Size Uint_0 or No_Uint - - -- It would be cleaner to use No_Uint in all these cases, but historically - -- we chose to use Uint_0 at first, and the change over will take time ??? - -- This is particularly true for the RM_Size field, where a value of zero - -- is legitimate. We deal with this by a considering that the value is - -- always known static for discrete types (and no other types can have - -- an RM_Size value of zero). - + ------------------------------------------ + -- Type Representation Attribute Fields -- + ------------------------------------------ + + -- Each of the following fields can be in a "known" or "unknown" state: + + -- Alignment + -- Component_Size + -- Component_Bit_Offset + -- Digits_Value + -- Esize + -- Normalized_First_Bit + -- Normalized_Position + -- RM_Size + -- + -- NOTE: "known" here does not mean "known at compile time". It means that + -- the compiler has computed the value of the field (either by default, or + -- by noting some representation clauses), and the field has not been + -- reinitialized. + -- + -- We document the Esize functions here; the others are analogous: + -- + -- Known_Esize: True if Set_Esize has been called without a subsequent + -- Reinit_Esize. + -- + -- Known_Static_Esize: True if Known_Esize and the Esize is known at + -- compile time. (We're not using "static" in the Ada RM sense here. We + -- are using it to mean "known at compile time.) + -- + -- Reinit_Esize: Set the Esize field to its initial unknown state. + -- + -- Copy_Esize: Copies the Esize from From to To; Known_Esize (From) may + -- be False, in which case Known_Esize (To) becomes False. + -- + -- Esize: This is the normal automatially-generated getter for Esize, + -- declared elsewhere. It is an error to call this if Set_Esize has not + -- yet been called, or if Reinit_Esize has been called subsequently. + -- + -- Set_Esize: This is the normal automatially-generated setter for + -- Esize. After a call to this, Known_Esize is True. It is an error + -- to call this with a No_Uint value. + -- + -- Normally, we call Set_Esize first, and then query Esize (and similarly + -- for other fields). However in some cases, we need to check Known_Esize + -- before calling Esize, because the code is written in such a way that we + -- don't know whether Set_Esize has already been called. + -- + -- We intend to use the initial zero value to represent "unknown". Note + -- that this value is different from No_Uint, and different from Uint_0. + -- However, this is work in progress; we are still using No_Uint or Uint_0 + -- to represent "unknown" in some cases. Using Uint_0 leads to several + -- bugs, because zero is a legitimate value (T'Size can be zero bits) -- + -- Uint_0 shouldn't mean two different things. + -- -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one -- more consideration, which is that we always return False for generic - -- types. Within a template, the size can look known, because of the fake - -- size values we put in template types, but they are not really known and - -- anyone testing if they are known within the template should get False as - -- a result to prevent incorrect assumptions. - - function Known_Alignment (E : Entity_Id) return B; - function Known_Component_Bit_Offset (E : Entity_Id) return B; - function Known_Component_Size (E : Entity_Id) return B; - function Known_Esize (E : Entity_Id) return B; - function Known_Normalized_First_Bit (E : Entity_Id) return B; - function Known_Normalized_Position (E : Entity_Id) return B; - function Known_Normalized_Position_Max (E : Entity_Id) return B; - function Known_RM_Size (E : Entity_Id) return B; - - function Known_Static_Component_Bit_Offset (E : Entity_Id) return B; - function Known_Static_Component_Size (E : Entity_Id) return B; - function Known_Static_Esize (E : Entity_Id) return B; - function Known_Static_Normalized_First_Bit (E : Entity_Id) return B; - function Known_Static_Normalized_Position (E : Entity_Id) return B; - function Known_Static_Normalized_Position_Max (E : Entity_Id) return B; - function Known_Static_RM_Size (E : Entity_Id) return B; - - pragma Inline (Known_Alignment); - pragma Inline (Known_Component_Bit_Offset); - pragma Inline (Known_Component_Size); - pragma Inline (Known_Esize); - pragma Inline (Known_Normalized_First_Bit); - pragma Inline (Known_Normalized_Position); - pragma Inline (Known_Normalized_Position_Max); - pragma Inline (Known_RM_Size); - - pragma Inline (Known_Static_Component_Bit_Offset); - pragma Inline (Known_Static_Component_Size); - pragma Inline (Known_Static_Esize); - pragma Inline (Known_Static_Normalized_First_Bit); - pragma Inline (Known_Static_Normalized_Position); - pragma Inline (Known_Static_Normalized_Position_Max); - pragma Inline (Known_Static_RM_Size); + -- types. Within a template, the size can look Known_Static, because of the + -- fake size values we put in template types, but they are not really + -- Known_Static and anyone testing if they are Known_Static within the + -- template should get False as a result to prevent incorrect assumptions. + + function Known_Alignment (E : Entity_Id) return B with Inline; + procedure Reinit_Alignment (Id : E) with Inline; + procedure Copy_Alignment (To, From : E); + + function Known_Component_Bit_Offset (E : Entity_Id) return B with Inline; + function Known_Static_Component_Bit_Offset (E : Entity_Id) return B + with Inline; + + function Known_Component_Size (E : Entity_Id) return B with Inline; + function Known_Static_Component_Size (E : Entity_Id) return B with Inline; + + function Known_Esize (E : Entity_Id) return B with Inline; + function Known_Static_Esize (E : Entity_Id) return B with Inline; + procedure Reinit_Esize (Id : E) with Inline; + procedure Copy_Esize (To, From : E); + + function Known_Normalized_First_Bit (E : Entity_Id) return B with Inline; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B + with Inline; + + function Known_Normalized_Position (E : Entity_Id) return B with Inline; + function Known_Static_Normalized_Position (E : Entity_Id) return B + with Inline; + + function Known_RM_Size (E : Entity_Id) return B with Inline; + function Known_Static_RM_Size (E : Entity_Id) return B with Inline; + procedure Reinit_RM_Size (Id : E) with Inline; + procedure Copy_RM_Size (To, From : E); + + --------------------------------------------------------- + -- Procedures for setting multiple of the above fields -- + --------------------------------------------------------- + + procedure Reinit_Component_Location (Id : E); + -- Initializes all fields describing the location of a component + -- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit, + -- Esize) to all be Unknown. + + procedure Init_Size (Id : E; V : Int); + -- Initialize both the Esize and RM_Size fields of E to V + + procedure Reinit_Size_Align (Id : E); + -- This procedure initializes both size fields and the alignment + -- field to all be Unknown. + + procedure Reinit_Object_Size_Align (Id : E); + -- Same as Reinit_Size_Align except RM_Size field (which is only for types) + -- is unaffected. --------------------------------------------------- -- Access to Subprograms in Subprograms_For_Type -- @@ -404,89 +444,6 @@ package Einfo.Utils is procedure Set_Predicate_Function (Id : E; V : E); procedure Set_Predicate_Function_M (Id : E; V : E); - ----------------------------------- - -- Field Initialization Routines -- - ----------------------------------- - - -- These routines are overloadings of some of the above Set procedures - -- where the argument is normally a Uint. The overloadings take an Int - -- parameter instead, and appropriately convert it. There are also - -- versions that implicitly initialize to the appropriate "not set" - -- value. The not set (unknown) values are as follows: - - -- Alignment Uint_0 - -- Component_Size Uint_0 - -- Component_Bit_Offset No_Uint - -- Digits_Value Uint_0 - -- Esize Uint_0 - -- Normalized_First_Bit No_Uint - -- Normalized_Position No_Uint - -- Normalized_Position_Max No_Uint - -- RM_Size Uint_0 - - -- It would be cleaner to use No_Uint in all these cases, but historically - -- we chose to use Uint_0 at first, and the change over will take time ??? - -- This is particularly true for the RM_Size field, where a value of zero - -- is legitimate and causes some special tests around the code. - - -- Contrary to the corresponding Set procedures above, these routines - -- do NOT check the entity kind of their argument, instead they set the - -- underlying Uint fields directly (this allows them to be used for - -- entities whose Ekind has not been set yet). - - procedure Init_Alignment (Id : E; V : Int); - procedure Init_Component_Bit_Offset (Id : E; V : Int); - procedure Init_Component_Size (Id : E; V : Int); - procedure Init_Digits_Value (Id : E; V : Int); - procedure Init_Esize (Id : E; V : Int); - procedure Init_Normalized_First_Bit (Id : E; V : Int); - procedure Init_Normalized_Position (Id : E; V : Int); - procedure Init_Normalized_Position_Max (Id : E; V : Int); - procedure Init_RM_Size (Id : E; V : Int); - - procedure Init_Alignment (Id : E); - procedure Init_Component_Bit_Offset (Id : E); - procedure Init_Component_Size (Id : E); - procedure Init_Digits_Value (Id : E); - procedure Init_Esize (Id : E); - procedure Init_Normalized_First_Bit (Id : E); - procedure Init_Normalized_Position (Id : E); - procedure Init_Normalized_Position_Max (Id : E); - procedure Init_RM_Size (Id : E); - - -- The following Copy_xxx procedures copy the value of xxx from From to - -- To. If xxx is set to its initial invalid (zero-bits) value, then it is - -- reset to invalid in To. We only have Copy_Alignment so far, but more are - -- planned. - - procedure Copy_Alignment (To, From : E); - - pragma Inline (Init_Alignment); - pragma Inline (Init_Component_Bit_Offset); - pragma Inline (Init_Component_Size); - pragma Inline (Init_Digits_Value); - pragma Inline (Init_Esize); - pragma Inline (Init_Normalized_First_Bit); - pragma Inline (Init_Normalized_Position); - pragma Inline (Init_Normalized_Position_Max); - pragma Inline (Init_RM_Size); - - procedure Init_Component_Location (Id : E); - -- Initializes all fields describing the location of a component - -- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit, - -- Normalized_Position_Max, Esize) to all be Unknown. - - procedure Init_Size (Id : E; V : Int); - -- Initialize both the Esize and RM_Size fields of E to V - - procedure Init_Size_Align (Id : E); - -- This procedure initializes both size fields and the alignment - -- field to all be Unknown. - - procedure Init_Object_Size_Align (Id : E); - -- Same as Init_Size_Align except RM_Size field (which is only for types) - -- is unaffected. - --------------- -- Iterators -- --------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e87ce4c..39ddd66 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3762,17 +3762,6 @@ package Einfo is -- units from the start of the record to the lowest addressed storage -- unit containing part or all of the field. --- Normalized_Position_Max --- Defined in components and discriminants. For almost all cases, this --- is the same as Normalized_Position. The one exception is for the case --- of a discriminated record containing one or more arrays whose length --- depends on discriminants. In this case, the Normalized_Position_Max --- field represents the maximum possible value of Normalized_Position --- assuming min/max values for discriminant subscripts in all fields. --- This is used by Layout in front end layout mode to properly compute --- the maximum size of such records (needed for allocation purposes when --- there are default discriminants, and also for the 'Size value). - -- Number_Dimensions (synthesized) -- Applies to array types and subtypes. Returns the number of dimensions -- of the array type or subtype as a value of type Pos. @@ -5228,7 +5217,6 @@ package Einfo is -- Linker_Section_Pragma $$$ -- Normalized_First_Bit -- Current_Value (always Empty) - -- Normalized_Position_Max -- Component_Bit_Offset -- Esize -- Component_Clause @@ -5328,7 +5316,6 @@ package Einfo is -- E_Discriminant -- Normalized_First_Bit -- Current_Value (always Empty) - -- Normalized_Position_Max -- Component_Bit_Offset -- Esize -- Component_Clause diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 0122304..99c7f9a 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -106,15 +106,15 @@ package body Errout is Opan : Source_Span; Msg_Cont : Boolean; Node : Node_Id); - -- This is the low level routine used to post messages after dealing with + -- This is the low-level routine used to post messages after dealing with -- the issue of messages placed on instantiations (which get broken up - -- into separate calls in Error_Msg). Sptr is the location on which the + -- into separate calls in Error_Msg). Span is the location on which the -- flag will be placed in the output. In the case where the flag is on -- the template, this points directly to the template, not to one of the - -- instantiation copies of the template. Optr is the original location + -- instantiation copies of the template. Opan is the original location -- used to flag the error, and this may indeed point to an instantiation - -- copy. So typically we can see Optr pointing to the template location - -- in an instantiation copy when Sptr points to the source location of + -- copy. So typically we can see Opan pointing to the template location + -- in an instantiation copy when Span points to the source location of -- the actual instantiation (i.e the line with the new). Msg_Cont is -- set true if this is a continuation message. Node is the relevant -- Node_Id for this message, to be used to compute the enclosing entity if @@ -2473,7 +2473,8 @@ package body Errout is function Get_Line_End (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; - -- Get the source location for the end of the line in Buf for Loc + -- Get the source location for the end of the line in Buf for Loc. If + -- Loc is past the end of Buf already, return Buf'Last. function Get_Line_Start (Buf : Source_Buffer_Ptr; @@ -2515,9 +2516,9 @@ package body Errout is (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr is - Cur_Loc : Source_Ptr := Loc; + Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last); begin - while Cur_Loc <= Buf'Last + while Cur_Loc < Buf'Last and then Buf (Cur_Loc) /= ASCII.LF loop Cur_Loc := Cur_Loc + 1; @@ -2692,9 +2693,7 @@ package body Errout is Write_Buffer_Char (Buf, Cur_Loc); end if; - Cur_Loc := Cur_Loc + 1; - - if Buf (Cur_Loc - 1) = ASCII.LF then + if Buf (Cur_Loc) = ASCII.LF then Cur_Line := Cur_Line + 1; -- Output ... for skipped lines @@ -2719,6 +2718,8 @@ package body Errout is Width); end if; end if; + + Cur_Loc := Cur_Loc + 1; end loop; end; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 1b08436..88303c9 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -504,7 +504,7 @@ package body Exp_Aggr is -- Scalar types are OK if their size is a multiple of Storage_Unit elsif Is_Scalar_Type (Ctyp) then - pragma Assert (Csiz /= No_Uint); + pragma Assert (Present (Csiz)); if Csiz mod System_Storage_Unit /= 0 then return False; @@ -4003,7 +4003,7 @@ package body Exp_Aggr is and then Present (First_Index (Etype (Expr_Q))) then declare - Expr_Q_Type : constant Node_Id := Etype (Expr_Q); + Expr_Q_Type : constant Entity_Id := Etype (Expr_Q); begin Append_List_To (L, Build_Array_Aggr_Code diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index fc6b0ef..c962c2a 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5530,6 +5530,21 @@ package body Exp_Attr is end if; end Pred; + ---------------------------------- + -- Preelaborable_Initialization -- + ---------------------------------- + + when Attribute_Preelaborable_Initialization => + + -- This attribute should already be folded during analysis, but if + -- for some reason it hasn't been, we fold it now. + + Fold_Uint + (N, + UI_From_Int + (Boolean'Pos (Has_Preelaborable_Initialization (Ptyp))), + Static => False); + -------------- -- Priority -- -------------- @@ -7339,7 +7354,7 @@ package body Exp_Attr is if Nkind (P) in N_Has_Entity and then Present (Entity (P)) and then Is_Object (Entity (P)) - and then Esize (Entity (P)) /= Uint_0 + and then Known_Esize (Entity (P)) then if Esize (Entity (P)) <= System_Max_Integer_Size then Size := Esize (Entity (P)); @@ -8028,7 +8043,7 @@ package body Exp_Attr is -- Common processing for record and array component case - if Siz /= No_Uint and then Siz /= 0 then + if Present (Siz) and then Siz /= 0 then declare CS : constant Boolean := Comes_From_Source (N); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index ad82e56..45d5baf 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -3421,7 +3421,8 @@ package body Exp_Ch3 is Clean_Task_Names (Typ, Proc_Id); - -- Simple initialization + -- Simple initialization. If the Esize is not yet set, we pass + -- Uint_0 as expected by Get_Simple_Init_Val. elsif Component_Needs_Simple_Initialization (Typ) then Actions := @@ -3431,7 +3432,9 @@ package body Exp_Ch3 is Get_Simple_Init_Val (Typ => Typ, N => N, - Size => Esize (Id))); + Size => + (if Known_Esize (Id) then Esize (Id) + else Uint_0))); -- Nothing needed for this case @@ -6507,7 +6510,8 @@ package body Exp_Ch3 is Get_Simple_Init_Val (Typ => Typ, N => Obj_Def, - Size => Esize (Def_Id))); + Size => (if Known_Esize (Def_Id) then Esize (Def_Id) + else Uint_0))); Analyze_And_Resolve (Expression (N), Typ, Suppress => All_Checks); @@ -6534,7 +6538,8 @@ package body Exp_Ch3 is Get_Simple_Init_Val (Typ => Typ, N => Obj_Def, - Size => Esize (Def_Id))); + Size => + (if Known_Esize (Def_Id) then Esize (Def_Id) else Uint_0))); Analyze_And_Resolve (Expression (N), Typ); end if; @@ -8506,7 +8511,7 @@ package body Exp_Ch3 is if Compile_Time_Known_Value (Lo) then Lo_Val := Expr_Value (Lo); - if Lo_Bound = No_Uint or else Lo_Bound < Lo_Val then + if No (Lo_Bound) or else Lo_Bound < Lo_Val then Lo_Bound := Lo_Val; end if; end if; @@ -8514,7 +8519,7 @@ package body Exp_Ch3 is if Compile_Time_Known_Value (Hi) then Hi_Val := Expr_Value (Hi); - if Hi_Bound = No_Uint or else Hi_Bound > Hi_Val then + if No (Hi_Bound) or else Hi_Bound > Hi_Val then Hi_Bound := Hi_Val; end if; end if; @@ -8643,7 +8648,7 @@ package body Exp_Ch3 is -- If zero is invalid, it is a convenient value to use that is for -- sure an appropriate invalid value in all situations. - elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then + elsif Present (Lo_Bound) and then Lo_Bound > Uint_0 then return Make_Integer_Literal (Loc, 0); -- Unsigned types @@ -8702,7 +8707,7 @@ package body Exp_Ch3 is -- If zero is invalid, it is a convenient value to use that is for -- sure an appropriate invalid value in all situations. - if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then + if Present (Lo_Bound) and then Lo_Bound > Uint_0 then Expr := Make_Integer_Literal (Loc, 0); -- Cases where all one bits is the appropriate invalid value @@ -8741,7 +8746,7 @@ package body Exp_Ch3 is -- For this exceptional case, use largest positive value - if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint + if Present (Lo_Bound) and then Present (Hi_Bound) and then Lo_Bound <= (-(2 ** Signed_Size)) and then Hi_Bound < 2 ** Signed_Size then @@ -8811,7 +8816,7 @@ package body Exp_Ch3 is -- Determine the size of the object. This is either the size provided -- by the caller, or the Esize of the scalar type. - if Size = No_Uint or else Size <= Uint_0 then + if No (Size) or else Size <= Uint_0 then Size_To_Use := UI_Max (Uint_1, Esize (Typ)); else Size_To_Use := Size; @@ -8821,7 +8826,7 @@ package body Exp_Ch3 is -- will create values of type Long_Long_Long_Unsigned and the range -- must fit this type. - if Size_To_Use /= No_Uint + if Present (Size_To_Use) and then Size_To_Use > System_Max_Integer_Size then Size_To_Use := UI_From_Int (System_Max_Integer_Size); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 16f513e..497a52b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -767,8 +767,7 @@ package body Exp_Ch4 is Cond := Make_Op_Gt (Loc, Left_Opnd => Cond, - Right_Opnd => - Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); + Right_Opnd => Accessibility_Level (N, Dynamic_Level)); -- Due to the complexity and side effects of the check, utilize an -- if statement instead of the regular Program_Error circuitry. @@ -2294,7 +2293,7 @@ package body Exp_Ch4 is -- We can only do this if we in fact have full range information (which -- won't be the case if either operand is bignum at this stage). - if Llo /= No_Uint and then Rlo /= No_Uint then + if Present (Llo) and then Present (Rlo) then case N_Op_Compare (Nkind (N)) is when N_Op_Eq => if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then @@ -7763,8 +7762,8 @@ package body Exp_Ch4 is if Is_Unchecked_Union (Op_Type) then declare - Lhs_Type : constant Node_Id := Etype (L_Exp); - Rhs_Type : constant Node_Id := Etype (R_Exp); + Lhs_Type : constant Entity_Id := Etype (L_Exp); + Rhs_Type : constant Entity_Id := Etype (R_Exp); Lhs_Discr_Vals : Elist_Id; -- List of inferred discriminant values for left operand. @@ -12361,10 +12360,16 @@ package body Exp_Ch4 is -- an instantiation, otherwise the conversion will already have been -- rejected as illegal. - -- Note: warnings are issued by the analyzer for the instance cases + -- Note: warnings are issued by the analyzer for the instance cases, + -- and, since we are late in expansion, a check is performed to + -- verify that neither the target type nor the operand type are + -- internally generated - as this can lead to spurious errors when, + -- for example, the operand type is a result of BIP expansion. elsif In_Instance_Body and then Statically_Deeper_Relation_Applies (Target_Type) + and then not Is_Internal (Target_Type) + and then not Is_Internal (Operand_Type) and then Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 8ac9662..9827326 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -742,8 +742,8 @@ package body Exp_Ch5 is -- in the front end. declare - L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); - R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + L_Index_Typ : constant Entity_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Entity_Id := Etype (First_Index (R_Type)); Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ); @@ -1382,8 +1382,8 @@ package body Exp_Ch5 is Loc : constant Source_Ptr := Sloc (N); - L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); - R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + L_Index_Typ : constant Entity_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Entity_Id := Etype (First_Index (R_Type)); Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ); @@ -1698,8 +1698,8 @@ package body Exp_Ch5 is (Etype (Left_Base_Index))) and then RTE_Available (RE_Fast_Copy_Bitfield) then - pragma Assert (Esize (L_Type) /= 0); - pragma Assert (Esize (R_Type) /= 0); + pragma Assert (Known_Esize (L_Type)); + pragma Assert (Known_Esize (R_Type)); return Expand_Assign_Array_Bitfield_Fast (N, Larray, Rarray); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 59704a4..7717fa7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4520,6 +4520,8 @@ package body Exp_Ch6 is or else (Is_Record_Type (Formal_Typ) and then Is_Record_Type (Parent_Typ))) + and then Known_Esize (Formal_Typ) + and then Known_Esize (Parent_Typ) and then (Esize (Formal_Typ) /= Esize (Parent_Typ) or else Has_Pragma_Pack (Formal_Typ) /= @@ -7435,6 +7437,10 @@ package body Exp_Ch6 is and then not Is_Class_Wide_Type (Utyp) and then (Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion + or else (Nkind (Exp) = N_Explicit_Dereference + and then Nkind (Prefix (Exp)) in + N_Type_Conversion | + N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp)))) then diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f7807ac..8d08ff1 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -5918,12 +5918,7 @@ package body Exp_Ch7 is Build_Static_Dispatch_Tables (N); end if; - -- If procedures marked with CUDA_Global have been defined within N, - -- we need to register them with the CUDA runtime at program startup. - -- This requires multiple declarations and function calls which need - -- to be appended to N's declarations. - - Build_And_Insert_CUDA_Initialization (N); + Expand_CUDA_Package (N); Build_Task_Activation_Call (N); @@ -6072,7 +6067,7 @@ package body Exp_Ch7 is Pop_Scope; end if; - -- Build dispatch tables of library level tagged types + -- Build dispatch tables of library-level tagged types if Tagged_Type_Expansion and then (Is_Compilation_Unit (Id) @@ -9560,8 +9555,11 @@ package body Exp_Ch7 is -- If initialization procedure for an array of controlled objects is -- trivial, do not generate a useless call to it. + -- The initialization procedure may be missing altogether in the case + -- of a derived container whose components have trivial initialization. - if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc)) + if No (Proc) + or else (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc)) or else (not Comes_From_Source (Proc) and then Present (Alias (Proc)) diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index bfc3b33..a375169 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -438,7 +438,7 @@ package body Exp_Dbug is Enable or else Is_Packed (Underlying_Type (Etype (Prefix (Ren)))) - or else (First_Bit /= No_Uint + or else (Present (First_Bit) and then First_Bit /= Uint_0); end; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index e9d6e74..bac6492 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -93,10 +93,6 @@ package body Exp_Disp is -- Duplicate_Subexpr with an explicit dereference when From is an access -- parameter. - function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; - -- Check if the type has a private view or if the public view appears in - -- the visible part of a package spec. - function Prim_Op_Kind (Prim : Entity_Id; Typ : Entity_Id) return Node_Id; @@ -581,7 +577,7 @@ package body Exp_Disp is -- If number of primitives already set in the tag component, use it if Present (Tag_Comp) - and then DT_Entry_Count (Tag_Comp) /= No_Uint + and then Present (DT_Entry_Count (Tag_Comp)) then return UI_To_Int (DT_Entry_Count (Tag_Comp)); @@ -4716,7 +4712,7 @@ package body Exp_Disp is Exname : Entity_Id; HT_Link : Entity_Id; ITable : Node_Id; - I_Depth : Nat := 0; + I_Depth : Nat; Iface_Table_Node : Node_Id; Name_ITable : Name_Id; Nb_Prim : Nat := 0; @@ -6614,7 +6610,6 @@ package body Exp_Disp is Append_Elmt (DT, DT_Decl); Analyze_List (Result, Suppress => All_Checks); - Set_Has_Dispatch_Table (Typ); -- Mark entities containing dispatch tables. Required by the backend to -- handle them properly. @@ -6647,6 +6642,8 @@ package body Exp_Disp is <<Leave_SCIL>> + Set_Has_Dispatch_Table (Typ); + -- Register the tagged type in the call graph nodes table Register_CG_Node (Typ); @@ -7394,31 +7391,6 @@ package body Exp_Disp is end if; end New_Value; - ----------------------------------- - -- Original_View_In_Visible_Part -- - ----------------------------------- - - function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is - Scop : constant Entity_Id := Scope (Typ); - - begin - -- The scope must be a package - - if not Is_Package_Or_Generic_Package (Scop) then - return False; - end if; - - -- A type with a private declaration has a private view declared in - -- the visible part. - - if Has_Private_Declaration (Typ) then - return True; - end if; - - return List_Containing (Parent (Typ)) = - Visible_Declarations (Package_Specification (Scop)); - end Original_View_In_Visible_Part; - ------------------ -- Prim_Op_Kind -- ------------------ @@ -8036,14 +8008,14 @@ package body Exp_Disp is (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, Use_Full_View => True) then - pragma Assert (DT_Position (Prim) = No_Uint - and then Present (DTC_Entity (Interface_Alias (Prim)))); + pragma Assert (No (DT_Position (Prim))); + pragma Assert (Present (DTC_Entity (Interface_Alias (Prim)))); E := Interface_Alias (Prim); Set_DT_Position_Value (Prim, DT_Position (E)); pragma Assert - (DT_Position (Alias (Prim)) = No_Uint + (No (DT_Position (Alias (Prim))) or else DT_Position (Alias (Prim)) = DT_Position (E)); Set_DT_Position_Value (Alias (Prim), DT_Position (E)); Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); @@ -8094,7 +8066,7 @@ package body Exp_Disp is -- Skip primitives previously set entries - if DT_Position (Prim) /= No_Uint then + if Present (DT_Position (Prim)) then null; -- Primitives covering interface primitives are handled later @@ -8127,7 +8099,7 @@ package body Exp_Disp is while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - if DT_Position (Prim) = No_Uint + if No (DT_Position (Prim)) and then Present (Interface_Alias (Prim)) then pragma Assert (Present (Alias (Prim)) @@ -8139,14 +8111,14 @@ package body Exp_Disp is (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, Use_Full_View => True) then - pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); + pragma Assert (Present (DT_Position (Alias (Prim)))); Set_DT_Position_Value (Prim, DT_Position (Alias (Prim))); -- Otherwise it will be placed in the secondary DT else pragma Assert - (DT_Position (Interface_Alias (Prim)) /= No_Uint); + (Present (DT_Position (Interface_Alias (Prim)))); Set_DT_Position_Value (Prim, DT_Position (Interface_Alias (Prim))); end if; @@ -8175,7 +8147,7 @@ package body Exp_Disp is -- At this point all the primitives MUST have a position in the -- dispatch table. - if DT_Position (Prim) = No_Uint then + if No (DT_Position (Prim)) then raise Program_Error; end if; @@ -8795,7 +8767,7 @@ package body Exp_Disp is -- (primary or secondary) dispatch table. if Present (DTC_Entity (Prim)) - and then DT_Position (Prim) /= No_Uint + and then Present (DT_Position (Prim)) then Write_Str (" at #"); Write_Int (UI_To_Int (DT_Position (Prim))); diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 88f86f4..779dbb3 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -493,7 +493,7 @@ package body Exp_Pakd is Ancest : Entity_Id; PB_Type : Entity_Id; - PASize : Uint; + PASize : Uint := No_Uint; Decl : Node_Id; PAT : Entity_Id; Len_Expr : Node_Id; @@ -563,19 +563,21 @@ package body Exp_Pakd is -- Do not reset RM_Size if already set, as happens in the case of -- a modular type. - if not Known_Esize (PAT) then - Set_Esize (PAT, PASize); - end if; + if Present (PASize) then + if not Known_Esize (PAT) then + Set_Esize (PAT, PASize); + end if; - if not Known_RM_Size (PAT) then - Set_RM_Size (PAT, PASize); + if not Known_RM_Size (PAT) then + Set_RM_Size (PAT, PASize); + end if; end if; Adjust_Esize_Alignment (PAT); -- Set remaining fields of packed array type - Init_Alignment (PAT); + Reinit_Alignment (PAT); Set_Parent (PAT, Empty); Set_Associated_Node_For_Itype (PAT, Typ); Set_Original_Array_Type (PAT, Typ); @@ -680,7 +682,9 @@ package body Exp_Pakd is -- type, since this size clearly belongs to the packed array type. The -- size of the conceptual unpacked type is always set to unknown. - PASize := RM_Size (Typ); + if Known_RM_Size (Typ) then + PASize := RM_Size (Typ); + end if; -- Case of an array where at least one index is of an enumeration -- type with a non-standard representation, but the component size @@ -943,7 +947,7 @@ package body Exp_Pakd is Make_Integer_Literal (Loc, 0), High_Bound => Lit)))); - if PASize = Uint_0 then + if Present (PASize) then PASize := Len_Bits; end if; @@ -1973,6 +1977,7 @@ package body Exp_Pakd is Rtyp : Entity_Id; PAT : Entity_Id; Lit : Node_Id; + Size : Unat; begin Convert_To_Actual_Subtype (Opnd); @@ -1994,9 +1999,15 @@ package body Exp_Pakd is -- where PAT is the packed array type, Mask is a mask of all 1 bits of -- length equal to the size of this packed type, and Rtyp is the actual - -- actual subtype of the operand. + -- actual subtype of the operand. Preserve old behavior in case size is + -- not set. - Lit := Make_Integer_Literal (Loc, 2 ** RM_Size (PAT) - 1); + if Known_RM_Size (PAT) then + Size := RM_Size (PAT); + else + Size := Uint_0; + end if; + Lit := Make_Integer_Literal (Loc, 2 ** Size - 1); Set_Print_In_Hex (Lit); if not Is_Array_Type (PAT) then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 2584041..ad5a6fa 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4892,6 +4892,9 @@ package body Exp_Util is then return False; + elsif not Known_Normalized_First_Bit (Comp) then + return True; + -- Otherwise if the component is not byte aligned, we know we have the -- nasty unaligned case. @@ -6589,6 +6592,7 @@ package body Exp_Util is Related_Id : Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound : Boolean := False; + Discr_Number : Int := 0; Mode : Force_Evaluation_Mode := Relaxed) is begin @@ -6600,6 +6604,7 @@ package body Exp_Util is Related_Id => Related_Id, Is_Low_Bound => Is_Low_Bound, Is_High_Bound => Is_High_Bound, + Discr_Number => Discr_Number, Check_Side_Effects => Is_Static_Expression (Exp) or else Mode = Relaxed); @@ -10992,26 +10997,25 @@ package body Exp_Util is -- At the current time, the only types that we return False for (i.e. where -- we decide we know they cannot generate large temps) are ones where we -- know the size is 256 bits or less at compile time, and we are still not - -- doing a thorough job on arrays and records ??? + -- doing a thorough job on arrays and records. function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is begin if not Size_Known_At_Compile_Time (Typ) then return False; + end if; - elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then + if Known_Esize (Typ) and then Esize (Typ) <= 256 then return False; + end if; - elsif Is_Array_Type (Typ) + if Is_Array_Type (Typ) and then Present (Packed_Array_Impl_Type (Typ)) then return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ)); - - -- We could do more here to find other small types ??? - - else - return True; end if; + + return True; end May_Generate_Large_Temp; -------------------------------------------- @@ -11623,6 +11627,7 @@ package body Exp_Util is Related_Id : Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound : Boolean := False; + Discr_Number : Int := 0; Check_Side_Effects : Boolean := True) is function Build_Temporary @@ -11651,19 +11656,45 @@ package body Exp_Util is is Temp_Id : Entity_Id; Temp_Nam : Name_Id; + Should_Set_Related_Expression : Boolean := False; begin - -- The context requires an external symbol + -- The context requires an external symbol : expression is + -- the bound of an array, or a discriminant value. We create + -- a unique string using the related entity and an appropriate + -- suffix, rather than a numeric serial number (used for internal + -- entities) that may vary depending on compilation options, in + -- particular on the Assertions_Enabled mode. This avoids spurious + -- link errors. if Present (Related_Id) then if Is_Low_Bound then Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST"); - else pragma Assert (Is_High_Bound); + + elsif Is_High_Bound then Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST"); + + else + pragma Assert (Discr_Number > 0); + + -- We don't have any intelligible way of printing T_DISCR in + -- CodePeer. Thus, set a related expression in this case. + + Should_Set_Related_Expression := True; + + -- Use fully qualified name to avoid ambiguities. + + Temp_Nam := + New_External_Name + (Get_Qualified_Name (Related_Id), "_DISCR", Discr_Number); end if; Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam); + if Should_Set_Related_Expression then + Set_Related_Expression (Temp_Id, Related_Nod); + end if; + -- Otherwise generate an internal temporary else @@ -13111,11 +13142,11 @@ package body Exp_Util is (Component_Type (Ityp)))); end if; - if Ialign /= No_Uint and then Ialign > Maximum_Alignment then + if Present (Ialign) and then Ialign > Maximum_Alignment then return True; - elsif Ialign /= No_Uint - and then Oalign /= No_Uint + elsif Present (Ialign) + and then Present (Oalign) and then Ialign <= Oalign then return True; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 5c931c9..56ff61f 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -668,6 +668,7 @@ package Exp_Util is Related_Id : Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound : Boolean := False; + Discr_Number : Int := 0; Mode : Force_Evaluation_Mode := Relaxed); -- Force the evaluation of the expression right away. Similar behavior -- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to @@ -688,6 +689,12 @@ package Exp_Util is -- of the Is_xxx_Bound flags must be set. For use of these parameters see -- the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl. + -- Discr_Number is positive when the expression is a discriminant value + -- in an object or component declaration. In that case Discr_Number is + -- the position of the corresponding discriminant in the corresponding + -- type declaration, and the name for the evaluated expression is built + -- out of the Related_Id and the Discr_Number. + function Fully_Qualified_Name_String (E : Entity_Id; Append_NUL : Boolean := True) return String_Id; @@ -1004,6 +1011,7 @@ package Exp_Util is Related_Id : Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound : Boolean := False; + Discr_Number : Int := 0; Check_Side_Effects : Boolean := True); -- Given the node for a subexpression, this function replaces the node if -- necessary by an equivalent subexpression that is guaranteed to be side @@ -1028,6 +1036,9 @@ package Exp_Util is -- of the Is_xxx_Bound flags must be set. For use of these parameters see -- the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl. -- + -- If Discr_Number is positive, the expression denotes a discrimant value + -- in a constraint, the suffix DISCR is used to create the external name. + -- The side effects are captured using one of the following methods: -- -- 1) a constant initialized with the value of the subexpression diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 4517c59..488e811 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -69,6 +69,15 @@ extern Boolean Debug_Flag_NN; /* einfo: */ +/* Valid_Uint is used to preserve the old behavior of Esize and + friends, where Uint_0 was the default. All calls to this + are questionable. */ +INLINE Valid_Uint +No_Uint_To_0 (Uint X) +{ + return X == No_Uint ? Uint_0 : X; +} + #define Set_Alignment einfo__entities__set_alignment #define Set_Component_Bit_Offset einfo__entities__set_component_bit_offset #define Set_Component_Size einfo__entities__set_component_size @@ -615,30 +624,15 @@ B Known_Normalized_Position_Max (Entity_Id E); #define Known_RM_Size einfo__utils__known_rm_size B Known_RM_Size (Entity_Id E); -#define Known_Static_Component_Bit_Offset einfo__utils__known_static_component_bit_offset -B Known_Static_Component_Bit_Offset (Entity_Id E); - -#define Known_Static_Component_Size einfo__utils__known_static_component_size -B Known_Static_Component_Size (Entity_Id E); - -#define Known_Static_Esize einfo__utils__known_static_esize -B Known_Static_Esize (Entity_Id E); - -#define Known_Static_Normalized_First_Bit einfo__utils__known_static_normalized_first_bit -B Known_Static_Normalized_First_Bit (Entity_Id E); - -#define Known_Static_Normalized_Position einfo__utils__known_static_normalized_position -B Known_Static_Normalized_Position (Entity_Id E); - -#define Known_Static_Normalized_Position_Max einfo__utils__known_static_normalized_position_max -B Known_Static_Normalized_Position_Max (Entity_Id E); - -#define Known_Static_RM_Size einfo__utils__known_static_rm_size -B Known_Static_RM_Size (Entity_Id E); - #define Copy_Alignment einfo__utils__copy_alignment B Copy_Alignment(Entity_Id To, Entity_Id From); +#define Copy_Esize einfo__utils__copy_esize +B Copy_Esize(Entity_Id To, Entity_Id From); + +#define Copy_RM_Size einfo__utils__copy_rm_size +B Copy_RM_Size(Entity_Id To, Entity_Id From); + #define Is_Discrete_Or_Fixed_Point_Type einfo__utils__is_discrete_or_fixed_point_type B Is_Discrete_Or_Fixed_Point_Type (E Id); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 84502d8..15ce832 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1268,9 +1268,13 @@ package body Freeze is if Present (Component_Clause (Comp)) then Comp_Byte_Aligned := - (Normalized_First_Bit (Comp) mod System_Storage_Unit = 0) + Known_Normalized_First_Bit (Comp) and then - (Esize (Comp) mod System_Storage_Unit = 0); + Known_Esize (Comp) + and then + Normalized_First_Bit (Comp) mod System_Storage_Unit = 0 + and then + Esize (Comp) mod System_Storage_Unit = 0; else Comp_Byte_Aligned := not Is_Packed (Encl_Type); end if; @@ -3640,8 +3644,8 @@ package body Freeze is (No (Ancestor_Subtype (Arr)) or else not Has_Size_Clause (Ancestor_Subtype (Arr))) then - Set_Esize (Arr, Esize (Packed_Array_Impl_Type (Arr))); - Set_RM_Size (Arr, RM_Size (Packed_Array_Impl_Type (Arr))); + Copy_Esize (To => Arr, From => Packed_Array_Impl_Type (Arr)); + Copy_RM_Size (To => Arr, From => Packed_Array_Impl_Type (Arr)); end if; if not Has_Alignment_Clause (Arr) then @@ -4173,6 +4177,7 @@ package body Freeze is -- active. if Is_Access_Type (F_Type) + and then Known_Esize (F_Type) and then Esize (F_Type) > Ttypes.System_Address_Size and then (not Unnest_Subprogram_Mode or else not Is_Access_Subprogram_Type (F_Type)) @@ -4313,6 +4318,7 @@ package body Freeze is -- Check suspicious return of fat C pointer if Is_Access_Type (R_Type) + and then Known_Esize (R_Type) and then Esize (R_Type) > Ttypes.System_Address_Size and then not Has_Warnings_Off (E) and then not Has_Warnings_Off (R_Type) @@ -6249,7 +6255,8 @@ package body Freeze is if Is_Array_Type (E) then declare Ctyp : constant Entity_Id := Component_Type (E); - Rsiz : constant Uint := RM_Size (Ctyp); + Rsiz : constant Uint := + (if Known_RM_Size (Ctyp) then RM_Size (Ctyp) else Uint_0); SZ : constant Node_Id := Size_Clause (E); Btyp : constant Entity_Id := Base_Type (E); @@ -6695,7 +6702,7 @@ package body Freeze is if Is_Type (Full_View (E)) then Set_Size_Info (E, Full_View (E)); - Set_RM_Size (E, RM_Size (Full_View (E))); + Copy_RM_Size (To => E, From => Full_View (E)); end if; goto Leave; @@ -7467,7 +7474,7 @@ package body Freeze is and then not Target_Short_Enums then - Init_Esize (Typ, Standard_Integer_Size); + Set_Esize (Typ, UI_From_Int (Standard_Integer_Size)); Set_Alignment (Typ, Alignment (Standard_Integer)); -- Normal Ada case or size clause present or not Long_C_Enums on target @@ -8579,10 +8586,10 @@ package body Freeze is Orig_Hi : Ureal; -- Save original bounds (for shaving tests) - Actual_Size : Nat; + Actual_Size : Int; -- Actual size chosen - function Fsize (Lov, Hiv : Ureal) return Nat; + function Fsize (Lov, Hiv : Ureal) return Int; -- Returns size of type with given bounds. Also leaves these -- bounds set as the current bounds of the Typ. @@ -8596,7 +8603,7 @@ package body Freeze is -- Fsize -- ----------- - function Fsize (Lov, Hiv : Ureal) return Nat is + function Fsize (Lov, Hiv : Ureal) return Int is begin Set_Realval (Lo, Lov); Set_Realval (Hi, Hiv); @@ -8642,7 +8649,7 @@ package body Freeze is if Present (Atype) then Set_Esize (Typ, Esize (Atype)); else - Set_Esize (Typ, Esize (Btyp)); + Copy_Esize (To => Typ, From => Btyp); end if; end if; @@ -8705,8 +8712,8 @@ package body Freeze is Loval_Excl_EP : Ureal; Hival_Excl_EP : Ureal; - Size_Incl_EP : Nat; - Size_Excl_EP : Nat; + Size_Incl_EP : Int; + Size_Excl_EP : Int; Model_Num : Ureal; First_Subt : Entity_Id; @@ -9076,7 +9083,7 @@ package body Freeze is Actual_Size := 128; end if; - Init_Esize (Typ, Actual_Size); + Set_Esize (Typ, UI_From_Int (Actual_Size)); Adjust_Esize_For_Alignment (Typ); end if; @@ -9132,7 +9139,7 @@ package body Freeze is -- Set Esize to calculated size if not set already if not Known_Esize (Typ) then - Init_Esize (Typ, Actual_Size); + Set_Esize (Typ, UI_From_Int (Actual_Size)); end if; -- Set RM_Size if not already set. If already set, check value @@ -9141,7 +9148,9 @@ package body Freeze is Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); begin - if RM_Size (Typ) /= Uint_0 then + if Known_RM_Size (Typ) + and then RM_Size (Typ) /= Uint_0 + then if RM_Size (Typ) < Minsiz then Error_Msg_Uint_1 := RM_Size (Typ); Error_Msg_Uint_2 := Minsiz; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 765654f..c341e2d 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -298,6 +298,7 @@ GNAT_ADA_OBJS = \ ada/alloc.o \ ada/aspects.o \ ada/atree.o \ + ada/backend_utils.o \ ada/butil.o \ ada/casing.o \ ada/checks.o \ diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 0120b21..884d1d8 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -4303,7 +4303,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, VAR_DECL, false, false, size_s, type_s); - else + + /* ??? The test on Has_Size_Clause must be removed when "unknown" is + no longer represented as Uint_0 (i.e. Use_New_Unknown_Rep). */ + else if (Known_RM_Size (gnat_entity) + || Has_Size_Clause (gnat_entity)) gnu_size = validate_size (RM_Size (gnat_entity), gnu_type, gnat_entity, TYPE_DECL, false, Has_Size_Clause (gnat_entity), @@ -4386,7 +4390,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Now set the RM size of the type. We cannot do it before padding because we need to accept arbitrary RM sizes on integral types. */ - set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); + if (Known_RM_Size (gnat_entity)) + set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); /* Back-annotate the alignment of the type if not already set. */ if (!Known_Alignment (gnat_entity)) @@ -4417,16 +4422,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Likewise for the size, if any. */ if (!Known_Esize (gnat_entity) && TYPE_SIZE (gnu_type)) { - tree gnu_size = TYPE_SIZE (gnu_type); + tree size = TYPE_SIZE (gnu_type); /* If the size is self-referential, annotate the maximum value after saturating it, if need be, to avoid a No_Uint value. */ - if (CONTAINS_PLACEHOLDER_P (gnu_size)) + if (CONTAINS_PLACEHOLDER_P (size)) { const unsigned int align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT; - gnu_size - = maybe_saturate_size (max_size (gnu_size, true), align); + size = maybe_saturate_size (max_size (size, true), align); } /* If we are just annotating types and the type is tagged, the tag @@ -4464,12 +4468,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (TYPE_FIELDS (gnu_type)) offset = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type))); - gnu_size = size_binop (PLUS_EXPR, gnu_size, offset); + size = size_binop (PLUS_EXPR, size, offset); } - gnu_size - = maybe_saturate_size (round_up (gnu_size, align), align); - Set_Esize (gnat_entity, annotate_value (gnu_size)); + size = maybe_saturate_size (round_up (size, align), align); + Set_Esize (gnat_entity, annotate_value (size)); /* Tagged types are Strict_Alignment so RM_Size = Esize. */ if (!Known_RM_Size (gnat_entity)) @@ -4478,12 +4481,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Otherwise no adjustment is needed. */ else - Set_Esize (gnat_entity, annotate_value (gnu_size)); + Set_Esize (gnat_entity, No_Uint_To_0 (annotate_value (size))); } /* Likewise for the RM size, if any. */ if (!Known_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type)) - Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); + Set_RM_Size (gnat_entity, + No_Uint_To_0 (annotate_value (rm_size (gnu_type)))); /* If we are at global level, GCC applied variable_size to the size but this has done nothing. So, if it's not constant or self-referential, @@ -4758,9 +4762,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (!Known_Alignment (gnat_entity)) Copy_Alignment (gnat_entity, gnat_annotate_type); if (!Known_Esize (gnat_entity)) - Set_Esize (gnat_entity, Esize (gnat_annotate_type)); + Copy_Esize (gnat_entity, gnat_annotate_type); if (!Known_RM_Size (gnat_entity)) - Set_RM_Size (gnat_entity, RM_Size (gnat_annotate_type)); + Copy_RM_Size (gnat_entity, gnat_annotate_type); } /* If we haven't already, associate the ..._DECL node that we just made with @@ -8774,7 +8778,7 @@ annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref) size = TYPE_SIZE (gnu_type); if (size) - Set_Esize (gnat_entity, annotate_value (size)); + Set_Esize (gnat_entity, No_Uint_To_0 (annotate_value (size))); } if (!Known_Alignment (gnat_entity)) @@ -8880,8 +8884,9 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type) (gnat_field, annotate_value (bit_from_pos (offset, bit_offset))); - Set_Esize (gnat_field, - annotate_value (DECL_SIZE (TREE_PURPOSE (t)))); + Set_Esize + (gnat_field, + No_Uint_To_0 (annotate_value (DECL_SIZE (TREE_PURPOSE (t))))); } else if (is_extension) { diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 3df56aa..d3c421d 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -9279,10 +9279,10 @@ process_freeze_entity (Node_Id gnat_node) Copy_Alignment (gnat_entity, full_view); if (!Known_Esize (gnat_entity)) - Set_Esize (gnat_entity, Esize (full_view)); + Copy_Esize (gnat_entity, full_view); if (!Known_RM_Size (gnat_entity)) - Set_RM_Size (gnat_entity, RM_Size (full_view)); + Copy_RM_Size (gnat_entity, full_view); /* The above call may have defined this entity (the simplest example of this is when we have a private enumeral type since the bounds diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 0a3046e..360e2e1 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -828,7 +828,6 @@ package Gen_IL.Fields is Nonzero_Is_True, Normalized_First_Bit, Normalized_Position, - Normalized_Position_Max, OK_To_Rename, Optimize_Alignment_Space, Optimize_Alignment_Time, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 41dd232..bca0549 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -316,7 +316,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Interface_Name, Node_Id), Sm (Normalized_First_Bit, Uint), Sm (Normalized_Position, Uint), - Sm (Normalized_Position_Max, Uint), Sm (Original_Record_Component, Node_Id))); Cc (E_Component, Record_Field_Kind, diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index a9c7bd7..3bb9807 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -1405,6 +1405,10 @@ package body Gen_IL.Gen is -- Print out a subtype (of type Node_Id or Entity_Id) for a given -- nonroot abstract type. + procedure Put_Opt_Subtype (T : Node_Or_Entity_Type); + -- Print out an "optional" subtype; that is, one that allows + -- Empty. Their names start with "Opt_". + procedure Put_Enum_Type is procedure Put_Enum_Lit (T : Node_Or_Entity_Type); -- Print out one enumeration literal in the declaration of @@ -1496,6 +1500,29 @@ package body Gen_IL.Gen is end if; end Put_Id_Subtype; + procedure Put_Opt_Subtype (T : Node_Or_Entity_Type) is + begin + if Type_Table (T).Parent /= No_Type then + Put (S, "subtype Opt_" & Id_Image (T) & " is" & LF); + Increase_Indent (S, 2); + Put (S, Id_Image (Root)); + + -- Assert that the Opt_XXX subtype is empty or in the XXX + -- subtype. + + if Enable_Assertions then + Put (S, " with Predicate =>" & LF); + Increase_Indent (S, 2); + Put (S, "Opt_" & Id_Image (T) & " = Empty or else" & LF); + Put (S, "Opt_" & Id_Image (T) & " in " & Id_Image (T)); + Decrease_Indent (S, 2); + end if; + + Put (S, ";" & LF); + Decrease_Indent (S, 2); + end if; + end Put_Opt_Subtype; + begin -- Put_Type_And_Subtypes Put_Enum_Type; @@ -1544,7 +1571,20 @@ package body Gen_IL.Gen is end if; end loop; - Put (S, "subtype Flag is Boolean;" & LF & LF); + Put (S, LF & "-- Optional subtypes of " & Id_Image (Root) & "." & + " These allow Empty." & LF & LF); + + Iterate_Types (Root, Pre => Put_Opt_Subtype'Access); + + Put (S, LF & "-- Optional union types:" & LF & LF); + + for T in First_Abstract (Root) .. Last_Abstract (Root) loop + if Type_Table (T) /= null and then Type_Table (T).Is_Union then + Put_Opt_Subtype (T); + end if; + end loop; + + Put (S, LF & "subtype Flag is Boolean;" & LF & LF); end Put_Type_And_Subtypes; function Low_Level_Getter_Name (T : Type_Enum) return String is diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads index ae448de..53c23a2 100644 --- a/gcc/ada/gen_il-internals.ads +++ b/gcc/ada/gen_il-internals.ads @@ -190,11 +190,6 @@ package Gen_IL.Internals is (Field_Type : Type_Enum) return String is (if Field_Type = Elist_Id then "No_Elist" else "Uint_0"); - function Invalid_Val - (Field_Type : Uint_Subtype) return String is - ("No_Uint"); - -- We could generalize this to other than Uint at some point - ---------------- subtype Node_Field is diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 6f65d74..95c1537 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1616,7 +1616,14 @@ begin Errout.Finalize (Last_Call => True); Errout.Output_Messages; - Repinfo.List_Rep_Info (Ttypes.Bytes_Big_Endian); + + -- Back annotation of representation info is not done in CodePeer and + -- SPARK modes. + + if not (Generate_SCIL or GNATprove_Mode) then + Repinfo.List_Rep_Info (Ttypes.Bytes_Big_Endian); + end if; + Inline.List_Inlining_Info; -- Only write the library if the backend did not generate any error diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb index b7ce953..6273a5d 100644 --- a/gcc/ada/gnat_cuda.adb +++ b/gcc/ada/gnat_cuda.adb @@ -66,6 +66,25 @@ package body GNAT_CUDA is -- least one procedure marked with aspect CUDA_Global. The values are -- Elists of the marked procedures. + procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); + -- Builds declarations necessary for CUDA initialization and inserts them + -- in N, the package body that contains CUDA_Global nodes. These + -- declarations are: + -- + -- * A symbol to hold the pointer P to the CUDA fat binary. + -- + -- * A type definition T for a wrapper that contains the pointer to the + -- CUDA fat binary. + -- + -- * An object of the aforementioned type to hold the aforementioned + -- pointer. + -- + -- * For each CUDA_Global procedure in the package, a declaration of a C + -- string containing the function's name. + -- + -- * A procedure that takes care of calling CUDA functions that register + -- CUDA_Global procedures with the runtime. + function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id; -- Returns an Elist of all procedures marked with pragma CUDA_Global that -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id @@ -94,6 +113,23 @@ package body GNAT_CUDA is Append_Elmt (Kernel, Kernels); end Add_CUDA_Kernel; + procedure Expand_CUDA_Package (N : Node_Id) is + begin + + -- If not compiling for the host, do not do anything. + + if not Debug_Flag_Underscore_C then + return; + end if; + + -- If procedures marked with CUDA_Global have been defined within N, + -- we need to register them with the CUDA runtime at program startup. + -- This requires multiple declarations and function calls which need + -- to be appended to N's declarations. + + Build_And_Insert_CUDA_Initialization (N); + end Expand_CUDA_Package; + ---------- -- Hash -- ---------- @@ -524,7 +560,7 @@ package body GNAT_CUDA is -- Start of processing for Build_And_Insert_CUDA_Initialization begin - if CUDA_Node_List = No_Elist or not Debug_Flag_Underscore_C then + if CUDA_Node_List = No_Elist then return; end if; diff --git a/gcc/ada/gnat_cuda.ads b/gcc/ada/gnat_cuda.ads index 200aeeb..d35bc8a 100644 --- a/gcc/ada/gnat_cuda.ads +++ b/gcc/ada/gnat_cuda.ads @@ -82,26 +82,8 @@ package GNAT_CUDA is -- Kernel is a procedure entity marked with CUDA_Global, Pack_Id is the -- entity of its parent package body. - procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); - -- Builds declarations necessary for CUDA initialization and inserts them - -- in N, the package body that contains CUDA_Global nodes. These - -- declarations are: - -- - -- * A symbol to hold the pointer to the CUDA fat binary - -- - -- * A type definition for a wrapper that contains the pointer to the - -- CUDA fat binary - -- - -- * An object of the aforementioned type to hold the aforementioned - -- pointer. - -- - -- * For each CUDA_Global procedure in the package, a declaration of a C - -- string containing the function's name. - -- - -- * A function that takes care of calling CUDA functions that register - -- CUDA_Global procedures with the runtime. - -- - -- * A boolean that holds the result of the call to the aforementioned - -- function. + procedure Expand_CUDA_Package (N : Node_Id); + -- When compiling for the host, generate code to register kernels with the + -- CUDA runtime and post-process kernels. end GNAT_CUDA; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 713a662..9919cad 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Jun 23, 2021 +GNAT User's Guide for Native Platforms , Aug 03, 2021 AdaCore @@ -12633,8 +12633,8 @@ See @ref{e6,,Static Stack Usage Analysis} for details. This switch enables most warnings from the GCC back end. The code generator detects a number of warning situations that are missed by the GNAT front end, and this switch can be used to activate them. -The use of this switch also sets the default front end warning mode to -@code{-gnatwa}, that is, most front end warnings activated as well. +The use of this switch also sets the default front-end warning mode to +@code{-gnatwa}, that is, most front-end warnings are activated as well. @end table @geindex -w (gcc) @@ -12645,8 +12645,8 @@ The use of this switch also sets the default front end warning mode to @item @code{-w} Conversely, this switch suppresses warnings from the GCC back end. -The use of this switch also sets the default front end warning mode to -@code{-gnatws}, that is, front end warnings suppressed as well. +The use of this switch also sets the default front-end warning mode to +@code{-gnatws}, that is, front-end warnings are suppressed as well. @end table @geindex -Werror (gcc) @@ -12659,6 +12659,9 @@ The use of this switch also sets the default front end warning mode to This switch causes warnings from the GCC back end to be treated as errors. The warning string still appears, but the warning messages are counted as errors, and prevent the generation of an object file. +The use of this switch also sets the default front-end warning mode to +@code{-gnatwe}, that is, front-end warning messages and style check +messages are treated as errors as well. @end table A string of warning parameters can be used in the same parameter. For example: @@ -23100,9 +23103,9 @@ calling convention. All convention specifiers are ignored on this platform. When a subprogram @code{F} (caller) calls a subprogram @code{G} -(callee), there are several ways to push @code{G}’s parameters on the +(callee), there are several ways to push @code{G}‘s parameters on the stack and there are several possible scenarios to clean up the stack -upon @code{G}’s return. A calling convention is an agreed upon software +upon @code{G}‘s return. A calling convention is an agreed upon software protocol whereby the responsibilities between the caller (@code{F}) and the callee (@code{G}) are clearly defined. Several calling conventions are available for Windows: diff --git a/gcc/ada/init.c b/gcc/ada/init.c index c48e244..2bbb601 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -661,6 +661,28 @@ __gnat_install_handler (void) #include <signal.h> #include <unistd.h> +/* SA_SIGINFO is not supported by default on LynxOS, so all we have + available here is the "sig" argument. On newer LynxOS versions it's + possible to support SA_SIGINFO by setting a kernel configuration macro. + + To wit: + + #define NONPOSIX_SA_HANDLER_PROTO (0) + + This macro must be set to 1 in either sys/bsp.<bspname>/uparam.h + or in the associated uparam.h customization file sys/bsp.<bspname>/xparam.h + (uparam.h includes xparam.h for customization) + + The NONPOSIX_SA_HANDLER_PROTO macro makes it possible to provide + signal-catching function with 'info' and 'context' input parameters + even if SA_SIGINFO flag is not set or it is set for a non-realtime signal. + + It also allows signal-catching function to update thread context even + if SA_UPDATECTX flag is not set. + + This would be useful, but relying on that would transmit the requirement + to users to configure that feature as well, which is undesirable. */ + static void __gnat_error_handler (int sig) { diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 6c330b2..773b376 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -4215,8 +4215,6 @@ package body Inline is (Subp : Entity_Id; Decls : List_Id) return Boolean is - D : Node_Id; - function Is_Unchecked_Conversion (D : Node_Id) return Boolean; -- Nested subprograms make a given body ineligible for inlining, but -- we make an exception for instantiations of unchecked conversion. @@ -4250,6 +4248,10 @@ package body Inline is and then Is_Intrinsic_Subprogram (Conv); end Is_Unchecked_Conversion; + -- Local variables + + Decl : Node_Id; + -- Start of processing for Has_Excluded_Declaration begin @@ -4259,19 +4261,19 @@ package body Inline is return False; end if; - D := First (Decls); - while Present (D) loop + Decl := First (Decls); + while Present (Decl) loop -- First declarations universally excluded - if Nkind (D) = N_Package_Declaration then + if Nkind (Decl) = N_Package_Declaration then Cannot_Inline - ("cannot inline & (nested package declaration)?", D, Subp); + ("cannot inline & (nested package declaration)?", Decl, Subp); return True; - elsif Nkind (D) = N_Package_Instantiation then + elsif Nkind (Decl) = N_Package_Instantiation then Cannot_Inline - ("cannot inline & (nested package instantiation)?", D, Subp); + ("cannot inline & (nested package instantiation)?", Decl, Subp); return True; end if; @@ -4280,51 +4282,50 @@ package body Inline is if Back_End_Inlining then null; - elsif Nkind (D) = N_Task_Type_Declaration - or else Nkind (D) = N_Single_Task_Declaration + elsif Nkind (Decl) = N_Task_Type_Declaration + or else Nkind (Decl) = N_Single_Task_Declaration then Cannot_Inline - ("cannot inline & (nested task type declaration)?", D, Subp); + ("cannot inline & (nested task type declaration)?", Decl, Subp); return True; - elsif Nkind (D) = N_Protected_Type_Declaration - or else Nkind (D) = N_Single_Protected_Declaration + elsif Nkind (Decl) in N_Protected_Type_Declaration + | N_Single_Protected_Declaration then Cannot_Inline ("cannot inline & (nested protected type declaration)?", - D, Subp); + Decl, Subp); return True; - elsif Nkind (D) = N_Subprogram_Body then + elsif Nkind (Decl) = N_Subprogram_Body then Cannot_Inline - ("cannot inline & (nested subprogram)?", D, Subp); + ("cannot inline & (nested subprogram)?", Decl, Subp); return True; - elsif Nkind (D) = N_Function_Instantiation - and then not Is_Unchecked_Conversion (D) + elsif Nkind (Decl) = N_Function_Instantiation + and then not Is_Unchecked_Conversion (Decl) then Cannot_Inline - ("cannot inline & (nested function instantiation)?", D, Subp); + ("cannot inline & (nested function instantiation)?", Decl, Subp); return True; - elsif Nkind (D) = N_Procedure_Instantiation then + elsif Nkind (Decl) = N_Procedure_Instantiation then Cannot_Inline - ("cannot inline & (nested procedure instantiation)?", D, Subp); + ("cannot inline & (nested procedure instantiation)?", + Decl, Subp); return True; -- Subtype declarations with predicates will generate predicate -- functions, i.e. nested subprogram bodies, so inlining is not -- possible. - elsif Nkind (D) = N_Subtype_Declaration - and then Present (Aspect_Specifications (D)) - then + elsif Nkind (Decl) = N_Subtype_Declaration then declare A : Node_Id; A_Id : Aspect_Id; begin - A := First (Aspect_Specifications (D)); + A := First (Aspect_Specifications (Decl)); while Present (A) loop A_Id := Get_Aspect_Id (Chars (Identifier (A))); @@ -4334,7 +4335,7 @@ package body Inline is then Cannot_Inline ("cannot inline & (subtype declaration with " - & "predicate)?", D, Subp); + & "predicate)?", Decl, Subp); return True; end if; @@ -4343,7 +4344,7 @@ package body Inline is end; end if; - Next (D); + Next (Decl); end loop; return False; diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb index f51b44a..ffaa4fe 100644 --- a/gcc/ada/itypes.adb +++ b/gcc/ada/itypes.adb @@ -29,7 +29,6 @@ with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Stand; use Stand; with Targparm; use Targparm; -with Uintp; use Uintp; package body Itypes is @@ -62,9 +61,9 @@ package body Itypes is end if; -- Make sure Esize (Typ) was properly initialized, it should be since - -- New_Internal_Entity/New_External_Entity call Init_Size_Align. + -- New_Internal_Entity/New_External_Entity call Reinit_Size_Align. - pragma Assert (Esize (Typ) = Uint_0); + pragma Assert (not Known_Esize (Typ)); Set_Etype (Typ, Any_Type); Set_Is_Itype (Typ); diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index e69386c..092f2f5 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -155,7 +155,7 @@ package body Layout is exit when Esize (E) mod Abits = 0; end loop; - Init_Alignment (E, Abits / SSU); + Set_Alignment (E, UI_From_Int (Abits / SSU)); return; end if; @@ -243,8 +243,8 @@ package body Layout is -- like or need the size to be set. if Ekind (E) = E_String_Literal_Subtype then - Set_Esize (E, Uint_0); - Set_RM_Size (E, Uint_0); + Reinit_Esize (E); + Reinit_RM_Size (E); return; end if; @@ -287,7 +287,7 @@ package body Layout is elsif Ekind (E) = E_Access_Subtype then Set_Size_Info (E, Base_Type (E)); - Set_RM_Size (E, RM_Size (Base_Type (E))); + Copy_RM_Size (To => E, From => Base_Type (E)); -- For other access types, we use either address size, or, if a fat -- pointer is used (pointer-to-unconstrained array case), twice the @@ -379,7 +379,7 @@ package body Layout is -- If size is big enough, set it and exit if S >= RM_Size (E) then - Init_Esize (E, S); + Set_Esize (E, UI_From_Int (S)); exit; -- If the RM_Size is greater than System_Max_Integer_Size @@ -426,15 +426,15 @@ package body Layout is begin if not Known_Esize (E) then - Set_Esize (E, Esize (PAT)); + Copy_Esize (To => E, From => PAT); end if; if not Known_RM_Size (E) then - Set_RM_Size (E, RM_Size (PAT)); + Copy_RM_Size (To => E, From => PAT); end if; - if not Known_Alignment (E) and then Known_Alignment (PAT) then - Set_Alignment (E, Alignment (PAT)); + if not Known_Alignment (E) then + Copy_Alignment (To => E, From => PAT); end if; end; end if; @@ -624,13 +624,13 @@ package body Layout is if Is_Scalar_Type (E) then if Size <= SSU then - Init_Esize (E, SSU); + Set_Esize (E, UI_From_Int (SSU)); elsif Size <= 16 then - Init_Esize (E, 16); + Set_Esize (E, Uint_16); elsif Size <= 32 then - Init_Esize (E, 32); + Set_Esize (E, Uint_32); else - Set_Esize (E, (Size + 63) / 64 * 64); + Set_Esize (E, (Size + 63) / 64 * 64); end if; -- Finally, make sure that alignment is consistent with @@ -899,7 +899,7 @@ package body Layout is -- nothing to do with code. if Is_Generic_Type (Root_Type (FST)) then - Set_RM_Size (Def_Id, Uint_0); + Reinit_RM_Size (Def_Id); -- If the subtype statically matches the first subtype, then it is -- required to have exactly the same layout. This is required by @@ -1021,7 +1021,7 @@ package body Layout is -- this new calculated value. if not Known_Alignment (E) then - Init_Alignment (E, A); + Set_Alignment (E, UI_From_Int (A)); -- Cases where we have inherited an alignment @@ -1030,7 +1030,7 @@ package body Layout is -- sure that no constructed types have weird alignments. elsif not Comes_From_Source (E) then - Init_Alignment (E, A); + Set_Alignment (E, UI_From_Int (A)); -- If this inherited alignment is the same as the one we computed, -- then obviously everything is fine, and we do not need to reset it. @@ -1136,7 +1136,7 @@ package body Layout is -- ACATS problem which seems to have disappeared anyway, and -- in any case, this peculiarity was never documented. - Init_Alignment (E, A); + Set_Alignment (E, UI_From_Int (A)); -- If no Size (or Object_Size) was specified, then we have -- inherited the object size, so we should also inherit the diff --git a/gcc/ada/libgnarl/s-vxwext__noints.adb b/gcc/ada/libgnarl/s-vxwext__noints.adb deleted file mode 100644 index 421781f..0000000 --- a/gcc/ada/libgnarl/s-vxwext__noints.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S . E X T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2021, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- ------------------------------------------------------------------------------- - --- This package provides vxworks specific support functions needed --- by System.OS_Interface. - --- This is a version for VxWorks 5 based systems with no interrupts: --- HI-Ravenscar for VxWorks 5, VxWorks 653 vThreads (not ravenscar-cert) - -package body System.VxWorks.Ext is - - ERROR : constant := -1; - - -------------- - -- Int_Lock -- - -------------- - - function Int_Lock return int is - begin - return ERROR; - end Int_Lock; - - ---------------- - -- Int_Unlock -- - ---------------- - - function Int_Unlock (Old : int) return int is - pragma Unreferenced (Old); - begin - 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 VxWorks 653 vThreads, 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_Sem_Delete (Sem : SEM_ID) return int; - pragma Import (C, Os_Sem_Delete, "semDelete"); - begin - return Os_Sem_Delete (Sem); - end semDelete; - - ------------------------ - -- taskCpuAffinitySet -- - ------------------------ - - function taskCpuAffinitySet (tid : t_id; CPU : int) return int is - pragma Unreferenced (tid, CPU); - begin - return ERROR; - end taskCpuAffinitySet; - - ------------------------- - -- taskMaskAffinitySet -- - ------------------------- - - function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is - pragma Unreferenced (tid, CPU_Set); - begin - return ERROR; - end taskMaskAffinitySet; - -end System.VxWorks.Ext; diff --git a/gcc/ada/libgnarl/s-vxwext__vthreads.ads b/gcc/ada/libgnarl/s-vxwext__vthreads.ads deleted file mode 100644 index e97561e..0000000 --- a/gcc/ada/libgnarl/s-vxwext__vthreads.ads +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S . E X T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2021, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- ------------------------------------------------------------------------------- - --- This package provides VxWorks specific support functions needed --- by System.OS_Interface. - --- This is the VxWorks 653 vThreads version of this package - -with Interfaces.C; - -package System.VxWorks.Ext is - pragma Preelaborate; - - 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; - subtype unsigned is Interfaces.C.unsigned; - - type Interrupt_Handler is access procedure (parameter : System.Address); - pragma Convention (C, Interrupt_Handler); - - type Interrupt_Vector is new System.Address; - function Int_Lock return int; - pragma Inline (Int_Lock); - - function Int_Unlock (Old : int) return int; - pragma Inline (Int_Unlock); - - function Interrupt_Connect - (Vector : Interrupt_Vector; - Handler : Interrupt_Handler; - 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"); - - function Task_Stop (tid : t_id) return int; - pragma Import (C, Task_Stop, "taskSuspend"); - - function kill (pid : t_id; sig : int) return int; - pragma Import (C, kill, "kill"); - - function getpid return t_id; - pragma Import (C, getpid, "taskIdSelf"); - - function Set_Time_Slice (ticks : int) return int; - pragma Import (C, Set_Time_Slice, "kernelTimeSlice"); - - type UINT64 is mod 2 ** Long_Long_Integer'Size; - - function tickGet return UINT64; - -- "tickGet" not available for cert vThreads: - pragma Import (C, tickGet, "tick64Get"); - - -------------------------------- - -- Processor Affinity for SMP -- - -------------------------------- - - function taskCpuAffinitySet (tid : t_id; CPU : int) return int; - pragma Convention (C, taskCpuAffinitySet); - -- For SMP run-times set the CPU affinity. - -- For uniprocessor systems return ERROR status. - - function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int; - pragma Convention (C, taskMaskAffinitySet); - -- For SMP run-times set the CPU mask affinity. - -- For uniprocessor systems return ERROR status. - -end System.VxWorks.Ext; diff --git a/gcc/ada/libgnat/a-calend.adb b/gcc/ada/libgnat/a-calend.adb index 8295a7c..5dedfc5 100644 --- a/gcc/ada/libgnat/a-calend.adb +++ b/gcc/ada/libgnat/a-calend.adb @@ -35,6 +35,8 @@ with Interfaces.C; with System.OS_Primitives; +with System.OS_Lib; + package body Ada.Calendar with SPARK_Mode => Off is @@ -685,13 +687,10 @@ is type int_Pointer is access all Interfaces.C.int; type long_Pointer is access all Interfaces.C.long; - type time_t is - range -(2 ** (Standard'Address_Size - Integer'(1))) .. - +(2 ** (Standard'Address_Size - Integer'(1)) - 1); - type time_t_Pointer is access all time_t; + type OS_Time_Pointer is access all System.OS_Lib.OS_Time; procedure localtime_tzoff - (timer : time_t_Pointer; + (timer : OS_Time_Pointer; is_historic : int_Pointer; off : long_Pointer); pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff"); @@ -708,7 +707,7 @@ is Date_N : Time_Rep; Flag : aliased Interfaces.C.int; Offset : aliased Interfaces.C.long; - Secs_T : aliased time_t; + Secs_T : aliased System.OS_Lib.OS_Time; -- Start of processing for UTC_Time_Offset @@ -745,7 +744,7 @@ is -- Convert the date into seconds - Secs_T := time_t (Date_N / Nano); + Secs_T := System.OS_Lib.To_Ada (Long_Long_Integer (Date_N / Nano)); -- Determine whether to treat the input date as historical or not. A -- value of "0" signifies that the date is NOT historic. diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb index 143805e..3752ca9 100644 --- a/gcc/ada/libgnat/a-cbdlli.adb +++ b/gcc/ada/libgnat/a-cbdlli.adb @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; with System.Put_Images; @@ -858,74 +860,6 @@ is procedure Sort (Container : in out List) is N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot, Back : Count_Type); - -- What does this do ??? - - procedure Sort (Front, Back : Count_Type); - -- Internal procedure, what does it do??? rename it??? - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot, Back : Count_Type) is - Node : Count_Type; - - begin - Node := N (Pivot).Next; - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Count_Type) is - Pivot : constant Count_Type := - (if Front = 0 then Container.First else N (Front).Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -941,8 +875,43 @@ is declare Lock : With_Lock (Container.TC'Unchecked_Access); + + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element < N (R).Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; begin - Sort (Front => 0, Back => 0); + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); end; pragma Assert (N (Container.First).Prev = 0); diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb index d989751..1d48ed9 100644 --- a/gcc/ada/libgnat/a-cdlili.adb +++ b/gcc/ada/libgnat/a-cdlili.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; with System.Put_Images; @@ -674,156 +676,6 @@ is ---------- procedure Sort (Container : in out List) is - - type List_Descriptor is - record - First, Last : Node_Access; - Length : Count_Type; - end record; - - function Merge_Sort (Arg : List_Descriptor) return List_Descriptor; - -- Sort list of given length using MergeSort; length must be >= 2. - -- As required by RM, the sort is stable. - - ---------------- - -- Merge_Sort -- - ---------------- - - function Merge_Sort (Arg : List_Descriptor) return List_Descriptor - is - procedure Split_List - (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor); - -- Split list into two parts for divide-and-conquer. - -- Unsplit.Length must be >= 2. - - function Merge_Parts - (Part1, Part2 : List_Descriptor) return List_Descriptor; - -- Merge two sorted lists, preserving sorted property. - - ---------------- - -- Split_List -- - ---------------- - - procedure Split_List - (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor) - is - Rover : Node_Access := Unsplit.First; - Bump_Count : constant Count_Type := (Unsplit.Length - 1) / 2; - begin - for Iter in 1 .. Bump_Count loop - Rover := Rover.Next; - end loop; - - Part1 := (First => Unsplit.First, - Last => Rover, - Length => Bump_Count + 1); - - Part2 := (First => Rover.Next, - Last => Unsplit.Last, - Length => Unsplit.Length - Part1.Length); - - -- Detach - Part1.Last.Next := null; - Part2.First.Prev := null; - end Split_List; - - ----------------- - -- Merge_Parts -- - ----------------- - - function Merge_Parts - (Part1, Part2 : List_Descriptor) return List_Descriptor - is - Empty : constant List_Descriptor := (null, null, 0); - - procedure Detach_First (Source : in out List_Descriptor; - Detached : out Node_Access); - -- Detach the first element from a non-empty list and - -- return the detached node via the Detached parameter. - - ------------------ - -- Detach_First -- - ------------------ - - procedure Detach_First (Source : in out List_Descriptor; - Detached : out Node_Access) is - begin - Detached := Source.First; - - if Source.Length = 1 then - Source := Empty; - else - Source := (Source.First.Next, - Source.Last, - Source.Length - 1); - - Detached.Next.Prev := null; - Detached.Next := null; - end if; - end Detach_First; - - P1 : List_Descriptor := Part1; - P2 : List_Descriptor := Part2; - Merged : List_Descriptor := Empty; - - Take_From_P2 : Boolean; - Detached : Node_Access; - - -- Start of processing for Merge_Parts - - begin - while (P1.Length /= 0) or (P2.Length /= 0) loop - if P1.Length = 0 then - Take_From_P2 := True; - elsif P2.Length = 0 then - Take_From_P2 := False; - else - -- If the compared elements are equal then Take_From_P2 - -- must be False in order to ensure stability. - - Take_From_P2 := P2.First.Element < P1.First.Element; - end if; - - if Take_From_P2 then - Detach_First (P2, Detached); - else - Detach_First (P1, Detached); - end if; - - if Merged.Length = 0 then - Merged := (First | Last => Detached, Length => 1); - else - Detached.Prev := Merged.Last; - Merged.Last.Next := Detached; - Merged.Last := Detached; - Merged.Length := Merged.Length + 1; - end if; - end loop; - return Merged; - end Merge_Parts; - - -- Start of processing for Merge_Sort - - begin - if Arg.Length < 2 then - -- already sorted - return Arg; - end if; - - declare - Part1, Part2 : List_Descriptor; - begin - Split_List (Unsplit => Arg, Part1 => Part1, Part2 => Part2); - - Part1 := Merge_Sort (Part1); - Part2 := Merge_Sort (Part2); - - return Merge_Parts (Part1, Part2); - end; - end Merge_Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -838,28 +690,43 @@ is -- element tampering by a generic actual subprogram. declare - Lock : With_Lock (Container.TC'Unchecked_Access); + Lock : With_Lock (Container.TC'Unchecked_Access); + + package Descriptors is new List_Descriptors + (Node_Ref => Node_Access, Nil => null); + use Descriptors; + + function Next (N : Node_Access) return Node_Access is (N.Next); + procedure Set_Next (N : Node_Access; Next : Node_Access) + with Inline; + procedure Set_Prev (N : Node_Access; Prev : Node_Access) + with Inline; + function "<" (L, R : Node_Access) return Boolean is + (L.Element < R.Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (N : Node_Access; Next : Node_Access) is + begin + N.Next := Next; + end Set_Next; - Unsorted : constant List_Descriptor := - (First => Container.First, - Last => Container.Last, - Length => Container.Length); + procedure Set_Prev (N : Node_Access; Prev : Node_Access) is + begin + N.Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; - Sorted : List_Descriptor; + procedure Sort_List is new Doubly_Linked_List_Sort; begin - -- If a call to the formal < operator references the container - -- during sorting, seeing an empty container seems preferable - -- to seeing an internally inconsistent container. - -- - Container.First := null; - Container.Last := null; - Container.Length := 0; - - Sorted := Merge_Sort (Unsorted); - - Container.First := Sorted.First; - Container.Last := Sorted.Last; - Container.Length := Sorted.Length; + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); end; pragma Assert (Container.First.Prev = null); diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb index b289def..c9897c7 100644 --- a/gcc/ada/libgnat/a-cfdlli.adb +++ b/gcc/ada/libgnat/a-cfdlli.adb @@ -25,6 +25,8 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; package body Ada.Containers.Formal_Doubly_Linked_Lists with @@ -976,77 +978,6 @@ is procedure Sort (Container : in out List) is N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot : Count_Type; Back : Count_Type); - procedure Sort (Front : Count_Type; Back : Count_Type); - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot : Count_Type; Back : Count_Type) is - Node : Count_Type; - - begin - Node := N (Pivot).Next; - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front : Count_Type; Back : Count_Type) is - Pivot : Count_Type; - - begin - if Front = 0 then - Pivot := Container.First; - else - Pivot := N (Front).Next; - end if; - - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -1055,7 +986,44 @@ is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - Sort (Front => 0, Back => 0); + declare + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element < N (R).Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; + begin + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); + end; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index 8713d33..590643e 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -1596,8 +1596,7 @@ is M_Elements_Sorted'Result = (for all I in 1 .. M.Length (Container) => (for all J in I .. M.Length (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); + not (Element (Container, J) < Element (Container, I)))); pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); end Formal_Model; diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb index 3fc57da..1cf9401 100644 --- a/gcc/ada/libgnat/a-cidlli.adb +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; with System.Put_Images; @@ -731,73 +733,6 @@ is ---------- procedure Sort (Container : in out List) is - procedure Partition (Pivot : Node_Access; Back : Node_Access); - -- Comment ??? - - procedure Sort (Front, Back : Node_Access); - -- Comment??? Confusing name??? change name??? - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot : Node_Access; Back : Node_Access) is - Node : Node_Access; - - begin - Node := Pivot.Next; - while Node /= Back loop - if Node.Element.all < Pivot.Element.all then - declare - Prev : constant Node_Access := Node.Prev; - Next : constant Node_Access := Node.Next; - - begin - Prev.Next := Next; - - if Next = null then - Container.Last := Prev; - else - Next.Prev := Prev; - end if; - - Node.Next := Pivot; - Node.Prev := Pivot.Prev; - - Pivot.Prev := Node; - - if Node.Prev = null then - Container.First := Node; - else - Node.Prev.Next := Node; - end if; - - Node := Next; - end; - - else - Node := Node.Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Node_Access) is - Pivot : constant Node_Access := - (if Front = null then Container.First else Front.Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -813,8 +748,42 @@ is declare Lock : With_Lock (Container.TC'Unchecked_Access); + + package Descriptors is new List_Descriptors + (Node_Ref => Node_Access, Nil => null); + use Descriptors; + + function Next (N : Node_Access) return Node_Access is (N.Next); + procedure Set_Next (N : Node_Access; Next : Node_Access) + with Inline; + procedure Set_Prev (N : Node_Access; Prev : Node_Access) + with Inline; + function "<" (L, R : Node_Access) return Boolean is + (L.Element.all < R.Element.all); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (N : Node_Access; Next : Node_Access) is + begin + N.Next := Next; + end Set_Next; + + procedure Set_Prev (N : Node_Access; Prev : Node_Access) is + begin + N.Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; begin - Sort (Front => null, Back => null); + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); end; pragma Assert (Container.First.Prev = null); diff --git a/gcc/ada/libgnat/a-costso.adb b/gcc/ada/libgnat/a-costso.adb new file mode 100644 index 0000000..e14ecbb --- /dev/null +++ b/gcc/ada/libgnat/a-costso.adb @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . S T A B L E _ S O R T I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2021, 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- -- +-- 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 -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Stable_Sorting is + package body List_Descriptors is + procedure Doubly_Linked_List_Sort (List : List_Descriptor) is + + Empty : constant List_Descriptor := (Nil, Nil, 0); + + function Merge_Sort (Arg : List_Descriptor) return List_Descriptor; + -- Sort list of given length using MergeSort; length must be >= 2. + -- As required by RM, the sort is stable. + + ---------------- + -- Merge_Sort -- + ---------------- + + function Merge_Sort (Arg : List_Descriptor) return List_Descriptor + is + procedure Split_List + (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor); + -- Split list into two parts for divide-and-conquer. + -- Unsplit.Length must be >= 2. + + function Merge_Parts + (Part1, Part2 : List_Descriptor) return List_Descriptor; + -- Merge two sorted lists, preserving sorted property. + + ---------------- + -- Split_List -- + ---------------- + + procedure Split_List + (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor) + is + Rover : Node_Ref := Unsplit.First; + Bump_Count : constant Count_Type := (Unsplit.Length - 1) / 2; + begin + for Iter in 1 .. Bump_Count loop + Rover := Next (Rover); + end loop; + + Part1 := (First => Unsplit.First, + Last => Rover, + Length => Bump_Count + 1); + + Part2 := (First => Next (Rover), + Last => Unsplit.Last, + Length => Unsplit.Length - Part1.Length); + + -- Detach + Set_Next (Part1.Last, Nil); + Set_Prev (Part2.First, Nil); + end Split_List; + + ----------------- + -- Merge_Parts -- + ----------------- + + function Merge_Parts + (Part1, Part2 : List_Descriptor) return List_Descriptor + is + procedure Detach_First (Source : in out List_Descriptor; + Detached : out Node_Ref); + -- Detach the first element from a non-empty list and + -- return the detached node via the Detached parameter. + + ------------------ + -- Detach_First -- + ------------------ + + procedure Detach_First (Source : in out List_Descriptor; + Detached : out Node_Ref) is + begin + Detached := Source.First; + + if Source.Length = 1 then + Source := Empty; + else + Source := (Next (Source.First), + Source.Last, + Source.Length - 1); + + Set_Prev (Next (Detached), Nil); + Set_Next (Detached, Nil); + end if; + end Detach_First; + + P1 : List_Descriptor := Part1; + P2 : List_Descriptor := Part2; + Merged : List_Descriptor := Empty; + + Take_From_P2 : Boolean; + Detached : Node_Ref; + + -- Start of processing for Merge_Parts + + begin + while (P1.Length /= 0) or (P2.Length /= 0) loop + if P1.Length = 0 then + Take_From_P2 := True; + elsif P2.Length = 0 then + Take_From_P2 := False; + else + -- If the compared elements are equal then Take_From_P2 + -- must be False in order to ensure stability. + + Take_From_P2 := P2.First < P1.First; + end if; + + if Take_From_P2 then + Detach_First (P2, Detached); + else + Detach_First (P1, Detached); + end if; + + if Merged.Length = 0 then + Merged := (First | Last => Detached, Length => 1); + else + Set_Prev (Detached, Merged.Last); + Set_Next (Merged.Last, Detached); + Merged.Last := Detached; + Merged.Length := Merged.Length + 1; + end if; + end loop; + return Merged; + end Merge_Parts; + + -- Start of processing for Merge_Sort + + begin + if Positive (Arg.Length) < 2 then + -- already sorted + return Arg; + end if; + + declare + Part1, Part2 : List_Descriptor; + begin + Split_List (Unsplit => Arg, Part1 => Part1, Part2 => Part2); + + Part1 := Merge_Sort (Part1); + Part2 := Merge_Sort (Part2); + + return Merge_Parts (Part1, Part2); + end; + end Merge_Sort; + + -- Start of processing for Sort + + begin + if List.Length > 1 then + -- If a call to the formal "<" op references the container + -- during sorting, seeing an empty container seems preferable + -- to seeing an internally inconsistent container. + -- + Update_Container (Empty); + + Update_Container (Merge_Sort (List)); + end if; + end Doubly_Linked_List_Sort; + end List_Descriptors; +end Ada.Containers.Stable_Sorting; diff --git a/gcc/ada/libgnat/a-costso.ads b/gcc/ada/libgnat/a-costso.ads new file mode 100644 index 0000000..db0be24 --- /dev/null +++ b/gcc/ada/libgnat/a-costso.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . S T A B L E _ S O R T I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2021, 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- -- +-- 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 -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Stable_Sorting package + +-- This package provides a generic stable sorting procedure that is +-- intended for use by the various doubly linked list container generics. +-- If a stable array sorting algorithm with better-than-quadratic worst +-- case execution time is ever needed, then it could also reside here. + +private package Ada.Containers.Stable_Sorting is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + -- Stable sorting algorithms with N-log-N worst case execution time. + + generic + type Node_Ref is private; -- access value or array index + Nil : Node_Ref; + package List_Descriptors is + + type List_Descriptor is + record + First, Last : Node_Ref := Nil; + Length : Count_Type := 0; + end record; + + -- We use a nested generic here so that the inner generic can + -- refer to the List_Descriptor type. + + generic + with function Next (N : Node_Ref) return Node_Ref is <>; + with procedure Set_Next (N : Node_Ref; Next : Node_Ref) is <>; + with procedure Set_Prev (N : Node_Ref; Prev : Node_Ref) is <>; + with function "<" (L, R : Node_Ref) return Boolean is <>; + + with procedure Update_Container (List : List_Descriptor) is <>; + procedure Doubly_Linked_List_Sort (List : List_Descriptor); + + end List_Descriptors; + +end Ada.Containers.Stable_Sorting; diff --git a/gcc/ada/libgnat/a-crdlli.adb b/gcc/ada/libgnat/a-crdlli.adb index 6538b26..48cdb0c 100644 --- a/gcc/ada/libgnat/a-crdlli.adb +++ b/gcc/ada/libgnat/a-crdlli.adb @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; package body Ada.Containers.Restricted_Doubly_Linked_Lists is @@ -509,83 +511,53 @@ package body Ada.Containers.Restricted_Doubly_Linked_Lists is procedure Sort (Container : in out List) is N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot, Back : Count_Type); - procedure Sort (Front, Back : Count_Type); - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot, Back : Count_Type) is - Node : Count_Type := N (Pivot).Next; - - begin - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Count_Type) is - Pivot : constant Count_Type := - (if Front = 0 then Container.First else N (Front).Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; end if; - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - -- if Container.Busy > 0 then -- raise Program_Error; -- end if; - Sort (Front => 0, Back => 0); + declare + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element < N (R).Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; + begin + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); + end; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); diff --git a/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb b/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb deleted file mode 100644 index 69f5cc2..0000000 --- a/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2021, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Warnings (Off); -with System.Standard_Library; -pragma Warnings (On); - -with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; -with GNAT.IO; use GNAT.IO; - --- Default last chance handler for use with the full VxWorks 653 partition OS --- Ada run-time library. - --- Logs error with health monitor, and dumps exception identity and argument --- string for vxaddr2line for generation of a symbolic stack backtrace. - -procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is - - ---------------------- - -- APEX definitions -- - ---------------------- - - pragma Warnings (Off); - type Error_Code_Type is ( - Deadline_Missed, - Application_Error, - Numeric_Error, - Illegal_Request, - Stack_Overflow, - Memory_Violation, - Hardware_Fault, - Power_Fail); - pragma Warnings (On); - pragma Convention (C, Error_Code_Type); - -- APEX Health Management error codes - - type Message_Addr_Type is new System.Address; - - type Apex_Integer is range -(2 ** 31) .. (2 ** 31) - 1; - pragma Convention (C, Apex_Integer); - - Max_Error_Message_Size : constant := 64; - - type Error_Message_Size_Type is new Apex_Integer range - 1 .. Max_Error_Message_Size; - - pragma Warnings (Off); - type Return_Code_Type is ( - No_Error, -- request valid and operation performed - No_Action, -- status of system unaffected by request - Not_Available, -- resource required by request unavailable - Invalid_Param, -- invalid parameter specified in request - Invalid_Config, -- parameter incompatible with configuration - Invalid_Mode, -- request incompatible with current mode - Timed_Out); -- time-out tied up with request has expired - pragma Warnings (On); - pragma Convention (C, Return_Code_Type); - -- APEX return codes - - procedure Raise_Application_Error - (Error_Code : Error_Code_Type; - Message_Addr : Message_Addr_Type; - Length : Error_Message_Size_Type; - Return_Code : out Return_Code_Type); - pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR"); - - procedure Unhandled_Terminate; - pragma No_Return (Unhandled_Terminate); - pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - -- Perform system dependent shutdown code - - procedure Adainit; - pragma Import (Ada, Adainit, "adainit"); - - Adainit_Addr : constant System.Address := Adainit'Code_Address; - -- Part of arguments to vxaddr2line - - Result : Return_Code_Type; - - Message : String := - Exception_Name (Except) & ": " & ASCII.LF & - Exception_Message (Except) & ASCII.NUL; - - Message_Length : Error_Message_Size_Type; - -begin - New_Line; - Put_Line ("In last chance handler"); - Put_Line (Message (1 .. Message'Length - 1)); - New_Line; - - Put_Line ("adainit and traceback addresses for vxaddr2line:"); - - Put (Image_C (Adainit_Addr)); Put (" "); - - for J in 1 .. Except.Num_Tracebacks loop - Put (Image_C (Except.Tracebacks (J))); - Put (" "); - end loop; - - New_Line; - - if Message'Length > Error_Message_Size_Type'Last then - Message_Length := Error_Message_Size_Type'Last; - else - Message_Length := Message'Length; - end if; - - Raise_Application_Error - (Error_Code => Application_Error, - Message_Addr => Message_Addr_Type (Message (1)'Address), - Length => Message_Length, - Return_Code => Result); - - -- Shutdown the run-time library now. The rest of the procedure needs to be - -- careful not to use anything that would require runtime support. In - -- particular, functions returning strings are banned since the sec stack - -- is no longer functional. - - System.Standard_Library.Adafinal; - Unhandled_Terminate; -end Ada.Exceptions.Last_Chance_Handler; diff --git a/gcc/ada/libgnat/a-stbufi.adb b/gcc/ada/libgnat/a-stbufi.adb index 0a8feab..656e7bd 100644 --- a/gcc/ada/libgnat/a-stbufi.adb +++ b/gcc/ada/libgnat/a-stbufi.adb @@ -45,7 +45,7 @@ package body Ada.Strings.Text_Buffers.Files is end Put_UTF_8_Implementation; function Create_From_FD - (FD : GNAT.OS_Lib.File_Descriptor; + (FD : System.OS_Lib.File_Descriptor; Close_Upon_Finalization : Boolean := True) return File_Buffer is use OS; diff --git a/gcc/ada/libgnat/a-stbufi.ads b/gcc/ada/libgnat/a-stbufi.ads index 2a2db90..b9444ab 100644 --- a/gcc/ada/libgnat/a-stbufi.ads +++ b/gcc/ada/libgnat/a-stbufi.ads @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ with Ada.Finalization; -with GNAT.OS_Lib; +with System.OS_Lib; package Ada.Strings.Text_Buffers.Files is @@ -38,7 +38,7 @@ package Ada.Strings.Text_Buffers.Files is -- Output written to a File_Buffer is written to the associated file. function Create_From_FD - (FD : GNAT.OS_Lib.File_Descriptor; + (FD : System.OS_Lib.File_Descriptor; Close_Upon_Finalization : Boolean := True) return File_Buffer; -- file closed upon finalization if specified @@ -47,9 +47,11 @@ package Ada.Strings.Text_Buffers.Files is -- file closed upon finalization function Create_Standard_Output_Buffer return File_Buffer is - (Create_From_FD (GNAT.OS_Lib.Standout, Close_Upon_Finalization => False)); + (Create_From_FD (System.OS_Lib.Standout, + Close_Upon_Finalization => False)); function Create_Standard_Error_Buffer return File_Buffer is - (Create_From_FD (GNAT.OS_Lib.Standerr, Close_Upon_Finalization => False)); + (Create_From_FD (System.OS_Lib.Standerr, + Close_Upon_Finalization => False)); private @@ -60,7 +62,7 @@ private package Mapping is new Output_Mapping (Put_UTF_8_Implementation); - package OS renames GNAT.OS_Lib; + package OS renames System.OS_Lib; type Self_Ref (Self : not null access File_Buffer) is new Finalization.Limited_Controlled with null record; diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index ee72b6b..00967c4 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -38,10 +38,17 @@ -- bounds of function return results were also fixed, and use of & removed for -- efficiency reasons. +-- Ghost code, loop invariants and assertions in this unit are meant for +-- analysis only, not for run-time checking, as it would be too costly +-- otherwise. This is enforced by setting the assertion policy to Ignore. + +pragma Assertion_Policy (Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); + with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Strings.Search; -package body Ada.Strings.Fixed is +package body Ada.Strings.Fixed with SPARK_Mode is ------------------------ -- Search Subprograms -- @@ -146,9 +153,12 @@ package body Ada.Strings.Fixed is Right : Character) return String is begin - return Result : String (1 .. Left) do + return Result : String (1 .. Left) with Relaxed_Initialization do for J in Result'Range loop Result (J) := Right; + pragma Loop_Invariant + (for all K in 1 .. J => + Result (K)'Initialized and then Result (K) = Right); end loop; end return; end "*"; @@ -157,12 +167,82 @@ package body Ada.Strings.Fixed is (Left : Natural; Right : String) return String is - Ptr : Integer := 1; + Ptr : Integer := 0; + + -- Parts of the proof involving manipulations with the modulo operator + -- are complicated for the prover and can't be done automatically in + -- the global subprogram. That's why we isolate them in these two ghost + -- lemmas. + + procedure Lemma_Mod (K : Integer) with + Ghost, + Pre => + Right'Length /= 0 + and then Ptr mod Right'Length = 0 + and then Ptr in 0 .. Natural'Last - Right'Length + and then K in Ptr .. Ptr + Right'Length - 1, + Post => K mod Right'Length = K - Ptr; + -- Lemma_Mod is applied to an index considered in Lemma_Split to prove + -- that it has the right value modulo Right'Length. + + procedure Lemma_Split (Result : String) with + Ghost, + Relaxed_Initialization => Result, + Pre => + Right'Length /= 0 + and then Result'First = 1 + and then Result'Last >= 0 + and then Ptr mod Right'Length = 0 + and then Ptr in 0 .. Result'Last - Right'Length + and then Result (Result'First .. Ptr + Right'Length)'Initialized + and then Result (Ptr + 1 .. Ptr + Right'Length) = Right, + Post => + (for all K in Ptr + 1 .. Ptr + Right'Length => + Result (K) = Right (Right'First + (K - 1) mod Right'Length)); + -- Lemma_Split is used after Result (Ptr + 1 .. Ptr + Right'Length) is + -- updated to Right and concludes that the characters match for each + -- index when taken modulo Right'Length, as the considered slice starts + -- at index 1 modulo Right'Length. + + --------------- + -- Lemma_Mod -- + --------------- + + procedure Lemma_Mod (K : Integer) is null; + + ----------------- + -- Lemma_Split -- + ----------------- + + procedure Lemma_Split (Result : String) is + begin + for K in Ptr + 1 .. Ptr + Right'Length loop + Lemma_Mod (K - 1); + pragma Loop_Invariant + (for all J in Ptr + 1 .. K => + Result (J) = Right (Right'First + (J - 1) mod Right'Length)); + end loop; + end Lemma_Split; + + -- Start of processing for "*" + begin - return Result : String (1 .. Left * Right'Length) do + if Right'Length = 0 then + return ""; + end if; + + return Result : String (1 .. Left * Right'Length) + with Relaxed_Initialization + do for J in 1 .. Left loop - Result (Ptr .. Ptr + Right'Length - 1) := Right; + Result (Ptr + 1 .. Ptr + Right'Length) := Right; + Lemma_Split (Result); Ptr := Ptr + Right'Length; + pragma Loop_Invariant (Ptr = J * Right'Length); + pragma Loop_Invariant (Result (1 .. Ptr)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. Ptr => + Result (K) = Right (Right'First + (K - 1) mod Right'Length)); end loop; end return; end "*"; @@ -176,7 +256,6 @@ package body Ada.Strings.Fixed is From : Positive; Through : Natural) return String is - Front : Integer; begin if From > Through then declare @@ -204,13 +283,22 @@ package body Ada.Strings.Fixed is end if; else - Front := From - Source'First; - return Result : String (1 .. Source'Length - (Through - From + 1)) do - Result (1 .. Front) := - Source (Source'First .. From - 1); - Result (Front + 1 .. Result'Last) := - Source (Through + 1 .. Source'Last); - end return; + declare + Front : constant Integer := From - Source'First; + + begin + return Result : String (1 .. Source'Length - (Through - From + 1)) + with Relaxed_Initialization + do + Result (1 .. Front) := + Source (Source'First .. From - 1); + + if Through < Source'Last then + Result (Front + 1 .. Result'Last) := + Source (Through + 1 .. Source'Last); + end if; + end return; + end; end if; end Delete; @@ -219,8 +307,7 @@ package body Ada.Strings.Fixed is From : Positive; Through : Natural; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) with SPARK_Mode => Off is begin Move (Source => Delete (Source, From, Through), Target => Source, @@ -240,16 +327,19 @@ package body Ada.Strings.Fixed is subtype Result_Type is String (1 .. Count); begin - if Count < Source'Length then + if Count <= Source'Length then return - Result_Type (Source (Source'First .. Source'First + Count - 1)); + Result_Type (Source (Source'First .. Source'First + (Count - 1))); else - return Result : Result_Type do + return Result : Result_Type with Relaxed_Initialization do Result (1 .. Source'Length) := Source; for J in Source'Length + 1 .. Count loop Result (J) := Pad; + pragma Loop_Invariant + (for all K in Source'Length + 1 .. J => + Result (K)'Initialized and then Result (K) = Pad); end loop; end return; end if; @@ -281,17 +371,31 @@ package body Ada.Strings.Fixed is Front : constant Integer := Before - Source'First; begin - if Before not in Source'First .. Source'Last + 1 then + if Before - 1 not in Source'First - 1 .. Source'Last then raise Index_Error; end if; - return Result : String (1 .. Source'Length + New_Item'Length) do + return Result : String (1 .. Source'Length + New_Item'Length) + with Relaxed_Initialization + do Result (1 .. Front) := Source (Source'First .. Before - 1); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - Result (Front + New_Item'Length + 1 .. Result'Last) := - Source (Before .. Source'Last); + pragma Assert + (Result + (Before - Source'First + 1 + .. Before - Source'First + New_Item'Length) + = New_Item); + + if Before <= Source'Last then + Result (Front + New_Item'Length + 1 .. Result'Last) := + Source (Before .. Source'Last); + end if; + + pragma Assert + (Result (1 .. Before - Source'First) + = Source (Source'First .. Before - 1)); end return; end Insert; @@ -299,8 +403,7 @@ package body Ada.Strings.Fixed is (Source : in out String; Before : Positive; New_Item : String; - Drop : Truncation := Error) - is + Drop : Truncation := Error) with SPARK_Mode => Off is begin Move (Source => Insert (Source, Before, New_Item), Target => Source, @@ -316,7 +419,7 @@ package body Ada.Strings.Fixed is Target : out String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space) + Pad : Character := Space) with SPARK_Mode => Off is Sfirst : constant Integer := Source'First; Slast : constant Integer := Source'Last; @@ -423,7 +526,7 @@ package body Ada.Strings.Fixed is Position : Positive; New_Item : String) return String is begin - if Position not in Source'First .. Source'Last + 1 then + if Position - 1 not in Source'First - 1 .. Source'Last then raise Index_Error; end if; @@ -434,11 +537,32 @@ package body Ada.Strings.Fixed is Front : constant Integer := Position - Source'First; begin - return Result : String (1 .. Result_Length) do + return Result : String (1 .. Result_Length) + with Relaxed_Initialization + do Result (1 .. Front) := Source (Source'First .. Position - 1); + pragma Assert + (Result (1 .. Position - Source'First) + = Source (Source'First .. Position - 1)); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - Result (Front + New_Item'Length + 1 .. Result'Length) := - Source (Position + New_Item'Length .. Source'Last); + pragma Assert + (Result + (Position - Source'First + 1 + .. Position - Source'First + New_Item'Length) + = New_Item); + + if Position <= Source'Last - New_Item'Length then + Result (Front + New_Item'Length + 1 .. Result'Last) := + Source (Position + New_Item'Length .. Source'Last); + end if; + + pragma Assert + (if Position <= Source'Last - New_Item'Length + then + Result + (Position - Source'First + New_Item'Length + 1 + .. Result'Last) + = Source (Position + New_Item'Length .. Source'Last)); end return; end; end Overwrite; @@ -447,8 +571,7 @@ package body Ada.Strings.Fixed is (Source : in out String; Position : Positive; New_Item : String; - Drop : Truncation := Right) - is + Drop : Truncation := Right) with SPARK_Mode => Off is begin Move (Source => Overwrite (Source, Position, New_Item), Target => Source, @@ -463,10 +586,9 @@ package body Ada.Strings.Fixed is (Source : String; Low : Positive; High : Natural; - By : String) return String - is + By : String) return String is begin - if Low > Source'Last + 1 or else High < Source'First - 1 then + if Low - 1 > Source'Last or else High < Source'First - 1 then raise Index_Error; end if; @@ -484,11 +606,34 @@ package body Ada.Strings.Fixed is -- Length of result begin - return Result : String (1 .. Result_Length) do + return Result : String (1 .. Result_Length) + with Relaxed_Initialization do Result (1 .. Front_Len) := Source (Source'First .. Low - 1); + pragma Assert + (Result (1 .. Integer'Max (0, Low - Source'First)) + = Source (Source'First .. Low - 1)); Result (Front_Len + 1 .. Front_Len + By'Length) := By; - Result (Front_Len + By'Length + 1 .. Result'Length) := - Source (High + 1 .. Source'Last); + + if High < Source'Last then + Result (Front_Len + By'Length + 1 .. Result'Last) := + Source (High + 1 .. Source'Last); + end if; + + pragma Assert + (Result (1 .. Integer'Max (0, Low - Source'First)) + = Source (Source'First .. Low - 1)); + pragma Assert + (Result + (Integer'Max (0, Low - Source'First) + 1 + .. Integer'Max (0, Low - Source'First) + By'Length) + = By); + pragma Assert + (if High < Source'Last + then + Result + (Integer'Max (0, Low - Source'First) + By'Length + 1 + .. Result'Last) + = Source (High + 1 .. Source'Last)); end return; end; else @@ -503,8 +648,7 @@ package body Ada.Strings.Fixed is By : String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) with SPARK_Mode => Off is begin Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); end Replace_Slice; @@ -521,18 +665,26 @@ package body Ada.Strings.Fixed is subtype Result_Type is String (1 .. Count); begin - if Count < Source'Length then + if Count = 0 then + return ""; + + elsif Count < Source'Length then return Result_Type (Source (Source'Last - Count + 1 .. Source'Last)); -- Pad on left else - return Result : Result_Type do + return Result : Result_Type with Relaxed_Initialization do for J in 1 .. Count - Source'Length loop Result (J) := Pad; + pragma Loop_Invariant + (for all K in 1 .. J => + Result (K)'Initialized and then Result (K) = Pad); end loop; - Result (Count - Source'Length + 1 .. Count) := Source; + if Source'Length /= 0 then + Result (Count - Source'Length + 1 .. Count) := Source; + end if; end return; end if; end Tail; @@ -560,9 +712,18 @@ package body Ada.Strings.Fixed is Mapping : Maps.Character_Mapping) return String is begin - return Result : String (1 .. Source'Length) do + return Result : String (1 .. Source'Length) + with Relaxed_Initialization + do for J in Source'Range loop Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + pragma Loop_Invariant + (for all K in Source'First .. J => + Result (K - (Source'First - 1))'Initialized); + pragma Loop_Invariant + (for all K in Source'First .. J => + Result (K - (Source'First - 1)) = + Value (Mapping, Source (K))); end loop; end return; end Translate; @@ -574,6 +735,9 @@ package body Ada.Strings.Fixed is begin for J in Source'Range loop Source (J) := Value (Mapping, Source (J)); + pragma Loop_Invariant + (for all K in Source'First .. J => + Source (K) = Value (Mapping, Source'Loop_Entry (K))); end loop; end Translate; @@ -583,9 +747,17 @@ package body Ada.Strings.Fixed is is pragma Unsuppress (Access_Check); begin - return Result : String (1 .. Source'Length) do + return Result : String (1 .. Source'Length) + with Relaxed_Initialization + do for J in Source'Range loop Result (J - (Source'First - 1)) := Mapping.all (Source (J)); + pragma Loop_Invariant + (for all K in Source'First .. J => + Result (K - (Source'First - 1))'Initialized); + pragma Loop_Invariant + (for all K in Source'First .. J => + Result (K - (Source'First - 1)) = Mapping (Source (K))); end loop; end return; end Translate; @@ -598,6 +770,9 @@ package body Ada.Strings.Fixed is begin for J in Source'Range loop Source (J) := Mapping.all (Source (J)); + pragma Loop_Invariant + (for all K in Source'First .. J => + Source (K) = Mapping (Source'Loop_Entry (K))); end loop; end Translate; @@ -609,6 +784,9 @@ package body Ada.Strings.Fixed is (Source : String; Side : Trim_End) return String is + Empty_String : constant String (1 .. 0) := ""; + -- Without declaring the empty string as a separate string starting + -- at 1, SPARK provers have trouble proving the postcondition. begin case Side is when Strings.Left => @@ -618,7 +796,7 @@ package body Ada.Strings.Fixed is -- All blanks case if Low = 0 then - return ""; + return Empty_String; end if; declare @@ -635,7 +813,7 @@ package body Ada.Strings.Fixed is -- All blanks case if High = 0 then - return ""; + return Empty_String; end if; declare @@ -652,7 +830,7 @@ package body Ada.Strings.Fixed is -- All blanks case if Low = 0 then - return ""; + return Empty_String; end if; declare @@ -695,8 +873,7 @@ package body Ada.Strings.Fixed is return ""; end if; - High := - Index (Source, Set => Right, Test => Outside, Going => Backward); + High := Index (Source, Set => Right, Test => Outside, Going => Backward); -- Case where source comprises only characters in Right @@ -705,7 +882,8 @@ package body Ada.Strings.Fixed is end if; declare - subtype Result_Type is String (1 .. High - Low + 1); + Result_Length : constant Integer := High - Low + 1; + subtype Result_Type is String (1 .. Result_Length); begin return Result_Type (Source (Low .. High)); diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads index 4214157..1a5ee94 100644 --- a/gcc/ada/libgnat/a-strfix.ads +++ b/gcc/ada/libgnat/a-strfix.ads @@ -13,14 +13,6 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore); - -with Ada.Strings.Maps; - -- The language-defined package Strings.Fixed provides string-handling -- subprograms for fixed-length strings; that is, for values of type -- Standard.String. Several of these subprograms are procedures that modify @@ -40,6 +32,20 @@ with Ada.Strings.Maps; -- these effects. Similar control is provided by the string transformation -- procedures. +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced by +-- setting the corresponding assertion policy to Ignore. Postconditions and +-- contract cases should not be executed at runtime as well, in order not to +-- slow down the execution of these functions. + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore); + +with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; +with Ada.Strings.Search; + package Ada.Strings.Fixed with SPARK_Mode is pragma Preelaborate; @@ -108,56 +114,60 @@ package Ada.Strings.Fixed with SPARK_Mode is Going : Direction := Forward; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => - Pattern'Length /= 0 - and then (if Source'Length /= 0 then From in Source'Range), + Pre => Pattern'Length > 0 + and then Mapping /= null + and then (if Source'Length > 0 then From in Source'Range), Post => Index'Result in 0 | Source'Range, Contract_Cases => - -- If no slice in the considered range of Source matches Pattern, - -- then 0 is returned. + -- If Source is the empty string, then 0 is returned - ((for all J in Source'Range => - (if (if Going = Forward - then J in From .. Source'Last - Pattern'Length + 1 - else J <= From - Pattern'Length + 1) - then Translate (Source (J .. J - 1 + Pattern'Length), Mapping) - /= Pattern)) + (Source'Length = 0 => Index'Result = 0, - -- Otherwise, a valid index is returned + -- If some slice of Source matches Pattern, then a valid index is + -- returned. - others + Source'Length > 0 + and then + (for some J in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) => + Ada.Strings.Search.Match (Source, Pattern, Mapping, J)) => - -- The result is in the considered range of Source - (if Going = Forward - then Index'Result in From .. Source'Last - Pattern'Length + 1 - else Index'Result in Source'First .. From - Pattern'Length + 1) + Index'Result in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) -- The slice beginning at the returned index matches Pattern and then - Translate (Source (Index'Result - .. Index'Result - 1 + Pattern'Length), - Mapping) - = Pattern + Ada.Strings.Search.Match (Source, Pattern, Mapping, Index'Result) - -- The result is the smallest or largest index which satisfies the - -- matching, respectively when Going = Forward and - -- Going = Backwards. + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. and then (for all J in Source'Range => (if (if Going = Forward then J in From .. Index'Result - 1 - else J - 1 in Index'Result .. From - Pattern'Length) - then Translate (Source (J .. J - 1 + Pattern'Length), - Mapping) - /= Pattern))), + else J - 1 in Index'Result + .. From - Pattern'Length) + then not (Ada.Strings.Search.Match + (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), Global => null; pragma Ada_05 (Index); @@ -168,56 +178,59 @@ package Ada.Strings.Fixed with SPARK_Mode is Going : Direction := Forward; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural with - Pre => - Pattern'Length /= 0 - and then (if Source'Length /= 0 then From in Source'Range), + Pre => Pattern'Length > 0 + and then (if Source'Length > 0 then From in Source'Range), Post => Index'Result in 0 | Source'Range, Contract_Cases => - -- If no slice in the considered range of Source matches Pattern, - -- then 0 is returned. + -- If Source is the empty string, then 0 is returned - ((for all J in Source'Range => - (if (if Going = Forward - then J in From .. Source'Last - Pattern'Length + 1 - else J <= From - Pattern'Length + 1) - then Translate (Source (J .. J - 1 + Pattern'Length), Mapping) - /= Pattern)) + (Source'Length = 0 => Index'Result = 0, - -- Otherwise, a valid index is returned + -- If some slice of Source matches Pattern, then a valid index is + -- returned. - others + Source'Length > 0 + and then + (for some J in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) => + Ada.Strings.Search.Match (Source, Pattern, Mapping, J)) => - -- The result is in the considered range of Source - (if Going = Forward - then Index'Result in From .. Source'Last - Pattern'Length + 1 - else Index'Result in Source'First .. From - Pattern'Length + 1) + Index'Result in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) - -- The slice beginning at the returned index matches Pattern + -- The slice beginning at the returned index matches Pattern - and then - Translate (Source (Index'Result - .. Index'Result - 1 + Pattern'Length), - Mapping) - = Pattern + and then + Ada.Strings.Search.Match (Source, Pattern, Mapping, Index'Result) -- The result is the smallest or largest index which satisfies the -- matching, respectively when Going = Forward and - -- Going = Backwards. + -- Going = Backward. and then (for all J in Source'Range => (if (if Going = Forward then J in From .. Index'Result - 1 - else J - 1 in Index'Result .. From - Pattern'Length) - then Translate (Source (J .. J - 1 + Pattern'Length), - Mapping) - /= Pattern))), + else J - 1 in Index'Result + .. From - Pattern'Length) + then not (Ada.Strings.Search.Match + (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), Global => null; pragma Ada_05 (Index); @@ -245,37 +258,33 @@ package Ada.Strings.Fixed with SPARK_Mode is Post => Index'Result in 0 | Source'Range, Contract_Cases => - -- If Source is empty, or if no slice of Source matches Pattern, then - -- 0 is returned. + -- If Source is the empty string, then 0 is returned (Source'Length = 0 - or else - (for all J in Source'First .. Source'Last - Pattern'Length + 1 => - Translate (Source (J .. J - 1 + Pattern'Length), Mapping) - /= Pattern) => Index'Result = 0, - -- Otherwise, a valid index is returned + -- If some slice of Source matches Pattern, then a valid index is + -- returned. - others + Source'Length > 0 + and then + (for some J in + Source'First .. Source'Last - (Pattern'Length - 1) => + Ada.Strings.Search.Match (Source, Pattern, Mapping, J)) => - -- The result is in the considered range of Source - Index'Result in Source'First .. Source'Last - Pattern'Length + 1 + Index'Result in Source'First .. Source'Last - (Pattern'Length - 1) -- The slice beginning at the returned index matches Pattern and then - Translate (Source (Index'Result - .. Index'Result - 1 + Pattern'Length), - Mapping) - = Pattern + Ada.Strings.Search.Match (Source, Pattern, Mapping, Index'Result) - -- The result is the smallest or largest index which satisfies the - -- matching, respectively when Going = Forward and - -- Going = Backwards. + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. and then (for all J in Source'Range => @@ -283,9 +292,14 @@ package Ada.Strings.Fixed with SPARK_Mode is then J <= Index'Result - 1 else J - 1 in Index'Result .. Source'Last - Pattern'Length) - then Translate (Source (J .. J - 1 + Pattern'Length), - Mapping) - /= Pattern))), + then not (Ada.Strings.Search.Match + (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), Global => null; function Index @@ -294,42 +308,38 @@ package Ada.Strings.Fixed with SPARK_Mode is Going : Direction := Forward; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => Pattern'Length > 0, + Pre => Pattern'Length > 0 and then Mapping /= null, Post => Index'Result in 0 | Source'Range, Contract_Cases => - -- If Source is empty, or if no slice of Source matches Pattern, then - -- 0 is returned. + -- If Source is the empty string, then 0 is returned (Source'Length = 0 - or else - (for all J in Source'First .. Source'Last - Pattern'Length + 1 => - Translate (Source (J .. J - 1 + Pattern'Length), Mapping) - /= Pattern) => Index'Result = 0, - -- Otherwise, a valid index is returned + -- If some slice of Source matches Pattern, then a valid index is + -- returned. - others + Source'Length > 0 + and then + (for some J in + Source'First .. Source'Last - (Pattern'Length - 1) => + Ada.Strings.Search.Match (Source, Pattern, Mapping, J)) => - -- The result is in the considered range of Source - Index'Result in Source'First .. Source'Last - Pattern'Length + 1 + Index'Result in Source'First .. Source'Last - (Pattern'Length - 1) - -- The slice beginning at the returned index matches Pattern + -- The slice beginning at the returned index matches Pattern - and then - Translate (Source (Index'Result - .. Index'Result - 1 + Pattern'Length), - Mapping) - = Pattern + and then + Ada.Strings.Search.Match (Source, Pattern, Mapping, Index'Result) - -- The result is the smallest or largest index which satisfies the - -- matching, respectively when Going = Forward and - -- Going = Backwards. + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. and then (for all J in Source'Range => @@ -337,9 +347,14 @@ package Ada.Strings.Fixed with SPARK_Mode is then J <= Index'Result - 1 else J - 1 in Index'Result .. Source'Last - Pattern'Length) - then Translate (Source (J .. J - 1 + Pattern'Length), - Mapping) - /= Pattern))), + then not (Ada.Strings.Search.Match + (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), Global => null; -- If Going = Forward, returns: @@ -383,9 +398,9 @@ package Ada.Strings.Fixed with SPARK_Mode is (Test = Inside) = Ada.Strings.Maps.Is_In (Source (Index'Result), Set) - -- The result is the smallest or largest index which satisfies the - -- property, respectively when Going = Forward and - -- Going = Backwards. + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. and then (for all J in Source'Range => @@ -402,22 +417,23 @@ package Ada.Strings.Fixed with SPARK_Mode is Test : Membership := Inside; Going : Direction := Forward) return Natural with - Pre => (if Source'Length /= 0 then From in Source'Range), - + Pre => (if Source'Length > 0 then From in Source'Range), Post => Index'Result in 0 | Source'Range, Contract_Cases => - -- If no character in the considered slice of Source satisfies the - -- property Test on Set, then 0 is returned. + -- If Source is the empty string, or no character of the considered + -- slice of Source satisfies the property Test on Set, then 0 is + -- returned. - ((for all I in Source'Range => - (if I = From - or else (I > From) = (Going = Forward) - then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (I), Set))) + (Source'Length = 0 + or else + (for all J in Source'Range => + (if J = From or else (J > From) = (Going = Forward) then + (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set))) => Index'Result = 0, - -- Otherwise, an index in the range of Source is returned + -- Otherwise, a index in the considered range of Source is returned others => @@ -426,7 +442,8 @@ package Ada.Strings.Fixed with SPARK_Mode is Index'Result in Source'Range and then (Index'Result = From - or else (Index'Result > From) = (Going = Forward)) + or else + (Index'Result > From) = (Going = Forward)) -- The character at the returned index satisfies the property -- Test on Set. @@ -435,19 +452,18 @@ package Ada.Strings.Fixed with SPARK_Mode is (Test = Inside) = Ada.Strings.Maps.Is_In (Source (Index'Result), Set) - -- The result is the smallest or largest index which satisfies the - -- property, respectively when Going = Forward and - -- Going = Backwards. + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. and then (for all J in Source'Range => (if J /= Index'Result - and then (J < Index'Result) = (Going = Forward) - and then (J = From - or else (J > From) = (Going = Forward)) - then - (Test = Inside) - /= Ada.Strings.Maps.Is_In (Source (J), Set)))), + and then (J < Index'Result) = (Going = Forward) + and then (J = From + or else (J > From) = (Going = Forward)) + then (Test = Inside) + /= Ada.Strings.Maps.Is_In (Source (J), Set)))), Global => null; pragma Ada_05 (Index); -- Index searches for the first or last occurrence of any of a set of @@ -469,12 +485,14 @@ package Ada.Strings.Fixed with SPARK_Mode is Post => Index_Non_Blank'Result in 0 | Source'Range, Contract_Cases => - -- If all characters in the considered slice of Source are Space - -- characters, then 0 is returned. + -- If Source is the empty string, or all characters in the considered + -- slice of Source are Space characters, then 0 is returned. - ((for all J in Source'Range => - (if J = From or else (J > From) = (Going = Forward) - then Source (J) = ' ')) + (Source'Length = 0 + or else + (for all J in Source'Range => + (if J = From or else (J > From) = (Going = Forward) then + Source (J) = ' ')) => Index_Non_Blank'Result = 0, @@ -496,7 +514,7 @@ package Ada.Strings.Fixed with SPARK_Mode is -- The result is the smallest or largest index which is not a -- Space character, respectively when Going = Forward and - -- Going = Backwards. + -- Going = Backward. and then (for all J in Source'Range => @@ -535,8 +553,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then Source (Index_Non_Blank'Result) /= ' ' -- The result is the smallest or largest index which is not a - -- Space character, respectively when Going = Forward and - -- Going = Backwards. + -- Space character, respectively when Going = Forward and Going + -- = Backward. and then (for all J in Source'Range => @@ -560,7 +578,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Pattern : String; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => Pattern'Length /= 0, + Pre => Pattern'Length /= 0 and then Mapping /= null, Global => null; -- Returns the maximum number of nonoverlapping slices of Source that match @@ -646,6 +664,7 @@ package Ada.Strings.Fixed with SPARK_Mode is First : out Positive; Last : out Natural) with + Pre => Source'First > 0, Contract_Cases => -- If Source is the empty string, or if no character of Source @@ -701,6 +720,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : String; Mapping : Maps.Character_Mapping_Function) return String with + Pre => Mapping /= null, Post => -- Lower bound of the returned string is 1 @@ -751,10 +771,11 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Mapping : Maps.Character_Mapping_Function) with + Pre => Mapping /= null, Post => - -- Each character in Source after the call is the translation of - -- the character at the same position before the call, through Mapping. + -- Each character in Source after the call is the translation of the + -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Mapping (Source'Old (J))), Global => null; @@ -765,8 +786,8 @@ package Ada.Strings.Fixed with SPARK_Mode is with Post => - -- Each character in Source after the call is the translation of - -- the character at the same position before the call, through Mapping. + -- Each character in Source after the call is the translation of the + -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Ada.Strings.Maps.Value (Mapping, Source'Old (J))), @@ -778,32 +799,6 @@ package Ada.Strings.Fixed with SPARK_Mode is -- String Transformation Subprograms -- --------------------------------------- - procedure Replace_Slice - (Source : in out String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Character := Space) - with - Pre => - - -- Incomplete contract - - Low - 1 <= Source'Last - and then High >= Source'First - 1, - Global => null; - -- If Low > Source'Last+1, or High < Source'First - 1, then Index_Error is - -- propagated. Otherwise: - -- - -- * If High >= Low, then the returned string comprises - -- Source (Source'First .. Low - 1) - -- & By & Source(High + 1 .. Source'Last), but with lower bound 1. - -- - -- * If High < Low, then the returned string is - -- Insert (Source, Before => Low, New_Item => By). - function Replace_Slice (Source : String; Low : Positive; @@ -834,19 +829,19 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Length of the returned string Replace_Slice'Result'Length - = Natural'Max (0, Low - Source'First) + = Integer'Max (0, Low - Source'First) + By'Length - + Natural'Max (Source'Last - High, 0) + + Integer'Max (Source'Last - High, 0) -- Elements starting at Low are replaced by elements of By and then - Replace_Slice'Result (1 .. Natural'Max (0, Low - Source'First)) + Replace_Slice'Result (1 .. Integer'Max (0, Low - Source'First)) = Source (Source'First .. Low - 1) and then Replace_Slice'Result - (Natural'Max (0, Low - Source'First) + 1 - .. Natural'Max (0, Low - Source'First) + By'Length) + (Integer'Max (0, Low - Source'First) + 1 + .. Integer'Max (0, Low - Source'First) + By'Length) = By -- When there are remaining characters after the replaced slice, @@ -856,7 +851,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (if High < Source'Last then Replace_Slice'Result - (Natural'Max (0, Low - Source'First) + By'Length + 1 + (Integer'Max (0, Low - Source'First) + By'Length + 1 .. Replace_Slice'Result'Last) = Source (High + 1 .. Source'Last)), @@ -890,6 +885,30 @@ package Ada.Strings.Fixed with SPARK_Mode is .. Replace_Slice'Result'Last) = Source (Low .. Source'Last))), Global => null; + -- If Low > Source'Last + 1, or High < Source'First - 1, then Index_Error + -- is propagated. Otherwise: + -- + -- * If High >= Low, then the returned string comprises + -- Source (Source'First .. Low - 1) + -- & By & Source(High + 1 .. Source'Last), but with lower bound 1. + -- + -- * If High < Low, then the returned string is + -- Insert (Source, Before => Low, New_Item => By). + + procedure Replace_Slice + (Source : in out String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space) + with + Pre => Low - 1 <= Source'Last, + + -- Incomplete contract + + Global => null; -- Equivalent to: -- -- Move (Replace_Slice (Source, Low, High, By), @@ -929,7 +948,7 @@ package Ada.Strings.Fixed with SPARK_Mode is -- are appended to the returned string. and then - (if Before - 1 < Source'Last + (if Before <= Source'Last then Insert'Result (Before - Source'First + New_Item'Length + 1 @@ -937,7 +956,7 @@ package Ada.Strings.Fixed with SPARK_Mode is = Source (Before .. Source'Last)), Global => null; -- Propagates Index_Error if Before is not in - -- Source'First .. Source'Last+1; otherwise, returns + -- Source'First .. Source'Last + 1; otherwise, returns -- Source (Source'First .. Before - 1) -- & New_Item & Source(Before..Source'Last), but with lower bound 1. @@ -1384,9 +1403,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Content of the string is Right concatenated with itself Left times and then - (for all J in 0 .. Left - 1 => - "*"'Result (J * Right'Length + 1 .. (J + 1) * Right'Length) - = Right), + (for all K in "*"'Result'Range => + "*"'Result (K) = Right (Right'First + (K - 1) mod Right'Length)), Global => null; -- These functions replicate a character or string a specified number of diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb index d96a4c7..243c92c 100644 --- a/gcc/ada/libgnat/a-strsea.adb +++ b/gcc/ada/libgnat/a-strsea.adb @@ -35,10 +35,18 @@ -- case of identity mappings for Count and Index, and also Index_Non_Blank -- is specialized (rather than using the general Index routine). +-- Ghost code, loop invariants and assertions in this unit are meant for +-- analysis only, not for run-time checking, as it would be too costly +-- otherwise. This is enforced by setting the assertion policy to Ignore. + +pragma Assertion_Policy (Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); + with Ada.Strings.Maps; use Ada.Strings.Maps; with System; use System; -package body Ada.Strings.Search is +package body Ada.Strings.Search with SPARK_Mode is ----------------------- -- Local Subprograms -- @@ -61,13 +69,9 @@ package body Ada.Strings.Search is Set : Maps.Character_Set; Test : Membership) return Boolean is - begin - if Test = Inside then - return Is_In (Element, Set); - else - return not Is_In (Element, Set); - end if; - end Belongs; + (if Test = Inside then + Is_In (Element, Set) + else not (Is_In (Element, Set))); ----------- -- Count -- @@ -81,47 +85,63 @@ package body Ada.Strings.Search is PL1 : constant Integer := Pattern'Length - 1; Num : Natural; Ind : Natural; - Cur : Natural; begin if Pattern = "" then raise Pattern_Error; end if; + -- Isolating the null string case to ensure Source'First, Source'Last in + -- Positive. + + if Source = "" then + return 0; + end if; + Num := 0; - Ind := Source'First; + Ind := Source'First - 1; -- Unmapped case - if Mapping'Address = Maps.Identity'Address then - while Ind <= Source'Last - PL1 loop + if Is_Identity (Mapping) then + while Ind < Source'Last - PL1 loop + Ind := Ind + 1; if Pattern = Source (Ind .. Ind + PL1) then Num := Num + 1; - Ind := Ind + Pattern'Length; - else - Ind := Ind + 1; + Ind := Ind + PL1; end if; + + pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); + pragma Loop_Invariant (Ind >= Source'First); end loop; -- Mapped case else - while Ind <= Source'Last - PL1 loop - Cur := Ind; + while Ind < Source'Last - PL1 loop + Ind := Ind + 1; for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - Ind := Ind + 1; + if Pattern (K) /= Value (Mapping, + Source (Ind + (K - Pattern'First))) + then + pragma Assert (not (Match (Source, Pattern, Mapping, Ind))); goto Cont; - else - Cur := Cur + 1; end if; + + pragma Loop_Invariant + (for all J in Pattern'First .. K => + Pattern (J) = Value (Mapping, + Source (Ind + (J - Pattern'First)))); end loop; + pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; - Ind := Ind + Pattern'Length; + Ind := Ind + PL1; - <<Cont>> + <<Cont>> null; + pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); + pragma Loop_Invariant (Ind >= Source'First); end loop; end if; @@ -138,13 +158,19 @@ package body Ada.Strings.Search is PL1 : constant Integer := Pattern'Length - 1; Num : Natural; Ind : Natural; - Cur : Natural; begin if Pattern = "" then raise Pattern_Error; end if; + -- Isolating the null string case to ensure Source'First, Source'Last in + -- Positive. + + if Source = "" then + return 0; + end if; + -- Check for null pointer in case checks are off if Mapping = null then @@ -152,23 +178,28 @@ package body Ada.Strings.Search is end if; Num := 0; - Ind := Source'First; - while Ind <= Source'Last - PL1 loop - Cur := Ind; + Ind := Source'First - 1; + while Ind < Source'Last - PL1 loop + Ind := Ind + 1; for K in Pattern'Range loop - if Pattern (K) /= Mapping (Source (Cur)) then - Ind := Ind + 1; + if Pattern (K) /= Mapping (Source (Ind + (K - Pattern'First))) then + pragma Assert (not (Match (Source, Pattern, Mapping, Ind))); goto Cont; - else - Cur := Cur + 1; end if; + + pragma Loop_Invariant + (for all J in Pattern'First .. K => + Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); end loop; + pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; - Ind := Ind + Pattern'Length; + Ind := Ind + PL1; <<Cont>> null; + pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); + pragma Loop_Invariant (Ind >= Source'First); end loop; return Num; @@ -182,6 +213,7 @@ package body Ada.Strings.Search is begin for J in Source'Range loop + pragma Loop_Invariant (N <= J - Source'First); if Is_In (Source (J), Set) then N := N + 1; end if; @@ -217,12 +249,18 @@ package body Ada.Strings.Search is if Belongs (Source (J), Set, Test) then First := J; - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; + if J < Source'Last then + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + + pragma Loop_Invariant + (for all L in J .. K => + Belongs (Source (L), Set, Test)); + end loop; + end if; -- Here if J indexes first char of token, and all chars after J -- are in the token. @@ -230,6 +268,10 @@ package body Ada.Strings.Search is Last := Source'Last; return; end if; + + pragma Loop_Invariant + (for all K in Integer'Max (From, Source'First) .. J => + not (Belongs (Source (K), Set, Test))); end loop; -- Here if no token found @@ -250,12 +292,18 @@ package body Ada.Strings.Search is if Belongs (Source (J), Set, Test) then First := J; - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; + if J < Source'Last then + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + + pragma Loop_Invariant + (for all L in J .. K => + Belongs (Source (L), Set, Test)); + end loop; + end if; -- Here if J indexes first char of token, and all chars after J -- are in the token. @@ -263,6 +311,10 @@ package body Ada.Strings.Search is Last := Source'Last; return; end if; + + pragma Loop_Invariant + (for all K in Source'First .. J => + not (Belongs (Source (K), Set, Test))); end loop; -- Here if no token found @@ -292,53 +344,61 @@ package body Ada.Strings.Search is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is PL1 : constant Integer := Pattern'Length - 1; - Cur : Natural; - - Ind : Integer; - -- Index for start of match check. This can be negative if the pattern - -- length is greater than the string length, which is why this variable - -- is Integer instead of Natural. In this case, the search loops do not - -- execute at all, so this Ind value is never used. begin if Pattern = "" then raise Pattern_Error; end if; + -- If Pattern is longer than Source, it can't be found + + if Pattern'Length > Source'Length then + return 0; + end if; + -- Forwards case if Going = Forward then - Ind := Source'First; -- Unmapped forward case - if Mapping'Address = Maps.Identity'Address then - for J in 1 .. Source'Length - PL1 loop + if Is_Identity (Mapping) then + for Ind in Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then + pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; - else - Ind := Ind + 1; end if; + + pragma Loop_Invariant + (for all J in Source'First .. Ind => + not (Match (Source, Pattern, Mapping, J))); end loop; -- Mapped forward case else - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - + for Ind in Source'First .. Source'Last - PL1 loop for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then + if Pattern (K) /= Value (Mapping, + Source (Ind + (K - Pattern'First))) + then goto Cont1; - else - Cur := Cur + 1; end if; + + pragma Loop_Invariant + (for all J in Pattern'First .. K => + Pattern (J) = Value (Mapping, + Source (Ind + (J - Pattern'First)))); end loop; + pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; - <<Cont1>> - Ind := Ind + 1; + <<Cont1>> + pragma Loop_Invariant + (for all J in Source'First .. Ind => + not (Match (Source, Pattern, Mapping, J))); + null; end loop; end if; @@ -347,35 +407,43 @@ package body Ada.Strings.Search is else -- Unmapped backward case - Ind := Source'Last - PL1; - - if Mapping'Address = Maps.Identity'Address then - for J in reverse 1 .. Source'Length - PL1 loop + if Is_Identity (Mapping) then + for Ind in reverse Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then + pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; - else - Ind := Ind - 1; end if; + + pragma Loop_Invariant + (for all J in Ind .. Source'Last - PL1 => + not (Match (Source, Pattern, Mapping, J))); end loop; -- Mapped backward case else - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - + for Ind in reverse Source'First .. Source'Last - PL1 loop for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then + if Pattern (K) /= Value (Mapping, + Source (Ind + (K - Pattern'First))) + then goto Cont2; - else - Cur := Cur + 1; end if; + + pragma Loop_Invariant + (for all J in Pattern'First .. K => + Pattern (J) = Value (Mapping, + Source (Ind + (J - Pattern'First)))); end loop; + pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; - <<Cont2>> - Ind := Ind - 1; + <<Cont2>> + pragma Loop_Invariant + (for all J in Ind .. Source'Last - PL1 => + not (Match (Source, Pattern, Mapping, J))); + null; end loop; end if; end if; @@ -393,9 +461,6 @@ package body Ada.Strings.Search is Mapping : Maps.Character_Mapping_Function) return Natural is PL1 : constant Integer := Pattern'Length - 1; - Ind : Natural; - Cur : Natural; - begin if Pattern = "" then raise Pattern_Error; @@ -416,43 +481,52 @@ package body Ada.Strings.Search is -- Forwards case if Going = Forward then - Ind := Source'First; - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - + for Ind in Source'First .. Source'Last - PL1 loop for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then + if Pattern (K) /= Mapping.all + (Source (Ind + (K - Pattern'First))) + then goto Cont1; - else - Cur := Cur + 1; end if; + + pragma Loop_Invariant + (for all J in Pattern'First .. K => + Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); end loop; + pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; - <<Cont1>> - Ind := Ind + 1; + <<Cont1>> + pragma Loop_Invariant + (for all J in Source'First .. Ind => + not (Match (Source, Pattern, Mapping, J))); + null; end loop; -- Backwards case else - Ind := Source'Last - PL1; - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - + for Ind in reverse Source'First .. Source'Last - PL1 loop for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then + if Pattern (K) /= Mapping.all + (Source (Ind + (K - Pattern'First))) + then goto Cont2; - else - Cur := Cur + 1; end if; + + pragma Loop_Invariant + (for all J in Pattern'First .. K => + Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); end loop; return Ind; - <<Cont2>> - Ind := Ind - 1; + <<Cont2>> + pragma Loop_Invariant + (for all J in Ind .. (Source'Last - PL1) => + not (Match (Source, Pattern, Mapping, J))); + null; end loop; end if; @@ -476,6 +550,10 @@ package body Ada.Strings.Search is if Belongs (Source (J), Set, Test) then return J; end if; + + pragma Loop_Invariant + (for all C of Source (Source'First .. J) => + not (Belongs (C, Set, Test))); end loop; -- Backwards case @@ -485,6 +563,10 @@ package body Ada.Strings.Search is if Belongs (Source (J), Set, Test) then return J; end if; + + pragma Loop_Invariant + (for all C of Source (J .. Source'Last) => + not (Belongs (C, Set, Test))); end loop; end if; @@ -500,6 +582,8 @@ package body Ada.Strings.Search is Going : Direction := Forward; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is + Result : Natural; + PL1 : constant Integer := Pattern'Length - 1; begin -- AI05-056: If source is empty result is always zero @@ -512,17 +596,29 @@ package body Ada.Strings.Search is raise Index_Error; end if; - return + Result := Index (Source (From .. Source'Last), Pattern, Forward, Mapping); + pragma Assert + (if (for some J in From .. Source'Last - PL1 => + Match (Source, Pattern, Mapping, J)) + then Result in From .. Source'Last - PL1 + else Result = 0); else if From > Source'Last then raise Index_Error; end if; - return + Result := Index (Source (Source'First .. From), Pattern, Backward, Mapping); + pragma Assert + (if (for some J in Source'First .. From - PL1 => + Match (Source, Pattern, Mapping, J)) + then Result in Source'First .. From - PL1 + else Result = 0); end if; + + return Result; end Index; function Index @@ -603,6 +699,9 @@ package body Ada.Strings.Search is if Source (J) /= ' ' then return J; end if; + + pragma Loop_Invariant + (for all C of Source (Source'First .. J) => C = ' '); end loop; else -- Going = Backward @@ -610,6 +709,9 @@ package body Ada.Strings.Search is if Source (J) /= ' ' then return J; end if; + + pragma Loop_Invariant + (for all C of Source (J .. Source'Last) => C = ' '); end loop; end if; @@ -624,6 +726,13 @@ package body Ada.Strings.Search is Going : Direction := Forward) return Natural is begin + + -- For equivalence with Index, if Source is empty the result is 0 + + if Source'Length = 0 then + return 0; + end if; + if Going = Forward then if From < Source'First then raise Index_Error; @@ -642,4 +751,12 @@ package body Ada.Strings.Search is end if; end Index_Non_Blank; + function Is_Identity + (Mapping : Maps.Character_Mapping) return Boolean + with SPARK_Mode => Off + is + begin + return Mapping'Address = Maps.Identity'Address; + end Is_Identity; + end Ada.Strings.Search; diff --git a/gcc/ada/libgnat/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads index 623c0f4..4396747 100644 --- a/gcc/ada/libgnat/a-strsea.ads +++ b/gcc/ada/libgnat/a-strsea.ads @@ -32,76 +32,489 @@ -- This package contains the search functions from Ada.Strings.Fixed. They -- are separated out because they are shared by Ada.Strings.Bounded and -- Ada.Strings.Unbounded, and we don't want to drag in other irrelevant stuff --- from Ada.Strings.Fixed when using the other two packages. We make this a --- private package, since user programs should access these subprograms via --- one of the standard string packages. +-- from Ada.Strings.Fixed when using the other two packages. Although user +-- programs should access these subprograms via one of the standard string +-- packages, we do not make this a private package, since ghost function +-- Match is used in the contracts of the standard string packages. -with Ada.Strings.Maps; +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced +-- by setting the corresponding assertion policy to Ignore. Postconditions, +-- contract cases and ghost code should not be executed at runtime as well, +-- in order not to slow down the execution of these functions. -private package Ada.Strings.Search is +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore); + +with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; + +package Ada.Strings.Search with SPARK_Mode is pragma Preelaborate; + -- The ghost function Match tells whether the slice of Source starting at + -- From and of length Pattern'Length matches with Pattern with respect to + -- Mapping. Pattern should be non-empty and the considered slice should be + -- fully included in Source'Range. + + function Match + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function; + From : Integer) return Boolean + is + (for all K in Pattern'Range => + Pattern (K) = Mapping (Source (From + (K - Pattern'First)))) + with + Ghost, + Pre => Mapping /= null + and then Pattern'Length > 0 + and then Source'Length > 0 + and then From in Source'First .. Source'Last - (Pattern'Length - 1), + Global => null; + + function Match + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping; + From : Integer) return Boolean + is + (for all K in Pattern'Range => + Pattern (K) = + Ada.Strings.Maps.Value + (Mapping, Source (From + (K - Pattern'First)))) + with + Ghost, + Pre => Pattern'Length > 0 + and then Source'Length > 0 + and then From in Source'First .. Source'Last - (Pattern'Length - 1), + Global => null; + + function Is_Identity + (Mapping : Maps.Character_Mapping) return Boolean + with + Post => (if Is_Identity'Result then + (for all K in Character => + Ada.Strings.Maps.Value (Mapping, K) = K)), + Global => null; + function Index (Source : String; Pattern : String; Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => Pattern'Length > 0, + + Post => Index'Result in 0 | Source'Range, + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Source'Length = 0 => Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Source'Length > 0 + and then + (for some J in + Source'First .. Source'Last - (Pattern'Length - 1) => + Match (Source, Pattern, Mapping, J)) + => + + -- The result is in the considered range of Source + + Index'Result in Source'First .. Source'Last - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Match (Source, Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in Source'Range => + (if (if Going = Forward + then J <= Index'Result - 1 + else J - 1 in Index'Result + .. Source'Last - Pattern'Length) + then not (Match (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others => Index'Result = 0), + Global => null; function Index (Source : String; Pattern : String; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length > 0 and then Mapping /= null, + Post => Index'Result in 0 | Source'Range, + Contract_Cases => + + -- If Source is the null string, then 0 is returned + + (Source'Length = 0 => Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Source'Length > 0 and then + (for some J in Source'First .. Source'Last - (Pattern'Length - 1) => + Match (Source, Pattern, Mapping, J)) + => + + -- The result is in the considered range of Source + + Index'Result in Source'First .. Source'Last - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Match (Source, Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in Source'Range => + (if (if Going = Forward + then J <= Index'Result - 1 + else J - 1 in Index'Result + .. Source'Last - Pattern'Length) + then not (Match (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others => Index'Result = 0), + Global => null; function Index (Source : String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Post => Index'Result in 0 | Source'Range, + Contract_Cases => + + -- If no character of Source satisfies the property Test on Set, then + -- 0 is returned. + + ((for all C of Source => + (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set)) + => + Index'Result = 0, + + -- Otherwise, a index in the range of Source is returned + + others => + + -- The result is in the range of Source + + Index'Result in Source'Range + + -- The character at the returned index satisfies the property + -- Test on Set + + and then (Test = Inside) + = Ada.Strings.Maps.Is_In (Source (Index'Result), Set) + + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in Source'Range => + (if J /= Index'Result + and then (J < Index'Result) = (Going = Forward) + then (Test = Inside) + /= Ada.Strings.Maps.Is_In (Source (J), Set)))), + Global => null; function Index (Source : String; Pattern : String; From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => Pattern'Length > 0 + and then (if Source'Length > 0 then From in Source'Range), + + Post => Index'Result in 0 | Source'Range, + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Source'Length = 0 => Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Source'Length > 0 + and then + (for some J in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) => + Match (Source, Pattern, Mapping, J)) + => + + -- The result is in the considered range of Source + + Index'Result in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Match (Source, Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in Source'Range => + (if (if Going = Forward + then J in From .. Index'Result - 1 + else J - 1 in Index'Result + .. From - Pattern'Length) + then not (Match (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others => Index'Result = 0), + Global => null; function Index (Source : String; Pattern : String; From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length > 0 + and then Mapping /= null + and then (if Source'Length > 0 then From in Source'Range), + + Post => Index'Result in 0 | Source'Range, + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Source'Length = 0 => Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Source'Length > 0 + and then + (for some J in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) => + Match (Source, Pattern, Mapping, J)) + => + + -- The result is in the considered range of Source + + Index'Result in + (if Going = Forward then From else Source'First) + .. (if Going = Forward then Source'Last else From) + - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Match (Source, Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backwards. + + and then + (for all J in Source'Range => + (if (if Going = Forward + then J in From .. Index'Result - 1 + else J - 1 in Index'Result + .. From - Pattern'Length) + then not (Match (Source, Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others => Index'Result = 0), + Global => null; function Index (Source : String; Set : Maps.Character_Set; From : Positive; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Source'Length > 0 then From in Source'Range), + Post => Index'Result in 0 | Source'Range, + Contract_Cases => + + -- If Source is the empty string, or no character of the considered + -- slice of Source satisfies the property Test on Set, then 0 is + -- returned. + + (Source'Length = 0 + or else + (for all J in Source'Range => + (if J = From or else (J > From) = (Going = Forward) then + (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set))) + => + Index'Result = 0, + + -- Otherwise, a index in the considered range of Source is returned + + others => + + -- The result is in the considered range of Source + + Index'Result in Source'Range + and then (Index'Result = From + or else + (Index'Result > From) = (Going = Forward)) + + -- The character at the returned index satisfies the property + -- Test on Set + + and then + (Test = Inside) + = Ada.Strings.Maps.Is_In (Source (Index'Result), Set) + + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in Source'Range => + (if J /= Index'Result + and then (J < Index'Result) = (Going = Forward) + and then (J = From + or else (J > From) = (Going = Forward)) + then (Test = Inside) + /= Ada.Strings.Maps.Is_In (Source (J), Set)))), + Global => null; function Index_Non_Blank (Source : String; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Post => Index_Non_Blank'Result in 0 | Source'Range, + Contract_Cases => + + -- If all characters of Source are Space characters, then 0 is + -- returned. + + ((for all C of Source => C = ' ') => Index_Non_Blank'Result = 0, + + -- Otherwise, a valid index is returned + + others => + + -- The result is in the range of Source + + Index_Non_Blank'Result in Source'Range + + -- The character at the returned index is not a Space character + + and then Source (Index_Non_Blank'Result) /= ' ' + + -- The result is the smallest or largest index which is not a + -- Space character, respectively when Going = Forward and + -- Going = Backward. + + and then + (for all J in Source'Range => + (if J /= Index_Non_Blank'Result + and then (J < Index_Non_Blank'Result) + = (Going = Forward) + then Source (J) = ' '))), + Global => null; function Index_Non_Blank (Source : String; From : Positive; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Source'Length /= 0 then From in Source'Range), + Post => Index_Non_Blank'Result in 0 | Source'Range, + Contract_Cases => + + -- If Source is the null string, or all characters in the considered + -- slice of Source are Space characters, then 0 is returned. + + (Source'Length = 0 + or else + (for all J in Source'Range => + (if J = From or else (J > From) = (Going = Forward) then + Source (J) = ' ')) + => + Index_Non_Blank'Result = 0, + + -- Otherwise, a valid index is returned + + others => + + -- The result is in the considered range of Source + + Index_Non_Blank'Result in Source'Range + and then (Index_Non_Blank'Result = From + or else (Index_Non_Blank'Result > From) + = (Going = Forward)) + + -- The character at the returned index is not a Space character + + and then Source (Index_Non_Blank'Result) /= ' ' + + -- The result is the smallest or largest index which is not a + -- Space character, respectively when Going = Forward and + -- Going = Backward. + + and then + (for all J in Source'Range => + (if J /= Index_Non_Blank'Result + and then (J < Index_Non_Blank'Result) + = (Going = Forward) + and then (J = From or else (J > From) + = (Going = Forward)) + then Source (J) = ' '))), + Global => null; function Count (Source : String; Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => Pattern'Length > 0, + Global => null; function Count (Source : String; Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length > 0 and then Mapping /= null, + Global => null; function Count (Source : String; - Set : Maps.Character_Set) return Natural; + Set : Maps.Character_Set) return Natural + with + Global => null; procedure Find_Token (Source : String; @@ -109,13 +522,104 @@ private package Ada.Strings.Search is From : Positive; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Pre => (if Source'Length /= 0 then From in Source'Range), + Contract_Cases => + + -- If Source is the empty string, or if no character of the considered + -- slice of Source satisfies the property Test on Set, then First is + -- set to From and Last is set to 0. + + (Source'Length = 0 + or else + (for all C of Source (From .. Source'Last) => + (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set)) + => + First = From and then Last = 0, + + -- Otherwise, First and Last are set to valid indexes + + others => + + -- First and Last are in the considered range of Source + + First in From .. Source'Last + and then Last in First .. Source'Last + + -- No character between From and First satisfies the property Test + -- on Set. + + and then + (for all C of Source (From .. First - 1) => + (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set)) + + -- All characters between First and Last satisfy the property Test + -- on Set. + + and then + (for all C of Source (First .. Last) => + (Test = Inside) = Ada.Strings.Maps.Is_In (C, Set)) + + -- If Last is not Source'Last, then the character at position + -- Last + 1 does not satify the property Test on Set. + + and then + (if Last < Source'Last + then (Test = Inside) + /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), + Global => null; procedure Find_Token (Source : String; Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Pre => Source'First > 0, + Contract_Cases => + + -- If Source is the empty string, or if no character of Source + -- satisfies the property Test on Set, then First is set to From + -- and Last is set to 0. + + (Source'Length = 0 + or else + (for all C of Source => + (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set)) + => + First = Source'First and then Last = 0, + + -- Otherwise, First and Last are set to valid indexes + + others => + + -- First and Last are in the considered range of Source + + First in Source'Range + and then Last in First .. Source'Last + + -- No character before First satisfies the property Test on Set + + and then + (for all C of Source (Source'First .. First - 1) => + (Test = Inside) /= Ada.Strings.Maps.Is_In (C, Set)) + + -- All characters between First and Last satisfy the property Test + -- on Set. + + and then + (for all C of Source (First .. Last) => + (Test = Inside) = Ada.Strings.Maps.Is_In (C, Set)) + + -- If Last is not Source'Last, then the character at position + -- Last + 1 does not satify the property Test on Set. + + and then + (if Last < Source'Last + then (Test = Inside) + /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), + Global => null; end Ada.Strings.Search; diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index 4a9d538..e02b0fd 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -31,7 +31,6 @@ with Ada.Characters.Handling; with Ada.Containers.Generic_Array_Sort; -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with Ada.Unchecked_Deallocation; with Interfaces; use Interfaces; @@ -42,13 +41,16 @@ with System.Bounded_Strings; use System.Bounded_Strings; with System.IO; use System.IO; with System.Mmap; use System.Mmap; with System.Object_Reader; use System.Object_Reader; -with System.Traceback_Entries; use System.Traceback_Entries; with System.Storage_Elements; use System.Storage_Elements; package body System.Dwarf_Lines is SSU : constant := System.Storage_Unit; + function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset; + -- Return the displacement between the load address present in the binary + -- and the run-time address at which it is loaded (i.e. non-zero for PIE). + function String_Length (Str : Str_Access) return Natural; -- Return the length of the C string Str @@ -76,7 +78,7 @@ package body System.Dwarf_Lines is procedure Read_Aranges_Entry (C : in out Dwarf_Context; - Start : out Storage_Offset; + Start : out Address; Len : out Storage_Count); -- Read a single .debug_aranges pair @@ -88,7 +90,7 @@ package body System.Dwarf_Lines is procedure Aranges_Lookup (C : in out Dwarf_Context; - Addr : Storage_Offset; + Addr : Address; Info_Offset : out Offset; Success : out Boolean); -- Search for Addr in .debug_aranges and return offset Info_Offset in @@ -153,7 +155,7 @@ package body System.Dwarf_Lines is procedure Symbolic_Address (C : in out Dwarf_Context; - Addr : Storage_Offset; + Addr : Address; Dir_Name : out Str_Access; File_Name : out Str_Access; Subprg_Name : out String_Ptr_Len; @@ -370,6 +372,19 @@ package body System.Dwarf_Lines is end loop; end For_Each_Row; + --------------------------- + -- Get_Load_Displacement -- + --------------------------- + + function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset is + begin + if C.Load_Address /= Null_Address then + return C.Load_Address - Address (Get_Load_Address (C.Obj.all)); + else + return 0; + end if; + end Get_Load_Displacement; + --------------------- -- Initialize_Pass -- --------------------- @@ -405,18 +420,19 @@ package body System.Dwarf_Lines is --------------- function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is + Disp : constant Storage_Offset := Get_Load_Displacement (C); + begin - return (Addr >= C.Low + C.Load_Address - and then Addr <= C.High + C.Load_Address); + return Addr >= C.Low + Disp and then Addr <= C.High + Disp; end Is_Inside; ----------------- -- Low_Address -- ----------------- - function Low_Address (C : Dwarf_Context) return System.Address is + function Low_Address (C : Dwarf_Context) return Address is begin - return C.Load_Address + C.Low; + return C.Low + Get_Load_Displacement (C); end Low_Address; ---------- @@ -450,12 +466,12 @@ package body System.Dwarf_Lines is Success := True; - -- Get memory bounds for executable code. Note that such code + -- Get address bounds for executable code. Note that such code -- might come from multiple sections. Get_Xcode_Bounds (C.Obj.all, Lo, Hi); - C.Low := Storage_Offset (Lo); - C.High := Storage_Offset (Hi); + C.Low := Address (Lo); + C.High := Address (Hi); -- Create a stream for debug sections @@ -568,10 +584,10 @@ package body System.Dwarf_Lines is Standard_Opcode_Lengths (J) := Read (C.Lines); end loop; - -- The directories table follows. Up to DWARF 4, this is a list of null + -- The Directories table follows. Up to DWARF 4, this is a list of null -- terminated strings terminated by a null byte. In DWARF 5, this is a - -- sequence of Directories_Count entries encoded as described by the - -- Directory_Entry_Format field. We store its offset for later decoding. + -- sequence of Directories_Count entries which are encoded as described + -- by the Directory_Entry_Format field. We store its offset for later. if Header.Version <= 4 then Tell (C.Lines, Header.Directories); @@ -603,12 +619,12 @@ package body System.Dwarf_Lines is end loop; end if; - -- The file_names table is next. Up to DWARF 4, this is a list of record + -- The File_Names table is next. Up to DWARF 4, this is a list of record -- containing a null terminated string for the file name, an unsigned -- LEB128 directory index in the Directories table, an unsigned LEB128 -- modification time, and an unsigned LEB128 for the file length; the -- table is terminated by a null byte. In DWARF 5, this is a sequence - -- of File_Names_Count entries encoded as described by the + -- of File_Names_Count entries which are encoded as described by the -- File_Name_Entry_Format field. We store its offset for later decoding. if Header.Version <= 4 then @@ -941,8 +957,10 @@ package body System.Dwarf_Lines is when DW_FORM_line_strp => Read_Section_Offset (C.Lines, Off, C.Header.Is64); - Seek (C.Line_Str, Off); - Read_C_String (C.Line_Str, Buf); + if J = File then + Seek (C.Line_Str, Off); + Read_C_String (C.Line_Str, Buf); + end if; when others => raise Dwarf_Error with "DWARF form not implemented"; @@ -1027,7 +1045,7 @@ package body System.Dwarf_Lines is case C_Type is when DW_LNCT_path .. DW_LNCT_MD5 => if N not in A'Range then - raise Dwarf_Error with "DWARF duplicate content type"; + raise Dwarf_Error with "duplicate DWARF content type"; end if; A (N) := (C_Type, Form); @@ -1048,7 +1066,7 @@ package body System.Dwarf_Lines is procedure Aranges_Lookup (C : in out Dwarf_Context; - Addr : Storage_Offset; + Addr : Address; Info_Offset : out Offset; Success : out Boolean) is @@ -1062,7 +1080,7 @@ package body System.Dwarf_Lines is loop declare - Start : Storage_Offset; + Start : Address; Len : Storage_Count; begin Read_Aranges_Entry (C, Start, Len); @@ -1098,8 +1116,6 @@ package body System.Dwarf_Lines is case Form is when DW_FORM_addr => Skip := Offset (Ptr_Sz); - when DW_FORM_addrx => - Skip := Offset (uint32'(Read_LEB128 (S))); when DW_FORM_block1 => Skip := Offset (uint8'(Read (S))); when DW_FORM_block2 => @@ -1145,11 +1161,12 @@ package body System.Dwarf_Lines is begin return; end; - when DW_FORM_udata - | DW_FORM_ref_udata + when DW_FORM_addrx | DW_FORM_loclistx + | DW_FORM_ref_udata | DW_FORM_rnglistx | DW_FORM_strx + | DW_FORM_udata => declare Val : constant uint32 := Read_LEB128 (S); @@ -1157,7 +1174,7 @@ package body System.Dwarf_Lines is begin return; end; - when DW_FORM_flag_present => + when DW_FORM_flag_present | DW_FORM_implicit_const => return; when DW_FORM_ref_addr | DW_FORM_sec_offset @@ -1171,10 +1188,10 @@ package body System.Dwarf_Lines is null; end loop; return; - when DW_FORM_implicit_const | DW_FORM_indirect => - raise Constraint_Error; + when DW_FORM_indirect => + raise Dwarf_Error with "DW_FORM_indirect not implemented"; when others => - raise Constraint_Error; + raise Dwarf_Error with "DWARF form not implemented"; end case; Seek (S, Tell (S) + Skip); @@ -1393,7 +1410,7 @@ package body System.Dwarf_Lines is procedure Read_Aranges_Entry (C : in out Dwarf_Context; - Start : out Storage_Offset; + Start : out Address; Len : out Storage_Count) is begin @@ -1405,7 +1422,7 @@ package body System.Dwarf_Lines is begin S := Read (C.Aranges); L := Read (C.Aranges); - Start := Storage_Offset (S); + Start := Address (S); Len := Storage_Count (L); end; @@ -1415,7 +1432,7 @@ package body System.Dwarf_Lines is begin S := Read (C.Aranges); L := Read (C.Aranges); - Start := Storage_Offset (S); + Start := Address (S); Len := Storage_Count (L); end; @@ -1505,11 +1522,12 @@ package body System.Dwarf_Lines is Info_Offset : Offset; Line_Offset : Offset; Success : Boolean; - Ar_Start : Storage_Offset; + Ar_Start : Address; Ar_Len : Storage_Count; Start, Len : uint32; First, Last : Natural; Mid : Natural; + begin Seek (C.Aranges, 0); @@ -1524,7 +1542,7 @@ package body System.Dwarf_Lines is loop Read_Aranges_Entry (C, Ar_Start, Ar_Len); - exit when Ar_Start = 0 and Ar_Len = 0; + exit when Ar_Start = Null_Address and Ar_Len = 0; Len := uint32 (Ar_Len); Start := uint32 (Ar_Start - C.Low); @@ -1580,7 +1598,7 @@ package body System.Dwarf_Lines is procedure Symbolic_Address (C : in out Dwarf_Context; - Addr : Storage_Offset; + Addr : Address; Dir_Name : out Str_Access; File_Name : out Str_Access; Subprg_Name : out String_Ptr_Len; @@ -1658,8 +1676,10 @@ package body System.Dwarf_Lines is when DW_FORM_line_strp => Read_Section_Offset (C.Lines, Off, C.Header.Is64); - Seek (C.Line_Str, Off); - File_Name := Read_C_String (C.Line_Str); + if J = Match.File then + Seek (C.Line_Str, Off); + File_Name := Read_C_String (C.Line_Str); + end if; when others => raise Dwarf_Error with "DWARF form not implemented"; @@ -1678,7 +1698,8 @@ package body System.Dwarf_Lines is Dir_Idx := Read_LEB128 (C.Lines); when others => - raise Dwarf_Error with "invalid DWARF"; + raise Dwarf_Error with + "invalid DWARF form for DW_LNCT_directory_index"; end case; else @@ -1702,8 +1723,10 @@ package body System.Dwarf_Lines is when DW_FORM_line_strp => Read_Section_Offset (C.Lines, Off, C.Header.Is64); - Seek (C.Line_Str, Off); - Dir_Name := Read_C_String (C.Line_Str); + if J = Dir_Idx then + Seek (C.Line_Str, Off); + Dir_Name := Read_C_String (C.Line_Str); + end if; when others => raise Dwarf_Error with "DWARF form not implemented"; @@ -1864,7 +1887,7 @@ package body System.Dwarf_Lines is procedure Symbolic_Traceback (Cin : Dwarf_Context; - Traceback : AET.Tracebacks_Array; + Traceback : STE.Tracebacks_Array; Suppress_Hex : Boolean; Symbol_Found : out Boolean; Res : in out System.Bounded_Strings.Bounded_String) @@ -1873,7 +1896,6 @@ package body System.Dwarf_Lines is C : Dwarf_Context := Cin; Addr_In_Traceback : Address; - Offset_To_Lookup : Storage_Offset; Dir_Name : Str_Access; File_Name : Str_Access; @@ -1893,13 +1915,11 @@ package body System.Dwarf_Lines is -- If the buffer is full, no need to do any useless work exit when Is_Full (Res); - Addr_In_Traceback := PC_For (Traceback (J)); - - Offset_To_Lookup := Addr_In_Traceback - C.Load_Address; + Addr_In_Traceback := STE.PC_For (Traceback (J)); Symbolic_Address (C, - Offset_To_Lookup, + Addr_In_Traceback - Get_Load_Displacement (C), Dir_Name, File_Name, Subprg_Name, diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads index 132d3e1..bd86e5e 100644 --- a/gcc/ada/libgnat/s-dwalin.ads +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -35,15 +35,13 @@ -- -- Files must be compiled with at least minimal debugging information (-g1). -with Ada.Exceptions.Traceback; - -with System.Object_Reader; -with System.Storage_Elements; with System.Bounded_Strings; +with System.Object_Reader; +with System.Traceback_Entries; package System.Dwarf_Lines is - package AET renames Ada.Exceptions.Traceback; + package STE renames System.Traceback_Entries; package SOR renames System.Object_Reader; type Dwarf_Context (In_Exception : Boolean := False) is private; @@ -58,19 +56,19 @@ package System.Dwarf_Lines is C : out Dwarf_Context; Success : out Boolean); procedure Close (C : in out Dwarf_Context); - -- Open and close files + -- Open and close a file procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address); - -- Set the load address of a file. This is used to rebase PIE (Position + -- Set the run-time load address of a file. Used to rebase PIE (Position -- Independent Executable) binaries. function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean; pragma Inline (Is_Inside); - -- Return true iff a run-time address Addr is within the module + -- Return whether a run-time address Addr lies within the file - function Low_Address (C : Dwarf_Context) return System.Address; + function Low_Address (C : Dwarf_Context) return Address; pragma Inline (Low_Address); - -- Return the lowest address of C, accounting for the module load address + -- Return the lowest run-time address of the file procedure Dump (C : in out Dwarf_Context); -- Dump each row found in the object's .debug_lines section to standard out @@ -83,7 +81,7 @@ package System.Dwarf_Lines is procedure Symbolic_Traceback (Cin : Dwarf_Context; - Traceback : AET.Tracebacks_Array; + Traceback : STE.Tracebacks_Array; Suppress_Hex : Boolean; Symbol_Found : out Boolean; Res : in out System.Bounded_Strings.Bounded_String); @@ -175,13 +173,13 @@ private type Search_Array_Access is access Search_Array; type Dwarf_Context (In_Exception : Boolean := False) is record - Low, High : System.Storage_Elements.Storage_Offset; - -- Bounds of the module, per the module object file + Low, High : Address; + -- Address bounds for executable code Obj : SOR.Object_File_Access; -- The object file containing dwarf sections - Load_Address : System.Address := System.Null_Address; + Load_Address : Address := Null_Address; -- The address at which the object file was loaded at run time Has_Debug : Boolean; diff --git a/gcc/ada/libgnat/s-ficobl.ads b/gcc/ada/libgnat/s-ficobl.ads index 6fff2da..4e97079 100644 --- a/gcc/ada/libgnat/s-ficobl.ads +++ b/gcc/ada/libgnat/s-ficobl.ads @@ -39,7 +39,7 @@ with Ada.Streams; with Interfaces.C_Streams; with System.CRTL; -package System.File_Control_Block is +package System.File_Control_Block with SPARK_Mode => Off is pragma Preelaborate; ---------------------------- diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb index 9dd8c1f..e1bc677 100644 --- a/gcc/ada/libgnat/s-objrea.adb +++ b/gcc/ada/libgnat/s-objrea.adb @@ -36,6 +36,7 @@ with Interfaces.C; with System.CRTL; package body System.Object_Reader is + use Interfaces; use Interfaces.C; use System.Mmap; @@ -220,7 +221,6 @@ package body System.Object_Reader is Characteristics : uint16; Variant : uint16; end record; - pragma Pack (Header); type Optional_Header_PE32 is record @@ -306,7 +306,6 @@ package body System.Object_Reader is NumberOfLinenumbers : uint16; Characteristics : uint32; end record; - pragma Pack (Section_Header); IMAGE_SCN_CNT_CODE : constant := 16#0020#; @@ -319,7 +318,6 @@ package body System.Object_Reader is StorageClass : uint8; NumberOfAuxSymbols : uint8; end record; - pragma Pack (Symtab_Entry); type Auxent_Section is record @@ -435,7 +433,6 @@ package body System.Object_Reader is s_nlnno : uint16; s_flags : uint32; end record; - pragma Pack (Section_Header); STYP_TEXT : constant := 16#0020#; @@ -460,7 +457,6 @@ package body System.Object_Reader is x_snstab : uint16; end record; for Aux_Entry'Size use 18 * 8; - pragma Pack (Aux_Entry); C_EXT : constant := 2; @@ -549,6 +545,7 @@ package body System.Object_Reader is Shnum : uint32) return Object_Section is SHdr : constant Section_Header := Read_Section_Header (Obj, Shnum); + begin return (Shnum, Offset (SHdr.Sh_Offset), @@ -680,6 +677,7 @@ package body System.Object_Reader is function Read_Header (F : in out Mapped_Stream) return Header is Hdr : Header; + begin Seek (F, 0); Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); @@ -695,6 +693,7 @@ package body System.Object_Reader is Shnum : uint32) return Section_Header is Shdr : Section_Header; + begin Seek (Obj.Sectab_Stream, Offset (Shnum * Section_Header'Size / SSU)); Read_Raw (Obj.Sectab_Stream, Shdr'Address, Section_Header'Size / SSU); @@ -749,6 +748,7 @@ package body System.Object_Reader is Sec : Object_Section) return String is SHdr : Section_Header; + begin SHdr := Read_Section_Header (Obj, Sec.Num); return Offset_To_String (Obj.Secstr_Stream, Offset (SHdr.Sh_Name)); @@ -861,7 +861,8 @@ package body System.Object_Reader is ------------------ function First_Symbol - (Obj : in out PECOFF_Object_File) return Object_Symbol is + (Obj : in out PECOFF_Object_File) return Object_Symbol + is begin -- Return Null_Symbol in the case that the symbol table is empty @@ -881,6 +882,7 @@ package body System.Object_Reader is Index : uint32) return Object_Section is Sec : constant Section_Header := Read_Section_Header (Obj, Index); + begin -- Use VirtualSize instead of SizeOfRawData. The latter is rounded to -- the page size, so it may add garbage to the content. On the other @@ -938,6 +940,7 @@ package body System.Object_Reader is Hdr_Offset : Offset; Opt_Offset : File_Size; Opt_Stream : Mapped_Stream; + begin Res.MF := F; Res.In_Exception := In_Exception; @@ -1180,7 +1183,8 @@ package body System.Object_Reader is function String_Table (Obj : in out PECOFF_Object_File; - Index : Offset) return String is + Index : Offset) return String + is begin -- An index of zero is used to represent an empty string, as the -- first word of the string table is specified to contain the length @@ -1361,6 +1365,7 @@ package body System.Object_Reader is is Res : XCOFF32_Object_File (Format => XCOFF32); Strtab_Sz : uint32; + begin Res.Mf := F; Res.In_Exception := In_Exception; @@ -1401,6 +1406,7 @@ package body System.Object_Reader is Index : uint32) return Object_Section is Sec : constant Section_Header := Read_Section_Header (Obj, Index); + begin return (Index, Offset (Sec.s_scnptr), uint64 (Sec.s_vaddr), @@ -1414,6 +1420,7 @@ package body System.Object_Reader is function Read_Header (F : in out Mapped_Stream) return Header is Hdr : Header; + begin Seek (F, 0); Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); @@ -1428,7 +1435,7 @@ package body System.Object_Reader is (Obj : in out XCOFF32_Object_File; Index : uint32) return Section_Header is - Sec : Section_Header; + Sec : Section_Header; begin -- Seek to the end of the object header @@ -1451,6 +1458,7 @@ package body System.Object_Reader is Sec : Object_Section) return String is Hdr : Section_Header; + begin Hdr := Read_Section_Header (Obj, Sec.Num); return Trim_Trailing_Nuls (Hdr.s_name); @@ -1520,7 +1528,8 @@ package body System.Object_Reader is function Create_Stream (Obj : Object_File; - Sec : Object_Section) return Mapped_Stream is + Sec : Object_Section) return Mapped_Stream + is begin return Create_Stream (Obj.Mf, File_Size (Sec.Off), File_Size (Sec.Size)); end Create_Stream; @@ -1573,7 +1582,8 @@ package body System.Object_Reader is function Strip_Leading_Char (Obj : in out Object_File; - Sym : String_Ptr_Len) return Positive is + Sym : String_Ptr_Len) return Positive + is begin if (Obj.Format = PECOFF and then Sym.Ptr (1) = '_') or else @@ -1605,6 +1615,7 @@ package body System.Object_Reader is String (Sym.Ptr (1 .. Sym.Len)) & ASCII.NUL; Decoded : char_array (0 .. size_t (Sym.Len) * 2 + 60); Off : Natural; + begin -- In the PECOFF case most but not all symbol table entries have an -- extra leading underscore. In this case we trim it. @@ -1645,8 +1656,11 @@ package body System.Object_Reader is function Get_Load_Address (Obj : Object_File) return uint64 is begin - raise Format_Error with "Get_Load_Address not implemented"; - return 0; + case Obj.Format is + when ELF => return 0; + when Any_PECOFF => return Obj.ImageBase; + when XCOFF32 => raise Format_Error; + end case; end Get_Load_Address; ----------------- @@ -1655,7 +1669,8 @@ package body System.Object_Reader is function Get_Section (Obj : in out Object_File; - Shnum : uint32) return Object_Section is + Shnum : uint32) return Object_Section + is begin case Obj.Format is when ELF32 => return ELF32_Ops.Get_Section (Obj, Shnum); @@ -1692,9 +1707,11 @@ package body System.Object_Reader is ---------------------- procedure Get_Xcode_Bounds - (Obj : in out Object_File; - Low, High : out uint64) is + (Obj : in out Object_File; + Low, High : out uint64) + is Sec : Object_Section; + begin -- First set as an empty range Low := uint64'Last; @@ -1721,7 +1738,8 @@ package body System.Object_Reader is function Name (Obj : in out Object_File; - Sec : Object_Section) return String is + Sec : Object_Section) return String + is begin case Obj.Format is when ELF32 => return ELF32_Ops.Name (Obj, Sec); @@ -1733,7 +1751,8 @@ package body System.Object_Reader is function Name (Obj : in out Object_File; - Sym : Object_Symbol) return String_Ptr_Len is + Sym : Object_Symbol) return String_Ptr_Len + is begin case Obj.Format is when ELF32 => return ELF32_Ops.Name (Obj, Sym); @@ -1749,7 +1768,8 @@ package body System.Object_Reader is function Next_Symbol (Obj : in out Object_File; - Prev : Object_Symbol) return Object_Symbol is + Prev : Object_Symbol) return Object_Symbol + is begin -- Test whether we've reached the end of the symbol table @@ -1801,6 +1821,7 @@ package body System.Object_Reader is Off : Offset) return String is Buf : Buffer; + begin Seek (S, Off); Read_C_String (S, Buf); @@ -1922,10 +1943,10 @@ package body System.Object_Reader is -- Read -- ---------- - function Read (S : in out Mapped_Stream) return Mmap.Str_Access - is + function Read (S : in out Mapped_Stream) return Mmap.Str_Access is function To_Str_Access is new Ada.Unchecked_Conversion (Address, Str_Access); + begin return To_Str_Access (Data (S.Region) (Natural (S.Off + 1))'Address); end Read; @@ -1949,8 +1970,8 @@ package body System.Object_Reader is is function To_Str_Access is new Ada.Unchecked_Conversion (Address, Str_Access); - Sz : constant Offset := Offset (Size); + begin -- Check size @@ -2027,7 +2048,8 @@ package body System.Object_Reader is ------------------ function Read_Address - (Obj : Object_File; S : in out Mapped_Stream) return uint64 is + (Obj : Object_File; S : in out Mapped_Stream) return uint64 + is Address_32 : uint32; Address_64 : uint64; @@ -2147,7 +2169,8 @@ package body System.Object_Reader is function Read_Symbol (Obj : in out Object_File; - Off : Offset) return Object_Symbol is + Off : Offset) return Object_Symbol + is begin case Obj.Format is when ELF32 => return ELF32_Ops.Read_Symbol (Obj, Off); @@ -2221,7 +2244,8 @@ package body System.Object_Reader is function To_String_Ptr_Len (Ptr : Mmap.Str_Access; - Max_Len : Natural := Natural'Last) return String_Ptr_Len is + Max_Len : Natural := Natural'Last) return String_Ptr_Len + is begin for I in 1 .. Max_Len loop if Ptr (I) = ASCII.NUL then diff --git a/gcc/ada/libgnat/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads index a83ca53..d20a53d 100644 --- a/gcc/ada/libgnat/s-objrea.ads +++ b/gcc/ada/libgnat/s-objrea.ads @@ -287,7 +287,7 @@ package System.Object_Reader is (Obj : in out Object_File; Low, High : out uint64); -- Return the low and high addresses of the code for the object file. Can - -- be used to check if an address in within this object file. This + -- be used to check if an address lies within this object file. This -- procedure is not efficient and the result should be saved to avoid -- recomputation. @@ -381,9 +381,8 @@ private subtype Any_PECOFF is Object_Format range PECOFF .. PECOFF_PLUS; type Object_File (Format : Object_Format) is record - Mf : System.Mmap.Mapped_File := - System.Mmap.Invalid_Mapped_File; - Arch : Object_Arch := Unknown; + Mf : System.Mmap.Mapped_File := System.Mmap.Invalid_Mapped_File; + Arch : Object_Arch := Unknown; Num_Sections : uint32 := 0; -- Number of sections @@ -406,6 +405,7 @@ private when ELF => Secstr_Stream : Mapped_Stream; -- Section strings + when Any_PECOFF => ImageBase : uint64; -- ImageBase value from header @@ -413,19 +413,20 @@ private GSVA_Sec : uint32 := uint32'Last; GSVA_Addr : uint64; + when XCOFF32 => null; end case; end record; - subtype ELF_Object_File is Object_File; -- with - -- Predicate => ELF_Object_File.Format in ELF; - subtype PECOFF_Object_File is Object_File; -- with - -- Predicate => PECOFF_Object_File.Format in Any_PECOFF; - subtype XCOFF32_Object_File is Object_File; -- with - -- Predicate => XCOFF32_Object_File.Format in XCOFF32; - -- ???Above predicates cause the compiler to crash when instantiating - -- ELF64_Ops (see package body). + subtype ELF_Object_File is Object_File + with Predicate => ELF_Object_File.Format in ELF; + + subtype PECOFF_Object_File is Object_File + with Predicate => PECOFF_Object_File.Format in Any_PECOFF; + + subtype XCOFF32_Object_File is Object_File + with Predicate => XCOFF32_Object_File.Format in XCOFF32; type Object_Section is record Num : uint32 := 0; diff --git a/gcc/ada/libgnat/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads index 2049e38..139d2e0 100644 --- a/gcc/ada/libgnat/s-os_lib.ads +++ b/gcc/ada/libgnat/s-os_lib.ads @@ -169,16 +169,15 @@ package System.OS_Lib is ------------------ -- Note: Do not use time_t in the compiler and host-based tools; instead - -- use OS_Time. These 3 declarations are intended for use only by consumers - -- of the GNAT.OS_Lib renaming of this package. + -- use OS_Time. subtype time_t is Long_Long_Integer; - -- C time_t can be either long or long long, but this is a subtype not used - -- in the compiler or tools, but only for user applications, so we choose - -- the Ada equivalent of the latter because eventually that will be the + -- C time_t can be either long or long long, so we choose the Ada + -- equivalent of the latter because eventually that will be the -- type used out of necessity. This may affect some user code on 32-bit -- targets that have not yet migrated to the Posix 2008 standard, - -- particularly pre version 5 32-bit Linux. + -- particularly pre version 5 32-bit Linux. Do not change this + -- declaration without coordinating it with conversions in Ada.Calendar. function To_C (Time : OS_Time) return time_t; -- Convert OS_Time to C time_t type diff --git a/gcc/ada/libgnat/s-osprim__vxworks.adb b/gcc/ada/libgnat/s-osprim__vxworks.adb deleted file mode 100644 index ad2ac40..0000000 --- a/gcc/ada/libgnat/s-osprim__vxworks.adb +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2021, 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for VxWorks targets - -with System.OS_Interface; --- Since the thread library is part of the VxWorks kernel, using OS_Interface --- is not a problem here, as long as we only use System.OS_Interface as a --- set of C imported routines: using Ada routines from this package would --- create a dependency on libgnarl in libgnat, which is not desirable. - -with System.OS_Constants; -with Interfaces.C; - -package body System.OS_Primitives is - - use System.OS_Interface; - use type Interfaces.C.int; - - package OSC renames System.OS_Constants; - - ------------------------ - -- Internal functions -- - ------------------------ - - function To_Clock_Ticks (D : Duration) return int; - -- Convert a duration value (in seconds) into clock ticks. - -- Note that this routine is duplicated from System.OS_Interface since - -- as explained above, we do not want to depend on libgnarl - - function To_Clock_Ticks (D : Duration) return int is - Ticks : Long_Long_Integer; - Rate_Duration : Duration; - Ticks_Duration : Duration; - - begin - if D < 0.0 then - return -1; - end if; - - -- Ensure that the duration can be converted to ticks - -- at the current clock tick rate without overflowing. - - Rate_Duration := Duration (sysClkRateGet); - - if D > (Duration'Last / Rate_Duration) then - Ticks := Long_Long_Integer (int'Last); - else - Ticks_Duration := D * Rate_Duration; - Ticks := Long_Long_Integer (Ticks_Duration); - - if Ticks_Duration > Duration (Ticks) then - Ticks := Ticks + 1; - end if; - - if Ticks > Long_Long_Integer (int'Last) then - Ticks := Long_Long_Integer (int'Last); - end if; - end if; - - return int (Ticks); - end To_Clock_Ticks; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TS : aliased timespec; - Result : int; - begin - Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); - pragma Assert (Result = 0); - return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; - end Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - Ticks : int; - - Result : int; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Ticks := To_Clock_Ticks (Rel_Time); - - if Mode = Relative and then Ticks < int'Last then - -- The first tick will delay anytime between 0 and - -- 1 / sysClkRateGet seconds, so we need to add one to - -- be on the safe side. - - Ticks := Ticks + 1; - end if; - - Result := taskDelay (Ticks); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osvers__vxworks-653.ads b/gcc/ada/libgnat/s-osvers__vxworks-653.ads deleted file mode 100644 index e180e7c..0000000 --- a/gcc/ada/libgnat/s-osvers__vxworks-653.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . O S _ V E R S I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2010-2021, 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- -- --- 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks 653 Partition OS version of this file. If you add an OS --- variant please be sure to update type OS_Version in all variants of this --- file, which is part of the Level A certified run-time libraries. - -package System.OS_Versions is - pragma Pure (System.OS_Versions); - type OS_Version is - (LynxOS_178, VxWorks_Cert, VxWorks_Cert_RTP, VxWorks_653, VxWorks_MILS); - OS : constant OS_Version := VxWorks_653; -end System.OS_Versions; diff --git a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads deleted file mode 100644 index 0857c67..0000000 --- a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks e500 AE653 vThreads) -- --- -- --- Copyright (C) 1992-2021, 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for the AE653/e500v2 vThreads full run-time - -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). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_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 := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- 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 := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -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 := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - 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 := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads deleted file mode 100644 index 64f1303..0000000 --- a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks PPC AE653 vThreads) -- --- -- --- Copyright (C) 1992-2021, 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for the AE653 vThreads full run-time - -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). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_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 := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- 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 := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -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 := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := True; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - 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 := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads deleted file mode 100644 index 3b78e7e..0000000 --- a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 653 x86 vThreads) -- --- -- --- Copyright (C) 1992-2021, 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 -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for the AE653 vThreads full run-time - -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). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_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 := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- 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) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -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 := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := True; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : 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 := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index b4f7609..513275a 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -2248,6 +2248,8 @@ package body Par_SCO is | Name_Loop_Invariant | Name_Postcondition | Name_Precondition + | Name_Type_Invariant + | Name_Invariant => -- For Assert/Check/Precondition/Postcondition, we -- must generate a P entry for the decision. Note @@ -2256,7 +2258,10 @@ package body Par_SCO is -- on when we output the decision line in Put_SCOs, -- depending on setting by Set_SCO_Pragma_Enabled. - if Nam = Name_Check then + if Nam = Name_Check + or else Nam = Name_Type_Invariant + or else Nam = Name_Invariant + then Next (Arg); end if; @@ -2285,8 +2290,7 @@ package body Par_SCO is -- never disabled. -- Should generate P decisions (not X) for assertion - -- related pragmas: [Type_]Invariant, - -- [{Static,Dynamic}_]Predicate??? + -- related pragmas: [{Static,Dynamic}_]Predicate??? when others => Process_Decisions_Defer (N, 'X'); diff --git a/gcc/ada/repinfo-input.adb b/gcc/ada/repinfo-input.adb index 5d85040..7e250a4 100644 --- a/gcc/ada/repinfo-input.adb +++ b/gcc/ada/repinfo-input.adb @@ -776,7 +776,7 @@ package body Repinfo.Input is -- Compute Component_Bit_Offset from Position and First_Bit, -- either symbolically or literally depending on Position. - if Position = No_Uint or else First_Bit = No_Uint then + if No (Position) or else No (First_Bit) then Error ("bit offset expected"); end if; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 148de53..58e0161 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -422,7 +422,8 @@ package body Repinfo is Write_Line (";"); end if; - -- Alignment is not always set for task and protected types + -- Alignment is not always set for task, protected, and class-wide + -- types. else pragma Assert @@ -807,7 +808,7 @@ package body Repinfo is -- Start of processing for List_GCC_Expression begin - if U = No_Uint then + if No (U) then Write_Unknown_Val; else Print_Expr (U); @@ -1188,13 +1189,7 @@ package body Repinfo is Write_Str (" .. "); end if; - -- Allowing Uint_0 here is an annoying special case. Really this - -- should be a fine Esize value but currently it means unknown, - -- except that we know after gigi has back annotated that a size - -- of zero is real, since otherwise gigi back annotates using - -- No_Uint as the value to indicate unknown. - - if (Esize (Ent) = Uint_0 or else Known_Static_Esize (Ent)) + if Known_Static_Esize (Ent) and then Known_Static_Normalized_First_Bit (Ent) then Lbit := Sbit + Esiz - 1; @@ -1209,14 +1204,7 @@ package body Repinfo is UI_Write (Lbit, Decimal); end if; - -- The test for Esize (Ent) not Uint_0 here is an annoying special - -- case. Officially a value of zero for Esize means unknown, but - -- here we use the fact that we know that gigi annotates Esize with - -- No_Uint, not Uint_0. Really everyone should use No_Uint??? - - elsif List_Representation_Info < 3 - or else (Esize (Ent) /= Uint_0 and then not Known_Esize (Ent)) - then + elsif List_Representation_Info < 3 or else not Known_Esize (Ent) then Write_Unknown_Val; -- List_Representation >= 3 and Known_Esize (Ent) @@ -2116,7 +2104,7 @@ package body Repinfo is function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is begin - if Val = No_Uint or else Val < 0 then + if No (Val) or else Val < 0 then return True; else return False; @@ -2315,7 +2303,7 @@ package body Repinfo is -- Start of processing for Rep_Value begin - if Val = No_Uint then + if No (Val) then return No_Uint; else @@ -2401,7 +2389,7 @@ package body Repinfo is procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is begin if Rep_Not_Constant (Val) then - if List_Representation_Info < 3 or else Val = No_Uint then + if List_Representation_Info < 3 or else No (Val) then Write_Unknown_Val; else diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index ad53279..e81985f 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -159,7 +159,7 @@ package body Scn is -- Int_Literal_Value can be No_Uint in some cases in syntax-only -- mode (see Scng.Scan.Nlit). - if Int_Literal_Value /= No_Uint then + if Present (Int_Literal_Value) then Set_Intval (Token_Node, Int_Literal_Value); end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d1a91d8..b44bbe3 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -175,6 +175,7 @@ package body Sem_Attr is Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_Enum_Rep | Attribute_Enum_Val => True, + Attribute_Preelaborable_Initialization => True, others => False); -- The following array contains all attributes that imply a modification @@ -5408,6 +5409,45 @@ package body Sem_Attr is end if; end if; + ---------------------------------- + -- Preelaborable_Initialization -- + ---------------------------------- + + when Attribute_Preelaborable_Initialization => + Check_E0; + Check_Type; + + -- If we're in an instance, we know that the legality of the + -- attribute prefix type was already checked in the generic. + + if not In_Instance then + + -- If the prefix type is a generic formal type, then it must be + -- either a formal private type or a formal derived type. + + if Is_Generic_Type (P_Type) then + if not Is_Private_Type (P_Type) + and then not Is_Derived_Type (P_Type) + then + Error_Attr_P ("formal type prefix of % attribute must be " + & "formal private or formal derived type"); + end if; + + -- Otherwise, the prefix type must be a nonformal composite + -- type declared within the visible part of a package or + -- generic package. + + elsif not Is_Composite_Type (P_Type) + or else not Original_View_In_Visible_Part (P_Type) + then + Error_Attr_P + ("prefix of % attribute must be composite type declared " + & "in visible part of a package or generic package"); + end if; + end if; + + Set_Etype (N, Standard_Boolean); + -------------- -- Priority -- -------------- @@ -8084,13 +8124,13 @@ package body Sem_Attr is end if; -- If we are asked to evaluate an attribute where the prefix is a - -- non-frozen generic actual type whose RM_Size is still set to zero, + -- non-frozen generic actual type whose RM_Size has not been set, -- then abandon the effort. if Is_Type (P_Entity) and then (not Is_Frozen (P_Entity) and then Is_Generic_Actual_Type (P_Entity) - and then RM_Size (P_Entity) = 0) + and then not Known_RM_Size (P_Entity)) -- However, the attribute Unconstrained_Array must be evaluated, -- since it is documented to be a static attribute (and can for @@ -8182,15 +8222,16 @@ package body Sem_Attr is -- is to say if we are within an instantiation. Same processing applies -- to selected GNAT attributes. - elsif (Id = Attribute_Atomic_Always_Lock_Free or else - Id = Attribute_Definite or else - Id = Attribute_Descriptor_Size or else - Id = Attribute_Has_Access_Values or else - Id = Attribute_Has_Discriminants or else - Id = Attribute_Has_Tagged_Values or else - Id = Attribute_Lock_Free or else - Id = Attribute_Type_Class or else - Id = Attribute_Unconstrained_Array or else + elsif (Id = Attribute_Atomic_Always_Lock_Free or else + Id = Attribute_Definite or else + Id = Attribute_Descriptor_Size or else + Id = Attribute_Has_Access_Values or else + Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free or else + Id = Attribute_Preelaborable_Initialization 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 @@ -8315,15 +8356,20 @@ package body Sem_Attr is -- unconstrained arrays. Furthermore, it is essential to fold this -- in the packed case, since otherwise the value will be incorrect. - elsif Id = Attribute_Atomic_Always_Lock_Free or else - Id = Attribute_Definite or else - Id = Attribute_Descriptor_Size or else - Id = Attribute_Has_Access_Values or else - Id = Attribute_Has_Discriminants or else - Id = Attribute_Has_Tagged_Values or else - Id = Attribute_Lock_Free or else - Id = Attribute_Type_Class or else - Id = Attribute_Unconstrained_Array or else + -- Folding can also be done for Preelaborable_Initialization based on + -- whether the prefix type has preelaborable initialization, even though + -- the attribute is nonstatic. + + elsif Id = Attribute_Atomic_Always_Lock_Free or else + Id = Attribute_Definite or else + Id = Attribute_Descriptor_Size or else + Id = Attribute_Has_Access_Values or else + Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free or else + Id = Attribute_Preelaborable_Initialization or else + Id = Attribute_Type_Class or else + Id = Attribute_Unconstrained_Array or else Id = Attribute_Component_Size then Static := False; @@ -9143,7 +9189,7 @@ package body Sem_Attr is Fold_Uint (N, Uint_0, Static); when LT => - if Diff /= No_Uint then + if Present (Diff) then Fold_Uint (N, Diff + 1, Static); end if; @@ -9609,6 +9655,17 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (E1) - 1, Static); end if; + ---------------------------------- + -- Preelaborable_Initialization -- + ---------------------------------- + + when Attribute_Preelaborable_Initialization => + Fold_Uint + (N, + UI_From_Int + (Boolean'Pos (Has_Preelaborable_Initialization (P_Type))), + Static); + ----------- -- Range -- ----------- @@ -9653,7 +9710,7 @@ package body Sem_Attr is Fold_Uint (N, Uint_0, Static); when LT => - if Diff /= No_Uint then + if Present (Diff) then Fold_Uint (N, Diff + 1, Static); end if; @@ -9824,9 +9881,9 @@ package body Sem_Attr is P_TypeA : constant Entity_Id := Underlying_Type (P_Type); begin - if Is_Scalar_Type (P_TypeA) - or else RM_Size (P_TypeA) /= Uint_0 - then + pragma Assert + (if Is_Scalar_Type (P_TypeA) then Known_RM_Size (P_TypeA)); + if Known_RM_Size (P_TypeA) then -- VADS_Size case if Id = Attribute_VADS_Size or else Use_VADS_Size then @@ -10102,7 +10159,9 @@ package body Sem_Attr is P_TypeA : constant Entity_Id := Underlying_Type (P_Type); begin - if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then + pragma Assert + (if Is_Scalar_Type (P_TypeA) then Known_RM_Size (P_TypeA)); + if Known_RM_Size (P_TypeA) then Fold_Uint (N, RM_Size (P_TypeA), Static); end if; end Value_Size; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index ea3b59c..bce7c38 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -846,10 +846,7 @@ package body Sem_Aux is Btype : constant Entity_Id := Base_Type (Ent); begin - if Error_Posted (Ent) or else Error_Posted (Btype) then - return False; - - elsif Is_Private_Type (Btype) then + if Is_Private_Type (Btype) then declare Utyp : constant Entity_Id := Underlying_Type (Btype); begin diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 1e7b93c..dd78501 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -5825,7 +5825,7 @@ package body Sem_Ch10 is Set_Is_First_Subtype (Ent); Set_Scope (Ent, Scop); Set_Stored_Constraint (Ent, No_Elist); - Init_Size_Align (Ent); + Reinit_Size_Align (Ent); if From_Limited_With (Ent) then Set_Private_Dependents (Ent, New_Elmt_List); @@ -5865,7 +5865,7 @@ package body Sem_Ch10 is Set_Is_Tagged_Type (CW_Typ); Set_Materialize_Entity (CW_Typ, Materialize); Set_Scope (CW_Typ, Scop); - Init_Size_Align (CW_Typ); + Reinit_Size_Align (CW_Typ); end if; end Decorate_Type; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 85c854f..eca2abf 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2495,7 +2495,7 @@ package body Sem_Ch12 is Mutate_Ekind (T, E_Enumeration_Subtype); Set_Etype (T, Base); Init_Size (T, 8); - Init_Alignment (T); + Reinit_Alignment (T); Set_Is_Generic_Type (T); Set_Is_Constrained (T); @@ -2524,7 +2524,7 @@ package body Sem_Ch12 is Mutate_Ekind (Base, E_Enumeration_Type); Set_Etype (Base, Base); Init_Size (Base, 8); - Init_Alignment (Base); + Reinit_Alignment (Base); Set_Is_Generic_Type (Base); Set_Scalar_Range (Base, Scalar_Range (T)); Set_Parent (Base, Parent (Def)); @@ -7112,8 +7112,8 @@ package body Sem_Ch12 is Astype := First_Subtype (E); end if; - Set_Size_Info (E, (Astype)); - Set_RM_Size (E, RM_Size (Astype)); + Set_Size_Info (E, (Astype)); + Copy_RM_Size (To => E, From => Astype); Set_First_Rep_Item (E, First_Rep_Item (Astype)); if Is_Discrete_Or_Fixed_Point_Type (E) then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 76859c5..228fd39 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -862,7 +862,7 @@ package body Sem_Ch13 is and then not Has_Alignment_Clause (Typ) and then Size mod (Alignment (Typ) * SSU) /= 0 then - Init_Alignment (Typ); + Reinit_Alignment (Typ); end if; end Alignment_Check_For_Size_Change; @@ -1455,9 +1455,17 @@ package body Sem_Ch13 is -- Aspect Full_Access_Only must be analyzed last so that -- aspects Volatile and Atomic, if any, are analyzed. + -- Skip creation of pragma Preelaborable_Initialization + -- in the case where the aspect has an expression, + -- because the pragma is only needed for setting flag + -- Known_To_Have_Preelab_Init, which is set by other + -- means following resolution of the aspect expression. + if A_Id not in Aspect_Export | Aspect_Full_Access_Only | Aspect_Import + and then (A_Id /= Aspect_Preelaborable_Initialization + or else not Present (Expression (ASN))) then Make_Pragma_From_Boolean_Aspect (ASN); end if; @@ -1876,6 +1884,11 @@ package body Sem_Ch13 is -- expression is allowed. Includes checking that the expression -- does not raise Constraint_Error. + function Directly_Specified + (Id : Entity_Id; A : Aspect_Id) return Boolean; + -- Returns True if the given aspect is directly (as opposed to + -- via any form of inheritance) specified for the given entity. + function Make_Aitem_Pragma (Pragma_Argument_Associations : List_Id; Pragma_Name : Name_Id) return Node_Id; @@ -2769,6 +2782,18 @@ package body Sem_Ch13 is end if; end Check_Expr_Is_OK_Static_Expression; + ------------------------ + -- Directly_Specified -- + ------------------------ + + function Directly_Specified + (Id : Entity_Id; A : Aspect_Id) return Boolean + is + Aspect_Spec : constant Node_Id := Find_Aspect (Id, A); + begin + return Present (Aspect_Spec) and then Entity (Aspect_Spec) = Id; + end Directly_Specified; + ----------------------- -- Make_Aitem_Pragma -- ----------------------- @@ -2915,6 +2940,7 @@ package body Sem_Ch13 is | Aspect_Async_Writers | Aspect_Effective_Reads | Aspect_Effective_Writes + | Aspect_Preelaborable_Initialization then Error_Msg_Name_1 := Nam; @@ -2951,6 +2977,7 @@ package body Sem_Ch13 is | Aspect_Async_Writers | Aspect_Effective_Reads | Aspect_Effective_Writes + | Aspect_Preelaborable_Initialization then Error_Msg_N ("aspect % not allowed for formal type declaration", @@ -3332,6 +3359,15 @@ package body Sem_Ch13 is ("Predicate_Failure requires previous predicate" & " specification", Aspect); goto Continue; + + elsif not (Directly_Specified (E, Aspect_Dynamic_Predicate) + or else Directly_Specified (E, Aspect_Static_Predicate) + or else Directly_Specified (E, Aspect_Predicate)) + then + Error_Msg_N + ("Predicate_Failure requires accompanying" & + " noninherited predicate specification", Aspect); + goto Continue; end if; -- Construct the pragma @@ -6621,7 +6657,7 @@ package body Sem_Ch13 is elsif Duplicate_Clause then null; - elsif Align /= No_Uint then + elsif Present (Align) then Set_Has_Alignment_Clause (U_Ent); -- Tagged type case, check for attempt to set alignment to a @@ -6711,7 +6747,7 @@ package body Sem_Ch13 is elsif Rep_Item_Too_Early (Btype, N) then null; - elsif Csize /= No_Uint then + elsif Present (Csize) then Check_Size (Expr, Ctyp, Csize, Biased); -- For the biased case, build a declaration for a subtype that @@ -6736,9 +6772,9 @@ package body Sem_Ch13 is Analyze (Decl, Suppress => All_Checks); Set_Has_Delayed_Freeze (New_Ctyp, False); - Init_Esize (New_Ctyp); + Reinit_Esize (New_Ctyp); Set_RM_Size (New_Ctyp, Csize); - Init_Alignment (New_Ctyp); + Reinit_Alignment (New_Ctyp); Set_Is_Itype (New_Ctyp, True); Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); @@ -7051,7 +7087,7 @@ package body Sem_Ch13 is elsif Duplicate_Clause then null; - elsif Radix /= No_Uint then + elsif Present (Radix) then Set_Has_Machine_Radix_Clause (U_Ent); Set_Has_Non_Standard_Rep (Base_Type (U_Ent)); @@ -7264,7 +7300,7 @@ package body Sem_Ch13 is Error_Msg_N (Attr_Name & " cannot be given for unconstrained array", Nam); - elsif Size /= No_Uint then + elsif Present (Size) then declare Etyp : constant Entity_Id := (if Is_Type (U_Ent) then U_Ent else Etype (U_Ent)); @@ -7312,13 +7348,14 @@ package body Sem_Ch13 is if Is_First_Subtype (U_Ent) then if Is_Elementary_Type (U_Ent) then if Size <= System_Storage_Unit then - Init_Esize (U_Ent, System_Storage_Unit); + Set_Esize + (U_Ent, UI_From_Int (System_Storage_Unit)); elsif Size <= 16 then - Init_Esize (U_Ent, 16); + Set_Esize (U_Ent, Uint_16); elsif Size <= 32 then - Init_Esize (U_Ent, 32); + Set_Esize (U_Ent, Uint_32); else - Set_Esize (U_Ent, (Size + 63) / 64 * 64); + Set_Esize (U_Ent, (Size + 63) / 64 * 64); end if; Alignment_Check_For_Size_Change @@ -7788,11 +7825,16 @@ package body Sem_Ch13 is null; elsif Is_Elementary_Type (U_Ent) then - if Size /= System_Storage_Unit - and then Size /= System_Storage_Unit * 2 - and then Size /= System_Storage_Unit * 3 - and then Size /= System_Storage_Unit * 4 - and then Size /= System_Storage_Unit * 8 + -- Size will be empty if we already detected an error + -- (e.g. Expr is of the wrong type); we might as well + -- give the useful hint below even in that case. + + if No (Size) or else + (Size /= System_Storage_Unit + and then Size /= System_Storage_Unit * 2 + and then Size /= System_Storage_Unit * 3 + and then Size /= System_Storage_Unit * 4 + and then Size /= System_Storage_Unit * 8) then Error_Msg_N ("stream size for elementary type must be 8, 16, 24, " & @@ -8095,7 +8137,7 @@ package body Sem_Ch13 is -- the list. The final checks for completeness and ordering are -- skipped in this case. - if Val = No_Uint then + if No (Val) then Err := True; elsif Val < Lo or else Hi < Val then @@ -8174,7 +8216,7 @@ package body Sem_Ch13 is Expr := Expression (Assoc); Val := Static_Integer (Expr); - if Val = No_Uint then + if No (Val) then Err := True; elsif Val < Lo or else Hi < Val then @@ -8209,12 +8251,12 @@ package body Sem_Ch13 is else Val := Enumeration_Rep (Elit); - if Min = No_Uint then + if No (Min) then Min := Val; end if; - if Val /= No_Uint then - if Max /= No_Uint and then Val <= Max then + if Present (Val) then + if Present (Max) and then Val <= Max then Error_Msg_NE ("enumeration value for& not ordered!", Enumeration_Rep_Expr (Elit), Elit); @@ -8499,9 +8541,9 @@ package body Sem_Ch13 is 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 + if Present (Posit) + and then Present (Fbit) + and then Present (Lbit) then if Posit < 0 then Error_Msg_N ("position cannot be negative", Position (CC)); @@ -8642,9 +8684,6 @@ package body Sem_Ch13 is Set_Normalized_First_Bit (Comp, Fbit mod SSU); Set_Normalized_Position (Comp, Fbit / SSU); - Set_Normalized_Position_Max - (Comp, Normalized_Position (Comp)); - if Warn_On_Overridden_Size and then Has_Size_Clause (Etype (Comp)) and then RM_Size (Etype (Comp)) /= Esize (Comp) @@ -8676,9 +8715,6 @@ package body Sem_Ch13 is Set_Normalized_First_Bit (Ocomp, Fbit mod SSU); Set_Normalized_Position (Ocomp, Fbit / SSU); - 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. @@ -11872,9 +11908,23 @@ package body Sem_Ch13 is -------- function Lt (Op1, Op2 : Natural) return Boolean is + K1 : constant Boolean := + Known_Component_Bit_Offset (Comps (Op1)); + K2 : constant Boolean := + Known_Component_Bit_Offset (Comps (Op2)); + -- Record representation clauses can be incomplete, so the + -- Component_Bit_Offsets can be unknown. begin - return Component_Bit_Offset (Comps (Op1)) - < Component_Bit_Offset (Comps (Op2)); + if K1 then + if K2 then + return Component_Bit_Offset (Comps (Op1)) + < Component_Bit_Offset (Comps (Op2)); + else + return True; + end if; + else + return K2; + end if; end Lt; ---------- @@ -11938,7 +11988,7 @@ package body Sem_Ch13 is begin -- Skip components with unknown offsets - if CBO /= No_Uint and then CBO >= 0 then + if Present (CBO) and then CBO >= 0 then Error_Msg_Uint_1 := CBO - Nbit; if Warn and then Error_Msg_Uint_1 > 0 then @@ -12053,7 +12103,7 @@ package body Sem_Ch13 is Pcomp := First_Entity (Tagged_Parent); while Present (Pcomp) loop if Ekind (Pcomp) in E_Discriminant | E_Component then - if Component_Bit_Offset (Pcomp) /= No_Uint + if Present (Component_Bit_Offset (Pcomp)) and then Known_Static_Esize (Pcomp) then Parent_Last_Bit := @@ -12094,8 +12144,7 @@ package body Sem_Ch13 is 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_Esize (Fent, UI_From_Int (System_Address_Size)); Set_Component_Clause (Fent, Make_Component_Clause (Loc, @@ -13123,7 +13172,7 @@ package body Sem_Ch13 is Align : constant Uint := Static_Integer (Expr); begin - if Align = No_Uint then + if No (Align) then return No_Uint; elsif Align < 0 then @@ -13700,6 +13749,7 @@ package body Sem_Ch13 is | Attribute_Iterable | Attribute_Iterator_Element | Attribute_Output + | Attribute_Put_Image | Attribute_Read | Attribute_Variable_Indexing | Attribute_Write; @@ -13979,7 +14029,7 @@ package body Sem_Ch13 is function Minimum_Size (T : Entity_Id; - Biased : Boolean := False) return Nat + Biased : Boolean := False) return Int is Lo : Uint := No_Uint; Hi : Uint := No_Uint; @@ -13993,17 +14043,17 @@ package body Sem_Ch13 is R_Typ : constant Entity_Id := Root_Type (T); begin - -- If bad type, return 0 + -- Bad type if T = Any_Type then - return 0; + return Unknown_Minimum_Size; - -- For generic types, just return zero. There cannot be any legitimate - -- need to know such a size, but this routine may be called with a - -- generic type as part of normal processing. + -- For generic types, just return unknown. There cannot be any + -- legitimate need to know such a size, but this routine may be + -- called with a generic type as part of normal processing. elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then - return 0; + return Unknown_Minimum_Size; -- Access types (cannot have size smaller than System.Address) @@ -14026,7 +14076,7 @@ package body Sem_Ch13 is Ancest := T; loop if Ancest = Any_Type or else Etype (Ancest) = Any_Type then - return 0; + return Unknown_Minimum_Size; end if; if not LoSet then @@ -14051,7 +14101,7 @@ package body Sem_Ch13 is Ancest := Base_Type (T); if Is_Generic_Type (Ancest) then - return 0; + return Unknown_Minimum_Size; end if; end if; end loop; @@ -14072,7 +14122,7 @@ package body Sem_Ch13 is Ancest := T; loop if Ancest = Any_Type or else Etype (Ancest) = Any_Type then - return 0; + return Unknown_Minimum_Size; end if; -- Note: In the following two tests for LoSet and HiSet, it may @@ -14112,7 +14162,7 @@ package body Sem_Ch13 is Ancest := Base_Type (T); if Is_Generic_Type (Ancest) then - return 0; + return Unknown_Minimum_Size; end if; end if; end loop; @@ -14142,7 +14192,7 @@ package body Sem_Ch13 is -- type case, since that's the odd case that came up. Probably we should -- also do this in the fixed-point case, but doing so causes peculiar -- gigi failures, and it is not worth worrying about this incredibly - -- marginal case (explicit null-range fixed-point type declarations)??? + -- marginal case (explicit null-range fixed-point type declarations). if Lo > Hi and then Is_Discrete_Type (T) then S := 0; @@ -15681,18 +15731,17 @@ package body Sem_Ch13 is ------------------------------ procedure Resolve_Aspect_Aggregate - (Typ : Entity_Id; + (Typ : Entity_Id; Expr : Node_Id) is + function Valid_Empty (E : Entity_Id) return Boolean; + function Valid_Add_Named (E : Entity_Id) return Boolean; + function Valid_Add_Unnamed (E : Entity_Id) return Boolean; + function Valid_New_Indexed (E : Entity_Id) return Boolean; + function Valid_Assign_Indexed (E : Entity_Id) return Boolean; -- Predicates that establish the legality of each possible operation in -- an Aggregate aspect. - function Valid_Empty (E : Entity_Id) return Boolean; - function Valid_Add_Named (E : Entity_Id) return Boolean; - function Valid_Add_Unnamed (E : Entity_Id) return Boolean; - function Valid_New_Indexed (E : Entity_Id) return Boolean; - function Valid_Assign_Indexed (E : Entity_Id) return Boolean; - generic with function Pred (Id : Node_Id) return Boolean; procedure Resolve_Operation (Subp_Id : Node_Id); @@ -15715,7 +15764,7 @@ package body Sem_Ch13 is end Valid_Assign_Indexed; ----------------- - -- Valid_Emoty -- + -- Valid_Empty -- ----------------- function Valid_Empty (E : Entity_Id) return Boolean is @@ -15740,7 +15789,7 @@ package body Sem_Ch13 is -- Valid_Add_Named -- --------------------- - function Valid_Add_Named (E : Entity_Id) return Boolean is + function Valid_Add_Named (E : Entity_Id) return Boolean is F2, F3 : Entity_Id; begin if Ekind (E) = E_Procedure @@ -15839,6 +15888,9 @@ package body Sem_Ch13 is procedure Resolve_Assign_Indexed is new Resolve_Operation (Valid_Assign_Indexed); + + -- Start of processing for Resolve_Aspect_Aggregate + begin Assoc := First (Component_Associations (Expr)); @@ -16120,10 +16172,10 @@ package body Sem_Ch13 is procedure Set_Enum_Esize (T : Entity_Id) is Lo : Uint; Hi : Uint; - Sz : Nat; + Sz : Unat; begin - Init_Alignment (T); + Reinit_Alignment (T); -- Find the minimum standard size (8,16,32,64,128) that fits @@ -16131,37 +16183,38 @@ package body Sem_Ch13 is Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); if Lo < 0 then - if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then - Sz := Standard_Character_Size; -- May be > 8 on some targets + if Lo >= -Uint_2**7 and then Hi < Uint_2**7 then + Sz := UI_From_Int (Standard_Character_Size); + -- Might be > 8 on some targets elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then - Sz := 16; + Sz := Uint_16; elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then - Sz := 32; + Sz := Uint_32; elsif Lo >= -Uint_2**63 and then Hi < Uint_2**63 then - Sz := 64; + Sz := Uint_64; else pragma Assert (Lo >= -Uint_2**127 and then Hi < Uint_2**127); - Sz := 128; + Sz := Uint_128; end if; else - if Hi < Uint_2**08 then - Sz := Standard_Character_Size; -- May be > 8 on some targets + if Hi < Uint_2**8 then + Sz := UI_From_Int (Standard_Character_Size); elsif Hi < Uint_2**16 then - Sz := 16; + Sz := Uint_16; elsif Hi < Uint_2**32 then - Sz := 32; + Sz := Uint_32; elsif Hi < Uint_2**64 then - Sz := 64; + Sz := Uint_64; else pragma Assert (Hi < Uint_2**128); - Sz := 128; + Sz := Uint_128; end if; end if; @@ -16177,9 +16230,9 @@ package body Sem_Ch13 is and then not Target_Short_Enums then - Init_Esize (T, Standard_Integer_Size); + Set_Esize (T, UI_From_Int (Standard_Integer_Size)); else - Init_Esize (T, Sz); + Set_Esize (T, Sz); end if; end Set_Enum_Esize; @@ -16262,7 +16315,7 @@ package body Sem_Ch13 is elsif Nkind (N) = N_Selected_Component then Off := Component_Bit_Offset (Entity (Selector_Name (N))); - if Off /= No_Uint and then Off >= Uint_0 then + if Present (Off) and then Off >= Uint_0 then Val := Val + Off; N := Prefix (N); else @@ -16271,7 +16324,7 @@ package body Sem_Ch13 is elsif Nkind (N) = N_Indexed_Component then Off := Indexed_Component_Bit_Offset (N); - if Off /= No_Uint then + if Present (Off) then Val := Val + Off; N := Prefix (N); else @@ -16319,7 +16372,8 @@ package body Sem_Ch13 is if Present (ACCR.Y) then Y_Alignment := Alignment (ACCR.Y); - Y_Size := Esize (ACCR.Y); + Y_Size := + (if Known_Esize (ACCR.Y) then Esize (ACCR.Y) else Uint_0); end if; if ACCR.Off diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 3b21484..0d3b041 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -81,9 +81,11 @@ package Sem_Ch13 is -- the setting of the RM_Size field is not affected. This routine also -- initializes the alignment field to zero. + Unknown_Minimum_Size : constant Nonzero_Int := -1; + function Minimum_Size (T : Entity_Id; - Biased : Boolean := False) return Nat; + Biased : Boolean := False) return Int; -- Given an elementary type, determines the minimum number of bits required -- to represent all values of the type. This function may not be called -- with any other types. If the flag Biased is set True, then the minimum @@ -96,7 +98,7 @@ package Sem_Ch13 is -- the type is already biased, then Minimum_Size returns the biased size, -- regardless of the setting of Biased. Also, fixed-point types are never -- biased in the current implementation. If the size is not known at - -- compile time, this function returns 0. + -- compile time, this function returns Unknown_Minimum_Size. procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id); -- Expr is an expression for an address clause. This procedure checks diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e9b4456..cc8a9b7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1299,7 +1299,7 @@ package body Sem_Ch3 is Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target); Set_Etype (T_Name, T_Name); - Init_Size_Align (T_Name); + Reinit_Size_Align (T_Name); Set_Directly_Designated_Type (T_Name, Desig_Type); -- If the access_to_subprogram is not declared at the library level, @@ -1465,7 +1465,7 @@ package body Sem_Ch3 is -- and the pointer size is already set. Else, initialize. if not From_Limited_With (T) then - Init_Size_Align (T); + Reinit_Size_Align (T); end if; -- Note that Has_Task is always false, since the access type itself @@ -1551,7 +1551,7 @@ package body Sem_Ch3 is Set_Is_Aliased (Tag); Set_Is_Independent (Tag); Set_Related_Type (Tag, Iface); - Init_Component_Location (Tag); + Reinit_Component_Location (Tag); pragma Assert (Is_Frozen (Iface)); @@ -1591,7 +1591,7 @@ package body Sem_Ch3 is Set_Is_Aliased (Offset); Set_Is_Independent (Offset); Set_Related_Type (Offset, Iface); - Init_Component_Location (Offset); + Reinit_Component_Location (Offset); Insert_After (Last_Tag, Decl); Last_Tag := Decl; end if; @@ -2648,6 +2648,48 @@ package body Sem_Ch3 is E := First_Entity (Current_Scope); while Present (E) loop Resolve_Aspect_Expressions (E); + + -- Now that the aspect expressions have been resolved, if this is + -- at the end of the visible declarations, we can set the flag + -- Known_To_Have_Preelab_Init properly on types declared in the + -- visible part, which is needed for checking whether full types + -- in the private part satisfy the Preelaborable_Initialization + -- aspect of the partial view. We can't wait for the creation of + -- the pragma by Analyze_Aspects_At_Freeze_Point, because the + -- freeze point may occur after the end of the package declaration + -- (in the case of nested packages). + + if Is_Type (E) + and then L = Visible_Declarations (Parent (L)) + and then Has_Aspect (E, Aspect_Preelaborable_Initialization) + then + declare + ASN : constant Node_Id := + Find_Aspect (E, Aspect_Preelaborable_Initialization); + Expr : constant Node_Id := Expression (ASN); + begin + -- Set Known_To_Have_Preelab_Init to True if aspect has no + -- expression, or if the expression is True (or was folded + -- to True), or if the expression is a conjunction of one or + -- more Preelaborable_Initialization attributes applied to + -- formal types and wasn't folded to False. (Note that + -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes goes to + -- Original_Node if needed, hence test for Standard_False.) + + if not Present (Expr) + or else (Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_True) + or else + (Is_Conjunction_Of_Formal_Preelab_Init_Attributes (Expr) + and then + not (Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False)) + then + Set_Known_To_Have_Preelab_Init (E); + end if; + end; + end if; + Next_Entity (E); end loop; end Resolve_Aspects; @@ -3450,7 +3492,7 @@ package body Sem_Ch3 is Mutate_Ekind (T, E_Incomplete_Type); Set_Etype (T, T); Set_Is_First_Subtype (T); - Init_Size_Align (T); + Reinit_Size_Align (T); -- Set the SPARK mode from the current context @@ -4849,8 +4891,8 @@ package body Sem_Ch3 is -- Initialize alignment and size and capture alignment setting - Init_Alignment (Id); - Init_Esize (Id); + Reinit_Alignment (Id); + Reinit_Esize (Id); Set_Optimize_Alignment_Flags (Id); -- Deal with aliased case @@ -5183,7 +5225,7 @@ package body Sem_Ch3 is Set_Is_Pure (T, Is_Pure (Current_Scope)); Set_Scope (T, Current_Scope); Mutate_Ekind (T, E_Record_Type_With_Private); - Init_Size_Align (T); + Reinit_Size_Align (T); Set_Default_SSO (T); Set_No_Reordering (T, No_Component_Reordering); @@ -5348,7 +5390,7 @@ package body Sem_Ch3 is begin Generate_Definition (Id); Set_Is_Pure (Id, Is_Pure (Current_Scope)); - Init_Size_Align (Id); + Reinit_Size_Align (Id); -- The following guard condition on Enter_Name is to handle cases where -- the defining identifier has already been entered into the scope but @@ -5466,7 +5508,7 @@ package body Sem_Ch3 is Set_Machine_Radix_10 (Id, Machine_Radix_10 (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); - Set_RM_Size (Id, RM_Size (T)); + Copy_RM_Size (To => Id, From => T); when Enumeration_Kind => Mutate_Ekind (Id, E_Enumeration_Subtype); @@ -5475,7 +5517,7 @@ package body Sem_Ch3 is Set_Is_Character_Type (Id, Is_Character_Type (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); - Set_RM_Size (Id, RM_Size (T)); + Copy_RM_Size (To => Id, From => T); when Ordinary_Fixed_Point_Kind => Mutate_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); @@ -5484,7 +5526,7 @@ package body Sem_Ch3 is Set_Delta_Value (Id, Delta_Value (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); - Set_RM_Size (Id, RM_Size (T)); + Copy_RM_Size (To => Id, From => T); when Float_Kind => Mutate_Ekind (Id, E_Floating_Point_Subtype); @@ -5500,14 +5542,14 @@ package body Sem_Ch3 is Set_Scalar_Range (Id, Scalar_Range (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); - Set_RM_Size (Id, RM_Size (T)); + Copy_RM_Size (To => Id, From => T); when Modular_Integer_Kind => Mutate_Ekind (Id, E_Modular_Integer_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); - Set_RM_Size (Id, RM_Size (T)); + Copy_RM_Size (To => Id, From => T); when Class_Wide_Kind => Mutate_Ekind (Id, E_Class_Wide_Subtype); @@ -5534,7 +5576,7 @@ package body Sem_Ch3 is -- the type they rename. if Present (Generic_Parent_Type (N)) then - Set_RM_Size (Id, RM_Size (T)); + Copy_RM_Size (To => Id, From => T); end if; if Ekind (T) = E_Record_Subtype @@ -6290,7 +6332,7 @@ package body Sem_Ch3 is -- The constrained array type is a subtype of the unconstrained one Mutate_Ekind (T, E_Array_Subtype); - Init_Size_Align (T); + Reinit_Size_Align (T); Set_Etype (T, Implicit_Base); Set_Scope (T, Current_Scope); Set_Is_Constrained (T); @@ -6326,7 +6368,7 @@ package body Sem_Ch3 is end if; Mutate_Ekind (T, E_Array_Type); - Init_Size_Align (T); + Reinit_Size_Align (T); Set_Etype (T, T); Set_Scope (T, Current_Scope); Set_Component_Size (T, Uint_0); @@ -6813,8 +6855,8 @@ package body Sem_Ch3 is Set_Is_Constrained (Derived_Type, Is_Constrained (Subt)); Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type)); - Set_Size_Info (Derived_Type, Parent_Type); - Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + Set_Size_Info (Derived_Type, Parent_Type); + Copy_RM_Size (To => Derived_Type, From => Parent_Type); Set_Depends_On_Private (Derived_Type, Has_Private_Component (Derived_Type)); Conditional_Delay (Derived_Type, Subt); @@ -8945,7 +8987,7 @@ package body Sem_Ch3 is if Is_Tagged then Set_Is_Tagged_Type (Derived_Type); - Init_Size_Align (Derived_Type); + Reinit_Size_Align (Derived_Type); end if; -- STEP 0a: figure out what kind of derived type declaration we have @@ -9854,8 +9896,8 @@ package body Sem_Ch3 is Mutate_Ekind (Derived_Type, Ekind (Parent_Base)); Propagate_Concurrent_Flags (Derived_Type, Parent_Base); - Set_Size_Info (Derived_Type, Parent_Type); - Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + Set_Size_Info (Derived_Type, Parent_Type); + Copy_RM_Size (To => Derived_Type, From => Parent_Type); Set_Is_Controlled_Active (Derived_Type, Is_Controlled_Active (Parent_Type)); @@ -10392,6 +10434,7 @@ package body Sem_Ch3 is (Discr_Expr (J), Check_Concurrent => True) then Discrim_Present := True; + exit; end if; end loop; @@ -10449,7 +10492,43 @@ package body Sem_Ch3 is Apply_Range_Check (Discr_Expr (J), Etype (Discr)); end if; - Force_Evaluation (Discr_Expr (J)); + -- If the value of the discriminant may be visible in + -- another unit or child unit, create an external name + -- for it. We use the name of the object or component + -- that carries the discriminated subtype. The code + -- below may generate external symbols for the discriminant + -- expression when not strictly needed, which is harmless. + + if Expander_Active + and then Comes_From_Source (Def) + and then not Is_Subprogram (Current_Scope) + then + declare + Id : Entity_Id := Empty; + begin + if Nkind (Parent (Def)) = N_Object_Declaration then + Id := Defining_Identifier (Parent (Def)); + + elsif Nkind (Parent (Def)) = N_Component_Definition + and then + Nkind (Parent (Parent (Def))) + = N_Component_Declaration + then + Id := Defining_Identifier (Parent (Parent (Def))); + end if; + + if Present (Id) then + Force_Evaluation ( + Discr_Expr (J), + Related_Id => Id, + Discr_Number => J); + else + Force_Evaluation (Discr_Expr (J)); + end if; + end; + else + Force_Evaluation (Discr_Expr (J)); + end if; end if; -- Check that the designated type of an access discriminant's @@ -10554,7 +10633,7 @@ package body Sem_Ch3 is end if; Set_Etype (Def_Id, T); - Init_Size_Align (Def_Id); + Reinit_Size_Align (Def_Id); Set_Has_Discriminants (Def_Id, Has_Discrs); Set_Is_Constrained (Def_Id, Constrained); @@ -12689,7 +12768,7 @@ package body Sem_Ch3 is Set_Is_First_Subtype (Full, False); Set_Scope (Full, Scope (Priv)); Set_Size_Info (Full, Full_Base); - Set_RM_Size (Full, RM_Size (Full_Base)); + Copy_RM_Size (To => Full, From => Full_Base); Set_Is_Itype (Full); -- A subtype of a private-type-without-discriminants, whose full-view @@ -14516,7 +14595,7 @@ package body Sem_Ch3 is end if; Set_Size_Info (Def_Id, (T)); - Set_RM_Size (Def_Id, RM_Size (T)); + Copy_RM_Size (To => Def_Id, From => T); Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); -- If this is a range for a fixed-lower-bound subtype, then set the @@ -15320,12 +15399,12 @@ package body Sem_Ch3 is Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); - -- Note: We leave size as zero for now, size will be set at freeze + -- Note: We leave Esize unset for now, size will be set at freeze -- time. We have to do this for ordinary fixed-point, because the size -- depends on the specified small, and we might as well do the same for -- decimal fixed-point. - pragma Assert (Esize (Implicit_Base) = Uint_0); + pragma Assert (not Known_Esize (Implicit_Base)); -- If there are bounds given in the declaration use them as the -- bounds of the first named subtype. @@ -15676,7 +15755,7 @@ package body Sem_Ch3 is -- Set remaining characterstics of anonymous access type - Init_Alignment (Acc_Type); + Reinit_Alignment (Acc_Type); Set_Directly_Designated_Type (Acc_Type, Derived_Type); Set_Etype (New_Id, Acc_Type); @@ -19750,10 +19829,10 @@ package body Sem_Ch3 is Siz := Siz * 2; end loop; - Init_Esize (T, Siz); + Set_Esize (T, UI_From_Int (Siz)); else - Init_Esize (T, System_Max_Binary_Modulus_Power); + Set_Esize (T, UI_From_Int (System_Max_Binary_Modulus_Power)); end if; if not Non_Binary_Modulus (T) and then Esize (T) = RM_Size (T) then @@ -19788,7 +19867,7 @@ package body Sem_Ch3 is Set_Etype (T, T); Mutate_Ekind (T, E_Modular_Integer_Type); - Init_Alignment (T); + Reinit_Alignment (T); Set_Is_Constrained (T); if not Is_OK_Static_Expression (Mod_Expr) then @@ -19867,7 +19946,7 @@ package body Sem_Ch3 is Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); Set_Modular_Size (System_Max_Binary_Modulus_Power); - Init_Alignment (T); + Reinit_Alignment (T); end Modular_Type_Declaration; @@ -20189,7 +20268,7 @@ package body Sem_Ch3 is Mutate_Ekind (T, E_Ordinary_Fixed_Point_Subtype); Set_Etype (T, Implicit_Base); - Init_Size_Align (T); + Reinit_Size_Align (T); Inherit_Rep_Item_Chain (T, Implicit_Base); Set_Small_Value (T, Small_Val); Set_Delta_Value (T, Delta_Val); @@ -20591,8 +20670,8 @@ package body Sem_Ch3 is end if; Mutate_Ekind (Id, E_Discriminant); - Init_Component_Location (Id); - Init_Esize (Id); + Reinit_Component_Location (Id); + Reinit_Esize (Id); Set_Discriminant_Number (Id, Discr_Number); -- Make sure this is always set, even in illegal programs @@ -22260,7 +22339,7 @@ package body Sem_Ch3 is Mutate_Ekind (T, E_Record_Type); Set_Etype (T, T); - Init_Size_Align (T); + Reinit_Size_Align (T); Set_Interfaces (T, No_Elist); Set_Stored_Constraint (T, No_Elist); Set_Default_SSO (T); @@ -22369,7 +22448,7 @@ package body Sem_Ch3 is Set_Etype (Tag_Comp, RTE (RE_Tag)); Set_DT_Entry_Count (Tag_Comp, No_Uint); Set_Original_Record_Component (Tag_Comp, Tag_Comp); - Init_Component_Location (Tag_Comp); + Reinit_Component_Location (Tag_Comp); -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- implemented interfaces. @@ -22473,7 +22552,7 @@ package body Sem_Ch3 is and then not Is_Itype (Component) then Mutate_Ekind (Component, E_Component); - Init_Component_Location (Component); + Reinit_Component_Location (Component); end if; Propagate_Concurrent_Flags (T, Etype (Component)); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c052022..543ba12 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6626,7 +6626,7 @@ package body Sem_Ch4 is Get_Next_Interp (Index, It); end loop; end if; - else + elsif Has_Compatible_Type (R, T1) or else Covers (Etype (R), T1) then Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1)); end if; end Find_Non_Universal_Interpretations; @@ -8029,6 +8029,7 @@ package body Sem_Ch4 is while Present (It.Nam) loop if Is_Numeric_Type (It.Typ) and then Scope (It.Typ) = Standard_Standard + and then Ekind (It.Nam) = E_Operator then Set_Abstract_Op (I, Abstract_Op); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index f30a9aa..095bcda 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1768,11 +1768,16 @@ package body Sem_Ch7 is end if; -- Check preelaborable initialization for full type completing a - -- private type for which pragma Preelaborable_Initialization given. + -- private type when aspect Preelaborable_Initialization is True. + -- We pass True for the parameter Formal_Types_Have_Preelab_Init + -- to take into account the rule that presumes that subcomponents + -- of generic formal types mentioned in the type's P_I aspect have + -- preelaborable initialization (see RM 10.2.1(11.8/5)). if Is_Type (E) and then Must_Have_Preelab_Init (E) - and then not Has_Preelaborable_Initialization (E) + and then not Has_Preelaborable_Initialization + (E, Formal_Types_Have_Preelab_Init => True) then Error_Msg_N ("full view of & does not have preelaborable initialization", E); @@ -1891,7 +1896,7 @@ package body Sem_Ch7 is begin Generate_Definition (Id); Set_Is_Pure (Id, PF); - Init_Size_Align (Id); + Reinit_Size_Align (Id); if not Is_Package_Or_Generic_Package (Current_Scope) or else In_Private_Part (Current_Scope) @@ -2568,7 +2573,7 @@ package body Sem_Ch7 is Set_Etype (Id, Id); Set_Has_Delayed_Freeze (Id); Set_Is_First_Subtype (Id); - Init_Size_Align (Id); + Reinit_Size_Align (Id); Set_Is_Constrained (Id, No (Discriminant_Specifications (N)) @@ -2728,7 +2733,7 @@ package body Sem_Ch7 is begin Set_Size_Info (Priv, Full); - Set_RM_Size (Priv, RM_Size (Full)); + Copy_RM_Size (To => Priv, From => Full); Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time (Full)); Set_Is_Volatile (Priv, Is_Volatile (Full)); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 78d2426..a9f0f13 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1461,7 +1461,7 @@ package body Sem_Ch8 is Mutate_Ekind (Id, E_Variable); end if; - Init_Object_Size_Align (Id); + Reinit_Object_Size_Align (Id); -- If N comes from source then check that the original node is an -- object reference since there may have been several rewritting and diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index ab25dd0..5293efb 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2024,7 +2024,7 @@ package body Sem_Ch9 is Mutate_Ekind (T, E_Protected_Type); Set_Is_First_Subtype (T); - Init_Size_Align (T); + Reinit_Size_Align (T); Set_Etype (T, T); Set_Has_Delayed_Freeze (T); Set_Stored_Constraint (T, No_Elist); @@ -2143,7 +2143,7 @@ package body Sem_Ch9 is while Present (E) loop if Ekind (E) = E_Void then Mutate_Ekind (E, E_Component); - Init_Component_Location (E); + Reinit_Component_Location (E); end if; Next_Entity (E); @@ -3151,7 +3151,7 @@ package body Sem_Ch9 is Mutate_Ekind (T, E_Task_Type); Set_Is_First_Subtype (T, True); Set_Has_Task (T, True); - Init_Size_Align (T); + Reinit_Size_Align (T); Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); Set_Stored_Constraint (T, No_Elist); diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index b303229..538da57 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -318,7 +318,7 @@ package body Sem_Dim is (N : Node_Id; Description_Needed : Boolean := False) return String; -- Given a node N, return the dimension symbols of N, preceded by "has - -- dimension" if Description_Needed. if N is dimensionless, return "'[']", + -- dimension" if Description_Needed. If N is dimensionless, return "'[']", -- or "is dimensionless" if Description_Needed. function Dimension_System_Root (T : Entity_Id) return Entity_Id; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index a3a2864..6f81406 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3069,7 +3069,7 @@ package body Sem_Eval is -- Note that in this case, both Right_Int and Left_Int are set -- to No_Uint, so need to test for both. - if Right_Int = No_Uint then + if No (Right_Int) then Fold_Uint (N, Uint_0, Stat); else Fold_Uint (N, @@ -3083,7 +3083,7 @@ package body Sem_Eval is -- Note that in this case, both Right_Int and Left_Int are set -- to No_Uint, so need to test for both. - if Right_Int = No_Uint then + if No (Right_Int) then Fold_Uint (N, Uint_1, Stat); else Fold_Uint (N, @@ -5063,12 +5063,20 @@ package body Sem_Eval is -- result is always positive, even if the original operand was -- negative. - Fold_Uint - (N, - (Expr_Value (Left) + - (if Expr_Value (Left) >= Uint_0 then Uint_0 else Modulus)) - / (Uint_2 ** Expr_Value (Right)), - Static => Static); + declare + M : Unat; + begin + if Expr_Value (Left) >= Uint_0 then + M := Uint_0; + else + M := Modulus; + end if; + + Fold_Uint + (N, + (Expr_Value (Left) + M) / (Uint_2 ** Expr_Value (Right)), + Static => Static); + end; end if; elsif Op = N_Op_Shift_Right_Arithmetic then Check_Elab_Call; @@ -5741,6 +5749,8 @@ package body Sem_Eval is elsif Has_Dynamic_Predicate_Aspect (Typ) or else (Is_Derived_Type (Typ) and then Has_Aspect (Typ, Aspect_Dynamic_Predicate)) + or else (Has_Aspect (Typ, Aspect_Predicate) + and then not Has_Static_Predicate (Typ)) then return False; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0ff4e49..9cad55d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7562,7 +7562,7 @@ package body Sem_Prag is end if; if not Has_Alignment_Clause (Ent) then - Init_Alignment (Ent); + Reinit_Alignment (Ent); end if; end Set_Atomic_VFA; @@ -13400,11 +13400,11 @@ package body Sem_Prag is Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl); -- Perform minimal verification to ensure that the argument is at - -- least a variable or a type. Subsequent finer grained checks - -- will be done at the end of the declarative region that - -- contains the pragma. + -- least an object or a type. Subsequent finer grained checks will + -- be done at the end of the declarative region that contains the + -- pragma. - if Ekind (Obj_Or_Type_Id) = E_Variable + if Ekind (Obj_Or_Type_Id) in E_Constant | E_Variable or else Is_Type (Obj_Or_Type_Id) then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 03d747e..12b3295 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3454,7 +3454,6 @@ package body Sem_Res is procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); A : Node_Id; - A_Id : Entity_Id; A_Typ : Entity_Id := Empty; -- init to avoid warning F : Entity_Id; F_Typ : Entity_Id; @@ -4969,31 +4968,6 @@ package body Sem_Res is -- must be resolved first. Flag_Effectively_Volatile_Objects (A); - - -- An effectively volatile variable cannot act as an actual - -- parameter in a procedure call when the variable has enabled - -- property Effective_Reads and the corresponding formal is of - -- mode IN (SPARK RM 7.1.3(10)). - - if Ekind (Nam) = E_Procedure - and then Ekind (F) = E_In_Parameter - and then Is_Entity_Name (A) - then - A_Id := Entity (A); - - if Ekind (A_Id) = E_Variable - and then Is_Effectively_Volatile_For_Reading (Etype (A_Id)) - and then Effective_Reads_Enabled (A_Id) - then - Error_Msg_NE - ("effectively volatile variable & cannot appear as " - & "actual in procedure call", A, A_Id); - - Error_Msg_Name_1 := Name_Effective_Reads; - Error_Msg_N ("\\variable has enabled property %", A); - Error_Msg_N ("\\corresponding formal has mode IN", A); - end if; - end if; end if; -- A formal parameter of a specific tagged type whose related diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 01a4e2b..45a338a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -728,17 +728,6 @@ package body Sem_Util is return Make_Level_Literal (Typ_Access_Level (Etype (E))); - -- When E is a component of the current instance of a - -- protected type, we assume the level to be deeper than that of - -- the type itself. - - elsif not Is_Overloadable (E) - and then Ekind (Scope (E)) = E_Protected_Type - and then Comes_From_Source (Scope (E)) - then - return Make_Level_Literal - (Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1); - -- Check if E is an expansion-generated renaming of an iterator -- by examining Related_Expression. If so, determine the -- accessibility level based on the original expression. @@ -11802,7 +11791,7 @@ package body Sem_Util is -- Set to a factor of the offset from the base object when Expr is a -- selected or indexed component, based on Component_Bit_Offset and -- Component_Size respectively. A negative value is used to represent - -- a value which is not known at compile time. + -- a value that is not known at compile time. procedure Check_Prefix; -- Checks the prefix recursively in the case where the expression @@ -11901,7 +11890,7 @@ package body Sem_Util is Check_Prefix; Offs := Indexed_Component_Bit_Offset (Expr); - if Offs = No_Uint then + if No (Offs) then Offs := Component_Size (Typ); end if; end; @@ -11910,7 +11899,7 @@ package body Sem_Util is -- If we have a null offset, the result is entirely determined by -- the base object and has already been computed recursively. - if Offs = Uint_0 then + if Present (Offs) and then Offs = Uint_0 then null; -- Case where we know the alignment of the object @@ -11932,7 +11921,7 @@ package body Sem_Util is else -- If we have an offset, see if it is compatible - if Offs /= No_Uint and Offs > Uint_0 then + if Present (Offs) and then Offs > Uint_0 then if Offs mod (System_Storage_Unit * ObjA) /= 0 then Set_Result (Known_Incompatible); end if; @@ -11961,7 +11950,7 @@ package body Sem_Util is -- If we got an alignment, see if it is acceptable - if ExpA /= No_Uint and then ExpA < ObjA then + if Present (ExpA) and then ExpA < ObjA then Set_Result (Known_Incompatible); end if; @@ -11969,7 +11958,7 @@ package body Sem_Util is -- alignment, then we are fine. Otherwise, if its size is -- known, it must be big enough for the required alignment. - if Offs /= No_Uint then + if Present (Offs) then null; -- See if Expr is an object with known size @@ -11990,7 +11979,7 @@ package body Sem_Util is -- acceptable, since the size is always a multiple of the -- alignment. - if SizA /= No_Uint then + if Present (SizA) then if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then Set_Result (Known_Incompatible); end if; @@ -12001,7 +11990,7 @@ package body Sem_Util is -- If we do not know required alignment, any non-zero offset is a -- potential problem (but certainly may be OK, so result is unknown). - elsif Offs /= No_Uint then + elsif Present (Offs) then Set_Result (Unknown); -- If we can't find the result by direct comparison of alignment @@ -13399,7 +13388,10 @@ package body Sem_Util is -- Has_Preelaborable_Initialization -- -------------------------------------- - function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is + function Has_Preelaborable_Initialization + (E : Entity_Id; + Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean + is Has_PE : Boolean; procedure Check_Components (E : Entity_Id); @@ -13453,7 +13445,9 @@ package body Sem_Util is -- component type has PI. if No (Exp) then - if not Has_Preelaborable_Initialization (Etype (Ent)) then + if not Has_Preelaborable_Initialization + (Etype (Ent), Formal_Types_Have_Preelab_Init) + then Has_PE := False; exit; end if; @@ -13499,7 +13493,8 @@ package body Sem_Util is -- Array types have PI if the component type has PI elsif Is_Array_Type (E) then - Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); + Has_PE := Has_Preelaborable_Initialization + (Component_Type (E), Formal_Types_Have_Preelab_Init); -- A derived type has preelaborable initialization if its parent type -- has preelaborable initialization and (in the case of a derived record @@ -13510,6 +13505,14 @@ package body Sem_Util is elsif Is_Derived_Type (E) then + -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component + -- of a generic formal derived type has preelaborable initialization. + -- (See comment on spec of Has_Preelaborable_Initialization.) + + if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then + return True; + end if; + -- If the derived type is a private extension then it doesn't have -- preelaborable initialization. @@ -13545,7 +13548,16 @@ package body Sem_Util is -- have preelaborable initialization. elsif Is_Private_Type (E) then - return False; + + -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component + -- of a generic formal private type has preelaborable initialization. + -- (See comment on spec of Has_Preelaborable_Initialization.) + + if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then + return True; + else + return False; + end if; -- Record type has PI if it is non private and all components have PI @@ -15021,7 +15033,7 @@ package body Sem_Util is begin -- Return early if the component size is not known or variable - if Off = No_Uint or else Off < Uint_0 then + if No (Off) or else Off < Uint_0 then return No_Uint; end if; @@ -15544,7 +15556,7 @@ package body Sem_Util is -- Pragma Invalid_Scalars did not specify an invalid value for this -- type. Fall back to the value provided by the binder. - if Value = No_Uint then + if No (Value) then return Invalid_Binder_Value; else return Make_Integer_Literal (Loc, Intval => Value); @@ -16277,6 +16289,49 @@ package body Sem_Util is or else Is_Task_Interface (T); end Is_Concurrent_Interface; + ------------------------------------------------------ + -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes -- + ------------------------------------------------------ + + function Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Expr : Node_Id) return Boolean + is + + function Is_Formal_Preelab_Init_Attribute + (N : Node_Id) return Boolean; + -- Returns True if N is a Preelaborable_Initialization attribute + -- applied to a generic formal type, or N's Original_Node is such + -- an attribute. + + -------------------------------------- + -- Is_Formal_Preelab_Init_Attribute -- + -------------------------------------- + + function Is_Formal_Preelab_Init_Attribute + (N : Node_Id) return Boolean + is + Orig_N : constant Node_Id := Original_Node (N); + + begin + return Nkind (Orig_N) = N_Attribute_Reference + and then Attribute_Name (Orig_N) = Name_Preelaborable_Initialization + and then Is_Entity_Name (Prefix (Orig_N)) + and then Is_Generic_Type (Entity (Prefix (Orig_N))); + end Is_Formal_Preelab_Init_Attribute; + + -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes + + begin + return Is_Formal_Preelab_Init_Attribute (Expr) + or else (Nkind (Expr) = N_Op_And + and then + Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Left_Opnd (Expr)) + and then + Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Right_Opnd (Expr))); + end Is_Conjunction_Of_Formal_Preelab_Init_Attributes; + ----------------------- -- Is_Constant_Bound -- ----------------------- @@ -17483,9 +17538,9 @@ package body Sem_Util is -- Is_False -- -------------- - function Is_False (U : Uint) return Boolean is + function Is_False (U : Opt_Ubool) return Boolean is begin - return (U = 0); + return not Is_True (U); end Is_False; --------------------------- @@ -20981,9 +21036,9 @@ package body Sem_Util is -- Is_True -- ------------- - function Is_True (U : Uint) return Boolean is + function Is_True (U : Opt_Ubool) return Boolean is begin - return U /= 0; + return No (U) or else U = Uint_1; end Is_True; -------------------------------------- @@ -24920,7 +24975,7 @@ package body Sem_Util is Set_Public_Status (N); if Kind in Type_Kind then - Init_Size_Align (N); + Reinit_Size_Align (N); end if; return N; @@ -24944,7 +24999,7 @@ package body Sem_Util is Append_Entity (N, Scope_Id); if Kind in Type_Kind then - Init_Size_Align (N); + Reinit_Size_Align (N); end if; return N; @@ -25996,6 +26051,33 @@ package body Sem_Util is end if; end Original_Corresponding_Operation; + ----------------------------------- + -- Original_View_In_Visible_Part -- + ----------------------------------- + + function Original_View_In_Visible_Part + (Typ : Entity_Id) return Boolean + is + Scop : constant Entity_Id := Scope (Typ); + + begin + -- The scope must be a package + + if not Is_Package_Or_Generic_Package (Scop) then + return False; + end if; + + -- A type with a private declaration has a private view declared in + -- the visible part. + + if Has_Private_Declaration (Typ) then + return True; + end if; + + return List_Containing (Parent (Typ)) = + Visible_Declarations (Package_Specification (Scop)); + end Original_View_In_Visible_Part; + ------------------- -- Output_Entity -- ------------------- @@ -28178,7 +28260,7 @@ package body Sem_Util is begin -- Detect an attempt to set a different value for the same scalar type - pragma Assert (Slot = No_Uint); + pragma Assert (No (Slot)); Slot := Value; end Set_Invalid_Scalar_Value; @@ -28356,7 +28438,7 @@ package body Sem_Util is -- We copy Esize, but not RM_Size, since in general RM_Size is -- subtype specific and does not get inherited by all subtypes. - Set_Esize (T1, Esize (T2)); + Copy_Esize (To => T1, From => T2); Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2)); if Is_Discrete_Or_Fixed_Point_Type (T1) @@ -28405,7 +28487,7 @@ package body Sem_Util is -- Static_Boolean -- -------------------- - function Static_Boolean (N : Node_Id) return Uint is + function Static_Boolean (N : Node_Id) return Opt_Ubool is begin Analyze_And_Resolve (N, Standard_Boolean); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b0d6a2a..7c89585 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1530,9 +1530,18 @@ package Sem_Util is -- non-null), which causes the type to not have preelaborable -- initialization. - function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; + function Has_Preelaborable_Initialization + (E : Entity_Id; + Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean; -- Return True iff type E has preelaborable initialization as defined in -- Ada 2005 (see AI-161 for details of the definition of this attribute). + -- If Formal_Types_Have_Preelab_Init is True, indicates that the function + -- should presume that for any subcomponents of formal private or derived + -- types, the types have preelaborable initialization (RM 10.2.1(11.8/5)). + -- NOTE: The treatment of subcomponents of formal types should only apply + -- for types actually specified in the P_I aspect of the outer type, but + -- for now we take a more liberal interpretation. This needs addressing, + -- perhaps by passing the outermost type instead of the simple flag. ??? function Has_Prefix (N : Node_Id) return Boolean; -- Return True if N has attribute Prefix @@ -1828,6 +1837,13 @@ package Sem_Util is -- Returns true if the two specifications of the given -- nonoverridable aspect are compatible. + function Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Expr : Node_Id) return Boolean; + -- Returns True if Expr is a Preelaborable_Initialization attribute applied + -- to a formal type, or a sequence of two or more such attributes connected + -- by "and" operators, or if the Original_Node of Expr or its constituents + -- is such an attribute. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; -- Exp is the expression for an array bound. Determines whether the -- bound is a compile-time known value, or a constant entity, or an @@ -2038,11 +2054,17 @@ package Sem_Util is -- 3) An if expression with at least one EVF dependent_expression -- 4) A case expression with at least one EVF dependent_expression - function Is_False (U : Uint) return Boolean; + function Is_False (U : Opt_Ubool) 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). + -- True if U is Boolean'Pos (False) (i.e. Uint_0) + + function Is_True (U : Opt_Ubool) return Boolean; + pragma Inline (Is_True); + -- True if U is Boolean'Pos (True) (i.e. Uint_1). Also True if U is + -- No_Uint; we allow No_Uint because Static_Boolean returns that in + -- case of error. It doesn't really matter whether the error case is + -- considered True or False, but we don't want this to blow up in that + -- case. 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-point type @@ -2406,12 +2428,6 @@ package Sem_Util is -- unconditional transfer of control at run time, 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_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean; -- Determine whether an arbitrary entity denotes an instance of function -- Ada.Unchecked_Conversion. @@ -2845,6 +2861,10 @@ package Sem_Util is -- corresponding operation of S is the original corresponding operation of -- S2. Otherwise, it is S itself. + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; + -- Returns True if the type Typ has a private view or if the public view + -- appears in the visible part of a package spec. + procedure Output_Entity (Id : Entity_Id); -- Print entity Id to standard output. The name of the entity appears in -- fully qualified form. @@ -3199,7 +3219,7 @@ package Sem_Util is -- predefined unit. The _Par version should be called only from the parser; -- the _Sem version should be called only during semantic analysis. - function Static_Boolean (N : Node_Id) return Uint; + function Static_Boolean (N : Node_Id) return Opt_Ubool; -- This function analyzes the given expression node and then resolves it -- as Standard.Boolean. If the result is static, then Uint_1 or Uint_0 is -- returned corresponding to the value, otherwise an error message is diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index 7f9bb89..083c12e 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -191,7 +191,7 @@ package body Sinfo.Utils is function End_Location (N : Node_Id) return Source_Ptr is L : constant Uint := End_Span (N); begin - if L = No_Uint then + if No (L) then return No_Location; else return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L)); diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index a1ea3ee..8701ea9 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -258,6 +258,8 @@ package body Snames is return Pragma_Interrupt_Priority; when Name_Lock_Free => return Pragma_Lock_Free; + when Name_Preelaborable_Initialization => + return Pragma_Preelaborable_Initialization; when Name_Priority => return Pragma_Priority; when Name_Secondary_Stack_Size => @@ -488,6 +490,7 @@ package body Snames is or else N = Name_Interface or else N = Name_Interrupt_Priority or else N = Name_Lock_Free + or else N = Name_Preelaborable_Initialization or else N = Name_Priority or else N = Name_Secondary_Stack_Size or else N = Name_Storage_Size diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index a67623b..34f1cef 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -37,6 +37,17 @@ package Snames is -- some exceptions). See the body of Get_Attribute_Id for details. The -- same is true of other enumeration types declared in this package. + -- ALSO NOTE: In the case of a name that corresponds to both an attribute + -- and a pragma, the Name_Id must be defined in the attribute section + -- (between First_Attribute_Name and Last_Attribute_Name). Also, please + -- add a comment in the list of Name_Ids at the point where the name would + -- normally appear alphabetically (for an example, see comment starting + -- "Note: CPU ..."). The Pragma_Id with that name must be defined in the + -- last section of literals for type Pragma_Id (see set of Pragma_Ids that + -- require special processing due to matching an attribute name). Finally, + -- the bodies of functions Get_Pragma_Id and Is_Pragma_Name must be updated + -- to test for each such pragma that shares a name with an attribute. + ------------------ -- Preset Names -- ------------------ @@ -624,7 +635,13 @@ package Snames is Name_Precondition : constant Name_Id := N + $; -- GNAT Name_Predicate : constant Name_Id := N + $; -- GNAT Name_Predicate_Failure : constant Name_Id := N + $; -- Ada 12 - Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05 + + -- Note: Preelaborable_Initialization is not in this list because its name + -- matches 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_Name correctly recognize and process that pragma name. + -- Preelaborable_Initialization is a standard Ada 2005 pragma. + Name_Preelaborate : constant Name_Id := N + $; Name_Pre_Class : constant Name_Id := N + $; -- GNAT @@ -1007,6 +1024,7 @@ package Snames is Name_Pool_Address : constant Name_Id := N + $; -- GNAT Name_Pos : constant Name_Id := N + $; Name_Position : constant Name_Id := N + $; + Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 22 Name_Priority : constant Name_Id := N + $; -- Ada 05 Name_Range : constant Name_Id := N + $; Name_Range_Length : constant Name_Id := N + $; -- GNAT @@ -1536,6 +1554,7 @@ package Snames is Attribute_Pool_Address, Attribute_Pos, Attribute_Position, + Attribute_Preelaborable_Initialization, Attribute_Priority, Attribute_Range, Attribute_Range_Length, @@ -1921,7 +1940,6 @@ package Snames is Pragma_Precondition, Pragma_Predicate, Pragma_Predicate_Failure, - Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Pre_Class, Pragma_Provide_Shift_Operators, @@ -1974,7 +1992,9 @@ package Snames is -- The following pragmas are on their own, out of order, because of the -- special processing required to deal with the fact that their names - -- match existing attribute names. + -- match existing attribute names. Note that when a pragma is added in + -- this section, functions Get_Pragma_Id and Is_Pragma_Name must be + -- updated to account for the new pragma. Pragma_CPU, Pragma_Default_Scalar_Storage_Order, @@ -1983,6 +2003,7 @@ package Snames is Pragma_Interface, Pragma_Interrupt_Priority, Pragma_Lock_Free, + Pragma_Preelaborable_Initialization, Pragma_Priority, Pragma_Secondary_Stack_Size, Pragma_Storage_Size, diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index c1f1ede..8dc96a4 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -4222,7 +4222,7 @@ package body Sprint is -- Itype to be printed declare - B : constant Node_Id := Etype (Typ); + B : constant Entity_Id := Etype (Typ); P : constant Node_Id := Parent (Typ); S : constant Saved_Output_Buffer := Save_Output_Buffer; -- Save current output buffer diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index aa38c5c..ee951e3 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -643,11 +643,11 @@ long __gnat_invalid_tzoff = 259273; /* Reentrant localtime for Windows. */ extern void -__gnat_localtime_tzoff (const time_t *, const int *, long *); +__gnat_localtime_tzoff (const OS_Time *, const int *, long *); static const unsigned long long w32_epoch_offset = 11644473600ULL; void -__gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off) +__gnat_localtime_tzoff (const OS_Time *timer, const int *is_historic, long *off) { TIME_ZONE_INFORMATION tzi; @@ -737,10 +737,10 @@ __gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off) the Lynx convention when building against the legacy API. */ extern void -__gnat_localtime_tzoff (const time_t *, const int *, long *); +__gnat_localtime_tzoff (const OS_Time *, const int *, long *); void -__gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off) +__gnat_localtime_tzoff (const OS_Time *timer, const int *is_historic, long *off) { *off = 0; } @@ -756,21 +756,22 @@ extern void (*Lock_Task) (void); extern void (*Unlock_Task) (void); extern void -__gnat_localtime_tzoff (const time_t *, const int *, long *); +__gnat_localtime_tzoff (const OS_Time *, const int *, long *); void -__gnat_localtime_tzoff (const time_t *timer ATTRIBUTE_UNUSED, +__gnat_localtime_tzoff (const OS_Time *timer ATTRIBUTE_UNUSED, const int *is_historic ATTRIBUTE_UNUSED, long *off ATTRIBUTE_UNUSED) { struct tm tp ATTRIBUTE_UNUSED; + const time_t time = (time_t) *timer; /* AIX, HPUX, Sun Solaris */ #if defined (_AIX) || defined (__hpux__) || defined (__sun__) { (*Lock_Task) (); - localtime_r (timer, &tp); + localtime_r (&time, &tp); *off = (long) -timezone; (*Unlock_Task) (); @@ -787,7 +788,7 @@ __gnat_localtime_tzoff (const time_t *timer ATTRIBUTE_UNUSED, { (*Lock_Task) (); - localtime_r (timer, &tp); + localtime_r (&time, &tp); /* Try to read the environment variable TIMEZONE. The variable may not have been initialize, in that case return an offset of zero (0) for UTC. */ @@ -833,7 +834,7 @@ __gnat_localtime_tzoff (const time_t *timer ATTRIBUTE_UNUSED, || defined (__GLIBC__) || defined (__DragonFly__) || defined (__OpenBSD__) \ || defined (__DJGPP__) || defined (__QNX__) { - localtime_r (timer, &tp); + localtime_r (&time, &tp); *off = tp.tm_gmtoff; } diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 054d06c..48f76cb 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -614,7 +614,7 @@ package body Treepr is Write_Str (UI_Image (Val)); Write_Str (") "); - if Val /= No_Uint then + if Present (Val) then Write_Location (End_Location (N)); end if; end Print_End_Span; diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads index 5f59607..62a1c4f 100644 --- a/gcc/ada/ttypes.ads +++ b/gcc/ada/ttypes.ads @@ -25,7 +25,7 @@ -- This package contains constants describing target properties -with Types; use Types; +with Types; use Types; with Set_Targ; package Ttypes is diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index a74bfb6..2caaf50 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -59,6 +59,8 @@ package Types is subtype Pos is Int range 1 .. Int'Last; -- Positive Int values + subtype Nonzero_Int is Int with Predicate => Nonzero_Int /= 0; + type Word is mod 2 ** 32; -- Unsigned 32-bit integer diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 8183469..29d409b 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -73,6 +73,18 @@ package body Uintp is -- These values are used in some cases where the use of numeric literals -- would cause ambiguities (integer vs Uint). + type UI_Vector is array (Pos range <>) of Int; + -- Vector containing the integer values of a Uint value + + -- Note: An earlier version of this package used pointers of arrays of Ints + -- (dynamically allocated) for the Uint type. The change leads to a few + -- less natural idioms used throughout this code, but eliminates all uses + -- of the heap except for the table package itself. For example, Uint + -- parameters are often converted to UI_Vectors for internal manipulation. + -- This is done by creating the local UI_Vector using the function N_Digits + -- on the Uint to find the size needed for the vector, and then calling + -- Init_Operand to copy the values out of the table into the vector. + ---------------------------- -- UI_From_Int Hash Table -- ---------------------------- @@ -98,12 +110,12 @@ package body Uintp is -- Local Subprograms -- ----------------------- - function Direct (U : Uint) return Boolean; + function Direct (U : Valid_Uint) return Boolean; pragma Inline (Direct); -- Returns True if U is represented directly - function Direct_Val (U : Uint) return Int; - -- U is a Uint for is represented directly. The returned result is the + function Direct_Val (U : Valid_Uint) return Int; + -- U is a Uint that is represented directly. The returned result is the -- value represented. function GCD (Jin, Kin : Int) return Int; @@ -117,7 +129,7 @@ package body Uintp is -- UI_Image, and false for UI_Write, and Format is copied from the Format -- parameter to UI_Image or UI_Write. - procedure Init_Operand (UI : Uint; Vec : out UI_Vector); + procedure Init_Operand (UI : Valid_Uint; Vec : out UI_Vector); pragma Inline (Init_Operand); -- This procedure puts the value of UI into the vector in canonical -- multiple precision format. The parameter should be of the correct size @@ -127,7 +139,23 @@ package body Uintp is -- contain the corresponding one or two digit value. The low bound of Vec -- is always 1. - function Least_Sig_Digit (Arg : Uint) return Int; + function Vector_To_Uint + (In_Vec : UI_Vector; + Negative : Boolean) return Valid_Uint; + -- Functions that calculate values in UI_Vectors, call this function to + -- create and return the Uint value. In_Vec contains the multiple precision + -- (Base) representation of a non-negative value. Leading zeroes are + -- permitted. Negative is set if the desired result is the negative of the + -- given value. The result will be either the appropriate directly + -- represented value, or a table entry in the proper canonical format is + -- created and returned. + -- + -- Note that Init_Operand puts a signed value in the result vector, but + -- Vector_To_Uint is always presented with a non-negative value. The + -- processing of signs is something that is done by the caller before + -- calling Vector_To_Uint. + + function Least_Sig_Digit (Arg : Valid_Uint) return Int; pragma Inline (Least_Sig_Digit); -- Returns the Least Significant Digit of Arg quickly. When the given Uint -- is less than 2**15, the value returned is the input value, in this case @@ -137,8 +165,8 @@ package body Uintp is -- two. procedure Most_Sig_2_Digits - (Left : Uint; - Right : Uint; + (Left : Valid_Uint; + Right : Valid_Uint; Left_Hat : out Int; Right_Hat : out Int); -- Returns leading two significant digits from the given pair of Uint's. @@ -146,29 +174,40 @@ package body Uintp is -- K is as small as possible S.T. Right_Hat < Base * Base. It is required -- that Left >= Right for the algorithm to work. - function N_Digits (Input : Uint) return Int; + function N_Digits (Input : Valid_Uint) return Int; pragma Inline (N_Digits); -- Returns number of "digits" in a Uint procedure UI_Div_Rem - (Left, Right : Uint; + (Left, Right : Valid_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). + -- False then the quotient is returned in Quotient. If Discard_Remainder + -- is False, then the remainder is returned in Remainder. -- - -- If Discard_Quotient is True, Quotient is set to No_Uint - -- If Discard_Remainder is True, 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 UI_Modular_Exponentiation + (B : Valid_Uint; + E : Valid_Uint; + Modulo : Valid_Uint) return Valid_Uint with Unreferenced; + -- Efficiently compute (B**E) rem Modulo + + function UI_Modular_Inverse + (N : Valid_Uint; Modulo : Valid_Uint) return Valid_Uint with Unreferenced; + -- Compute the multiplicative inverse of N in modular arithmetics with the + -- given Modulo (uses Euclid's algorithm). Note: the call is considered + -- to be erroneous (and the behavior is undefined) if n is not invertible. ------------ -- Direct -- ------------ - function Direct (U : Uint) return Boolean is + function Direct (U : Valid_Uint) return Boolean is begin return Int (U) <= Int (Uint_Direct_Last); end Direct; @@ -177,7 +216,7 @@ package body Uintp is -- Direct_Val -- ---------------- - function Direct_Val (U : Uint) return Int is + function Direct_Val (U : Valid_Uint) return Int is begin pragma Assert (Direct (U)); return Int (U) - Int (Uint_Direct_Bias); @@ -224,8 +263,8 @@ package body Uintp is Format : UI_Format) is Marks : constant Uintp.Save_Mark := Uintp.Mark; - Base : Uint; - Ainput : Uint; + Base : Valid_Uint; + Ainput : Valid_Uint; Digs_Output : Natural := 0; -- Counts digits output. In hex mode, but not in decimal mode, we @@ -249,7 +288,7 @@ package body Uintp is -- Output non-zero exponent. Note that we only use the exponent form in -- the buffer case, so we know that To_Buffer is true. - procedure Image_Uint (U : Uint); + procedure Image_Uint (U : Valid_Uint); -- Internal procedure to output characters of non-negative Uint ------------------- @@ -257,8 +296,8 @@ package body Uintp is ------------------- function Better_In_Hex return Boolean is - T16 : constant Uint := Uint_2**Int'(16); - A : Uint; + T16 : constant Valid_Uint := Uint_2**Int'(16); + A : Valid_Uint; begin A := UI_Abs (Input); @@ -336,11 +375,11 @@ package body Uintp is -- Image_Uint -- ---------------- - procedure Image_Uint (U : Uint) is + procedure Image_Uint (U : Valid_Uint) is H : constant array (Int range 0 .. 15) of Character := "0123456789ABCDEF"; - Q, R : Uint; + Q, R : Valid_Uint; begin UI_Div_Rem (U, Base, Q, R); @@ -361,7 +400,7 @@ package body Uintp is -- Start of processing for Image_Out begin - if Input = No_Uint then + if No (Input) then Image_Char ('?'); return; end if; @@ -403,7 +442,7 @@ package body Uintp is -- Init_Operand -- ------------------- - procedure Init_Operand (UI : Uint; Vec : out UI_Vector) is + procedure Init_Operand (UI : Valid_Uint; Vec : out UI_Vector) is Loc : Int; pragma Assert (Vec'First = Int'(1)); @@ -454,7 +493,7 @@ package body Uintp is -- Least_Sig_Digit -- --------------------- - function Least_Sig_Digit (Arg : Uint) return Int is + function Least_Sig_Digit (Arg : Valid_Uint) return Int is V : Int; begin @@ -490,8 +529,8 @@ package body Uintp is ----------------------- procedure Most_Sig_2_Digits - (Left : Uint; - Right : Uint; + (Left : Valid_Uint; + Right : Valid_Uint; Left_Hat : out Int; Right_Hat : out Int) is @@ -552,9 +591,7 @@ package body Uintp is -- N_Digits -- --------------- - -- Note: N_Digits returns 1 for No_Uint - - function N_Digits (Input : Uint) return Int is + function N_Digits (Input : Valid_Uint) return Int is begin if Direct (Input) then if Direct_Val (Input) >= Base then @@ -572,7 +609,7 @@ package body Uintp is -- Num_Bits -- -------------- - function Num_Bits (Input : Uint) return Nat is + function Num_Bits (Input : Valid_Uint) return Nat is Bits : Nat; Num : Nat; @@ -633,7 +670,7 @@ package body Uintp is procedure Release (M : Save_Mark) is begin - Uints.Set_Last (Uint'Max (M.Save_Uint, Uints_Min)); + Uints.Set_Last (Valid_Uint'Max (M.Save_Uint, Uints_Min)); Udigits.Set_Last (Int'Max (M.Save_Udigit, Udigits_Min)); end Release; @@ -641,7 +678,7 @@ package body Uintp is -- Release_And_Save -- ---------------------- - procedure Release_And_Save (M : Save_Mark; UI : in out Uint) is + procedure Release_And_Save (M : Save_Mark; UI : in out Valid_Uint) is begin if Direct (UI) then Release (M); @@ -667,7 +704,7 @@ package body Uintp is end if; end Release_And_Save; - procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint) is + procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Valid_Uint) is begin if Direct (UI1) then Release_And_Save (M, UI2); @@ -713,7 +750,7 @@ package body Uintp is -- UI_Abs -- ------------- - function UI_Abs (Right : Uint) return Uint is + function UI_Abs (Right : Valid_Uint) return Unat is begin if Right < Uint_0 then return -Right; @@ -726,18 +763,23 @@ package body Uintp is -- UI_Add -- ------------- - function UI_Add (Left : Int; Right : Uint) return Uint is + function UI_Add (Left : Int; Right : Valid_Uint) return Valid_Uint is begin return UI_Add (UI_From_Int (Left), Right); end UI_Add; - function UI_Add (Left : Uint; Right : Int) return Uint is + function UI_Add (Left : Valid_Uint; Right : Int) return Valid_Uint is begin return UI_Add (Left, UI_From_Int (Right)); end UI_Add; - function UI_Add (Left : Uint; Right : Uint) return Uint is + function UI_Add (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint is begin + pragma Assert (Present (Left)); + pragma Assert (Present (Right)); + -- Assertions are here in case we're called from C++ code, which does + -- not check the predicates. + -- Simple cases of direct operands and addition of zero if Direct (Left) then @@ -902,7 +944,7 @@ package body Uintp is -- UI_Decimal_Digits_Hi -- -------------------------- - function UI_Decimal_Digits_Hi (U : Uint) return Nat is + function UI_Decimal_Digits_Hi (U : Valid_Uint) return Nat is begin -- The maximum value of a "digit" is 32767, which is 5 decimal digits, -- so an N_Digit number could take up to 5 times this number of digits. @@ -916,7 +958,7 @@ package body Uintp is -- UI_Decimal_Digits_Lo -- -------------------------- - function UI_Decimal_Digits_Lo (U : Uint) return Nat is + function UI_Decimal_Digits_Lo (U : Valid_Uint) return Nat is begin -- The maximum value of a "digit" is 32767, which is more than four -- decimal digits, but not a full five digits. The easily computed @@ -931,24 +973,27 @@ package body Uintp is -- UI_Div -- ------------ - function UI_Div (Left : Int; Right : Uint) return Uint is + function UI_Div (Left : Int; Right : Nonzero_Uint) return Valid_Uint is begin return UI_Div (UI_From_Int (Left), Right); end UI_Div; - function UI_Div (Left : Uint; Right : Int) return Uint is + function UI_Div + (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint + is begin return UI_Div (Left, UI_From_Int (Right)); end UI_Div; - function UI_Div (Left, Right : Uint) return Uint is - Quotient : Uint; - Remainder : Uint; - pragma Warnings (Off, Remainder); + function UI_Div + (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint + is + Quotient : Valid_Uint; + Ignored_Remainder : Uint; begin UI_Div_Rem (Left, Right, - Quotient, Remainder, + Quotient, Ignored_Remainder, Discard_Remainder => True); return Quotient; end UI_Div; @@ -958,7 +1003,7 @@ package body Uintp is ---------------- procedure UI_Div_Rem - (Left, Right : Uint; + (Left, Right : Valid_Uint; Quotient : out Uint; Remainder : out Uint; Discard_Quotient : Boolean := False; @@ -1232,14 +1277,13 @@ package body Uintp is if not Discard_Remainder then declare Remainder_V : UI_Vector (1 .. R_Length); - Discard_Int : Int; - pragma Warnings (Off, Discard_Int); + Ignore : Int; begin pragma Assert (D /= Int'(0)); UI_Div_Vector (Dividend (Dividend'Last - R_Length + 1 .. Dividend'Last), D, - Remainder_V, Discard_Int); + Remainder_V, Ignore); Remainder := Vector_To_Uint (Remainder_V, L_Vec (1) < Int_0); end; end if; @@ -1251,17 +1295,17 @@ package body Uintp is -- UI_Eq -- ------------ - function UI_Eq (Left : Int; Right : Uint) return Boolean is + function UI_Eq (Left : Int; Right : Valid_Uint) return Boolean is begin return not UI_Ne (UI_From_Int (Left), Right); end UI_Eq; - function UI_Eq (Left : Uint; Right : Int) return Boolean is + function UI_Eq (Left : Valid_Uint; Right : Int) return Boolean is begin return not UI_Ne (Left, UI_From_Int (Right)); end UI_Eq; - function UI_Eq (Left : Uint; Right : Uint) return Boolean is + function UI_Eq (Left : Valid_Uint; Right : Valid_Uint) return Boolean is begin return not UI_Ne (Left, Right); end UI_Eq; @@ -1270,22 +1314,24 @@ package body Uintp is -- UI_Expon -- -------------- - function UI_Expon (Left : Int; Right : Uint) return Uint is + function UI_Expon (Left : Int; Right : Unat) return Valid_Uint is begin return UI_Expon (UI_From_Int (Left), Right); end UI_Expon; - function UI_Expon (Left : Uint; Right : Int) return Uint is + function UI_Expon (Left : Valid_Uint; Right : Nat) return Valid_Uint is begin return UI_Expon (Left, UI_From_Int (Right)); end UI_Expon; - function UI_Expon (Left : Int; Right : Int) return Uint is + function UI_Expon (Left : Int; Right : Nat) return Valid_Uint is begin return UI_Expon (UI_From_Int (Left), UI_From_Int (Right)); end UI_Expon; - function UI_Expon (Left : Uint; Right : Uint) return Uint is + function UI_Expon + (Left : Valid_Uint; Right : Unat) return Valid_Uint + is begin pragma Assert (Right >= Uint_0); @@ -1358,9 +1404,9 @@ package body Uintp is -- If we fall through, then we have the general case (see Knuth 4.6.3) declare - N : Uint := Right; - Squares : Uint := Left; - Result : Uint := Uint_1; + N : Valid_Uint := Right; + Squares : Valid_Uint := Left; + Result : Valid_Uint := Uint_1; M : constant Uintp.Save_Mark := Uintp.Mark; begin @@ -1383,7 +1429,7 @@ package body Uintp is -- UI_From_CC -- ---------------- - function UI_From_CC (Input : Char_Code) return Uint is + function UI_From_CC (Input : Char_Code) return Valid_Uint is begin return UI_From_Int (Int (Input)); end UI_From_CC; @@ -1392,19 +1438,19 @@ package body Uintp is -- UI_From_Int -- ----------------- - function UI_From_Int (Input : Int) return Uint is + function UI_From_Int (Input : Int) return Valid_Uint is U : Uint; begin if Min_Direct <= Input and then Input <= Max_Direct then - return Uint (Int (Uint_Direct_Bias) + Input); + return Valid_Uint (Int (Uint_Direct_Bias) + Input); end if; -- If already in the hash table, return entry U := UI_Ints.Get (Input); - if U /= No_Uint then + if Present (U) then return U; end if; @@ -1438,7 +1484,7 @@ package body Uintp is -- UI_From_Integral -- ---------------------- - function UI_From_Integral (Input : In_T) return Uint is + function UI_From_Integral (Input : In_T) return Valid_Uint is begin -- If in range of our normal conversion function, use it so we can use -- direct access and our cache. @@ -1459,7 +1505,7 @@ package body Uintp is -- Base is defined so that 3 Uint digits is sufficient to hold the -- largest possible Int value. - U : Uint; + U : Valid_Uint; V : UI_Vector (1 .. Max_For_In_T); begin @@ -1489,8 +1535,8 @@ package body Uintp is -- We use the same notation as Knuth (U_Hat standing for the obvious) - function UI_GCD (Uin, Vin : Uint) return Uint is - U, V : Uint; + function UI_GCD (Uin, Vin : Valid_Uint) return Valid_Uint is + U, V : Valid_Uint; -- Copies of Uin and Vin U_Hat, V_Hat : Int; @@ -1498,7 +1544,7 @@ package body Uintp is A, B, C, D, T, Q, Den1, Den2 : Int; - Tmp_UI : Uint; + Tmp_UI : Valid_Uint; Marks : constant Uintp.Save_Mark := Uintp.Mark; Iterations : Integer := 0; @@ -1591,17 +1637,17 @@ package body Uintp is -- UI_Ge -- ------------ - function UI_Ge (Left : Int; Right : Uint) return Boolean is + function UI_Ge (Left : Int; Right : Valid_Uint) return Boolean is begin return not UI_Lt (UI_From_Int (Left), Right); end UI_Ge; - function UI_Ge (Left : Uint; Right : Int) return Boolean is + function UI_Ge (Left : Valid_Uint; Right : Int) return Boolean is begin return not UI_Lt (Left, UI_From_Int (Right)); end UI_Ge; - function UI_Ge (Left : Uint; Right : Uint) return Boolean is + function UI_Ge (Left : Valid_Uint; Right : Valid_Uint) return Boolean is begin return not UI_Lt (Left, Right); end UI_Ge; @@ -1610,17 +1656,17 @@ package body Uintp is -- UI_Gt -- ------------ - function UI_Gt (Left : Int; Right : Uint) return Boolean is + function UI_Gt (Left : Int; Right : Valid_Uint) return Boolean is begin return UI_Lt (Right, UI_From_Int (Left)); end UI_Gt; - function UI_Gt (Left : Uint; Right : Int) return Boolean is + function UI_Gt (Left : Valid_Uint; Right : Int) return Boolean is begin return UI_Lt (UI_From_Int (Right), Left); end UI_Gt; - function UI_Gt (Left : Uint; Right : Uint) return Boolean is + function UI_Gt (Left : Valid_Uint; Right : Valid_Uint) return Boolean is begin return UI_Lt (Left => Right, Right => Left); end UI_Gt; @@ -1647,7 +1693,10 @@ package body Uintp is -- UI_Is_In_Int_Range -- ------------------------- - function UI_Is_In_Int_Range (Input : Uint) return Boolean is + function UI_Is_In_Int_Range (Input : Valid_Uint) return Boolean is + pragma Assert (Present (Input)); + -- Assertion is here in case we're called from C++ code, which does + -- not check the predicates. begin -- Make sure we don't get called before Initialize @@ -1656,8 +1705,7 @@ package body Uintp is if Direct (Input) then return True; else - return Input >= Uint_Int_First - and then Input <= Uint_Int_Last; + return Input >= Uint_Int_First and then Input <= Uint_Int_Last; end if; end UI_Is_In_Int_Range; @@ -1665,17 +1713,17 @@ package body Uintp is -- UI_Le -- ------------ - function UI_Le (Left : Int; Right : Uint) return Boolean is + function UI_Le (Left : Int; Right : Valid_Uint) return Boolean is begin return not UI_Lt (Right, UI_From_Int (Left)); end UI_Le; - function UI_Le (Left : Uint; Right : Int) return Boolean is + function UI_Le (Left : Valid_Uint; Right : Int) return Boolean is begin return not UI_Lt (UI_From_Int (Right), Left); end UI_Le; - function UI_Le (Left : Uint; Right : Uint) return Boolean is + function UI_Le (Left : Valid_Uint; Right : Valid_Uint) return Boolean is begin return not UI_Lt (Left => Right, Right => Left); end UI_Le; @@ -1684,18 +1732,23 @@ package body Uintp is -- UI_Lt -- ------------ - function UI_Lt (Left : Int; Right : Uint) return Boolean is + function UI_Lt (Left : Int; Right : Valid_Uint) return Boolean is begin return UI_Lt (UI_From_Int (Left), Right); end UI_Lt; - function UI_Lt (Left : Uint; Right : Int) return Boolean is + function UI_Lt (Left : Valid_Uint; Right : Int) return Boolean is begin return UI_Lt (Left, UI_From_Int (Right)); end UI_Lt; - function UI_Lt (Left : Uint; Right : Uint) return Boolean is + function UI_Lt (Left : Valid_Uint; Right : Valid_Uint) return Boolean is begin + pragma Assert (Present (Left)); + pragma Assert (Present (Right)); + -- Assertions are here in case we're called from C++ code, which does + -- not check the predicates. + -- Quick processing for identical arguments if Int (Left) = Int (Right) then @@ -1777,17 +1830,17 @@ package body Uintp is -- UI_Max -- ------------ - function UI_Max (Left : Int; Right : Uint) return Uint is + function UI_Max (Left : Int; Right : Valid_Uint) return Valid_Uint is begin return UI_Max (UI_From_Int (Left), Right); end UI_Max; - function UI_Max (Left : Uint; Right : Int) return Uint is + function UI_Max (Left : Valid_Uint; Right : Int) return Valid_Uint is begin return UI_Max (Left, UI_From_Int (Right)); end UI_Max; - function UI_Max (Left : Uint; Right : Uint) return Uint is + function UI_Max (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint is begin if Left >= Right then return Left; @@ -1800,17 +1853,17 @@ package body Uintp is -- UI_Min -- ------------ - function UI_Min (Left : Int; Right : Uint) return Uint is + function UI_Min (Left : Int; Right : Valid_Uint) return Valid_Uint is begin return UI_Min (UI_From_Int (Left), Right); end UI_Min; - function UI_Min (Left : Uint; Right : Int) return Uint is + function UI_Min (Left : Valid_Uint; Right : Int) return Valid_Uint is begin return UI_Min (Left, UI_From_Int (Right)); end UI_Min; - function UI_Min (Left : Uint; Right : Uint) return Uint is + function UI_Min (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint is begin if Left <= Right then return Left; @@ -1823,18 +1876,22 @@ package body Uintp is -- UI_Mod -- ------------- - function UI_Mod (Left : Int; Right : Uint) return Uint is + function UI_Mod (Left : Int; Right : Nonzero_Uint) return Valid_Uint is begin return UI_Mod (UI_From_Int (Left), Right); end UI_Mod; - function UI_Mod (Left : Uint; Right : Int) return Uint is + function UI_Mod + (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint + is begin return UI_Mod (Left, UI_From_Int (Right)); end UI_Mod; - function UI_Mod (Left : Uint; Right : Uint) return Uint is - Urem : constant Uint := Left rem Right; + function UI_Mod + (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint + is + Urem : constant Valid_Uint := Left rem Right; begin if (Left < Uint_0) = (Right < Uint_0) @@ -1851,15 +1908,15 @@ package body Uintp is ------------------------------- function UI_Modular_Exponentiation - (B : Uint; - E : Uint; - Modulo : Uint) return Uint + (B : Valid_Uint; + E : Valid_Uint; + Modulo : Valid_Uint) return Valid_Uint is M : constant Save_Mark := Mark; - Result : Uint := Uint_1; - Base : Uint := B; - Exponent : Uint := E; + Result : Valid_Uint := Uint_1; + Base : Valid_Uint := B; + Exponent : Valid_Uint := E; begin while Exponent /= Uint_0 loop @@ -1879,15 +1936,17 @@ package body Uintp is -- UI_Modular_Inverse -- ------------------------ - function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint is + function UI_Modular_Inverse + (N : Valid_Uint; Modulo : Valid_Uint) return Valid_Uint + is M : constant Save_Mark := Mark; - U : Uint; - V : Uint; - Q : Uint; - R : Uint; - X : Uint; - Y : Uint; - T : Uint; + U : Valid_Uint; + V : Valid_Uint; + Q : Valid_Uint; + R : Valid_Uint; + X : Valid_Uint; + Y : Valid_Uint; + T : Valid_Uint; S : Int := 1; begin @@ -1923,17 +1982,17 @@ package body Uintp is -- UI_Mul -- ------------ - function UI_Mul (Left : Int; Right : Uint) return Uint is + function UI_Mul (Left : Int; Right : Valid_Uint) return Valid_Uint is begin return UI_Mul (UI_From_Int (Left), Right); end UI_Mul; - function UI_Mul (Left : Uint; Right : Int) return Uint is + function UI_Mul (Left : Valid_Uint; Right : Int) return Valid_Uint is begin return UI_Mul (Left, UI_From_Int (Right)); end UI_Mul; - function UI_Mul (Left : Uint; Right : Uint) return Uint is + function UI_Mul (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint is begin -- Case where product fits in the range of a 32-bit integer @@ -1991,20 +2050,24 @@ package body Uintp is -- UI_Ne -- ------------ - function UI_Ne (Left : Int; Right : Uint) return Boolean is + function UI_Ne (Left : Int; Right : Valid_Uint) return Boolean is begin return UI_Ne (UI_From_Int (Left), Right); end UI_Ne; - function UI_Ne (Left : Uint; Right : Int) return Boolean is + function UI_Ne (Left : Valid_Uint; Right : Int) return Boolean is begin return UI_Ne (Left, UI_From_Int (Right)); end UI_Ne; - function UI_Ne (Left : Uint; Right : Uint) return Boolean is + function UI_Ne (Left : Valid_Uint; Right : Valid_Uint) return Boolean is begin - -- Quick processing for identical arguments. Note that this takes - -- care of the case of two No_Uint arguments. + pragma Assert (Present (Left)); + pragma Assert (Present (Right)); + -- Assertions are here in case we're called from C++ code, which does + -- not check the predicates. + + -- Quick processing for identical arguments if Int (Left) = Int (Right) then return False; @@ -2062,7 +2125,7 @@ package body Uintp is -- UI_Negate -- ---------------- - function UI_Negate (Right : Uint) return Uint is + function UI_Negate (Right : Valid_Uint) return Valid_Uint is begin -- Case where input is directly represented. Note that since the range -- of Direct values is non-symmetrical, the result may not be directly @@ -2095,20 +2158,23 @@ package body Uintp is -- UI_Rem -- ------------- - function UI_Rem (Left : Int; Right : Uint) return Uint is + function UI_Rem (Left : Int; Right : Nonzero_Uint) return Valid_Uint is begin return UI_Rem (UI_From_Int (Left), Right); end UI_Rem; - function UI_Rem (Left : Uint; Right : Int) return Uint is + function UI_Rem + (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint + is begin return UI_Rem (Left, UI_From_Int (Right)); end UI_Rem; - function UI_Rem (Left, Right : Uint) return Uint is - Remainder : Uint; - Quotient : Uint; - pragma Warnings (Off, Quotient); + function UI_Rem + (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint + is + Remainder : Valid_Uint; + Ignored_Quotient : Uint; begin pragma Assert (Right /= Uint_0); @@ -2118,7 +2184,8 @@ package body Uintp is else UI_Div_Rem - (Left, Right, Quotient, Remainder, Discard_Quotient => True); + (Left, Right, Ignored_Quotient, Remainder, + Discard_Quotient => True); return Remainder; end if; end UI_Rem; @@ -2127,17 +2194,17 @@ package body Uintp is -- UI_Sub -- ------------ - function UI_Sub (Left : Int; Right : Uint) return Uint is + function UI_Sub (Left : Int; Right : Valid_Uint) return Valid_Uint is begin return UI_Add (Left, -Right); end UI_Sub; - function UI_Sub (Left : Uint; Right : Int) return Uint is + function UI_Sub (Left : Valid_Uint; Right : Int) return Valid_Uint is begin return UI_Add (Left, -Right); end UI_Sub; - function UI_Sub (Left : Uint; Right : Uint) return Uint is + function UI_Sub (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint is begin if Direct (Left) and then Direct (Right) then return UI_From_Int (Direct_Val (Left) - Direct_Val (Right)); @@ -2150,7 +2217,7 @@ package body Uintp is -- UI_To_CC -- -------------- - function UI_To_CC (Input : Uint) return Char_Code is + function UI_To_CC (Input : Valid_Uint) return Char_Code is begin if Direct (Input) then return Char_Code (Direct_Val (Input)); @@ -2183,9 +2250,7 @@ package body Uintp is -- UI_To_Int -- --------------- - function UI_To_Int (Input : Uint) return Int is - pragma Assert (Input /= No_Uint); - + function UI_To_Int (Input : Valid_Uint) return Int is begin if Direct (Input) then return Direct_Val (Input); @@ -2234,9 +2299,7 @@ package body Uintp is -- UI_To_Uns64 -- ----------------- - function UI_To_Unsigned_64 (Input : Uint) return Unsigned_64 is - pragma Assert (Input /= No_Uint); - + function UI_To_Unsigned_64 (Input : Valid_Uint) return Unsigned_64 is begin if Input < Uint_0 then raise Constraint_Error; @@ -2285,8 +2348,7 @@ package body Uintp is function Vector_To_Uint (In_Vec : UI_Vector; - Negative : Boolean) - return Uint + Negative : Boolean) return Valid_Uint is Size : Int; Val : Int; @@ -2306,9 +2368,9 @@ package body Uintp is if Size = Int_1 then if Negative then - return Uint (Int (Uint_Direct_Bias) - In_Vec (J)); + return Valid_Uint (Int (Uint_Direct_Bias) - In_Vec (J)); else - return Uint (Int (Uint_Direct_Bias) + In_Vec (J)); + return Valid_Uint (Int (Uint_Direct_Bias) + In_Vec (J)); end if; -- Positive two digit values may be in direct representation range @@ -2317,7 +2379,7 @@ package body Uintp is Val := In_Vec (J) * Base + In_Vec (J + 1); if Val <= Max_Direct then - return Uint (Int (Uint_Direct_Bias) + Val); + return Valid_Uint (Int (Uint_Direct_Bias) + Val); end if; end if; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index b2f2315..d9f1f8f 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -90,22 +90,23 @@ package Uintp is Uint_Minus_127 : constant Uint; Uint_Minus_128 : constant Uint; - subtype Valid_Uint is Uint with Predicate => Valid_Uint /= No_Uint; - subtype Unat is Valid_Uint with Predicate => Unat >= Uint_0; - subtype Upos is Valid_Uint with Predicate => Upos >= Uint_0; - subtype Nonzero_Uint is Valid_Uint with Predicate => Nonzero_Uint /= Uint_0; + -- Functions for detecting No_Uint. Note that clients of this package + -- cannot use "=" and "/=" to compare with No_Uint; they must use No + -- and Present instead. + + function No (X : Uint) return Boolean is (X = No_Uint); + -- Note that this is using the predefined "=", not the "=" declared below, + -- which would blow up on No_Uint. - type UI_Vector is array (Pos range <>) of Int; - -- Vector containing the integer values of a Uint value + function Present (X : Uint) return Boolean is (not No (X)); - -- Note: An earlier version of this package used pointers of arrays of Ints - -- (dynamically allocated) for the Uint type. The change leads to a few - -- less natural idioms used throughout this code, but eliminates all uses - -- of the heap except for the table package itself. For example, Uint - -- parameters are often converted to UI_Vectors for internal manipulation. - -- This is done by creating the local UI_Vector using the function N_Digits - -- on the Uint to find the size needed for the vector, and then calling - -- Init_Operand to copy the values out of the table into the vector. + subtype Valid_Uint is Uint with Predicate => Present (Valid_Uint); + subtype Unat is Valid_Uint with Predicate => Unat >= Uint_0; -- natural + subtype Upos is Valid_Uint with Predicate => Upos >= Uint_1; -- positive + subtype Nonzero_Uint is Valid_Uint with Predicate => Nonzero_Uint /= Uint_0; + subtype Ubool is Valid_Uint with Predicate => Ubool in Uint_0 | Uint_1; + subtype Opt_Ubool is Uint with + Predicate => No (Opt_Ubool) or else Opt_Ubool in Ubool; ----------------- -- Subprograms -- @@ -116,177 +117,150 @@ package Uintp is -- unit, these are among the few tables that can be expanded during -- gigi processing. - function UI_Abs (Right : Uint) return Uint; + function UI_Abs (Right : Valid_Uint) return Unat; pragma Inline (UI_Abs); -- Returns abs function of universal integer - function UI_Add (Left : Uint; Right : Uint) return Uint; - function UI_Add (Left : Int; Right : Uint) return Uint; - function UI_Add (Left : Uint; Right : Int) return Uint; + function UI_Add (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint; + function UI_Add (Left : Int; Right : Valid_Uint) return Valid_Uint; + function UI_Add (Left : Valid_Uint; Right : Int) return Valid_Uint; -- Returns sum of two integer values - function UI_Decimal_Digits_Hi (U : Uint) return Nat; + function UI_Decimal_Digits_Hi (U : Valid_Uint) return Nat; -- Returns an estimate of the number of decimal digits required to -- represent the absolute value of U. This estimate is correct or high, -- i.e. it never returns a value that is too low. The accuracy of the -- estimate affects only the effectiveness of comparison optimizations -- in Urealp. - function UI_Decimal_Digits_Lo (U : Uint) return Nat; + function UI_Decimal_Digits_Lo (U : Valid_Uint) return Nat; -- Returns an estimate of the number of decimal digits required to -- represent the absolute value of U. This estimate is correct or low, -- i.e. it never returns a value that is too high. The accuracy of the -- estimate affects only the effectiveness of comparison optimizations -- in Urealp. - function UI_Div (Left : Uint; Right : Uint) return Uint; - function UI_Div (Left : Int; Right : Uint) return Uint; - function UI_Div (Left : Uint; Right : Int) return Uint; + function UI_Div (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint; + function UI_Div (Left : Int; Right : Nonzero_Uint) return Valid_Uint; + function UI_Div (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint; -- Returns quotient of two integer values. Fatal error if Right = 0 - function UI_Eq (Left : Uint; Right : Uint) return Boolean; - function UI_Eq (Left : Int; Right : Uint) return Boolean; - function UI_Eq (Left : Uint; Right : Int) return Boolean; + function UI_Eq (Left : Valid_Uint; Right : Valid_Uint) return Boolean; + function UI_Eq (Left : Int; Right : Valid_Uint) return Boolean; + function UI_Eq (Left : Valid_Uint; Right : Int) return Boolean; pragma Inline (UI_Eq); -- Compares integer values for equality - function UI_Expon (Left : Uint; Right : Uint) return Uint; - function UI_Expon (Left : Int; Right : Uint) return Uint; - function UI_Expon (Left : Uint; Right : Int) return Uint; - function UI_Expon (Left : Int; Right : Int) return Uint; + function UI_Expon (Left : Valid_Uint; Right : Unat) return Valid_Uint; + function UI_Expon (Left : Int; Right : Unat) return Valid_Uint; + function UI_Expon (Left : Valid_Uint; Right : Nat) return Valid_Uint; + function UI_Expon (Left : Int; Right : Nat) return Valid_Uint; -- Returns result of exponentiating two integer values. -- Fatal error if Right is negative. - function UI_GCD (Uin, Vin : Uint) return Uint; + function UI_GCD (Uin, Vin : Valid_Uint) return Valid_Uint; -- Computes GCD of input values. Assumes Uin >= Vin >= 0 - function UI_Ge (Left : Uint; Right : Uint) return Boolean; - function UI_Ge (Left : Int; Right : Uint) return Boolean; - function UI_Ge (Left : Uint; Right : Int) return Boolean; + function UI_Ge (Left : Valid_Uint; Right : Valid_Uint) return Boolean; + function UI_Ge (Left : Int; Right : Valid_Uint) return Boolean; + function UI_Ge (Left : Valid_Uint; Right : Int) return Boolean; pragma Inline (UI_Ge); -- Compares integer values for greater than or equal - function UI_Gt (Left : Uint; Right : Uint) return Boolean; - function UI_Gt (Left : Int; Right : Uint) return Boolean; - function UI_Gt (Left : Uint; Right : Int) return Boolean; + function UI_Gt (Left : Valid_Uint; Right : Valid_Uint) return Boolean; + function UI_Gt (Left : Int; Right : Valid_Uint) return Boolean; + function UI_Gt (Left : Valid_Uint; Right : Int) return Boolean; pragma Inline (UI_Gt); -- Compares integer values for greater than - function UI_Is_In_Int_Range (Input : Uint) return Boolean; + function UI_Is_In_Int_Range (Input : Valid_Uint) return Boolean; pragma Inline (UI_Is_In_Int_Range); - -- Determines if universal integer is in Int range + -- Determines if universal integer is in Int range. - function UI_Le (Left : Uint; Right : Uint) return Boolean; - function UI_Le (Left : Int; Right : Uint) return Boolean; - function UI_Le (Left : Uint; Right : Int) return Boolean; + function UI_Le (Left : Valid_Uint; Right : Valid_Uint) return Boolean; + function UI_Le (Left : Int; Right : Valid_Uint) return Boolean; + function UI_Le (Left : Valid_Uint; Right : Int) return Boolean; pragma Inline (UI_Le); -- Compares integer values for less than or equal - function UI_Lt (Left : Uint; Right : Uint) return Boolean; - function UI_Lt (Left : Int; Right : Uint) return Boolean; - function UI_Lt (Left : Uint; Right : Int) return Boolean; + function UI_Lt (Left : Valid_Uint; Right : Valid_Uint) return Boolean; + function UI_Lt (Left : Int; Right : Valid_Uint) return Boolean; + function UI_Lt (Left : Valid_Uint; Right : Int) return Boolean; -- Compares integer values for less than - function UI_Max (Left : Uint; Right : Uint) return Uint; - function UI_Max (Left : Int; Right : Uint) return Uint; - function UI_Max (Left : Uint; Right : Int) return Uint; + function UI_Max (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint; + function UI_Max (Left : Int; Right : Valid_Uint) return Valid_Uint; + function UI_Max (Left : Valid_Uint; Right : Int) return Valid_Uint; -- Returns maximum of two integer values - function UI_Min (Left : Uint; Right : Uint) return Uint; - function UI_Min (Left : Int; Right : Uint) return Uint; - function UI_Min (Left : Uint; Right : Int) return Uint; + function UI_Min (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint; + function UI_Min (Left : Int; Right : Valid_Uint) return Valid_Uint; + function UI_Min (Left : Valid_Uint; Right : Int) return Valid_Uint; -- Returns minimum of two integer values - function UI_Mod (Left : Uint; Right : Uint) return Uint; - function UI_Mod (Left : Int; Right : Uint) return Uint; - function UI_Mod (Left : Uint; Right : Int) return Uint; + function UI_Mod (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint; + function UI_Mod (Left : Int; Right : Nonzero_Uint) return Valid_Uint; + function UI_Mod (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint; pragma Inline (UI_Mod); -- Returns mod function of two integer values - function UI_Mul (Left : Uint; Right : Uint) return Uint; - function UI_Mul (Left : Int; Right : Uint) return Uint; - function UI_Mul (Left : Uint; Right : Int) return Uint; + function UI_Mul (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint; + function UI_Mul (Left : Int; Right : Valid_Uint) return Valid_Uint; + function UI_Mul (Left : Valid_Uint; Right : Int) return Valid_Uint; -- Returns product of two integer values - function UI_Ne (Left : Uint; Right : Uint) return Boolean; - function UI_Ne (Left : Int; Right : Uint) return Boolean; - function UI_Ne (Left : Uint; Right : Int) return Boolean; + function UI_Ne (Left : Valid_Uint; Right : Valid_Uint) return Boolean; + function UI_Ne (Left : Int; Right : Valid_Uint) return Boolean; + function UI_Ne (Left : Valid_Uint; Right : Int) return Boolean; pragma Inline (UI_Ne); -- Compares integer values for inequality - function UI_Negate (Right : Uint) return Uint; + function UI_Negate (Right : Valid_Uint) return Valid_Uint; pragma Inline (UI_Negate); -- Returns negative of universal integer - function UI_Rem (Left : Uint; Right : Uint) return Uint; - function UI_Rem (Left : Int; Right : Uint) return Uint; - function UI_Rem (Left : Uint; Right : Int) return Uint; + function UI_Rem (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint; + function UI_Rem (Left : Int; Right : Nonzero_Uint) return Valid_Uint; + function UI_Rem (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint; -- Returns rem of two integer values - function UI_Sub (Left : Uint; Right : Uint) return Uint; - function UI_Sub (Left : Int; Right : Uint) return Uint; - function UI_Sub (Left : Uint; Right : Int) return Uint; + function UI_Sub (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint; + function UI_Sub (Left : Int; Right : Valid_Uint) return Valid_Uint; + function UI_Sub (Left : Valid_Uint; Right : Int) return Valid_Uint; pragma Inline (UI_Sub); -- Returns difference of two integer values - function UI_Modular_Exponentiation - (B : Uint; - E : Uint; - Modulo : Uint) return Uint; - -- Efficiently compute (B**E) rem Modulo - - function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint; - -- Compute the multiplicative inverse of N in modular arithmetics with the - -- 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_Int (Input : Int) return Uint; + function UI_From_Int (Input : Int) return Valid_Uint; -- Converts Int value to universal integer form generic type In_T is range <>; - function UI_From_Integral (Input : In_T) return Uint; + function UI_From_Integral (Input : In_T) return Valid_Uint; -- Likewise, but converts from any integer type. Must not be applied to -- biased types (instantiation will provide a warning if actual is a biased -- type). - function UI_From_CC (Input : Char_Code) return Uint; + function UI_From_CC (Input : Char_Code) return Valid_Uint; -- Converts Char_Code value to universal integer form - function UI_To_Int (Input : Uint) return Int; + function UI_To_Int (Input : Valid_Uint) return Int; -- Converts universal integer value to Int. Constraint_Error if value is -- not in appropriate range. type Unsigned_64 is mod 2**64; - function UI_To_Unsigned_64 (Input : Uint) return Unsigned_64; + function UI_To_Unsigned_64 (Input : Valid_Uint) return Unsigned_64; -- Converts universal integer value to Unsigned_64. Constraint_Error if -- value is not in appropriate range. - function UI_To_CC (Input : Uint) return Char_Code; + function UI_To_CC (Input : Valid_Uint) return Char_Code; -- Converts universal integer value to Char_Code. Constraint_Error if value -- is not in Char_Code range. - function Num_Bits (Input : Uint) return Nat; + function Num_Bits (Input : Valid_Uint) return Nat; -- Approximate number of binary bits in given universal integer. This -- function is used for capacity checks, and it can be one bit off -- without affecting its usage. - function Vector_To_Uint - (In_Vec : UI_Vector; - Negative : Boolean) return Uint; - -- Functions that calculate values in UI_Vectors, call this function to - -- create and return the Uint value. In_Vec contains the multiple precision - -- (Base) representation of a non-negative value. Leading zeroes are - -- permitted. Negative is set if the desired result is the negative of the - -- given value. The result will be either the appropriate directly - -- represented value, or a table entry in the proper canonical format is - -- created and returned. - -- - -- Note that Init_Operand puts a signed value in the result vector, but - -- Vector_To_Uint is always presented with a non-negative value. The - -- processing of signs is something that is done by the caller before - -- calling Vector_To_Uint. - --------------------- -- Output Routines -- --------------------- @@ -338,58 +312,97 @@ package Uintp is -- Operator Renamings -- ------------------------ - function "+" (Left : Uint; Right : Uint) return Uint renames UI_Add; - function "+" (Left : Int; Right : Uint) return Uint renames UI_Add; - function "+" (Left : Uint; Right : Int) return Uint renames UI_Add; - - function "/" (Left : Uint; Right : Uint) return Uint renames UI_Div; - function "/" (Left : Int; Right : Uint) return Uint renames UI_Div; - function "/" (Left : Uint; Right : Int) return Uint renames UI_Div; - - function "*" (Left : Uint; Right : Uint) return Uint renames UI_Mul; - function "*" (Left : Int; Right : Uint) return Uint renames UI_Mul; - function "*" (Left : Uint; Right : Int) return Uint renames UI_Mul; - - function "-" (Left : Uint; Right : Uint) return Uint renames UI_Sub; - function "-" (Left : Int; Right : Uint) return Uint renames UI_Sub; - function "-" (Left : Uint; Right : Int) return Uint renames UI_Sub; - - function "**" (Left : Uint; Right : Uint) return Uint renames UI_Expon; - function "**" (Left : Uint; Right : Int) return Uint renames UI_Expon; - function "**" (Left : Int; Right : Uint) return Uint renames UI_Expon; - function "**" (Left : Int; Right : Int) return Uint renames UI_Expon; - - function "abs" (Real : Uint) return Uint renames UI_Abs; - - function "mod" (Left : Uint; Right : Uint) return Uint renames UI_Mod; - function "mod" (Left : Int; Right : Uint) return Uint renames UI_Mod; - function "mod" (Left : Uint; Right : Int) return Uint renames UI_Mod; - - function "rem" (Left : Uint; Right : Uint) return Uint renames UI_Rem; - function "rem" (Left : Int; Right : Uint) return Uint renames UI_Rem; - function "rem" (Left : Uint; Right : Int) return Uint renames UI_Rem; - - function "-" (Real : Uint) return Uint renames UI_Negate; - - function "=" (Left : Uint; Right : Uint) return Boolean renames UI_Eq; - function "=" (Left : Int; Right : Uint) return Boolean renames UI_Eq; - function "=" (Left : Uint; Right : Int) return Boolean renames UI_Eq; - - function ">=" (Left : Uint; Right : Uint) return Boolean renames UI_Ge; - function ">=" (Left : Int; Right : Uint) return Boolean renames UI_Ge; - function ">=" (Left : Uint; Right : Int) return Boolean renames UI_Ge; - - function ">" (Left : Uint; Right : Uint) return Boolean renames UI_Gt; - function ">" (Left : Int; Right : Uint) return Boolean renames UI_Gt; - function ">" (Left : Uint; Right : Int) return Boolean renames UI_Gt; - - function "<=" (Left : Uint; Right : Uint) return Boolean renames UI_Le; - function "<=" (Left : Int; Right : Uint) return Boolean renames UI_Le; - function "<=" (Left : Uint; Right : Int) return Boolean renames UI_Le; - - function "<" (Left : Uint; Right : Uint) return Boolean renames UI_Lt; - function "<" (Left : Int; Right : Uint) return Boolean renames UI_Lt; - function "<" (Left : Uint; Right : Int) return Boolean renames UI_Lt; + function "+" (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint + renames UI_Add; + function "+" (Left : Int; Right : Valid_Uint) return Valid_Uint + renames UI_Add; + function "+" (Left : Valid_Uint; Right : Int) return Valid_Uint + renames UI_Add; + + function "/" (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint + renames UI_Div; + function "/" (Left : Int; Right : Nonzero_Uint) return Valid_Uint + renames UI_Div; + function "/" (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint + renames UI_Div; + + function "*" (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint + renames UI_Mul; + function "*" (Left : Int; Right : Valid_Uint) return Valid_Uint + renames UI_Mul; + function "*" (Left : Valid_Uint; Right : Int) return Valid_Uint + renames UI_Mul; + + function "-" (Left : Valid_Uint; Right : Valid_Uint) return Valid_Uint + renames UI_Sub; + function "-" (Left : Int; Right : Valid_Uint) return Valid_Uint + renames UI_Sub; + function "-" (Left : Valid_Uint; Right : Int) return Valid_Uint + renames UI_Sub; + + function "**" (Left : Valid_Uint; Right : Unat) return Valid_Uint + renames UI_Expon; + function "**" (Left : Valid_Uint; Right : Nat) return Valid_Uint + renames UI_Expon; + function "**" (Left : Int; Right : Unat) return Valid_Uint + renames UI_Expon; + function "**" (Left : Int; Right : Nat) return Valid_Uint + renames UI_Expon; + + function "abs" (Real : Valid_Uint) return Unat + renames UI_Abs; + + function "mod" (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint + renames UI_Mod; + function "mod" (Left : Int; Right : Nonzero_Uint) return Valid_Uint + renames UI_Mod; + function "mod" (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint + renames UI_Mod; + + function "rem" (Left : Valid_Uint; Right : Nonzero_Uint) return Valid_Uint + renames UI_Rem; + function "rem" (Left : Int; Right : Nonzero_Uint) return Valid_Uint + renames UI_Rem; + function "rem" (Left : Valid_Uint; Right : Nonzero_Int) return Valid_Uint + renames UI_Rem; + + function "-" (Real : Valid_Uint) return Valid_Uint + renames UI_Negate; + + function "=" (Left : Valid_Uint; Right : Valid_Uint) return Boolean + renames UI_Eq; + function "=" (Left : Int; Right : Valid_Uint) return Boolean + renames UI_Eq; + function "=" (Left : Valid_Uint; Right : Int) return Boolean + renames UI_Eq; + + function ">=" (Left : Valid_Uint; Right : Valid_Uint) return Boolean + renames UI_Ge; + function ">=" (Left : Int; Right : Valid_Uint) return Boolean + renames UI_Ge; + function ">=" (Left : Valid_Uint; Right : Int) return Boolean + renames UI_Ge; + + function ">" (Left : Valid_Uint; Right : Valid_Uint) return Boolean + renames UI_Gt; + function ">" (Left : Int; Right : Valid_Uint) return Boolean + renames UI_Gt; + function ">" (Left : Valid_Uint; Right : Int) return Boolean + renames UI_Gt; + + function "<=" (Left : Valid_Uint; Right : Valid_Uint) return Boolean + renames UI_Le; + function "<=" (Left : Int; Right : Valid_Uint) return Boolean + renames UI_Le; + function "<=" (Left : Valid_Uint; Right : Int) return Boolean + renames UI_Le; + + function "<" (Left : Valid_Uint; Right : Valid_Uint) return Boolean + renames UI_Lt; + function "<" (Left : Int; Right : Valid_Uint) return Boolean + renames UI_Lt; + function "<" (Left : Valid_Uint; Right : Int) return Boolean + renames UI_Lt; ----------------------------- -- Mark/Release Processing -- @@ -409,12 +422,12 @@ package Uintp is procedure Release (M : Save_Mark); -- Release storage allocated since mark was noted - procedure Release_And_Save (M : Save_Mark; UI : in out Uint); + procedure Release_And_Save (M : Save_Mark; UI : in out Valid_Uint); -- Like Release, except that the given Uint value (which is typically among -- the data being released) is recopied after the release, so that it is -- the most recent item, and UI is updated to point to its copied location. - procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint); + procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Valid_Uint); -- Like Release, except that the given Uint values (which are typically -- among the data being released) are recopied after the release, so that -- they are the most recent items, and UI1 and UI2 are updated if necessary @@ -518,7 +531,7 @@ private -- UI_Mul to efficiently compute the product in this case. type Save_Mark is record - Save_Uint : Uint; + Save_Uint : Valid_Uint; Save_Udigit : Int; end record; @@ -537,8 +550,9 @@ private -- Some subprograms defined in this package manipulate the Udigits table -- directly, while for others it is more convenient to work with locally -- defined arrays of the digits of the Universal Integers. The type - -- UI_Vector is defined for this purpose and some internal subprograms - -- used for converting from one to the other are defined. + -- UI_Vector is declared in the package body for this purpose and some + -- internal subprograms used for converting from one to the other are + -- defined. type Uint_Entry is record Length : aliased Pos; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index c88ccec..bca3527 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -483,8 +483,10 @@ begin 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 (" .c+ turn on warnings for components without " & + "representation clauses"); + Write_Line (" .C* turn off warnings for components without " & + "representation clauses"); Write_Line (" _c* turn on warnings for unknown " & "Compile_Time_Warning"); Write_Line (" _C turn off warnings for unknown " & |