diff options
| author | Ian Lance Taylor <ian@gcc.gnu.org> | 2018-09-25 01:02:42 +0000 |
|---|---|---|
| committer | Ian Lance Taylor <ian@gcc.gnu.org> | 2018-09-25 01:02:42 +0000 |
| commit | 5055f108385c076346b3b279788dc0129549b11f (patch) | |
| tree | 91456c9f0ec368308f734e6d649b046d57a19114 /gcc/ada | |
| parent | 414925ab0cb8d0aea39cb3383b18f72f3ce887a0 (diff) | |
| parent | 44eb8fa73bb53afa17e4d72b1c073d0e08a76866 (diff) | |
| download | gcc-5055f108385c076346b3b279788dc0129549b11f.zip gcc-5055f108385c076346b3b279788dc0129549b11f.tar.gz gcc-5055f108385c076346b3b279788dc0129549b11f.tar.bz2 | |
Merge from trunk revision 264547.
From-SVN: r264554
Diffstat (limited to 'gcc/ada')
82 files changed, 7053 insertions, 3796 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c6f1911..e51a2a3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,325 @@ +2018-09-24 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/87396 + * fe.h (Get_Attribute_Definition_Clause): Use 'unsigned char' instead + of 'char' as the type of the second parameter. + +2018-09-13 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (arm% linux-gnueabi%): Always set EH_MECHANISM to -arm. + +2018-09-13 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/81103 + * terminals.c: Do not include termio.h. + +2018-08-27 Martin Liska <mliska@suse.cz> + + * gcc-interface/decl.c (update_profile): Use new function + fndecl_built_in_p and remove check for FUNCTION_DECL if + possible. + * gcc-interface/gigi.h (call_is_atomic_load): Likewise. + * gcc-interface/utils.c (gnat_pushdecl): Likewise. + +2018-08-23 Giuliano Belinassi <giuliano.belinassi@usp.br> + + * exp_unst.ads: Fix typo 'exapnded' to 'expanded'. + +2018-08-21 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb, contracts.adb, exp_aggr.adb, exp_attr.adb, + exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, exp_unst.adb, + exp_util.adb, freeze.adb, gnatlink.adb, layout.adb, + lib-writ.adb, lib-xref-spark_specific.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch6.adb, sem_res.adb, sem_util.adb, sinfo.ads, + sprint.adb: Minor reformatting. + +2018-08-21 Jerome Lambourg <lambourg@adacore.com> + + * vxlink-bind.adb, vxlink-bind.ads, vxlink-link.adb, + vxlink-link.ads, vxlink-main.adb, vxlink.adb, vxlink.ads: Add a + new tool vxlink to handle VxWorks constructors in DKMs. + * gcc-interface/Makefile.in: add rules to build vxlink + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper, Mask_Type): + Refine the handling of freezing types for expression functions + that are not completions, when analyzing the generated body for + the function: the body is inserted at the end of the enclosing + declarative part, and its analysis may freeze types declared in + the same scope that have not been frozen yet. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb: Remove Freeze_Expr_Types. + * freeze.ads, freeze.adb (Freeze_Expr_Types): Moved from + sem_ch6.adb, and extended to handle other expressions that may + contain unfrozen types that must be frozen in their proper + scopes. + * contracts.adb (Analyze_Entry_Or_Subprogram_Contract): If the + contract is for the generated body of an expression function + that is a completion, traverse the expressions for pre- and + postconditions to freeze all types before adding the contract + code within the subprogram body. + +2018-08-21 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch10.adb: Remove the with and use clause for unit Ghost. + (Analyze_With_Clause): Do not mark a with clause which mentions + an ignored Ghost code for elimination. + +2018-08-21 Javier Miranda <miranda@adacore.com> + + * lib-writ.adb (Write_Unit_Information): Handle pragmas removed + by the expander. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Check_Synchronized_Overriding): The conformance + between an overriding protected operation and the overridden + abstract progenitor operation requires subtype conformance; + requiring equality of return types in the case of a function is + too restrictive and leads to spurious errors when the return + type is a generic actual. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.adb (Expand_N_Timed_Entry_Call, + Expand_Conditional_Entry_Call): Use Reset_Scopes_Of to set + properly the scope of all entities created in blocks generated + by the expansion of these constructs. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functioss): Apply + Reset_Quantified_Variables_Scope after predicate function has + been analyzed, so that the scope can be reset on the generated + loop statements that have replaced the quantified expressions. + +2018-08-21 Bob Duff <duff@adacore.com> + + * einfo.ads, einfo.adb (Private_View, Shadow_Entities): Remove + obsolete code. + +2018-08-21 Maroua Maalej <maalej@adacore.com> + + * sem_spark.adb (Check_Call_Statement): Check global and formal + parameter permissions at call sites. + (Check_Callable_Body): Assume permissions on globals and + parameters depending on their modes then analyse the body + operations. + (Check_Declaration): Consider both deep (including elementary + access) object declarations and normal variables. First check + whether the deep object is of Ownership Aspec True or not, then, + depending on its initialization, assign the appropriate state. + Check related to non access type variables deal with + initialization value permissions. + (Check_Expression): Check nodes used in the expression being + analyzed. + (Check_Globals): Call by Check_Call_Statement to perform the + check on globals. + (Check_List): Call Check_Node on each element of the list. + (Check_Loop_Statement): Check the Iteration_Scheme and loop + statements. + (Check_Node): Main traversal procedure to check safe pointer usage. + (Check_Package_Body): Check subprogram's body. + (Check_Param_In): Take a formal and an actual parameter and + Check the permission of every in-mode parameter. + (Check_Param_Out): Take a formal and an actual parameter and + check the state of out-mode and in out-mode parameters. + (Check_Statement): Check statements other than procedure call. + (Get_Perm, Get_Perm_Or_Tree, Get_Perm_Tree): Find out the state + related to the given name. + (Is_Deep): Return True if an object is of access type or has + subfields of access type. + (Perm_Error, Perm_Error_Subprogram_End): Add an error message + whenever the found state on the given name is different from the + one expected (in the statement being analyzed). + (Process_Path): Given an operation and a current state, call + Perm_Error if there is any mismatch. + (Return_Declarations, Return_Globals, Return_The_Global): Check + the state of a given name at the end of the subprogram. These + procedures may change depending on how we shall finally deal + with globals and the rhs state in a move operation. + (Set_Perm_Extensions, Set_Perm_Prefixes_Borrow, + Set_Perm_Prefixes, Setup_Globals, Setup_Parameter_Or_Global, + Setup_Parameters): Set up the new states to the given node and + up and down the tree after an operation. + (Has_Ownership_Aspect_True): This function may disappear later + when the Ownership Aspect will be implemented in the FE. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Call): Resolve correctly a parameterless + call that returns an access type whose designated type is the + component type of an array, when the function has no defaulted + parameters. + +2018-08-21 Yannick Moy <moy@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Document entries of the target parametrization file. + * gnat_ugn.texi: Regenerate. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb: Set scope of elaboration flag for 'Access. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sprint.adb: Add guard on printing aspects. + +2018-08-21 Javier Miranda <miranda@adacore.com> + + * exp_cg.adb (Generate_CG_Output): Handle calls removed by the + expander. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * layout.adb: Do not set size of access subprogram if unnesting. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb: Remove warnings for access to subprograms when + unnesting is active. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_Array_Aggregate): If the component type + is limited, the array must be constructed in place, so set flag + In_Place_Assign_OK_For_Declaration accordingly. This prevents + improper copying of an array of tasks during initialization. + +2018-08-21 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Call_to_gnu): Always suppress an + unchecked conversion around the actual for an In parameter + passed by copy. + +2018-08-21 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Is_Possibly_Unaligned_Object): For the case of a + selected component inherited in a record extension and subject + to a representation clause, retrieve the position and size from + the original record component. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_util.ads, sem_util.adb (New_External_Entity): Type of + Suffix_Index must be Int, not Nat, so that a negative value can + be used to generate a unique name for an external object, as + specified in Tbuild.New_External_Name. + (Scope_Within): Handle private type whose completion is a + synchronized type (For unnesting). + * itypes.ads, itypes.adb (Create_Itype): Ditto + * sem_ch3.adb (Constrain_Corresponding_Record): Generate a + unique name for the created subtype, because there may be + several discriminated tasks present in the same scope, and each + needs its distinct corresponding record subtype. + +2018-08-21 Yannick Moy <moy@adacore.com> + + * doc/gnat_ugn/gnat_and_program_execution.rst: Update + documentation of dimensionality analysis. + * gnat_ugn.texi: Regenerate. + * Makefile.rtl, impunit.adb: Consider the new units. + * libgnat/s-dfmkio.ads, libgnat/s-dfmopr.ads, + libgnat/s-diflmk.ads: New units based on Float. + * libgnat/s-dilomk.ads, libgnat/s-dlmkio.ads, + libgnat/s-dlmopr.ads: New units based on Long_Float. + * libgnat/s-dmotpr.ads: Rename to libgnat/s-dgmgop.ads and turn + into an instance of + System.Dim.Generic_Mks.Generic_Other_Prefixes. + * libgnat/s-dimmks.ads: Rename to libgnat/s-digemk.ads and turn + into an instance of System.Dim.Generic_Mks. + +2018-08-21 Hristian Kirtchev <kirtchev@adacore.com> + + * impunit.adb: Add g-lists to the set of non-implementation + units. + * libgnat/g-lists.adb, libgnat/g-lists.ads: New unit. + * Makefile.rtl: Add g-lists to the set of non-tasking units. + * gcc-interface/Make-lang.in: Add g-lists to the set of files + used by gnat1. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.adb (Reset_Scopes): Do not recurse into type + declarations when resetting the scope of entities declared the + procedures generated for entry bodies and accept alternatives. + Use the entity of the procedure declaration, not its body, as + the new scope. + +2018-08-21 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb (Elaboration_Entity): Include entries and entry + families in the set of legal entities. + (Elaboration_Entity_Required): Include entries and entry + families in the set of legal entities. + (Set_Elaboration_Entity): Include entries and entry families in + the set of legal entities. + (Set_Elaboration_Entity_Required): Include entries and entry + families in the set of legal entities. + (Write_Field13_Name): Update the output of attribute + Elaboration_Entity. + * einfo.ads: Attributes Elaboration_Entity and + Elaboration_Entity_Required now apply to entries and entry + families. + +2018-08-21 Arnaud Charlet <charlet@adacore.com> + + * set_targ.adb: Mark some CodePeer message as Intentional. + +2018-08-21 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Call): Force the freezing of an + expression function that is called to provide a default value + for a defaulted discriminant in an object initialization. + +2018-08-21 Hristian Kirtchev <kirtchev@adacore.com> + + * libgnat/g-dynhta.adb, libgnat/g-dynhta.ads: New package + Dynamic_HTable. + +2018-08-21 Javier Miranda <miranda@adacore.com> + + * checks.ads (Determine_Range): Adding documentation. + * checks.adb (Determine_Range): Don't deal with enumerated types + with non-standard representation. + (Convert_And_Check_Range): For conversion of enumeration types + with non standard representation to an integer type perform a + direct conversion to the target integer type. + +2018-08-21 Piotr Trojanek <trojanek@adacore.com> + + * lib-xref.ads, lib-xref-spark_specific.adb + (Enclosing_Subprogram_Or_Library_Package): Now roughtly works + for pragmas that come from aspect specifications. + +2018-08-21 Pierre-Marie de Rodat <derodat@adacore.com> + + * sa_messages.ads, sa_messages.adb: New source files. + +2018-08-03 Pierre-Marie de Rodat <derodat@adacore.com> + + Reverts + 2018-07-06 Jim Wilson <jimw@sifive.com> + + * Make-generated.in (treeprs.ads): Use $(GNATMAKE) instead of gnatmake. + (einfo.h, sinfo.h, stamp-snames, stamp-nmake): Likewise. + * gcc-interface/Makefile.in (xoscons): Likewise. + +2018-07-31 Alexandre Oliva <oliva@adacore.com> + Olivier Hainque <hainque@adacore.com> + + * gcc-interface/trans.c: Include debug.h. + (file_map): New static variable. + (gigi): Set it. Create decl_to_instance_map when needed. + (Subprogram_Body_to_gnu): Pass gnu_subprog_decl to... + (Sloc_to_locus): ... this. Add decl parm, map it to instance. + * gcc-interface/gigi.h (Sloc_to_locus): Adjust declaration. + 2018-07-31 Arnaud Charlet <charlet@adacore.com> * clean.adb, gnatchop.adb, gnatfind.adb, gnatls.adb, @@ -60,7 +382,7 @@ 2018-07-31 Eric Botcazou <ebotcazou@adacore.com> - * libgnarl/s-osinte__solaris.ads (upad64_t): New private type. + * libgnarl/s-osinte__solaris.ads (upad64_t): New private type. (mutex_t): Use it for 'lock' and 'data' components. (cond_t): Likewise for 'data' and use single 'flags' component. diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in index bdcb62c..757eaa8 100644 --- a/gcc/ada/Make-generated.in +++ b/gcc/ada/Make-generated.in @@ -28,21 +28,21 @@ $(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/ -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/treeprs $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/treeprs/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs - (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; $(GNATMAKE) -q xtreeprs ; ./xtreeprs treeprs.ads ) + (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs treeprs.ads ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/treeprs/treeprs.ads $(ADA_GEN_SUBDIR)/treeprs.ads $(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo - (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; $(GNATMAKE) -q xeinfo ; ./xeinfo einfo.h ) + (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo einfo.h ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/einfo/einfo.h $(ADA_GEN_SUBDIR)/einfo.h $(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo - (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; $(GNATMAKE) -q xsinfo ; ./xsinfo sinfo.h ) + (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo sinfo.h ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/sinfo/sinfo.h $(ADA_GEN_SUBDIR)/sinfo.h $(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true @@ -50,7 +50,7 @@ $(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUB -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/snamest $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/snamest/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/snamest - (cd $(ADA_GEN_SUBDIR)/bldtools/snamest; $(GNATMAKE) -q xsnamest ; ./xsnamest ) + (cd $(ADA_GEN_SUBDIR)/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.ns $(ADA_GEN_SUBDIR)/snames.ads $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nb $(ADA_GEN_SUBDIR)/snames.adb $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nh $(ADA_GEN_SUBDIR)/snames.h @@ -61,7 +61,7 @@ $(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nma -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake - (cd $(ADA_GEN_SUBDIR)/bldtools/nmake; $(GNATMAKE) -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads) + (cd $(ADA_GEN_SUBDIR)/bldtools/nmake; gnatmake -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.ads $(ADA_GEN_SUBDIR)/nmake.ads $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.adb $(ADA_GEN_SUBDIR)/nmake.adb touch $(ADA_GEN_SUBDIR)/stamp-nmake diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 7eaa9ba..936a16d 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -427,6 +427,7 @@ GNATRTL_NONTASKING_OBJS= \ g-htable$(objext) \ g-io$(objext) \ g-io_aux$(objext) \ + g-lists$(objext) \ g-locfil$(objext) \ g-mbdira$(objext) \ g-mbflra$(objext) \ @@ -522,12 +523,20 @@ GNATRTL_NONTASKING_OBJS= \ s-conca9$(objext) \ s-crc32$(objext) \ s-crtl$(objext) \ + s-dfmkio$(objext) \ + s-dfmopr$(objext) \ + s-dgmgop$(objext) \ + s-dlmopr$(objext) \ s-diflio$(objext) \ + s-diflmk$(objext) \ + s-digemk$(objext) \ s-diinio$(objext) \ + s-dilomk$(objext) \ s-dim$(objext) \ s-dimkio$(objext) \ s-dimmks$(objext) \ s-direio$(objext) \ + s-dlmkio$(objext) \ s-dmotpr$(objext) \ s-dsaser$(objext) \ s-elaall$(objext) \ @@ -2131,15 +2140,10 @@ ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),) $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads<libgnat/system-linux-arm.ads - ifeq ($(strip $(filter-out arm%b,$(target_cpu))),) - EH_MECHANISM= - else - EH_MECHANISM=-arm - endif - TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EXTRA_GNATRTL_TASKING_OBJS=s-linux.o + EH_MECHANISM=-arm THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib @@ -2761,4 +2765,3 @@ a-tags.o : a-tags.adb a-tags.ads s-memory.o : s-memory.adb s-memory.ads $(ADAC) -c $(ALL_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) - diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 871f1f7..1704a2f 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -4490,6 +4490,11 @@ package body Checks is or else not Is_Discrete_Type (Typ) + -- Don't deal with enumerated types with non-standard representation + + or else (Is_Enumeration_Type (Typ) + and then Present (Enum_Pos_To_Rep (Base_Type (Typ)))) + -- Ignore type for which an error has been posted, since range in -- this case may well be a bogosity deriving from the error. Also -- ignore if error posted on the reference node. @@ -6758,9 +6763,36 @@ package body Checks is ----------------------------- procedure Convert_And_Check_Range is - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Conv_Node : Node_Id; begin + -- For enumeration types with non-standard representation this is a + -- direct conversion from the enumeration type to the target integer + -- type, which is treated by the back end as a normal integer type + -- conversion, treating the enumeration type as an integer, which is + -- exactly what we want. We set Conversion_OK to make sure that the + -- analyzer does not complain about what otherwise might be an + -- illegal conversion. + + if Is_Enumeration_Type (Source_Base_Type) + and then Present (Enum_Pos_To_Rep (Source_Base_Type)) + and then Is_Integer_Type (Target_Base_Type) + then + Conv_Node := + OK_Convert_To + (Typ => Target_Base_Type, + Expr => Duplicate_Subexpr (N)); + + -- Common case + + else + Conv_Node := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), + Expression => Duplicate_Subexpr (N)); + end if; + -- We make a temporary to hold the value of the converted value -- (converted to the base type), and then do the test against this -- temporary. The conversion itself is replaced by an occurrence of @@ -6776,10 +6808,7 @@ package body Checks is Defining_Identifier => Tnn, Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), Constant_Present => True, - Expression => - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), - Expression => Duplicate_Subexpr (N))), + Expression => Conv_Node), Make_Raise_Constraint_Error (Loc, Condition => diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 85affc4..f2eed3d 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -310,14 +310,16 @@ package Checks is -- then OK is True on return, and Lo and Hi are set to a conservative -- estimate of the possible range of values of N. Thus if OK is True on -- return, the value of the subexpression N is known to lie in the range - -- Lo .. Hi (inclusive). If the expression is not of a discrete type, or - -- some kind of error condition is detected, then OK is False on exit, and - -- Lo/Hi are set to No_Uint. Thus the significance of OK being False on - -- return is that no useful information is available on the range of the - -- expression. Assume_Valid determines whether the processing is allowed to - -- assume that values are in range of their subtypes. If it is set to True, - -- then this assumption is valid, if False, then processing is done using - -- base types to allow invalid values. + -- Lo .. Hi (inclusive). For enumeration and character literals the values + -- returned are the Pos value in the relevant enumeration type. If the + -- expression is not of a discrete type, or some kind of error condition + -- is detected, then OK is False on exit, and Lo/Hi are set to No_Uint. + -- Thus the significance of OK being False on return is that no useful + -- information is available on the range of the expression. Assume_Valid + -- determines whether the processing is allowed to assume that values are + -- in range of their subtypes. If it is set to True, then this assumption + -- is valid, if False, then processing is done using base types to allow + -- invalid values. procedure Determine_Range_R (N : Node_Id; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 5577604..26a8d28 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -32,6 +32,7 @@ with Errout; use Errout; with Exp_Prag; use Exp_Prag; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -47,6 +48,7 @@ with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; +with Stand; use Stand; with Stringt; use Stringt; with SCIL_LL; use SCIL_LL; with Tbuild; use Tbuild; @@ -589,14 +591,45 @@ package body Contracts is if Skip_Assert_Exprs then null; - -- Otherwise analyze the pre/postconditions + -- Otherwise analyze the pre/postconditions. Their expressions + -- might include references to types that are not frozen yet, in the + -- case where the body is a rewritten expression function that is a + -- completion, so freeze all types within before constructing the + -- contract code. else - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id); - Prag := Next_Pragma (Prag); - end loop; + declare + Bod : Node_Id; + Freeze_Types : Boolean := False; + + begin + if Present (Freeze_Id) then + Bod := Unit_Declaration_Node (Freeze_Id); + + if Nkind (Bod) = N_Subprogram_Body + and then Was_Expression_Function (Bod) + and then Ekind (Subp_Id) = E_Function + and then Chars (Subp_Id) = Chars (Freeze_Id) + and then Subp_Id /= Freeze_Id + then + Freeze_Types := True; + end if; + end if; + + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Freeze_Types then + Freeze_Expr_Types + (Def_Id => Subp_Id, + Typ => Standard_Boolean, + Expr => Expression (Corresponding_Aspect (Prag)), + N => Bod); + end if; + + Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id); + Prag := Next_Pragma (Prag); + end loop; + end; end if; -- Analyze contract-cases and test-cases diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index e79f630..1455087 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -1692,13 +1692,44 @@ Alphabetical List of All Switches Maximum_Alignment : Pos; -- Maximum permitted alignment Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field Pointer_Size : Pos; -- System.Address'Size - Short_Enums : Nat; -- Short foreign convention enums? + Short_Enums : Nat; -- Foreign enums use short size? Short_Size : Pos; -- Standard.Short_Integer'Size Strict_Alignment : Nat; -- Strict alignment? System_Allocator_Alignment : Nat; -- Alignment for malloc calls Wchar_T_Size : Pos; -- Interfaces.C.wchar_t'Size Words_BE : Nat; -- Words stored big-endian? + ``Bits_Per_Unit`` is the number of bits in a storage unit, the equivalent of + GCC macro ``BITS_PER_UNIT`` documented as follows: `Define this macro to be + the number of bits in an addressable storage unit (byte); normally 8.` + + ``Bits_Per_Word`` is the number of bits in a machine word, the equivalent of + GCC macro ``BITS_PER_WORD`` documented as follows: `Number of bits in a word; + normally 32.` + + ``Double_Scalar_Alignment`` is the alignment for a scalar whose size is two + machine words. It should be the same as the alignment for C ``long_long`` on + most targets. + + ``Maximum_Alignment`` is the maximum alignment that the compiler might choose + by default for a type or object, which is also the maximum alignment that can + be specified in GNAT. It is computed for GCC backends as ``BIGGEST_ALIGNMENT + / BITS_PER_UNIT`` where GCC macro ``BIGGEST_ALIGNMENT`` is documented as + follows: `Biggest alignment that any data type can require on this machine, + in bits.` + + ``Max_Unaligned_Field`` is the maximum size for unaligned bit field, which is + 64 for the majority of GCC targets (but can be different on some targets like + AAMP). + + ``Strict_Alignment`` is the equivalent of GCC macro ``STRICT_ALIGNMENT`` + documented as follows: `Define this macro to be the value 1 if instructions + will fail to work if given data not on the nominal alignment. If instructions + will merely go slower in that case, define this macro as 0.` + + ``System_Allocator_Alignment`` is the guaranteed alignment of data returned + by calls to ``malloc``. + The format of the input file is as follows. First come the values of the variables defined above, with one line per value: diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index 3e0c6ff..9cbdb15 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -3280,19 +3280,18 @@ to use the proper subtypes in object declarations. .. index:: MKS_Type type The simplest way to impose dimensionality checking on a computation is to make -use of the package ``System.Dim.Mks``, -which is part of the GNAT library. This -package defines a floating-point type ``MKS_Type``, -for which a sequence of -dimension names are specified, together with their conventional abbreviations. -The following should be read together with the full specification of the -package, in file :file:`s-dimmks.ads`. +use of one of the instantiations of the package ``System.Dim.Generic_Mks``, which +are part of the GNAT library. This generic package defines a floating-point +type ``MKS_Type``, for which a sequence of dimension names are specified, +together with their conventional abbreviations. The following should be read +together with the full specification of the package, in file +:file:`s-digemk.ads`. - .. index:: s-dimmks.ads file + .. index:: s-digemk.ads file .. code-block:: ada - type Mks_Type is new Long_Long_Float + type Mks_Type is new Float_Type with Dimension_System => ( (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), @@ -3336,10 +3335,16 @@ as well as useful multiples of these units: day : constant Time := 60.0 * 24.0 * min; ... -Using this package, you can then define a derived unit by -providing the aspect that -specifies its dimensions within the MKS system, as well as the string to -be used for output of a value of that unit: +There are three instantiations of ``System.Dim.Generic_Mks`` defined in the +GNAT library: + +* ``System.Dim.Float_Mks`` based on ``Float`` defined in :file:`s-diflmk.ads`. +* ``System.Dim.Long_Mks`` based on ``Long_Float`` defined in :file:`s-dilomk.ads`. +* ``System.Dim.Mks`` based on ``Long_Long_Float`` defined in :file:`s-dimmks.ads`. + +Using one of these packages, you can then define a derived unit by providing +the aspect that specifies its dimensions within the MKS system, as well as the +string to be used for output of a value of that unit: .. code-block:: ada diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e89ea5a..52a9435 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -118,7 +118,6 @@ package body Einfo is -- Alignment Uint14 -- Normalized_Position Uint14 -- Postconditions_Proc Node14 - -- Shadow_Entities List14 -- Discriminant_Number Uint15 -- DT_Position Uint15 @@ -199,7 +198,6 @@ package body Einfo is -- Corresponding_Remote_Type Node22 -- Enumeration_Rep_Expr Node22 -- Original_Record_Component Node22 - -- Private_View Node22 -- Protected_Formal Node22 -- Scope_Depth_Value Uint22 -- Shared_Var_Procs_Instance Node22 @@ -1182,7 +1180,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); return Node13 (Id); @@ -1193,7 +1191,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); return Flag174 (Id); @@ -3126,12 +3124,6 @@ package body Einfo is return Elist18 (Id); end Private_Dependents; - function Private_View (Id : E) return N is - begin - pragma Assert (Is_Private_Type (Id)); - return Node22 (Id); - end Private_View; - function Protected_Body_Subprogram (Id : E) return E is begin pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id)); @@ -3314,12 +3306,6 @@ package body Einfo is return Flag167 (Id); end Sec_Stack_Needed_For_Return; - function Shadow_Entities (Id : E) return S is - begin - pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); - return List14 (Id); - end Shadow_Entities; - function Shared_Var_Procs_Instance (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Variable); @@ -4412,7 +4398,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); Set_Node13 (Id, V); @@ -4423,7 +4409,7 @@ package body Einfo is pragma Assert (Is_Subprogram (Id) or else - Ekind (Id) = E_Package + Ekind_In (Id, E_Entry, E_Entry_Family, E_Package) or else Is_Generic_Unit (Id)); Set_Flag174 (Id, V); @@ -6376,12 +6362,6 @@ package body Einfo is Set_Elist18 (Id, V); end Set_Private_Dependents; - procedure Set_Private_View (Id : E; V : N) is - begin - pragma Assert (Is_Private_Type (Id)); - Set_Node22 (Id, V); - end Set_Private_View; - procedure Set_Prev_Entity (Id : E; V : E) is begin Set_Node36 (Id, V); @@ -6573,12 +6553,6 @@ package body Einfo is Set_Flag167 (Id, V); end Set_Sec_Stack_Needed_For_Return; - procedure Set_Shadow_Entities (Id : E; V : S) is - begin - pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); - Set_List14 (Id, V); - end Set_Shadow_Entities; - procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Variable); @@ -10355,7 +10329,9 @@ package body Einfo is => Write_Str ("Component_Clause"); - when E_Function + when E_Entry + | E_Entry_Family + | E_Function | E_Procedure | E_Package | Generic_Unit_Kind @@ -10403,11 +10379,6 @@ package body Einfo is => Write_Str ("Postconditions_Proc"); - when E_Generic_Package - | E_Package - => - Write_Str ("Shadow_Entities"); - when others => Write_Str ("Field14??"); end case; @@ -10843,15 +10814,6 @@ package body Einfo is when E_Enumeration_Literal => Write_Str ("Enumeration_Rep_Expr"); - when E_Limited_Private_Subtype - | E_Limited_Private_Type - | E_Private_Subtype - | E_Private_Type - | E_Record_Subtype_With_Private - | E_Record_Type_With_Private - => - Write_Str ("Private_View"); - when Formal_Kind => Write_Str ("Protected_Formal"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8e5bf65..018684d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1090,10 +1090,10 @@ package Einfo is -- to the spec as possible. -- Elaboration_Entity (Node13) --- Defined in generic and non-generic package and subprogram entities. --- This is a counter associated with the unit that is initially set to --- zero, is incremented when an elaboration request for the unit is --- made, and is decremented when a finalization request for the unit +-- Defined in entry, entry family, [generic] package, and subprogram +-- entities. This is a counter associated with the unit that is initially +-- set to zero, is incremented when an elaboration request for the unit +-- is made, and is decremented when a finalization request for the unit -- is made. This is used for three purposes. First, it is used to -- implement access before elaboration checks (the counter must be -- non-zero to call a subprogram at elaboration time). Second, it is @@ -1110,9 +1110,9 @@ package Einfo is -- is elaboration code), but is simply not used for any purpose. -- Elaboration_Entity_Required (Flag174) --- Defined in generic and non-generic package and subprogram entities. --- Set only if Elaboration_Entity is non-Empty to indicate that the --- counter is required to be non-zero even if there is no other +-- Defined in entry, entry family, [generic] package, and subprogram +-- entities. Set only if Elaboration_Entity is non-Empty to indicate that +-- the counter is required to be non-zero even if there is no other -- elaboration code. This occurs when the Elaboration_Entity counter -- is used for access before elaboration checks. If the counter is -- only used to prevent multiple execution of the elaboration code, @@ -4005,17 +4005,6 @@ package Einfo is -- declaration of the type is seen. Subprograms that have such an -- access parameter are also placed in the list of private_dependents. --- Private_View (Node22) --- For each private type, three entities are allocated, the private view, --- the full view, and the shadow entity. The shadow entity contains a --- copy of the private view and is used for restoring the proper private --- view after a region in which the full view is visible (and is copied --- into the entity normally used for the private view during this period --- of visibility). The Private_View field is self-referential when the --- private view lives in its normal entity, but in the copy that is made --- in the shadow entity, it points to the proper location in which to --- restore the private view saved in the shadow. - -- Protected_Body_Subprogram (Node11) -- Defined in protected operations. References the entity for the -- subprogram which implements the body of the operation. @@ -4264,18 +4253,6 @@ package Einfo is -- returned value of a function and thus should not be released on scope -- exit. --- Shadow_Entities (List14) --- Defined in package and generic package entities. Points to a list --- of entities that correspond to private types. For each private type --- a shadow entity is created that holds a copy of the private view. --- In regions of the program where the full views of these private --- entities are visible, the full view is copied into the entity that --- is normally used to hold the private view, but the shadow entity --- copy is unchanged. The shadow entities are then used to restore the --- original private views at the end of the region. This list is a --- standard format list (i.e. First (Shadow_Entities) is the first --- entry and subsequent entries are obtained using Next. - -- Shared_Var_Procs_Instance (Node22) -- Defined in variables. Set non-Empty only if Is_Shared_Passive is -- set, in which case this is the entity for the associated instance of @@ -6058,6 +6035,7 @@ package Einfo is -- E_Entry_Family -- Protected_Body_Subprogram (Node11) -- Barrier_Function (Node12) + -- Elaboration_Entity (Node13) -- Postconditions_Proc (Node14) -- Entry_Parameters_Type (Node15) -- First_Entity (Node17) @@ -6322,7 +6300,6 @@ package Einfo is -- Underlying_Full_View (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) -- Stored_Constraint (Elist23) -- Has_Completion (Flag26) -- (plus type attributes) @@ -6401,7 +6378,6 @@ package Einfo is -- Generic_Homonym (Node11) (generic case only) -- Associated_Formal_Package (Node12) -- Elaboration_Entity (Node13) - -- Shadow_Entities (List14) -- Related_Instance (Node15) (non-generic case only) -- First_Private_Entity (Node16) -- First_Entity (Node17) @@ -6479,7 +6455,6 @@ package Einfo is -- Underlying_Full_View (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) -- Stored_Constraint (Elist23) -- Has_Completion (Flag26) -- Is_Controlled_Active (Flag42) (base type only) @@ -6660,7 +6635,6 @@ package Einfo is -- Underlying_Full_View (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) - -- Private_View (Node22) -- Stored_Constraint (Elist23) -- Interfaces (Elist25) -- Predicated_Parent (Node38) (subtype only) @@ -7475,7 +7449,6 @@ package Einfo is function Prival (Id : E) return E; function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; - function Private_View (Id : E) return N; function Protected_Body_Subprogram (Id : E) return E; function Protected_Formal (Id : E) return E; function Protected_Subprogram (Id : E) return N; @@ -7508,7 +7481,6 @@ package Einfo is function Scale_Value (Id : E) return U; function Scope_Depth_Value (Id : E) return U; function Sec_Stack_Needed_For_Return (Id : E) return B; - function Shadow_Entities (Id : E) return S; function Shared_Var_Procs_Instance (Id : E) return E; function Size_Check_Code (Id : E) return N; function Size_Depends_On_Discriminant (Id : E) return B; @@ -8181,7 +8153,6 @@ package Einfo is procedure Set_Prival (Id : E; V : E); procedure Set_Prival_Link (Id : E; V : E); procedure Set_Private_Dependents (Id : E; V : L); - procedure Set_Private_View (Id : E; V : N); procedure Set_Protected_Body_Subprogram (Id : E; V : E); procedure Set_Protected_Formal (Id : E; V : E); procedure Set_Protected_Subprogram (Id : E; V : N); @@ -8214,7 +8185,6 @@ package Einfo is procedure Set_Scale_Value (Id : E; V : U); procedure Set_Scope_Depth_Value (Id : E; V : U); procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True); - procedure Set_Shadow_Entities (Id : E; V : S); procedure Set_Shared_Var_Procs_Instance (Id : E; V : E); procedure Set_Size_Check_Code (Id : E; V : N); procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True); @@ -9058,7 +9028,6 @@ package Einfo is pragma Inline (Prival); pragma Inline (Prival_Link); pragma Inline (Private_Dependents); - pragma Inline (Private_View); pragma Inline (Protected_Body_Subprogram); pragma Inline (Protected_Formal); pragma Inline (Protected_Subprogram); @@ -9092,7 +9061,6 @@ package Einfo is pragma Inline (Scale_Value); pragma Inline (Scope_Depth_Value); pragma Inline (Sec_Stack_Needed_For_Return); - pragma Inline (Shadow_Entities); pragma Inline (Shared_Var_Procs_Instance); pragma Inline (Size_Check_Code); pragma Inline (Size_Depends_On_Discriminant); @@ -9551,7 +9519,6 @@ package Einfo is pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); - pragma Inline (Set_Private_View); pragma Inline (Set_Protected_Body_Subprogram); pragma Inline (Set_Protected_Formal); pragma Inline (Set_Protected_Subprogram); @@ -9584,7 +9551,6 @@ package Einfo is pragma Inline (Set_Scale_Value); pragma Inline (Set_Scope_Depth_Value); pragma Inline (Set_Sec_Stack_Needed_For_Return); - pragma Inline (Set_Shadow_Entities); pragma Inline (Set_Shared_Var_Procs_Instance); pragma Inline (Set_Size_Check_Code); pragma Inline (Set_Size_Depends_On_Discriminant); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9d9ab6a..f65230f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6195,10 +6195,11 @@ package body Exp_Aggr is -- Look if in place aggregate expansion is possible -- For object declarations we build the aggregate in place, unless - -- the array is bit-packed or the component is controlled. + -- the array is bit-packed. -- For assignments we do the assignment in place if all the component - -- associations have compile-time known values. For other cases we + -- associations have compile-time known values, or are default- + -- initialized limited components, e.g. tasks. For other cases we -- create a temporary. The analysis for safety of on-line assignment -- is delicate, i.e. we don't know how to do it fully yet ??? @@ -6211,7 +6212,12 @@ package body Exp_Aggr is Establish_Transient_Scope (N, Manage_Sec_Stack => False); end if; - if Has_Default_Init_Comps (N) then + -- An array of limited components is built in place + + if Is_Limited_Type (Typ) then + Maybe_In_Place_OK := True; + + elsif Has_Default_Init_Comps (N) then Maybe_In_Place_OK := False; elsif Is_Bit_Packed_Array (Typ) @@ -6247,15 +6253,17 @@ package body Exp_Aggr is -- expected to appear in qualified form. In-place expansion eliminates -- the qualification and eventually violates this SPARK 05 restiction. - -- Should document the rest of the guards ??? + -- Arrays of limited components must be built in place. The code + -- previously excluded controlled components but this is an old + -- oversight: the rules in 7.6 (17) are clear. - if not Has_Default_Init_Comps (N) + if (not Has_Default_Init_Comps (N) + or else Is_Limited_Type (Etype (N))) and then Comes_From_Source (Parent_Node) and then Parent_Kind = N_Object_Declaration and then Present (Expression (Parent_Node)) and then not Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ) - and then not Has_Controlled_Component (Typ) and then not Is_Bit_Packed_Array (Typ) and then not Restriction_Check_Required (SPARK_05) then @@ -6292,6 +6300,15 @@ package body Exp_Aggr is Set_Expansion_Delayed (N); return; + -- Limited arrays in return statements are expanded when + -- enclosing construct is expanded. + + elsif Maybe_In_Place_OK + and then Nkind (Parent (N)) = N_Simple_Return_Statement + then + Set_Expansion_Delayed (N); + return; + -- In the remaining cases the aggregate is the RHS of an assignment elsif Maybe_In_Place_OK @@ -6365,8 +6382,9 @@ package body Exp_Aggr is Target := New_Occurrence_Of (Tmp, Loc); else - if Has_Default_Init_Comps (N) then - + if Has_Default_Init_Comps (N) + and then not Maybe_In_Place_OK + then -- Ada 2005 (AI-287): This case has not been analyzed??? raise Program_Error; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 469a90e..d789748 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3672,29 +3672,35 @@ package body Exp_Attr is if Is_Fixed_Point_Type (Etype (N)) then declare Loc : constant Source_Ptr := Sloc (N); - Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Expr : constant Node_Id := Expression (N); - Fst : constant Entity_Id := Root_Type (Etype (N)); + Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Expr : constant Node_Id := Expression (N); + Fst : constant Entity_Id := Root_Type (Etype (N)); Decl : Node_Id; begin - Decl := Make_Full_Type_Declaration (Sloc (N), - Equiv_T, - Type_Definition => - Make_Signed_Integer_Type_Definition (Loc, - Low_Bound => Make_Integer_Literal (Loc, - Intval => Corresponding_Integer_Value - (Type_Low_Bound (Fst))), - High_Bound => Make_Integer_Literal (Loc, - Intval => Corresponding_Integer_Value - (Type_High_Bound (Fst))))); + Decl := + Make_Full_Type_Declaration (Sloc (N), + Defining_Identifier => Equiv_T, + Type_Definition => + Make_Signed_Integer_Type_Definition (Loc, + Low_Bound => + Make_Integer_Literal (Loc, + Intval => + Corresponding_Integer_Value + (Type_Low_Bound (Fst))), + High_Bound => + Make_Integer_Literal (Loc, + Intval => + Corresponding_Integer_Value + (Type_High_Bound (Fst))))); Insert_Action (N, Decl); - -- Verify that the conversion is possible. - Generate_Range_Check - (Expr, Equiv_T, CE_Overflow_Check_Failed); + -- Verify that the conversion is possible + + Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed); + + -- and verify that the result is in range - -- and verify that the result is in range. Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed); end; end if; diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 00f029b..f40dc7e 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -121,7 +121,14 @@ package body Exp_CG is for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop N := Call_Graph_Nodes.Table (J); - if Nkind (N) in N_Subprogram_Call then + -- No action needed for subprogram calls removed by the expander + -- (for example, calls to ignored ghost entities). + + if Nkind (N) = N_Null_Statement then + pragma Assert (Nkind (Original_Node (N)) in N_Subprogram_Call); + null; + + elsif Nkind (N) in N_Subprogram_Call then Write_Call_Info (N); else pragma Assert (Nkind (N) = N_Defining_Identifier); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 224f4c7..e08b748 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6402,12 +6402,13 @@ package body Exp_Ch6 is and then Is_Protected_Type (Etype (Prefix (Name (Parent (N))))) and then Is_Entity_Name (Name (N)) and then Scope (Entity (Name (N))) = - Etype (Prefix (Name (Parent (N)))) + Etype (Prefix (Name (Parent (N)))) then Rewrite (Name (N), Make_Selected_Component (Sloc (N), - Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), + Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), Selector_Name => Relocate_Node (Name (N)))); + Analyze_And_Resolve (N); return; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 1b8b8f2..ee04b22 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4030,8 +4030,8 @@ package body Exp_Ch7 is ----------------------- function First_Local_Scope (L : List_Id) return Entity_Id is - Stat : Node_Id; Scop : Entity_Id; + Stat : Node_Id; begin Stat := First (L); @@ -4099,6 +4099,7 @@ package body Exp_Ch7 is when others => null; end case; + Next (Stat); end loop; @@ -4119,8 +4120,8 @@ package body Exp_Ch7 is and then Present (Handled_Statement_Sequence (N)) and then Is_Compilation_Unit (Current_Scope) then - Ent := First_Local_Scope - (Statements (Handled_Statement_Sequence (N))); + Ent := + First_Local_Scope (Statements (Handled_Statement_Sequence (N))); if Present (Ent) then Elab_Proc := diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index e7561df..4470c4e 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -476,10 +476,13 @@ package body Exp_Ch9 is -- ... -- <actualN> := P.<formalN>; - procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id); - -- Reset the scope of declarations and blocks at the top level of Proc_Body - -- to be E. Used after expanding entry bodies into their corresponding - -- procedures. + procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); + -- Reset the scope of declarations and blocks at the top level of Bod + -- to be E. Bod is either a block or a subprogram body. Used after + -- expanding various kinds of entry bodies into their corresponding + -- constructs. This is needed during unnesting to determine whether a + -- body geenrated for an entry or an accept alternative includes uplevel + -- references. function Trivial_Accept_OK return Boolean; -- If there is no DO-END block for an accept, or if the DO-END block has @@ -3807,7 +3810,7 @@ package body Exp_Ch9 is New_Occurrence_Of (RTE (RE_Get_GNAT_Exception), Loc))))))))); - Reset_Scopes_To (Proc_Body, Bod_Id); + Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent)); return Proc_Body; end if; end Build_Protected_Entry; @@ -8238,6 +8241,8 @@ package body Exp_Ch9 is end if; Analyze (N); + + Reset_Scopes_To (N, Entity (Identifier (N))); end Expand_N_Conditional_Entry_Call; --------------------------------------- @@ -12651,7 +12656,7 @@ package body Exp_Ch9 is Expression => D_Disc)); -- Do the assignment at this stage only because the evaluation of the - -- expression must not occur before (see ACVC C97302A). + -- expression must not occur earlier (see ACVC C97302A). Append_To (Stmts, Make_Assignment_Statement (Loc, @@ -12848,7 +12853,7 @@ package body Exp_Ch9 is end loop; -- Do the assignment at this stage only because the evaluation - -- of the expression must not occur before (see ACVC C97302A). + -- of the expression must not occur earlier (see ACVC C97302A). Insert_Before (Stmt, Make_Assignment_Statement (Loc, @@ -12933,6 +12938,21 @@ package body Exp_Ch9 is Make_Handled_Sequence_Of_Statements (Loc, Stmts))); Analyze (N); + + -- Some items in Decls used to be in the N_Block in E_Call that + -- is constructed in Expand_Entry_Call, and are now in the new + -- Block into which N has been rewritten. Adjust their scopes + -- to reflect that. + + if Nkind (E_Call) = N_Block_Statement then + Obj := First_Entity (Entity (Identifier (E_Call))); + while Present (Obj) loop + Set_Scope (Obj, Entity (Identifier (N))); + Next_Entity (Obj); + end loop; + end if; + + Reset_Scopes_To (N, Entity (Identifier (N))); end Expand_N_Timed_Entry_Call; ---------------------------------------- @@ -14830,11 +14850,12 @@ package body Exp_Ch9 is -- Reset_Scopes_To -- --------------------- - procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id) is + procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is function Reset_Scope (N : Node_Id) return Traverse_Result; -- Temporaries may have been declared during expansion of the procedure - -- alternative. Indicate that their scope is the new body, to prevent - -- generation of spurious uplevel references for these entities. + -- created for an entry body or an accept alternative. Indicate that + -- their scope is the new body, to unsure proper generation of uplevel + -- references where needed during unnesting. procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); @@ -14849,19 +14870,26 @@ package body Exp_Ch9 is -- If this is a block statement with an Identifier, it forms a scope, -- so we want to reset its scope but not look inside. - if Nkind (N) = N_Block_Statement + if N /= Bod + and then Nkind (N) = N_Block_Statement and then Present (Identifier (N)) then Set_Scope (Entity (Identifier (N)), E); return Skip; - elsif Nkind (N) = N_Package_Declaration then + -- Ditto for a package declaration or a full type declaration, etc. + + elsif Nkind (N) = N_Package_Declaration + or else Nkind (N) in N_Declaration + or else Nkind (N) in N_Renaming_Declaration + then Set_Scope (Defining_Entity (N), E); return Skip; - elsif N = Proc_Body then + elsif N = Bod then - -- Scan declarations + -- Scan declarations in new body. Declarations in the statement + -- part will be handled during later traversal. Decl := First (Declarations (N)); while Present (Decl) loop @@ -14869,10 +14897,8 @@ package body Exp_Ch9 is Next (Decl); end loop; - elsif N /= Proc_Body and then Nkind (N) in N_Proper_Body then + elsif N /= Bod and then Nkind (N) in N_Proper_Body then return Skip; - elsif Nkind (N) = N_Defining_Identifier then - Set_Scope (N, E); end if; return OK; @@ -14881,7 +14907,7 @@ package body Exp_Ch9 is -- Start of processing for Reset_Scopes_To begin - Reset_Scopes (Proc_Body); + Reset_Scopes (Bod); end Reset_Scopes_To; ---------------------- diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index c5b03c4..d688157 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -260,12 +260,10 @@ package body Exp_Unst is E := Ultimate_Alias (E); -- The body of a protected operation has a different name and - -- has been scanned at this point, and thus has an entry in - -- the subprogram table. + -- has been scanned at this point, and thus has an entry in the + -- subprogram table. - if E = Sub - and then Convention (E) = Convention_Protected - then + if E = Sub and then Convention (E) = Convention_Protected then E := Protected_Body_Subprogram (E); end if; @@ -551,9 +549,8 @@ package body Exp_Unst is -- Explicit dereference and selected component case - elsif Nkind_In (N, - N_Explicit_Dereference, - N_Selected_Component) + elsif Nkind_In (N, N_Explicit_Dereference, + N_Selected_Component) then Note_Uplevel_Bound (Prefix (N), Ref); diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 3b67a0d..a5cdf06 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -477,7 +477,7 @@ package Exp_Unst is -- subprograms exist. Similarly overloading would cause a naming issue. -- In fact, the expanded code includes qualified names which eliminate this - -- problem. We omitted the qualification from the exapnded examples above + -- problem. We omitted the qualification from the expanded examples above -- for simplicity. But to see this in action, consider this example: -- function Mnames return Boolean is diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 3bed508..314e3ee 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8402,9 +8402,23 @@ package body Exp_Util is declare Align_In_Bits : constant Nat := M * System_Storage_Unit; + Comp : Entity_Id; + begin - if Component_Bit_Offset (C) mod Align_In_Bits /= 0 - or else Esize (C) mod Align_In_Bits /= 0 + Comp := C; + + -- For a component inherited in a record extension, the + -- clause is inherited but position and size are not set. + + if Is_Base_Type (Etype (P)) + and then Is_Tagged_Type (Etype (P)) + and then Present (Original_Record_Component (Comp)) + then + Comp := Original_Record_Component (Comp); + end if; + + if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0 + or else Esize (Comp) mod Align_In_Bits /= 0 then return True; end if; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 1928609..2d07aa5 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -85,7 +85,7 @@ extern void Set_RM_Size (Entity_Id, Uint); extern Boolean Is_Entity_Name (Node_Id); #define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause -extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char); +extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char); /* errout: */ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 9979cbf..5036a79 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -49,6 +49,7 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; @@ -3611,10 +3612,14 @@ package body Freeze is Error_Msg_Qual_Level := 1; - -- Check suspicious use of fat C pointer + -- Check suspicious use of fat C pointer, but do not emit + -- a warning on an access to subprogram when unnesting is + -- active. if Is_Access_Type (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)) then Error_Msg_N ("?x?type of & does not correspond to C pointer!", Formal); @@ -7639,6 +7644,208 @@ package body Freeze is In_Spec_Expression := In_Spec_Exp; end Freeze_Expression; + ----------------------- + -- Freeze_Expr_Types -- + ----------------------- + + procedure Freeze_Expr_Types + (Def_Id : Entity_Id; + Typ : Entity_Id; + Expr : Node_Id; + N : Node_Id) + is + function Cloned_Expression return Node_Id; + -- Build a duplicate of the expression of the return statement that has + -- no defining entities shared with the original expression. + + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; + -- Freeze all types referenced in the subtree rooted at Node + + ----------------------- + -- Cloned_Expression -- + ----------------------- + + function Cloned_Expression return Node_Id is + function Clone_Id (Node : Node_Id) return Traverse_Result; + -- Tree traversal routine that clones the defining identifier of + -- iterator and loop parameter specification nodes. + + -------------- + -- Clone_Id -- + -------------- + + function Clone_Id (Node : Node_Id) return Traverse_Result is + begin + if Nkind_In (Node, N_Iterator_Specification, + N_Loop_Parameter_Specification) + then + Set_Defining_Identifier + (Node, New_Copy (Defining_Identifier (Node))); + end if; + + return OK; + end Clone_Id; + + procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id); + + -- Local variable + + Dup_Expr : constant Node_Id := New_Copy_Tree (Expr); + + -- Start of processing for Cloned_Expression + + begin + -- We must duplicate the expression with semantic information to + -- inherit the decoration of global entities in generic instances. + -- Set the parent of the new node to be the parent of the original + -- to get the proper context, which is needed for complete error + -- reporting and for semantic analysis. + + Set_Parent (Dup_Expr, Parent (Expr)); + + -- Replace the defining identifier of iterators and loop param + -- specifications by a clone to ensure that the cloned expression + -- and the original expression don't have shared identifiers; + -- otherwise, as part of the preanalysis of the expression, these + -- shared identifiers may be left decorated with itypes which + -- will not be available in the tree passed to the backend. + + Clone_Def_Ids (Dup_Expr); + + return Dup_Expr; + end Cloned_Expression; + + ---------------------- + -- Freeze_Type_Refs -- + ---------------------- + + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is + procedure Check_And_Freeze_Type (Typ : Entity_Id); + -- Check that Typ is fully declared and freeze it if so + + --------------------------- + -- Check_And_Freeze_Type -- + --------------------------- + + procedure Check_And_Freeze_Type (Typ : Entity_Id) is + begin + -- Skip Itypes created by the preanalysis, and itypes whose + -- scope is another type (i.e. component subtypes that depend + -- on a discriminant), + + if Is_Itype (Typ) + and then (Scope_Within_Or_Same (Scope (Typ), Def_Id) + or else Is_Type (Scope (Typ))) + then + return; + end if; + + -- This provides a better error message than generating primitives + -- whose compilation fails much later. Refine the error message if + -- possible. + + Check_Fully_Declared (Typ, Node); + + if Error_Posted (Node) then + if Has_Private_Component (Typ) + and then not Is_Private_Type (Typ) + then + Error_Msg_NE ("\type& has private component", Node, Typ); + end if; + + else + Freeze_Before (N, Typ); + end if; + end Check_And_Freeze_Type; + + -- Start of processing for Freeze_Type_Refs + + begin + -- Check that a type referenced by an entity can be frozen + + if Is_Entity_Name (Node) and then Present (Entity (Node)) then + Check_And_Freeze_Type (Etype (Entity (Node))); + + -- Check that the enclosing record type can be frozen + + if Ekind_In (Entity (Node), E_Component, E_Discriminant) then + Check_And_Freeze_Type (Scope (Entity (Node))); + end if; + + -- Freezing an access type does not freeze the designated type, but + -- freezing conversions between access to interfaces requires that + -- the interface types themselves be frozen, so that dispatch table + -- entities are properly created. + + -- Unclear whether a more general rule is needed ??? + + elsif Nkind (Node) = N_Type_Conversion + and then Is_Access_Type (Etype (Node)) + and then Is_Interface (Designated_Type (Etype (Node))) + then + Check_And_Freeze_Type (Designated_Type (Etype (Node))); + end if; + + -- An implicit dereference freezes the designated type. In the case + -- of a dispatching call whose controlling argument is an access + -- type, the dereference is not made explicit, so we must check for + -- such a call and freeze the designated type. + + if Nkind (Node) in N_Has_Etype + and then Present (Etype (Node)) + and then Is_Access_Type (Etype (Node)) + and then Nkind (Parent (Node)) = N_Function_Call + and then Node = Controlling_Argument (Parent (Node)) + then + Check_And_Freeze_Type (Designated_Type (Etype (Node))); + end if; + + -- No point in posting several errors on the same expression + + if Serious_Errors_Detected > 0 then + return Abandon; + else + return OK; + end if; + end Freeze_Type_Refs; + + procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); + + -- Local variables + + Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id); + Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id); + Dup_Expr : constant Node_Id := Cloned_Expression; + + -- Start of processing for Freeze_Expr_Types + + begin + -- Preanalyze a duplicate of the expression to have available the + -- minimum decoration needed to locate referenced unfrozen types + -- without adding any decoration to the function expression. + + Push_Scope (Def_Id); + Install_Formals (Def_Id); + + Preanalyze_Spec_Expression (Dup_Expr, Typ); + End_Scope; + + -- Restore certain attributes of Def_Id since the preanalysis may + -- have introduced itypes to this scope, thus modifying attributes + -- First_Entity and Last_Entity. + + Set_First_Entity (Def_Id, Saved_First_Entity); + Set_Last_Entity (Def_Id, Saved_Last_Entity); + + if Present (Last_Entity (Def_Id)) then + Set_Next_Entity (Last_Entity (Def_Id), Empty); + end if; + + -- Freeze all types referenced in the expression + + Freeze_References (Dup_Expr); + end Freeze_Expr_Types; + ----------------------------- -- Freeze_Fixed_Point_Type -- ----------------------------- diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 20badd0..96b3c90 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -230,6 +230,17 @@ package Freeze is -- so need to be similarly treated. Freeze_Expression takes care of -- determining the proper insertion point for generated freeze actions. + procedure Freeze_Expr_Types + (Def_Id : Entity_Id; + Typ : Entity_Id; + Expr : Node_Id; + N : Node_Id); + -- N is the body constructed for an expression function that is a + -- completion, and Def_Id is the function being completed. + -- This procedure freezes before N all the types referenced in Expr, + -- which is either the expression of the expression function, or + -- the expression in a pre/post aspect that applies to Def_Id; + procedure Freeze_Fixed_Point_Type (Typ : Entity_Id); -- Freeze fixed point type. For fixed-point types, we have to defer -- setting the size and bounds till the freeze point, since they are diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index d51d397..d8dac73 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -319,6 +319,7 @@ GNAT_ADA_OBJS = \ ada/libgnat/g-dynhta.o \ ada/libgnat/g-hesora.o \ ada/libgnat/g-htable.o \ + ada/libgnat/g-lists.o \ ada/libgnat/g-spchge.o \ ada/libgnat/g-speche.o \ ada/libgnat/g-u3spch.o \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 601f23a..4d870c2 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -441,6 +441,11 @@ ifeq ($(ENABLE_VXADDR2LINE),true) TOOLSCASE=cross top_buildir=../../.. \ ../../vxaddr2line$(exeext) endif +ifeq ($(ENABLE_VXLINK),true) + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=cross top_build=../../.. \ + ../../vxlink$(exeext) +endif common-tools: ../stamp-tools $(GNATMAKE) -j0 -c -b $(ADA_INCLUDES) \ @@ -478,6 +483,12 @@ common-tools: ../stamp-tools $(GNATLINK) -v vxaddr2line -o $@ \ --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" ../targext.o $(CLIB) +../../vxlink$(exeext): ../stamp-tools + $(GNATMAKE) -c $(ADA_INCLUDES) vxlink-main --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxlink-main + $(GNATLINK) -v vxlink-main -o $@ \ + --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" + gnatmake-re: ../stamp-tools $(GNATMAKE) -j0 $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)" $(GNATMAKE) -j0 -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)" @@ -613,7 +624,7 @@ OSCONS_EXTRACT=$(OSCONS_CC) $(GNATLIBCFLAGS_FOR_C) -S s-oscons-tmplt.i -$(MKDIR) ./bldtools/oscons $(RM) $(addprefix ./bldtools/oscons/,$(notdir $^)) $(CP) $^ ./bldtools/oscons - (cd ./bldtools/oscons ; $(GNATMAKE) -q xoscons) + (cd ./bldtools/oscons ; gnatmake -q xoscons) $(RTSDIR)/s-oscons.ads: ../stamp-gnatlib1-$(RTSDIR) s-oscons-tmplt.c gsocket.h ./bldtools/oscons/xoscons $(RM) $(RTSDIR)/s-oscons-tmplt.i $(RTSDIR)/s-oscons-tmplt.s diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index b1dc379..6f605bd 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5421,7 +5421,7 @@ update_profile (Entity_Id gnat_subprog) if (DECL_P (gnu_type)) { /* Builtins cannot have their address taken so we can reset them. */ - gcc_assert (DECL_BUILT_IN (gnu_type)); + gcc_assert (fndecl_built_in_p (gnu_type)); save_gnu_tree (gnat_subprog, NULL_TREE, false); save_gnu_tree (gnat_subprog, gnu_type, false); return; diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index a75cb90..eb64a8b 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -285,7 +285,7 @@ extern void process_type (Entity_Id gnat_entity); location and false if it doesn't. If CLEAR_COLUMN is true, set the column information to 0. */ extern bool Sloc_to_locus (Source_Ptr Sloc, location_t *locus, - bool clear_column = false); + bool clear_column = false, const_tree decl = 0); /* Post an error message. MSG is the error message, properly annotated. NODE is the node at which to post the error and the node to use for the @@ -1081,7 +1081,7 @@ call_is_atomic_load (tree exp) { tree fndecl = get_callee_fndecl (exp); - if (!(fndecl && DECL_BUILT_IN_CLASS (fndecl) == BUILT_IN_NORMAL)) + if (!(fndecl && fndecl_built_in_p (fndecl, BUILT_IN_NORMAL))) return false; enum built_in_function code = DECL_FUNCTION_CODE (fndecl); diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 31e098a..940bf5f 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -41,6 +41,7 @@ #include "stmt.h" #include "varasm.h" #include "output.h" +#include "debug.h" #include "libfuncs.h" /* For set_stack_check_libfunc. */ #include "tree-iterator.h" #include "gimplify.h" @@ -255,6 +256,12 @@ static tree create_init_temporary (const char *, tree, tree *, Node_Id); static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED; static const char *decode_name (const char *) ATTRIBUTE_UNUSED; +/* This makes gigi's file_info_ptr visible in this translation unit, + so that Sloc_to_locus can look it up when deciding whether to map + decls to instances. */ + +static struct File_Info_Type *file_map; + /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ @@ -300,6 +307,12 @@ gigi (Node_Id gnat_root, type_annotate_only = (gigi_operating_mode == 1); + if (Generate_SCO_Instance_Table != 0) + { + file_map = file_info_ptr; + maybe_create_decl_to_instance_map (number_file); + } + for (i = 0; i < number_file; i++) { /* Use the identifier table to make a permanent copy of the filename as @@ -701,6 +714,7 @@ gigi (Node_Id gnat_root, } /* Destroy ourselves. */ + file_map = NULL; destroy_gnat_decl (); destroy_gnat_utils (); @@ -3771,7 +3785,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) } /* Set the line number in the decl to correspond to that of the body. */ - if (!Sloc_to_locus (Sloc (gnat_node), &locus)) + if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl)) locus = input_location; DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus; @@ -4436,6 +4450,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, const bool suppress_type_conversion = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion && (!in_param + || !is_by_ref_formal_parm || (Is_Composite_Type (Underlying_Type (gnat_formal_type)) && !Is_Constrained (Underlying_Type (gnat_formal_type))))) || (Nkind (gnat_actual) == N_Type_Conversion @@ -9970,12 +9985,14 @@ maybe_implicit_deref (tree exp) return exp; } -/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code - location and false if it doesn't. If CLEAR_COLUMN is true, set the column - information to 0. */ +/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a + source code location and false if it doesn't. If CLEAR_COLUMN is + true, set the column information to 0. If DECL is given and SLOC + refers to a File with an instance, map DECL to that instance. */ bool -Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column) +Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column, + const_tree decl) { if (Sloc == No_Location) return false; @@ -9999,6 +10016,9 @@ Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column) *locus = linemap_position_for_line_and_column (line_table, map, line, column); + if (file_map && file_map[file - 1].Instance) + decl_to_instance_map->put (decl, file_map[file - 1].Instance); + return true; } diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index cc1fe77..313d984 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -773,7 +773,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) debugger at the proper time. */ if (DECL_EXTERNAL (decl) && TREE_CODE (decl) == FUNCTION_DECL - && DECL_BUILT_IN (decl)) + && fndecl_built_in_p (decl)) vec_safe_push (builtin_decls, decl); else if (global_bindings_p ()) vec_safe_push (global_decls, decl); diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index b5972bb..aeaa146 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 , Jul 13, 2018 +GNAT User's Guide for Native Platforms , Aug 20, 2018 AdaCore @@ -9429,7 +9429,7 @@ Long_Size : Pos; -- Standard.Long_Integer'Size Maximum_Alignment : Pos; -- Maximum permitted alignment Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field Pointer_Size : Pos; -- System.Address'Size -Short_Enums : Nat; -- Short foreign convention enums? +Short_Enums : Nat; -- Foreign enums use short size? Short_Size : Pos; -- Standard.Short_Integer'Size Strict_Alignment : Nat; -- Strict alignment? System_Allocator_Alignment : Nat; -- Alignment for malloc calls @@ -9437,6 +9437,32 @@ Wchar_T_Size : Pos; -- Interfaces.C.wchar_t'Size Words_BE : Nat; -- Words stored big-endian? @end example +@code{Bits_Per_Unit} is the number of bits in a storage unit, the equivalent of +GCC macro @code{BITS_PER_UNIT} documented as follows: @cite{Define this macro to be the number of bits in an addressable storage unit (byte); normally 8.} + +@code{Bits_Per_Word} is the number of bits in a machine word, the equivalent of +GCC macro @code{BITS_PER_WORD} documented as follows: @cite{Number of bits in a word; normally 32.} + +@code{Double_Scalar_Alignment} is the alignment for a scalar whose size is two +machine words. It should be the same as the alignment for C @code{long_long} on +most targets. + +@code{Maximum_Alignment} is the maximum alignment that the compiler might choose +by default for a type or object, which is also the maximum alignment that can +be specified in GNAT. It is computed for GCC backends as @code{BIGGEST_ALIGNMENT +/ BITS_PER_UNIT} where GCC macro @code{BIGGEST_ALIGNMENT} is documented as +follows: @cite{Biggest alignment that any data type can require on this machine@comma{} in bits.} + +@code{Max_Unaligned_Field} is the maximum size for unaligned bit field, which is +64 for the majority of GCC targets (but can be different on some targets like +AAMP). + +@code{Strict_Alignment} is the equivalent of GCC macro @code{STRICT_ALIGNMENT} +documented as follows: @cite{Define this macro to be the value 1 if instructions will fail to work if given data not on the nominal alignment. If instructions will merely go slower in that case@comma{} define this macro as 0.} + +@code{System_Allocator_Alignment} is the guaranteed alignment of data returned +by calls to @code{malloc}. + The format of the input file is as follows. First come the values of the variables defined above, with one line per value: @@ -22606,20 +22632,19 @@ to use the proper subtypes in object declarations. @geindex MKS_Type type The simplest way to impose dimensionality checking on a computation is to make -use of the package @code{System.Dim.Mks}, -which is part of the GNAT library. This -package defines a floating-point type @code{MKS_Type}, -for which a sequence of -dimension names are specified, together with their conventional abbreviations. -The following should be read together with the full specification of the -package, in file @code{s-dimmks.ads}. +use of one of the instantiations of the package @code{System.Dim.Generic_Mks}, which +are part of the GNAT library. This generic package defines a floating-point +type @code{MKS_Type}, for which a sequence of dimension names are specified, +together with their conventional abbreviations. The following should be read +together with the full specification of the package, in file +@code{s-digemk.ads}. @quotation -@geindex s-dimmks.ads file +@geindex s-digemk.ads file @example -type Mks_Type is new Long_Long_Float +type Mks_Type is new Float_Type with Dimension_System => ( (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), @@ -22674,10 +22699,25 @@ as well as useful multiples of these units: @end example @end quotation -Using this package, you can then define a derived unit by -providing the aspect that -specifies its dimensions within the MKS system, as well as the string to -be used for output of a value of that unit: +There are three instantiations of @code{System.Dim.Generic_Mks} defined in the +GNAT library: + + +@itemize * + +@item +@code{System.Dim.Float_Mks} based on @code{Float} defined in @code{s-diflmk.ads}. + +@item +@code{System.Dim.Long_Mks} based on @code{Long_Float} defined in @code{s-dilomk.ads}. + +@item +@code{System.Dim.Mks} based on @code{Long_Long_Float} defined in @code{s-dimmks.ads}. +@end itemize + +Using one of these packages, you can then define a derived unit by providing +the aspect that specifies its dimensions within the MKS system, as well as the +string to be used for output of a value of that unit: @quotation diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 16981b8..5c8bb7d 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1103,9 +1103,9 @@ procedure Gnatlink is -- as it is in the same directory as the shared version. if Nlast >= Library_Version'Length - and then Next_Line - (Nlast - Library_Version'Length + 1 .. Nlast) - = Library_Version + and then + Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) = + Library_Version then -- Set Last to point to last character before the -- library version. diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index cfa1d5e..3e5fbe0 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -281,6 +281,7 @@ package body Impunit is ("g-htable", F), -- GNAT.Htable ("g-io ", F), -- GNAT.IO ("g-io_aux", F), -- GNAT.IO_Aux + ("g-lists ", F), -- GNAT.Lists ("g-locfil", F), -- GNAT.Lock_Files ("g-mbdira", F), -- GNAT.MBBS_Discrete_Random ("g-mbflra", F), -- GNAT.MBBS_Float_Random @@ -372,10 +373,18 @@ package body Impunit is ("s-addima", F), -- System.Address_Image ("s-atocou", F), -- System.Atomic_Counters ("s-assert", F), -- System.Assertions + ("s-dfmkio", F), -- System.Dim.Float_Mks_IO + ("s-dfmopr", F), -- System.Dim.Float_Mks.Other_Prefixes + ("s-dgmgop", F), -- System.Dim.Generic_Mks.Generic_Other_Prefixes + ("s-dlmopr", F), -- System.Dim.Long_Mks.Other_Prefixes ("s-diflio", F), -- System.Dim.Float_IO + ("s-diflmk", F), -- System.Dim.Float_Mks + ("s-digemk", F), -- System.Dim.Generic_Mks ("s-diinio", F), -- System.Dim.Integer_IO + ("s-dilomk", F), -- System.Dim.Long_Mks ("s-dimkio", F), -- System.Dim.Mks_IO ("s-dimmks", F), -- System.Dim.Mks + ("s-dlmkio", F), -- System.Dim.Long_Mks_IO ("s-dmotpr", F), -- System.Dim.Mks.Other_Prefixes ("s-memory", F), -- System.Memory ("s-parint", F), -- System.Partition_Interface diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb index fa88ef7..6640c57 100644 --- a/gcc/ada/itypes.adb +++ b/gcc/ada/itypes.adb @@ -42,7 +42,7 @@ package body Itypes is Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; Suffix : Character := ' '; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Scope_Id : Entity_Id := Current_Scope) return Entity_Id is Typ : Entity_Id; diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads index e59cbe8..1513c8a 100644 --- a/gcc/ada/itypes.ads +++ b/gcc/ada/itypes.ads @@ -110,7 +110,7 @@ package Itypes is Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; Suffix : Character := ' '; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Scope_Id : Entity_Id := Current_Scope) return Entity_Id; -- Used to create a new Itype -- diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 6b77757..a7b24ab 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -325,6 +325,16 @@ package body Layout is then Init_Size (E, 2 * System_Address_Size); + -- If unnesting subprograms, subprogram access types contain the + -- address of both the subprogram and an activation record. But if we + -- set that, we'll get a warning on different unchecked conversion + -- sizes in the RTS. So leave unset ub that case. + + elsif Unnest_Subprogram_Mode + and then Is_Access_Subprogram_Type (E) + then + null; + -- Normal case of thin pointer else diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 9a54fa9..a4f9526 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -744,7 +744,14 @@ package body Lib.Writ is Note_Unit := U; end if; - if Note_Unit = Unit_Num then + -- No action needed for pragmas removed by the expander (for + -- example, pragmas of ignored ghost entities). + + if Nkind (N) = N_Null_Statement then + pragma Assert (Nkind (Original_Node (N)) = N_Pragma); + null; + + elsif Note_Unit = Unit_Num then Write_Info_Initiate ('N'); Write_Info_Char (' '); @@ -956,10 +963,11 @@ package body Lib.Writ is -- allow partial analysis on incomplete sources. if GNATprove_Mode then - Body_Fname := - Get_File_Name (Get_Body_Name (Uname), - Subunit => False, May_Fail => True); + Get_File_Name + (Uname => Get_Body_Name (Uname), + Subunit => False, + May_Fail => True); Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); @@ -974,8 +982,10 @@ package body Lib.Writ is else Body_Fname := - Get_File_Name (Get_Body_Name (Uname), - Subunit => False, May_Fail => False); + Get_File_Name + (Uname => Get_Body_Name (Uname), + Subunit => False, + May_Fail => False); Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); end if; diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 0ce834a..ce4538b 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -228,7 +228,18 @@ package body SPARK_Specific is end loop; if Nkind (Context) = N_Pragma then - Context := Parent (Context); + + -- When used for cross-references then aspects might not be + -- yet linked to pragmas; when used for AST navigation in + -- GNATprove this routine is expected to follow those links. + + if From_Aspect_Specification (Context) then + Context := Corresponding_Aspect (Context); + pragma Assert (Nkind (Context) = N_Aspect_Specification); + Context := Entity (Context); + else + Context := Parent (Context); + end if; end if; when N_Entry_Body diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 5c7a086..903e64e 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -632,6 +632,11 @@ package Lib.Xref is -- Return the closest enclosing subprogram or library-level package. -- This ensures that GNATprove can distinguish local variables from -- global variables. + -- + -- ??? This routine should only be used for processing related to + -- cross-references, where it might return wrong result but must avoid + -- crashes on ill-formed source code. It is wrong to use it where exact + -- result is needed. procedure Generate_Dereference (N : Node_Id; diff --git a/gcc/ada/libgnarl/a-intnam__dragonfly.ads b/gcc/ada/libgnarl/a-intnam__dragonfly.ads index 1de9735..8fb16f3 100644 --- a/gcc/ada/libgnarl/a-intnam__dragonfly.ads +++ b/gcc/ada/libgnarl/a-intnam__dragonfly.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2018, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.adb b/gcc/ada/libgnarl/s-osinte__dragonfly.adb index dc9e19c..3cf18d1 100644 --- a/gcc/ada/libgnarl/s-osinte__dragonfly.adb +++ b/gcc/ada/libgnarl/s-osinte__dragonfly.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1991-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2018, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.ads b/gcc/ada/libgnarl/s-osinte__dragonfly.ads index a67702c..5a4255f 100644 --- a/gcc/ada/libgnarl/s-osinte__dragonfly.ads +++ b/gcc/ada/libgnarl/s-osinte__dragonfly.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2018, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnarl/s-osinte__gnu.adb b/gcc/ada/libgnarl/s-osinte__gnu.adb index fb099ac..3147748 100644 --- a/gcc/ada/libgnarl/s-osinte__gnu.adb +++ b/gcc/ada/libgnarl/s-osinte__gnu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2015-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2015-2018, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnarl/s-osinte__gnu.ads b/gcc/ada/libgnarl/s-osinte__gnu.ads index 183c5b8..0482a4e 100644 --- a/gcc/ada/libgnarl/s-osinte__gnu.ads +++ b/gcc/ada/libgnarl/s-osinte__gnu.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2018, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb index a9d46a0..84d5101 100644 --- a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb +++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2018, 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- -- diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads index 28fb5ba..36c4b9c 100644 --- a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads +++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2018, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb index 1c5dcc1..6a1bb86 100644 --- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb +++ b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads index 137f34b..9c75f29 100644 --- a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads +++ b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2018, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index a6e2734..b093e79 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -38,11 +38,10 @@ package body GNAT.Dynamic_HTables is ------------------- package body Static_HTable is - function Get_Non_Null (T : Instance) return Elmt_Ptr; -- Returns Null_Ptr if Iterator_Started is False or if the Table is - -- empty. Returns Iterator_Ptr if non null, or the next non null - -- element in table if any. + -- empty. Returns Iterator_Ptr if non null, or the next non null element + -- in table if any. --------- -- Get -- @@ -363,7 +362,834 @@ package body GNAT.Dynamic_HTables is begin E.Next := Next; end Set_Next; - end Simple_HTable; + -------------------- + -- Dynamic_HTable -- + -------------------- + + package body Dynamic_HTable is + Minimum_Size : constant Bucket_Range_Type := 32; + -- Minimum size of the buckets + + Safe_Compression_Size : constant Bucket_Range_Type := + Minimum_Size * Compression_Factor; + -- Maximum safe size for hash table compression. Beyond this size, a + -- compression will violate the minimum size constraint on the buckets. + + Safe_Expansion_Size : constant Bucket_Range_Type := + Bucket_Range_Type'Last / Expansion_Factor; + -- Maximum safe size for hash table expansion. Beyond this size, an + -- expansion will overflow the buckets. + + procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr); + pragma Inline (Destroy_Buckets); + -- Destroy all nodes within buckets Bkts + + procedure Detach (Nod : Node_Ptr); + pragma Inline (Detach); + -- Detach node Nod from the bucket it resides in + + procedure Ensure_Circular (Head : Node_Ptr); + pragma Inline (Ensure_Circular); + -- Ensure that dummy head Head is circular with respect to itself + + procedure Ensure_Created (T : Instance); + pragma Inline (Ensure_Created); + -- Verify that hash table T is created. Raise Not_Created if this is not + -- the case. + + procedure Ensure_Unlocked (T : Instance); + pragma Inline (Ensure_Unlocked); + -- Verify that hash table T is unlocked. Raise Table_Locked if this is + -- not the case. + + function Find_Bucket + (Bkts : Bucket_Table_Ptr; + Key : Key_Type) return Node_Ptr; + pragma Inline (Find_Bucket); + -- Find the bucket among buckets Bkts which corresponds to key Key, and + -- return its dummy head. + + function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr; + pragma Inline (Find_Node); + -- Traverse a bucket indicated by dummy head Head to determine whether + -- there exists a node with key Key. If such a node exists, return it, + -- otherwise return null. + + procedure First_Valid_Node + (T : Instance; + Low_Bkt : Bucket_Range_Type; + High_Bkt : Bucket_Range_Type; + Idx : out Bucket_Range_Type; + Nod : out Node_Ptr); + pragma Inline (First_Valid_Node); + -- Find the first valid node in the buckets of hash table T constrained + -- by the range Low_Bkt .. High_Bkt. If such a node exists, return its + -- bucket index in Idx and reference in Nod. If no such node exists, + -- Idx is set to 0 and Nod to null. + + procedure Free is + new Ada.Unchecked_Deallocation (Bucket_Table, Bucket_Table_Ptr); + + procedure Free is + new Ada.Unchecked_Deallocation (Hash_Table, Instance); + + procedure Free is + new Ada.Unchecked_Deallocation (Node, Node_Ptr); + + function Is_Valid (Iter : Iterator) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether iterator Iter refers to a valid key-value pair + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether node Nod is non-null and does not refer to dummy + -- head Head, thus making it valid. + + function Load_Factor (T : Instance) return Threshold_Type; + pragma Inline (Load_Factor); + -- Calculate the load factor of hash table T + + procedure Lock (T : Instance); + pragma Inline (Lock); + -- Lock all mutation functionality of hash table T + + procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type); + pragma Inline (Mutate_And_Rehash); + -- Replace the buckets of hash table T with a new set of buckets of size + -- Size. Rehash all key-value pairs from the old to the new buckets. + + procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr); + pragma Inline (Prepend); + -- Insert node Nod immediately after dummy head Head + + procedure Unlock (T : Instance); + pragma Inline (Unlock); + -- Unlock all mutation functionality of hash table T + + ------------ + -- Create -- + ------------ + + function Create (Initial_Size : Bucket_Range_Type) return Instance is + Size : constant Bucket_Range_Type := + Bucket_Range_Type'Max (Initial_Size, Minimum_Size); + -- Ensure that the buckets meet a minimum size + + T : constant Instance := new Hash_Table; + + begin + T.Buckets := new Bucket_Table (0 .. Size - 1); + T.Initial_Size := Size; + + return T; + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (T : Instance; Key : Key_Type) is + procedure Compress; + pragma Inline (Compress); + -- Determine whether hash table T requires compression, and if so, + -- half its size. + + -------------- + -- Compress -- + -------------- + + procedure Compress is + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + Old_Size : constant Bucket_Range_Type := T.Buckets'Length; + + begin + -- The ratio of pairs to buckets is under the desited threshold. + -- Compress the hash table only when there is still room to do so. + + if Load_Factor (T) < Compression_Threshold + and then Old_Size >= Safe_Compression_Size + then + Mutate_And_Rehash (T, Old_Size / Compression_Factor); + end if; + end Compress; + + -- Local variables + + Head : Node_Ptr; + Nod : Node_Ptr; + + -- Start of processing for Delete + + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Try to find a node in the bucket which matches the key + + Nod := Find_Node (Head, Key); + + -- If such a node exists, remove it from the bucket and deallocate it + + if Is_Valid (Nod, Head) then + Detach (Nod); + Free (Nod); + + T.Pairs := T.Pairs - 1; + + -- Compress the hash table if the load factor drops below + -- Compression_Threshold. + + Compress; + end if; + end Delete; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (T : in out Instance) is + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Destroy all nodes in all buckets + + Destroy_Buckets (T.Buckets); + Free (T.Buckets); + Free (T); + end Destroy; + + --------------------- + -- Destroy_Buckets -- + --------------------- + + procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr) is + procedure Destroy_Bucket (Head : Node_Ptr); + pragma Inline (Destroy_Bucket); + -- Destroy all nodes in a bucket with dummy head Head + + -------------------- + -- Destroy_Bucket -- + -------------------- + + procedure Destroy_Bucket (Head : Node_Ptr) is + Nod : Node_Ptr; + + begin + -- Destroy all valid nodes which follow the dummy head + + while Is_Valid (Head.Next, Head) loop + Nod := Head.Next; + + Detach (Nod); + Free (Nod); + end loop; + end Destroy_Bucket; + + -- Start of processing for Destroy_Buckets + + begin + pragma Assert (Bkts /= null); + + for Scan_Idx in Bkts'Range loop + Destroy_Bucket (Bkts (Scan_Idx)'Access); + end loop; + end Destroy_Buckets; + + ------------ + -- Detach -- + ------------ + + procedure Detach (Nod : Node_Ptr) is + pragma Assert (Nod /= null); + + Next : constant Node_Ptr := Nod.Next; + Prev : constant Node_Ptr := Nod.Prev; + + begin + pragma Assert (Next /= null); + pragma Assert (Prev /= null); + + Prev.Next := Next; + Next.Prev := Prev; + + Nod.Next := null; + Nod.Prev := null; + end Detach; + + --------------------- + -- Ensure_Circular -- + --------------------- + + procedure Ensure_Circular (Head : Node_Ptr) is + pragma Assert (Head /= null); + + begin + if Head.Next = null and then Head.Prev = null then + Head.Next := Head; + Head.Prev := Head; + end if; + end Ensure_Circular; + + -------------------- + -- Ensure_Created -- + -------------------- + + procedure Ensure_Created (T : Instance) is + begin + if T = null then + raise Not_Created; + end if; + end Ensure_Created; + + --------------------- + -- Ensure_Unlocked -- + --------------------- + + procedure Ensure_Unlocked (T : Instance) is + begin + pragma Assert (T /= null); + + -- The hash table has at least one outstanding iterator + + if T.Locked > 0 then + raise Table_Locked; + end if; + end Ensure_Unlocked; + + ----------------- + -- Find_Bucket -- + ----------------- + + function Find_Bucket + (Bkts : Bucket_Table_Ptr; + Key : Key_Type) return Node_Ptr + is + pragma Assert (Bkts /= null); + + Idx : constant Bucket_Range_Type := Hash (Key) mod Bkts'Length; + + begin + return Bkts (Idx)'Access; + end Find_Bucket; + + --------------- + -- Find_Node -- + --------------- + + function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- Traverse the nodes of the bucket, looking for a key-value pair + -- with the same key. + + Nod := Head.Next; + while Is_Valid (Nod, Head) loop + if Equivalent_Keys (Nod.Key, Key) then + return Nod; + end if; + + Nod := Nod.Next; + end loop; + + return null; + end Find_Node; + + ---------------------- + -- First_Valid_Node -- + ---------------------- + + procedure First_Valid_Node + (T : Instance; + Low_Bkt : Bucket_Range_Type; + High_Bkt : Bucket_Range_Type; + Idx : out Bucket_Range_Type; + Nod : out Node_Ptr) + is + Head : Node_Ptr; + + begin + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + -- Assume that no valid node exists + + Idx := 0; + Nod := null; + + -- Examine the buckets of the hash table within the requested range, + -- looking for the first valid node. + + for Scan_Idx in Low_Bkt .. High_Bkt loop + Head := T.Buckets (Scan_Idx)'Access; + + -- The bucket contains at least one valid node, return the first + -- such node. + + if Is_Valid (Head.Next, Head) then + Idx := Scan_Idx; + Nod := Head.Next; + return; + end if; + end loop; + end First_Valid_Node; + + --------- + -- Get -- + --------- + + function Get (T : Instance; Key : Key_Type) return Value_Type is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Try to find a node in the bucket which matches the key + + Nod := Find_Node (Head, Key); + + -- If such a node exists, return the value of the key-value pair + + if Is_Valid (Nod, Head) then + return Nod.Value; + end if; + + return No_Value; + end Get; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Iterator) return Boolean is + Is_OK : constant Boolean := Is_Valid (Iter); + T : constant Instance := Iter.Table; + + begin + pragma Assert (T /= null); + + -- The iterator is no longer valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the hash table + -- because the iterator cannot be advanced any further. + + if not Is_OK then + Unlock (T); + end if; + + return Is_OK; + end Has_Next; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Iter : Iterator) return Boolean is + begin + -- The invariant of Iterate and Next ensures that the iterator always + -- refers to a valid node if there exists one. + + return Iter.Nod /= null; + end Is_Valid; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is + begin + -- A node is valid if it is non-null, and does not refer to the dummy + -- head of some bucket. + + return Nod /= null and then Nod /= Head; + end Is_Valid; + + ------------- + -- Iterate -- + ------------- + + function Iterate (T : Instance) return Iterator is + Iter : Iterator; + + begin + Ensure_Created (T); + pragma Assert (T.Buckets /= null); + + -- Initialize the iterator to reference the first valid node in + -- the full range of hash table buckets. If no such node exists, + -- the iterator is left in a state which does not allow it to + -- advance. + + First_Valid_Node + (T => T, + Low_Bkt => T.Buckets'First, + High_Bkt => T.Buckets'Last, + Idx => Iter.Idx, + Nod => Iter.Nod); + + -- Associate the iterator with the hash table to allow for future + -- mutation functionality unlocking. + + Iter.Table := T; + + -- Lock all mutation functionality of the hash table while it is + -- being iterated on. + + Lock (T); + + return Iter; + end Iterate; + + ----------------- + -- Load_Factor -- + ----------------- + + function Load_Factor (T : Instance) return Threshold_Type is + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + begin + -- The load factor is the ratio of key-value pairs to buckets + + return Threshold_Type (T.Pairs) / Threshold_Type (T.Buckets'Length); + end Load_Factor; + + ---------- + -- Lock -- + ---------- + + procedure Lock (T : Instance) is + begin + -- The hash table may be locked multiple times if multiple iterators + -- are operating over it. + + T.Locked := T.Locked + 1; + end Lock; + + ----------------------- + -- Mutate_And_Rehash -- + ----------------------- + + procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type) is + procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr); + pragma Inline (Rehash); + -- Remove all nodes from buckets From and rehash them into buckets To + + procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr); + pragma Inline (Rehash_Bucket); + -- Detach all nodes starting from dummy head Head and rehash them + -- into To. + + procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr); + pragma Inline (Rehash_Node); + -- Rehash node Nod into To + + ------------ + -- Rehash -- + ------------ + + procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr) is + begin + pragma Assert (From /= null); + pragma Assert (To /= null); + + for Scan_Idx in From'Range loop + Rehash_Bucket (From (Scan_Idx)'Access, To); + end loop; + end Rehash; + + ------------------- + -- Rehash_Bucket -- + ------------------- + + procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr) is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- Detach all nodes which follow the dummy head + + while Is_Valid (Head.Next, Head) loop + Nod := Head.Next; + + Detach (Nod); + Rehash_Node (Nod, To); + end loop; + end Rehash_Bucket; + + ----------------- + -- Rehash_Node -- + ----------------- + + procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr) is + pragma Assert (Nod /= null); + + Head : Node_Ptr; + + begin + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (To, Nod.Key); + + -- Ensure that the dummy head of an empty bucket is circular with + -- respect to itself. + + Ensure_Circular (Head); + + -- Prepend the node to the bucket + + Prepend (Nod, Head); + end Rehash_Node; + + -- Local declarations + + Old_Bkts : Bucket_Table_Ptr; + + -- Start of processing for Mutate_And_Rehash + + begin + pragma Assert (T /= null); + + Old_Bkts := T.Buckets; + T.Buckets := new Bucket_Table (0 .. Size - 1); + + -- Transfer and rehash all key-value pairs from the old buckets to + -- the new buckets. + + Rehash (From => Old_Bkts, To => T.Buckets); + Free (Old_Bkts); + end Mutate_And_Rehash; + + ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Iterator; Key : out Key_Type) is + Is_OK : constant Boolean := Is_Valid (Iter); + Saved : constant Node_Ptr := Iter.Nod; + T : constant Instance := Iter.Table; + Head : Node_Ptr; + + begin + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + -- The iterator is no longer valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the hash table as + -- the iterator cannot be advanced any further. + + if not Is_OK then + Unlock (T); + raise Iterator_Exhausted; + end if; + + -- Advance to the next node along the same bucket + + Iter.Nod := Iter.Nod.Next; + Head := T.Buckets (Iter.Idx)'Access; + + -- If the new node is no longer valid, then this indicates that the + -- current bucket has been exhausted. Advance to the next valid node + -- within the remaining range of buckets. If no such node exists, the + -- iterator is left in a state which does not allow it to advance. + + if not Is_Valid (Iter.Nod, Head) then + First_Valid_Node + (T => T, + Low_Bkt => Iter.Idx + 1, + High_Bkt => T.Buckets'Last, + Idx => Iter.Idx, + Nod => Iter.Nod); + end if; + + Key := Saved.Key; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr) is + pragma Assert (Nod /= null); + pragma Assert (Head /= null); + + Next : constant Node_Ptr := Head.Next; + + begin + Head.Next := Nod; + Next.Prev := Nod; + + Nod.Next := Next; + Nod.Prev := Head; + end Prepend; + + --------- + -- Put -- + --------- + + procedure Put + (T : Instance; + Key : Key_Type; + Value : Value_Type) + is + procedure Expand; + pragma Inline (Expand); + -- Determine whether hash table T requires expansion, and if so, + -- double its size. + + procedure Prepend_Or_Replace (Head : Node_Ptr); + pragma Inline (Prepend_Or_Replace); + -- Update the value of a node within a bucket with dummy head Head + -- whose key is Key to Value. If there is no such node, prepend a new + -- key-value pair to the bucket. + + ------------ + -- Expand -- + ------------ + + procedure Expand is + pragma Assert (T /= null); + pragma Assert (T.Buckets /= null); + + Old_Size : constant Bucket_Range_Type := T.Buckets'Length; + + begin + -- The ratio of pairs to buckets is over the desited threshold. + -- Expand the hash table only when there is still room to do so. + + if Load_Factor (T) > Expansion_Threshold + and then Old_Size <= Safe_Expansion_Size + then + Mutate_And_Rehash (T, Old_Size * Expansion_Factor); + end if; + end Expand; + + ------------------------ + -- Prepend_Or_Replace -- + ------------------------ + + procedure Prepend_Or_Replace (Head : Node_Ptr) is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- If the bucket containst at least one valid node, then there is + -- a chance that a node with the same key as Key exists. If this + -- is the case, the value of that node must be updated. + + Nod := Head.Next; + while Is_Valid (Nod, Head) loop + if Equivalent_Keys (Nod.Key, Key) then + Nod.Value := Value; + return; + end if; + + Nod := Nod.Next; + end loop; + + -- At this point the bucket is either empty, or none of the nodes + -- match key Key. Prepend a new key-value pair. + + Nod := new Node'(Key, Value, null, null); + + Prepend (Nod, Head); + end Prepend_Or_Replace; + + -- Local variables + + Head : Node_Ptr; + + -- Start of processing for Put + + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Ensure that the dummy head of an empty bucket is circular with + -- respect to itself. + + Ensure_Circular (Head); + + -- In case the bucket already contains a node with the same key, + -- replace its value, otherwise prepend a new key-value pair. + + Prepend_Or_Replace (Head); + + T.Pairs := T.Pairs + 1; + + -- Expand the hash table if the ratio of pairs to buckets goes over + -- Expansion_Threshold. + + Expand; + end Put; + + ----------- + -- Reset -- + ----------- + + procedure Reset (T : Instance) is + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Destroy all nodes in all buckets + + Destroy_Buckets (T.Buckets); + Free (T.Buckets); + + -- Recreate the buckets using the original size from creation time + + T.Buckets := new Bucket_Table (0 .. T.Initial_Size - 1); + T.Pairs := 0; + end Reset; + + ---------- + -- Size -- + ---------- + + function Size (T : Instance) return Pair_Count_Type is + begin + Ensure_Created (T); + + return T.Pairs; + end Size; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (T : Instance) is + begin + -- The hash table may be locked multiple times if multiple iterators + -- are operating over it. + + T.Locked := T.Locked - 1; + end Unlock; + end Dynamic_HTable; + end GNAT.Dynamic_HTables; diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads index ea331c0..41574fd 100644 --- a/gcc/ada/libgnat/g-dynhta.ads +++ b/gcc/ada/libgnat/g-dynhta.ads @@ -31,13 +31,11 @@ -- Hash table searching routines --- This package contains three separate packages. The Simple_HTable package +-- This package contains two separate packages. The Simple_HTable package -- provides a very simple abstraction that associates one element to one key -- value and takes care of all allocations automatically using the heap. The -- Static_HTable package provides a more complex interface that allows full --- control over allocation. The Load_Factor_HTable package provides a more --- complex abstraction where collisions are resolved by chaining, and the --- table grows by a percentage after the load factor has been exceeded. +-- control over allocation. -- This package provides a facility similar to that of GNAT.HTable, except -- that this package declares types that can be used to define dynamic @@ -48,6 +46,8 @@ -- GNAT.HTable to keep as much coherency as possible between these two -- related units. +pragma Compiler_Unit_Warning; + package GNAT.Dynamic_HTables is ------------------- @@ -85,40 +85,38 @@ package GNAT.Dynamic_HTables is Null_Ptr : Elmt_Ptr; -- The null value of the Elmt_Ptr type + with function Next (E : Elmt_Ptr) return Elmt_Ptr; with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - with function Next (E : Elmt_Ptr) return Elmt_Ptr; -- The type must provide an internal link for the sake of the -- staticness of the HTable. type Key is limited private; with function Get_Key (E : Elmt_Ptr) return Key; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; + with function Hash (F : Key) return Header_Num; + with function Equal (F1 : Key; F2 : Key) return Boolean; package Static_HTable is - type Instance is private; Nil : constant Instance; procedure Reset (T : in out Instance); - -- Resets the hash table by releasing all memory associated with - -- it. The hash table can safely be reused after this call. For the - -- most common case where Elmt_Ptr is an access type, and Null_Ptr is - -- null, this is only needed if the same table is reused in a new - -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is - -- other than null, then Reset must be called before the first use of - -- the hash table. + -- Resets the hash table by releasing all memory associated with it. The + -- hash table can safely be reused after this call. For the most common + -- case where Elmt_Ptr is an access type, and Null_Ptr is null, this is + -- only needed if the same table is reused in a new context. If Elmt_Ptr + -- is other than an access type, or Null_Ptr is other than null, then + -- Reset must be called before the first use of the hash table. procedure Set (T : in out Instance; E : Elmt_Ptr); -- Insert the element pointer in the HTable function Get (T : Instance; K : Key) return Elmt_Ptr; - -- Returns the latest inserted element pointer with the given Key - -- or null if none. + -- Returns the latest inserted element pointer with the given Key or + -- null if none. procedure Remove (T : Instance; K : Key); - -- Removes the latest inserted element pointer associated with the - -- given key if any, does nothing if none. + -- Removes the latest inserted element pointer associated with the given + -- key if any, does nothing if none. function Get_First (T : Instance) return Elmt_Ptr; -- Returns Null_Ptr if the Htable is empty, otherwise returns one @@ -126,11 +124,11 @@ package GNAT.Dynamic_HTables is -- function will return the same element. function Get_Next (T : Instance) return Elmt_Ptr; - -- Returns an unspecified element that has not been returned by the - -- same function since the last call to Get_First or Null_Ptr if - -- there is no such element or Get_First has never been called. If - -- there is no call to 'Set' in between Get_Next calls, all the - -- elements of the Htable will be traversed. + -- Returns an unspecified element that has not been returned by the same + -- function since the last call to Get_First or Null_Ptr if there is no + -- such element or Get_First has never been called. If there is no call + -- to 'Set' in between Get_Next calls, all the elements of the Htable + -- will be traversed. private type Table_Type is array (Header_Num) of Elmt_Ptr; @@ -169,11 +167,10 @@ package GNAT.Dynamic_HTables is -- a given key type Key is private; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; + with function Hash (F : Key) return Header_Num; + with function Equal (F1 : Key; F2 : Key) return Boolean; package Simple_HTable is - type Instance is private; Nil : constant Instance; @@ -233,7 +230,6 @@ package GNAT.Dynamic_HTables is -- same restrictions apply as Get_Next. private - type Element_Wrapper; type Elmt_Ptr is access all Element_Wrapper; type Element_Wrapper is record @@ -260,7 +256,263 @@ package GNAT.Dynamic_HTables is type Instance is new Tab.Instance; Nil : constant Instance := Instance (Tab.Nil); - end Simple_HTable; + -------------------- + -- Dynamic_HTable -- + -------------------- + + -- The following package offers a hash table abstraction with the following + -- characteristics: + -- + -- * Dynamic resizing based on load factor. + -- * Creation of multiple instances, of different sizes. + -- * Iterable keys. + -- + -- This type of hash table is best used in scenarios where the size of the + -- key set is not known. The dynamic resizing aspect allows for performance + -- to remain within reasonable bounds as the size of the key set grows. + -- + -- The following use pattern must be employed when operating this table: + -- + -- Table : Instance := Create (<some size>); + -- + -- <various operations> + -- + -- Destroy (Table); + -- + -- The destruction of the table reclaims all storage occupied by it. + + -- The following type denotes the underlying range of the hash table + -- buckets. + + type Bucket_Range_Type is mod 2 ** 32; + + -- The following type denotes the multiplicative factor used in expansion + -- and compression of the hash table. + + subtype Factor_Type is Bucket_Range_Type range 2 .. 100; + + -- The following type denotes the number of key-value pairs stored in the + -- hash table. + + type Pair_Count_Type is range 0 .. 2 ** 31 - 1; + + -- The following type denotes the threshold range used in expansion and + -- compression of the hash table. + + subtype Threshold_Type is Long_Float range 0.0 .. Long_Float'Last; + + generic + type Key_Type is private; + type Value_Type is private; + -- The types of the key-value pairs stored in the hash table + + No_Value : Value_Type; + -- An indicator for a non-existent value + + Expansion_Threshold : Threshold_Type; + Expansion_Factor : Factor_Type; + -- Once the load factor goes over Expansion_Threshold, the size of the + -- buckets is increased using the formula + -- + -- New_Size = Old_Size * Expansion_Factor + -- + -- An Expansion_Threshold of 1.5 and Expansion_Factor of 2 indicate that + -- the size of the buckets will be doubled once the load factor exceeds + -- 1.5. + + Compression_Threshold : Threshold_Type; + Compression_Factor : Factor_Type; + -- Once the load factor drops below Compression_Threshold, the size of + -- the buckets is decreased using the formula + -- + -- New_Size = Old_Size / Compression_Factor + -- + -- A Compression_Threshold of 0.5 and Compression_Factor of 2 indicate + -- that the size of the buckets will be halved once the load factor + -- drops below 0.5. + + with function Equivalent_Keys + (Left : Key_Type; + Right : Key_Type) return Boolean; + -- Determine whether two keys are equivalent + + with function Hash (Key : Key_Type) return Bucket_Range_Type; + -- Map an arbitrary key into the range of buckets + + package Dynamic_HTable is + + ---------------------- + -- Table operations -- + ---------------------- + + -- The following type denotes a hash table handle. Each instance must be + -- created using routine Create. + + type Instance is private; + Nil : constant Instance; + + Not_Created : exception; + -- This exception is raised when the hash table has not been created by + -- routine Create, and an attempt is made to read or mutate its state. + + Table_Locked : exception; + -- This exception is raised when the hash table is being iterated on, + -- and an attempt is made to mutate its state. + + function Create (Initial_Size : Bucket_Range_Type) return Instance; + -- Create a new table with bucket capacity Initial_Size. This routine + -- must be called at the start of a hash table's lifetime. + + procedure Delete (T : Instance; Key : Key_Type); + -- Delete the value which corresponds to key Key from hash table T. The + -- routine has no effect if the value is not present in the hash table. + -- This action will raise Table_Locked if the hash table has outstanding + -- iterators. If the load factor drops below Compression_Threshold, the + -- size of the buckets is decreased by Copression_Factor. + + procedure Destroy (T : in out Instance); + -- Destroy the contents of hash table T, rendering it unusable. This + -- routine must be called at the end of a hash table's lifetime. This + -- action will raise Table_Locked if the hash table has outstanding + -- iterators. + + function Get (T : Instance; Key : Key_Type) return Value_Type; + -- Obtain the value which corresponds to key Key from hash table T. If + -- the value does not exist, return No_Value. + + procedure Put + (T : Instance; + Key : Key_Type; + Value : Value_Type); + -- Associate value Value with key Key in hash table T. If the table + -- already contains a mapping of the same key to a previous value, the + -- previous value is overwritten. This action will raise Table_Locked + -- if the hash table has outstanding iterators. If the load factor goes + -- over Expansion_Threshold, the size of the buckets is increased by + -- Expansion_Factor. + + procedure Reset (T : Instance); + -- Destroy the contents of hash table T, and reset it to its initial + -- created state. This action will raise Table_Locked if the hash table + -- has outstanding iterators. + + function Size (T : Instance) return Pair_Count_Type; + -- Obtain the number of key-value pairs in hash table T + + ------------------------- + -- Iterator operations -- + ------------------------- + + -- The following type represents a key iterator. An iterator locks + -- all mutation operations, and unlocks them once it is exhausted. + -- The iterator must be used with the following pattern: + -- + -- Iter := Iterate (My_Table); + -- while Has_Next (Iter) loop + -- Key := Next (Iter); + -- . . . + -- end loop; + -- + -- It is possible to advance the iterator by using Next only, however + -- this risks raising Iterator_Exhausted. + + type Iterator is private; + + Iterator_Exhausted : exception; + -- This exception is raised when an iterator is exhausted and further + -- attempts to advance it are made by calling routine Next. + + function Iterate (T : Instance) return Iterator; + -- Obtain an iterator over the keys of hash table T. This action locks + -- all mutation functionality of the associated hash table. + + function Has_Next (Iter : Iterator) return Boolean; + -- Determine whether iterator Iter has more keys to examine. If the + -- iterator has been exhausted, restore all mutation functionality of + -- the associated hash table. + + procedure Next + (Iter : in out Iterator; + Key : out Key_Type); + -- Return the current key referenced by iterator Iter and advance to + -- the next available key. If the iterator has been exhausted and + -- further attempts are made to advance it, this routine restores + -- mutation functionality of the associated hash table, and then + -- raises Iterator_Exhausted. + + private + -- The following type represents a doubly linked list node used to + -- store a key-value pair. There are several reasons to use a doubly + -- linked list: + -- + -- * Most read and write operations utilize the same primitve + -- routines to locate, create, and delete a node, allowing for + -- greater degree of code sharing. + -- + -- * Special cases are eliminated by maintaining a circular node + -- list with a dummy head (see type Bucket_Table). + -- + -- A node is said to be "valid" if it is non-null, and does not refer to + -- the dummy head of some bucket. + + type Node; + type Node_Ptr is access all Node; + type Node is record + Key : Key_Type; + Value : Value_Type := No_Value; + -- Key-value pair stored in a bucket + + Prev : Node_Ptr := null; + Next : Node_Ptr := null; + end record; + + -- The following type represents a bucket table. Each bucket contains a + -- circular doubly linked list of nodes with a dummy head. Initially, + -- the head does not refer to itself. This is intentional because it + -- improves the performance of creation, compression, and expansion by + -- avoiding a separate pass to link a head to itself. Several routines + -- ensure that the head is properly formed. + + type Bucket_Table is array (Bucket_Range_Type range <>) of aliased Node; + type Bucket_Table_Ptr is access Bucket_Table; + + -- The following type represents a hash table + + type Hash_Table is record + Buckets : Bucket_Table_Ptr := null; + -- Reference to the compressing / expanding buckets + + Initial_Size : Bucket_Range_Type := 0; + -- The initial size of the buckets as specified at creation time + + Locked : Natural := 0; + -- Number of outstanding iterators + + Pairs : Pair_Count_Type := 0; + -- Number of key-value pairs in the buckets + end record; + + type Instance is access Hash_Table; + Nil : constant Instance := null; + + -- The following type represents a key iterator + + type Iterator is record + Idx : Bucket_Range_Type := 0; + -- Index of the current bucket being examined. This index is always + -- kept within the range of the buckets. + + Nod : Node_Ptr := null; + -- Reference to the current node being examined within the current + -- bucket. The invariant of the iterator requires that this field + -- always point to a valid node. A value of null indicates that the + -- iterator is exhausted. + + Table : Instance := null; + -- Reference to the associated hash table + end record; + end Dynamic_HTable; + end GNAT.Dynamic_HTables; diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb new file mode 100644 index 0000000..a058f33 --- /dev/null +++ b/gcc/ada/libgnat/g-lists.adb @@ -0,0 +1,635 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . L I S T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body GNAT.Lists is + + package body Doubly_Linked_List is + procedure Delete_Node (L : Instance; Nod : Node_Ptr); + pragma Inline (Delete_Node); + -- Detach and delete node Nod from list L + + procedure Ensure_Circular (Head : Node_Ptr); + pragma Inline (Ensure_Circular); + -- Ensure that dummy head Head is circular with respect to itself + + procedure Ensure_Created (L : Instance); + pragma Inline (Ensure_Created); + -- Verify that list L is created. Raise Not_Created if this is not the + -- case. + + procedure Ensure_Full (L : Instance); + pragma Inline (Ensure_Full); + -- Verify that list L contains at least one element. Raise List_Empty if + -- this is not the case. + + procedure Ensure_Unlocked (L : Instance); + pragma Inline (Ensure_Unlocked); + -- Verify that list L is unlocked. Raise List_Locked if this is not the + -- case. + + function Find_Node + (Head : Node_Ptr; + Elem : Element_Type) return Node_Ptr; + pragma Inline (Find_Node); + -- Travers a list indicated by dummy head Head to determine whethe there + -- exists a node with element Elem. If such a node exists, return it, + -- otherwise return null; + + procedure Free is new Ada.Unchecked_Deallocation (Linked_List, Instance); + + procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr); + + procedure Insert_Between + (L : Instance; + Elem : Element_Type; + Left : Node_Ptr; + Right : Node_Ptr); + pragma Inline (Insert_Between); + -- Insert element Elem between nodes Left and Right of list L + + function Is_Valid (Iter : Iterator) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether iterator Iter refers to a valid element + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean; + pragma Inline (Is_Valid); + -- Determine whether node Nod is non-null and does not refer to dummy + -- head Head, thus making it valid. + + procedure Lock (L : Instance); + pragma Inline (Lock); + -- Lock all mutation functionality of list L + + procedure Unlock (L : Instance); + pragma Inline (Unlock); + -- Unlock all mutation functionality of list L + + ------------ + -- Append -- + ------------ + + procedure Append (L : Instance; Elem : Element_Type) is + Head : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + -- Ensure that the dummy head of an empty list is circular with + -- respect to itself. + + Head := L.Nodes'Access; + Ensure_Circular (Head); + + -- Append the node by inserting it between the last node and the + -- dummy head. + + Insert_Between + (L => L, + Elem => Elem, + Left => Head.Prev, + Right => Head); + end Append; + + ------------ + -- Create -- + ------------ + + function Create return Instance is + begin + return new Linked_List; + end Create; + + -------------- + -- Contains -- + -------------- + + function Contains (L : Instance; Elem : Element_Type) return Boolean is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Elem); + + return Is_Valid (Nod, Head); + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (L : Instance; Elem : Element_Type) is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Full (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Elem); + + if Is_Valid (Nod, Head) then + Delete_Node (L, Nod); + end if; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (L : Instance) is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Full (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Head.Next; + + if Is_Valid (Nod, Head) then + Delete_Node (L, Nod); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (L : Instance) is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Full (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Head.Prev; + + if Is_Valid (Nod, Head) then + Delete_Node (L, Nod); + end if; + end Delete_Last; + + ----------------- + -- Delete_Node -- + ----------------- + + procedure Delete_Node (L : Instance; Nod : Node_Ptr) is + Ref : Node_Ptr := Nod; + + pragma Assert (Ref /= null); + + Next : constant Node_Ptr := Ref.Next; + Prev : constant Node_Ptr := Ref.Prev; + + begin + pragma Assert (L /= null); + pragma Assert (Next /= null); + pragma Assert (Prev /= null); + + Prev.Next := Next; -- Prev ---> Next + Next.Prev := Prev; -- Prev <--> Next + + Ref.Next := null; + Ref.Prev := null; + + L.Elements := L.Elements - 1; + + Free (Ref); + end Delete_Node; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (L : in out Instance) is + Head : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + + while Is_Valid (Head.Next, Head) loop + Delete_Node (L, Head.Next); + end loop; + + Free (L); + end Destroy; + + --------------------- + -- Ensure_Circular -- + --------------------- + + procedure Ensure_Circular (Head : Node_Ptr) is + pragma Assert (Head /= null); + + begin + if Head.Next = null and then Head.Prev = null then + Head.Next := Head; + Head.Prev := Head; + end if; + end Ensure_Circular; + + -------------------- + -- Ensure_Created -- + -------------------- + + procedure Ensure_Created (L : Instance) is + begin + if L = null then + raise Not_Created; + end if; + end Ensure_Created; + + ----------------- + -- Ensure_Full -- + ----------------- + + procedure Ensure_Full (L : Instance) is + begin + pragma Assert (L /= null); + + if L.Elements = 0 then + raise List_Empty; + end if; + end Ensure_Full; + + --------------------- + -- Ensure_Unlocked -- + --------------------- + + procedure Ensure_Unlocked (L : Instance) is + begin + pragma Assert (L /= null); + + -- The list has at least one outstanding iterator + + if L.Locked > 0 then + raise List_Locked; + end if; + end Ensure_Unlocked; + + --------------- + -- Find_Node -- + --------------- + + function Find_Node + (Head : Node_Ptr; + Elem : Element_Type) return Node_Ptr + is + pragma Assert (Head /= null); + + Nod : Node_Ptr; + + begin + -- Traverse the nodes of the list, looking for a matching element + + Nod := Head.Next; + while Is_Valid (Nod, Head) loop + if Nod.Elem = Elem then + return Nod; + end if; + + Nod := Nod.Next; + end loop; + + return null; + end Find_Node; + + ----------- + -- First -- + ----------- + + function First (L : Instance) return Element_Type is + begin + Ensure_Created (L); + Ensure_Full (L); + + return L.Nodes.Next.Elem; + end First; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Iterator) return Boolean is + Is_OK : constant Boolean := Is_Valid (Iter); + + begin + -- The iterator is no longer valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the list because + -- the iterator cannot be advanced any further. + + if not Is_OK then + Unlock (Iter.List); + end if; + + return Is_OK; + end Has_Next; + + ------------------ + -- Insert_After -- + ------------------ + + procedure Insert_After + (L : Instance; + After : Element_Type; + Elem : Element_Type) + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, After); + + if Is_Valid (Nod, Head) then + Insert_Between + (L => L, + Elem => Elem, + Left => Nod, + Right => Nod.Next); + end if; + end Insert_After; + + ------------------- + -- Insert_Before -- + ------------------- + + procedure Insert_Before + (L : Instance; + Before : Element_Type; + Elem : Element_Type) + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Before); + + if Is_Valid (Nod, Head) then + Insert_Between + (L => L, + Elem => Elem, + Left => Nod.Prev, + Right => Nod); + end if; + end Insert_Before; + + -------------------- + -- Insert_Between -- + -------------------- + + procedure Insert_Between + (L : Instance; + Elem : Element_Type; + Left : Node_Ptr; + Right : Node_Ptr) + is + pragma Assert (L /= null); + pragma Assert (Left /= null); + pragma Assert (Right /= null); + + Nod : constant Node_Ptr := + new Node'(Elem => Elem, + Next => Right, -- Left Nod ---> Right + Prev => Left); -- Left <--- Nod ---> Right + + begin + Left.Next := Nod; -- Left <--> Nod ---> Right + Right.Prev := Nod; -- Left <--> Nod <--> Right + + L.Elements := L.Elements + 1; + end Insert_Between; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (L : Instance) return Boolean is + begin + Ensure_Created (L); + + return L.Elements = 0; + end Is_Empty; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Iter : Iterator) return Boolean is + begin + -- The invariant of Iterate and Next ensures that the iterator always + -- refers to a valid node if there exists one. + + return Is_Valid (Iter.Nod, Iter.List.Nodes'Access); + end Is_Valid; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is + begin + -- A node is valid if it is non-null, and does not refer to the dummy + -- head of some list. + + return Nod /= null and then Nod /= Head; + end Is_Valid; + + ------------- + -- Iterate -- + ------------- + + function Iterate (L : Instance) return Iterator is + begin + Ensure_Created (L); + + -- Lock all mutation functionality of the list while it is being + -- iterated on. + + Lock (L); + + return (List => L, Nod => L.Nodes.Next); + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (L : Instance) return Element_Type is + begin + Ensure_Created (L); + Ensure_Full (L); + + return L.Nodes.Prev.Elem; + end Last; + + ------------ + -- Length -- + ------------ + + function Length (L : Instance) return Element_Count_Type is + begin + Ensure_Created (L); + + return L.Elements; + end Length; + + ---------- + -- Lock -- + ---------- + + procedure Lock (L : Instance) is + begin + pragma Assert (L /= null); + + -- The list may be locked multiple times if multiple iterators are + -- operating over it. + + L.Locked := L.Locked + 1; + end Lock; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Iterator; + Elem : out Element_Type) + is + Is_OK : constant Boolean := Is_Valid (Iter); + Saved : constant Node_Ptr := Iter.Nod; + + begin + -- The iterator is no linger valid which indicates that it has been + -- exhausted. Unlock all mutation functionality of the list as the + -- iterator cannot be advanced any further. + + if not Is_OK then + Unlock (Iter.List); + raise Iterator_Exhausted; + end if; + + -- Advance to the next node along the list + + Iter.Nod := Iter.Nod.Next; + Elem := Saved.Elem; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (L : Instance; Elem : Element_Type) is + Head : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + -- Ensure that the dummy head of an empty list is circular with + -- respect to itself. + + Head := L.Nodes'Access; + Ensure_Circular (Head); + + -- Append the node by inserting it between the dummy head and the + -- first node. + + Insert_Between + (L => L, + Elem => Elem, + Left => Head, + Right => Head.Next); + end Prepend; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (L : Instance; + Old_Elem : Element_Type; + New_Elem : Element_Type) + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (L); + Ensure_Unlocked (L); + + Head := L.Nodes'Access; + Nod := Find_Node (Head, Old_Elem); + + if Is_Valid (Nod, Head) then + Nod.Elem := New_Elem; + end if; + end Replace; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : Instance) is + begin + pragma Assert (L /= null); + + -- The list may be locked multiple times if multiple iterators are + -- operating over it. + + L.Locked := L.Locked - 1; + end Unlock; + end Doubly_Linked_List; + +end GNAT.Lists; diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads new file mode 100644 index 0000000..777b4f6 --- /dev/null +++ b/gcc/ada/libgnat/g-lists.ads @@ -0,0 +1,245 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . L I S T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 Compiler_Unit_Warning; + +package GNAT.Lists is + + ------------------------ + -- Doubly_Linked_List -- + ------------------------ + + -- The following package offers a doubly linked list abstraction with the + -- following characteristics: + -- + -- * Creation of multiple instances, of different sizes. + -- * Iterable elements. + -- + -- The following use pattern must be employed with this list: + -- + -- List : Instance := Create; + -- + -- <various operations> + -- + -- Destroy (List) + -- + -- The destruction of the list reclaims all storage occupied by it. + + -- The following type denotes the number of elements stored in a list + + type Element_Count_Type is range 0 .. 2 ** 31 - 1; + + generic + type Element_Type is private; + + with function "=" + (Left : Element_Type; + Right : Element_Type) return Boolean; + + package Doubly_Linked_List is + + --------------------- + -- List operations -- + --------------------- + + type Instance is private; + Nil : constant Instance; + + List_Empty : exception; + -- This exception is raised when the list is empty, and an attempt is + -- made to delete an element from it. + + List_Locked : exception; + -- This exception is raised when the list is being iterated on, and an + -- attempt is made to mutate its state. + + Not_Created : exception; + -- This exception is raised when the list has not been created by + -- routine Create, and an attempt is made to read or mutate its state. + + procedure Append (L : Instance; Elem : Element_Type); + -- Insert element Elem at the end of list L. This action will raise + -- List_Locked if the list has outstanding iterators. + + function Contains (L : Instance; Elem : Element_Type) return Boolean; + -- Determine whether list L contains element Elem + + function Create return Instance; + -- Create a new list + + procedure Delete (L : Instance; Elem : Element_Type); + -- Delete element Elem from list L. The routine has no effect if Elem is + -- not present. This action will raise + -- + -- * List_Empty if the list is empty. + -- * List_Locked if the list has outstanding iterators. + + procedure Delete_First (L : Instance); + -- Delete an element from the start of list L. This action will raise + -- + -- * List_Empty if the list is empty. + -- * List_Locked if the list has outstanding iterators. + + procedure Delete_Last (L : Instance); + -- Delete an element from the end of list L. This action will raise + -- + -- * List_Empty if the list is empty. + -- * List_Locked if the list has outstanding iterators. + + procedure Destroy (L : in out Instance); + -- Destroy the contents of list L. This routine must be called at the + -- end of a list's lifetime. This action will raise List_Locked if the + -- list has outstanding iterators. + + function First (L : Instance) return Element_Type; + -- Obtain an element from the start of list L. This action will raise + -- List_Empty if the list is empty. + + procedure Insert_After + (L : Instance; + After : Element_Type; + Elem : Element_Type); + -- Insert new element Elem after element After in list L. The routine + -- has no effect if After is not present. This action will raise + -- List_Locked if the list has outstanding iterators. + + procedure Insert_Before + (L : Instance; + Before : Element_Type; + Elem : Element_Type); + -- Insert new element Elem before element Before in list L. The routine + -- has no effect if After is not present. This action will raise + -- List_Locked if the list has outstanding iterators. + + function Is_Empty (L : Instance) return Boolean; + -- Determine whether list L is empty + + function Last (L : Instance) return Element_Type; + -- Obtain an element from the end of list L. This action will raise + -- List_Empty if the list is empty. + + function Length (L : Instance) return Element_Count_Type; + -- Obtain the number of elements in list L + + procedure Prepend (L : Instance; Elem : Element_Type); + -- Insert element Elem at the start of list L. This action will raise + -- List_Locked if the list has outstanding iterators. + + procedure Replace + (L : Instance; + Old_Elem : Element_Type; + New_Elem : Element_Type); + -- Replace old element Old_Elem with new element New_Elem in list L. The + -- routine has no effect if Old_Elem is not present. This action will + -- raise List_Locked if the list has outstanding iterators. + + ------------------------- + -- Iterator operations -- + ------------------------- + + -- The following type represents an element iterator. An iterator locks + -- all mutation operations, and ulocks them once it is exhausted. The + -- iterator must be used with the following pattern: + -- + -- Iter := Iterate (My_List); + -- while Has_Next (Iter) loop + -- Next (Iter, Element); + -- end loop; + -- + -- It is possible to advance the iterator by using Next only, however + -- this risks raising Iterator_Exhausted. + + type Iterator is private; + + Iterator_Exhausted : exception; + -- This exception is raised when an iterator is exhausted and further + -- attempts to advance it are made by calling routine Next. + + function Iterate (L : Instance) return Iterator; + -- Obtain an iterator over the elements of list L. This action locks all + -- mutation functionality of the associated list. + + function Has_Next (Iter : Iterator) return Boolean; + -- Determine whether iterator Iter has more elements to examine. If the + -- iterator has been exhausted, restore all mutation functionality of + -- the associated list. + + procedure Next + (Iter : in out Iterator; + Elem : out Element_Type); + -- Return the current element referenced by iterator Iter and advance + -- to the next available element. If the iterator has been exhausted + -- and further attempts are made to advance it, this routine restores + -- mutation functionality of the associated list, and then raises + -- Iterator_Exhausted. + + private + -- The following type represents a list node + + type Node; + type Node_Ptr is access all Node; + type Node is record + Elem : Element_Type; + + Next : Node_Ptr := null; + Prev : Node_Ptr := null; + end record; + + -- The following type represents a list + + type Linked_List is record + Elements : Element_Count_Type := 0; + -- The number of elements in the list + + Locked : Natural := 0; + -- Number of outstanding iterators + + Nodes : aliased Node; + -- The dummy head of the list + end record; + + type Instance is access all Linked_List; + Nil : constant Instance := null; + + -- The following type represents an element iterator + + type Iterator is record + List : Instance := null; + -- Reference to the associated list + + Nod : Node_Ptr := null; + -- Reference to the current node being examined. The invariant of the + -- iterator requires that this field always points to a valid node. A + -- value of null indicates that the iterator is exhausted. + end record; + end Doubly_Linked_List; + +end GNAT.Lists; diff --git a/gcc/ada/libgnat/s-dfmkio.ads b/gcc/ada/libgnat/s-dfmkio.ads new file mode 100644 index 0000000..c9a96c2 --- /dev/null +++ b/gcc/ada/libgnat/s-dfmkio.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ M K S _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Provides output facilities for the Float MKS dimension system (see +-- System.Dim.Float_Mks and System.Dim.Float_IO). + +with System.Dim.Float_Mks; use System.Dim.Float_Mks; +with System.Dim.Float_IO; + +package System.Dim.Float_Mks_IO is new System.Dim.Float_IO (Mks_Type); diff --git a/gcc/ada/libgnat/s-dfmopr.ads b/gcc/ada/libgnat/s-dfmopr.ads new file mode 100644 index 0000000..6938feb --- /dev/null +++ b/gcc/ada/libgnat/s-dfmopr.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ M K S . O T H E R _ P R E F I X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks.Generic_Other_Prefixes; + +package System.Dim.Float_Mks.Other_Prefixes is + new System.Dim.Float_Mks.Generic_Other_Prefixes; diff --git a/gcc/ada/libgnat/s-dgmgop.ads b/gcc/ada/libgnat/s-dgmgop.ads new file mode 100644 index 0000000..496056d --- /dev/null +++ b/gcc/ada/libgnat/s-dgmgop.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . G E N E R I C _ M K S -- +-- . G E N E R I C _ O T H E R _ P R E F I X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 that defines some other prefixes for the MKS base unit system. + +-- These prefixes have been defined in a child package in order to avoid too +-- many constant declarations in System.Dim.Generic_Mks. + +generic +package System.Dim.Generic_Mks.Generic_Other_Prefixes is + + -- SI prefixes for Meter + + pragma Warnings (Off); + -- Turn off the all the dimension warnings + + ym : constant Length := 1.0E-24; -- yocto + zm : constant Length := 1.0E-21; -- zepto + am : constant Length := 1.0E-18; -- atto + fm : constant Length := 1.0E-15; -- femto + pm : constant Length := 1.0E-12; -- pico + nm : constant Length := 1.0E-09; -- nano + Gm : constant Length := 1.0E+09; -- giga + Tm : constant Length := 1.0E+12; -- tera + Pem : constant Length := 1.0E+15; -- peta + Em : constant Length := 1.0E+18; -- exa + Zem : constant Length := 1.0E+21; -- zetta + Yom : constant Length := 1.0E+24; -- yotta + + -- SI prefixes for Kilogram + + yg : constant Mass := 1.0E-27; -- yocto + zg : constant Mass := 1.0E-24; -- zepto + ag : constant Mass := 1.0E-21; -- atto + fg : constant Mass := 1.0E-18; -- femto + pg : constant Mass := 1.0E-15; -- pico + ng : constant Mass := 1.0E-12; -- nano + Gg : constant Mass := 1.0E+06; -- giga + Tg : constant Mass := 1.0E+09; -- tera + Peg : constant Mass := 1.0E+13; -- peta + Eg : constant Mass := 1.0E+15; -- exa + Zeg : constant Mass := 1.0E+18; -- zetta + Yog : constant Mass := 1.0E+21; -- yotta + + -- SI prefixes for Second + + ys : constant Time := 1.0E-24; -- yocto + zs : constant Time := 1.0E-21; -- zepto + as : constant Time := 1.0E-18; -- atto + fs : constant Time := 1.0E-15; -- femto + ps : constant Time := 1.0E-12; -- pico + ns : constant Time := 1.0E-09; -- nano + Gs : constant Time := 1.0E+09; -- giga + Ts : constant Time := 1.0E+12; -- tera + Pes : constant Time := 1.0E+15; -- peta + Es : constant Time := 1.0E+18; -- exa + Zes : constant Time := 1.0E+21; -- zetta + Yos : constant Time := 1.0E+24; -- yotta + + -- SI prefixes for Ampere + + yA : constant Electric_Current := 1.0E-24; -- yocto + zA : constant Electric_Current := 1.0E-21; -- zepto + aA : constant Electric_Current := 1.0E-18; -- atto + fA : constant Electric_Current := 1.0E-15; -- femto + nA : constant Electric_Current := 1.0E-09; -- nano + uA : constant Electric_Current := 1.0E-06; -- micro (u) + GA : constant Electric_Current := 1.0E+09; -- giga + TA : constant Electric_Current := 1.0E+12; -- tera + PeA : constant Electric_Current := 1.0E+15; -- peta + EA : constant Electric_Current := 1.0E+18; -- exa + ZeA : constant Electric_Current := 1.0E+21; -- zetta + YoA : constant Electric_Current := 1.0E+24; -- yotta + + -- SI prefixes for Kelvin + + yK : constant Thermodynamic_Temperature := 1.0E-24; -- yocto + zK : constant Thermodynamic_Temperature := 1.0E-21; -- zepto + aK : constant Thermodynamic_Temperature := 1.0E-18; -- atto + fK : constant Thermodynamic_Temperature := 1.0E-15; -- femto + pK : constant Thermodynamic_Temperature := 1.0E-12; -- pico + nK : constant Thermodynamic_Temperature := 1.0E-09; -- nano + uK : constant Thermodynamic_Temperature := 1.0E-06; -- micro (u) + mK : constant Thermodynamic_Temperature := 1.0E-03; -- milli + cK : constant Thermodynamic_Temperature := 1.0E-02; -- centi + dK : constant Thermodynamic_Temperature := 1.0E-01; -- deci + daK : constant Thermodynamic_Temperature := 1.0E+01; -- deka + hK : constant Thermodynamic_Temperature := 1.0E+02; -- hecto + kK : constant Thermodynamic_Temperature := 1.0E+03; -- kilo + MeK : constant Thermodynamic_Temperature := 1.0E+06; -- mega + GK : constant Thermodynamic_Temperature := 1.0E+09; -- giga + TK : constant Thermodynamic_Temperature := 1.0E+12; -- tera + PeK : constant Thermodynamic_Temperature := 1.0E+15; -- peta + EK : constant Thermodynamic_Temperature := 1.0E+18; -- exa + ZeK : constant Thermodynamic_Temperature := 1.0E+21; -- zetta + YoK : constant Thermodynamic_Temperature := 1.0E+24; -- yotta + + -- SI prefixes for Mole + + ymol : constant Amount_Of_Substance := 1.0E-24; -- yocto + zmol : constant Amount_Of_Substance := 1.0E-21; -- zepto + amol : constant Amount_Of_Substance := 1.0E-18; -- atto + fmol : constant Amount_Of_Substance := 1.0E-15; -- femto + pmol : constant Amount_Of_Substance := 1.0E-12; -- pico + nmol : constant Amount_Of_Substance := 1.0E-09; -- nano + umol : constant Amount_Of_Substance := 1.0E-06; -- micro (u) + mmol : constant Amount_Of_Substance := 1.0E-03; -- milli + cmol : constant Amount_Of_Substance := 1.0E-02; -- centi + dmol : constant Amount_Of_Substance := 1.0E-01; -- deci + damol : constant Amount_Of_Substance := 1.0E+01; -- deka + hmol : constant Amount_Of_Substance := 1.0E+02; -- hecto + kmol : constant Amount_Of_Substance := 1.0E+03; -- kilo + Memol : constant Amount_Of_Substance := 1.0E+06; -- mega + Gmol : constant Amount_Of_Substance := 1.0E+09; -- giga + Tmol : constant Amount_Of_Substance := 1.0E+12; -- tera + Pemol : constant Amount_Of_Substance := 1.0E+15; -- peta + Emol : constant Amount_Of_Substance := 1.0E+18; -- exa + Zemol : constant Amount_Of_Substance := 1.0E+21; -- zetta + Yomol : constant Amount_Of_Substance := 1.0E+24; -- yotta + + -- SI prefixes for Candela + + ycd : constant Luminous_Intensity := 1.0E-24; -- yocto + zcd : constant Luminous_Intensity := 1.0E-21; -- zepto + acd : constant Luminous_Intensity := 1.0E-18; -- atto + fcd : constant Luminous_Intensity := 1.0E-15; -- femto + pcd : constant Luminous_Intensity := 1.0E-12; -- pico + ncd : constant Luminous_Intensity := 1.0E-09; -- nano + ucd : constant Luminous_Intensity := 1.0E-06; -- micro (u) + mcd : constant Luminous_Intensity := 1.0E-03; -- milli + ccd : constant Luminous_Intensity := 1.0E-02; -- centi + dcd : constant Luminous_Intensity := 1.0E-01; -- deci + dacd : constant Luminous_Intensity := 1.0E+01; -- deka + hcd : constant Luminous_Intensity := 1.0E+02; -- hecto + kcd : constant Luminous_Intensity := 1.0E+03; -- kilo + Mecd : constant Luminous_Intensity := 1.0E+06; -- mega + Gcd : constant Luminous_Intensity := 1.0E+09; -- giga + Tcd : constant Luminous_Intensity := 1.0E+12; -- tera + Pecd : constant Luminous_Intensity := 1.0E+15; -- peta + Ecd : constant Luminous_Intensity := 1.0E+18; -- exa + Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta + Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta + + pragma Warnings (On); +end System.Dim.Generic_Mks.Generic_Other_Prefixes; diff --git a/gcc/ada/libgnat/s-diflmk.ads b/gcc/ada/libgnat/s-diflmk.ads new file mode 100644 index 0000000..435948e --- /dev/null +++ b/gcc/ada/libgnat/s-diflmk.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ M K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks; + +package System.Dim.Float_Mks is new System.Dim.Generic_Mks (Float); diff --git a/gcc/ada/libgnat/s-digemk.ads b/gcc/ada/libgnat/s-digemk.ads new file mode 100644 index 0000000..4f55ad4 --- /dev/null +++ b/gcc/ada/libgnat/s-digemk.ads @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . G E N E R I C _ M K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Defines the MKS dimension system which is the SI system of units + +-- Some other prefixes of this system are defined in a child package (see +-- System.Dim.Generic_Mks.Generic_Other_Prefixes) in order to avoid too many +-- constant declarations in this package. + +-- The dimension terminology is defined in System.Dim package + +with Ada.Numerics; + +generic + type Float_Type is digits <>; + +package System.Dim.Generic_Mks is + + e : constant := Ada.Numerics.e; + Pi : constant := Ada.Numerics.Pi; + + -- Dimensioned type Mks_Type + + type Mks_Type is new Float_Type + with + Dimension_System => ( + (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), + (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), + (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), + (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), + (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), + (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), + (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); + + -- SI Base dimensioned subtypes + + subtype Length is Mks_Type + with + Dimension => (Symbol => 'm', + Meter => 1, + others => 0); + + subtype Mass is Mks_Type + with + Dimension => (Symbol => "kg", + Kilogram => 1, + others => 0); + + subtype Time is Mks_Type + with + Dimension => (Symbol => 's', + Second => 1, + others => 0); + + subtype Electric_Current is Mks_Type + with + Dimension => (Symbol => 'A', + Ampere => 1, + others => 0); + + subtype Thermodynamic_Temperature is Mks_Type + with + Dimension => (Symbol => 'K', + Kelvin => 1, + others => 0); + + subtype Amount_Of_Substance is Mks_Type + with + Dimension => (Symbol => "mol", + Mole => 1, + others => 0); + + subtype Luminous_Intensity is Mks_Type + with + Dimension => (Symbol => "cd", + Candela => 1, + others => 0); + + -- Initialize SI Base unit values + + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes (we can't assign 1.0*m to m). + + pragma Warnings (Off, "*assumed to be*"); + + m : constant Length := 1.0; + kg : constant Mass := 1.0; + s : constant Time := 1.0; + A : constant Electric_Current := 1.0; + K : constant Thermodynamic_Temperature := 1.0; + mol : constant Amount_Of_Substance := 1.0; + cd : constant Luminous_Intensity := 1.0; + + pragma Warnings (On, "*assumed to be*"); + + -- SI Derived dimensioned subtypes + + subtype Absorbed_Dose is Mks_Type + with + Dimension => (Symbol => "Gy", + Meter => 2, + Second => -2, + others => 0); + + subtype Angle is Mks_Type + with + Dimension => (Symbol => "rad", + others => 0); + + subtype Area is Mks_Type + with + Dimension => ( + Meter => 2, + others => 0); + + subtype Catalytic_Activity is Mks_Type + with + Dimension => (Symbol => "kat", + Second => -1, + Mole => 1, + others => 0); + + subtype Celsius_Temperature is Mks_Type + with + Dimension => (Symbol => "°C", + Kelvin => 1, + others => 0); + + subtype Electric_Capacitance is Mks_Type + with + Dimension => (Symbol => 'F', + Meter => -2, + Kilogram => -1, + Second => 4, + Ampere => 2, + others => 0); + + subtype Electric_Charge is Mks_Type + with + Dimension => (Symbol => 'C', + Second => 1, + Ampere => 1, + others => 0); + + subtype Electric_Conductance is Mks_Type + with + Dimension => (Symbol => 'S', + Meter => -2, + Kilogram => -1, + Second => 3, + Ampere => 2, + others => 0); + + subtype Electric_Potential_Difference is Mks_Type + with + Dimension => (Symbol => 'V', + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -1, + others => 0); + + -- Note the type punning below. The Symbol is a single "ohm" character + -- encoded in UTF-8 (ce a9 in hexadecimal), but this file is not compiled + -- with -gnatW8, so we're treating the string literal as a two-character + -- String. + + subtype Electric_Resistance is Mks_Type + with + Dimension => (Symbol => "Ω", + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -2, + others => 0); + + subtype Energy is Mks_Type + with + Dimension => (Symbol => 'J', + Meter => 2, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Equivalent_Dose is Mks_Type + with + Dimension => (Symbol => "Sv", + Meter => 2, + Second => -2, + others => 0); + + subtype Force is Mks_Type + with + Dimension => (Symbol => 'N', + Meter => 1, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Frequency is Mks_Type + with + Dimension => (Symbol => "Hz", + Second => -1, + others => 0); + + subtype Illuminance is Mks_Type + with + Dimension => (Symbol => "lx", + Meter => -2, + Candela => 1, + others => 0); + + subtype Inductance is Mks_Type + with + Dimension => (Symbol => 'H', + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -2, + others => 0); + + subtype Luminous_Flux is Mks_Type + with + Dimension => (Symbol => "lm", + Candela => 1, + others => 0); + + subtype Magnetic_Flux is Mks_Type + with + Dimension => (Symbol => "Wb", + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); + + subtype Magnetic_Flux_Density is Mks_Type + with + Dimension => (Symbol => 'T', + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); + + subtype Power is Mks_Type + with + Dimension => (Symbol => 'W', + Meter => 2, + Kilogram => 1, + Second => -3, + others => 0); + + subtype Pressure is Mks_Type + with + Dimension => (Symbol => "Pa", + Meter => -1, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Radioactivity is Mks_Type + with + Dimension => (Symbol => "Bq", + Second => -1, + others => 0); + + subtype Solid_Angle is Mks_Type + with + Dimension => (Symbol => "sr", + others => 0); + + subtype Speed is Mks_Type + with + Dimension => ( + Meter => 1, + Second => -1, + others => 0); + + subtype Volume is Mks_Type + with + Dimension => ( + Meter => 3, + others => 0); + + -- Initialize derived dimension values + + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes. + + pragma Warnings (Off, "*assumed to be*"); + + rad : constant Angle := 1.0; + sr : constant Solid_Angle := 1.0; + Hz : constant Frequency := 1.0; + N : constant Force := 1.0; + Pa : constant Pressure := 1.0; + J : constant Energy := 1.0; + W : constant Power := 1.0; + C : constant Electric_Charge := 1.0; + V : constant Electric_Potential_Difference := 1.0; + F : constant Electric_Capacitance := 1.0; + Ohm : constant Electric_Resistance := 1.0; + Si : constant Electric_Conductance := 1.0; + Wb : constant Magnetic_Flux := 1.0; + T : constant Magnetic_Flux_Density := 1.0; + H : constant Inductance := 1.0; + dC : constant Celsius_Temperature := 273.15; + lm : constant Luminous_Flux := 1.0; + lx : constant Illuminance := 1.0; + Bq : constant Radioactivity := 1.0; + Gy : constant Absorbed_Dose := 1.0; + Sv : constant Equivalent_Dose := 1.0; + kat : constant Catalytic_Activity := 1.0; + + -- SI prefixes for Meter + + um : constant Length := 1.0E-06; -- micro (u) + mm : constant Length := 1.0E-03; -- milli + cm : constant Length := 1.0E-02; -- centi + dm : constant Length := 1.0E-01; -- deci + dam : constant Length := 1.0E+01; -- deka + hm : constant Length := 1.0E+02; -- hecto + km : constant Length := 1.0E+03; -- kilo + Mem : constant Length := 1.0E+06; -- mega + + -- SI prefixes for Kilogram + + ug : constant Mass := 1.0E-09; -- micro (u) + mg : constant Mass := 1.0E-06; -- milli + cg : constant Mass := 1.0E-05; -- centi + dg : constant Mass := 1.0E-04; -- deci + g : constant Mass := 1.0E-03; -- gram + dag : constant Mass := 1.0E-02; -- deka + hg : constant Mass := 1.0E-01; -- hecto + Meg : constant Mass := 1.0E+03; -- mega + + -- SI prefixes for Second + + us : constant Time := 1.0E-06; -- micro (u) + ms : constant Time := 1.0E-03; -- milli + cs : constant Time := 1.0E-02; -- centi + ds : constant Time := 1.0E-01; -- deci + das : constant Time := 1.0E+01; -- deka + hs : constant Time := 1.0E+02; -- hecto + ks : constant Time := 1.0E+03; -- kilo + Mes : constant Time := 1.0E+06; -- mega + + -- Other constants for Second + + min : constant Time := 60.0 * s; + hour : constant Time := 60.0 * min; + day : constant Time := 24.0 * hour; + year : constant Time := 365.25 * day; + + -- SI prefixes for Ampere + + mA : constant Electric_Current := 1.0E-03; -- milli + cA : constant Electric_Current := 1.0E-02; -- centi + dA : constant Electric_Current := 1.0E-01; -- deci + daA : constant Electric_Current := 1.0E+01; -- deka + hA : constant Electric_Current := 1.0E+02; -- hecto + kA : constant Electric_Current := 1.0E+03; -- kilo + MeA : constant Electric_Current := 1.0E+06; -- mega + + pragma Warnings (On, "*assumed to be*"); +end System.Dim.Generic_Mks; diff --git a/gcc/ada/libgnat/s-dilomk.ads b/gcc/ada/libgnat/s-dilomk.ads new file mode 100644 index 0000000..2aaecae --- /dev/null +++ b/gcc/ada/libgnat/s-dilomk.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . L O N G _ M K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks; + +package System.Dim.Long_Mks is new System.Dim.Generic_Mks (Long_Float); diff --git a/gcc/ada/libgnat/s-dimmks.ads b/gcc/ada/libgnat/s-dimmks.ads index f21f82d..bf89f1b 100644 --- a/gcc/ada/libgnat/s-dimmks.ads +++ b/gcc/ada/libgnat/s-dimmks.ads @@ -29,365 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Defines the MKS dimension system which is the SI system of units +with System.Dim.Generic_Mks; --- Some other prefixes of this system are defined in a child package (see --- System.Dim_Mks.Other_Prefixes) in order to avoid too many constant --- declarations in this package. - --- The dimension terminology is defined in System.Dim_IO package - -with Ada.Numerics; - -package System.Dim.Mks is - - e : constant := Ada.Numerics.e; - Pi : constant := Ada.Numerics.Pi; - - -- Dimensioned type Mks_Type - - type Mks_Type is new Long_Long_Float - with - Dimension_System => ( - (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), - (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), - (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), - (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), - (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), - (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), - (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); - - -- SI Base dimensioned subtypes - - subtype Length is Mks_Type - with - Dimension => (Symbol => 'm', - Meter => 1, - others => 0); - - subtype Mass is Mks_Type - with - Dimension => (Symbol => "kg", - Kilogram => 1, - others => 0); - - subtype Time is Mks_Type - with - Dimension => (Symbol => 's', - Second => 1, - others => 0); - - subtype Electric_Current is Mks_Type - with - Dimension => (Symbol => 'A', - Ampere => 1, - others => 0); - - subtype Thermodynamic_Temperature is Mks_Type - with - Dimension => (Symbol => 'K', - Kelvin => 1, - others => 0); - - subtype Amount_Of_Substance is Mks_Type - with - Dimension => (Symbol => "mol", - Mole => 1, - others => 0); - - subtype Luminous_Intensity is Mks_Type - with - Dimension => (Symbol => "cd", - Candela => 1, - others => 0); - - -- Initialize SI Base unit values - - -- Turn off the all the dimension warnings for these basic assignments - -- since otherwise we would get complaints about assigning dimensionless - -- values to dimensioned subtypes (we can't assign 1.0*m to m). - - pragma Warnings (Off, "*assumed to be*"); - - m : constant Length := 1.0; - kg : constant Mass := 1.0; - s : constant Time := 1.0; - A : constant Electric_Current := 1.0; - K : constant Thermodynamic_Temperature := 1.0; - mol : constant Amount_Of_Substance := 1.0; - cd : constant Luminous_Intensity := 1.0; - - pragma Warnings (On, "*assumed to be*"); - - -- SI Derived dimensioned subtypes - - subtype Absorbed_Dose is Mks_Type - with - Dimension => (Symbol => "Gy", - Meter => 2, - Second => -2, - others => 0); - - subtype Angle is Mks_Type - with - Dimension => (Symbol => "rad", - others => 0); - - subtype Area is Mks_Type - with - Dimension => ( - Meter => 2, - others => 0); - - subtype Catalytic_Activity is Mks_Type - with - Dimension => (Symbol => "kat", - Second => -1, - Mole => 1, - others => 0); - - subtype Celsius_Temperature is Mks_Type - with - Dimension => (Symbol => "°C", - Kelvin => 1, - others => 0); - - subtype Electric_Capacitance is Mks_Type - with - Dimension => (Symbol => 'F', - Meter => -2, - Kilogram => -1, - Second => 4, - Ampere => 2, - others => 0); - - subtype Electric_Charge is Mks_Type - with - Dimension => (Symbol => 'C', - Second => 1, - Ampere => 1, - others => 0); - - subtype Electric_Conductance is Mks_Type - with - Dimension => (Symbol => 'S', - Meter => -2, - Kilogram => -1, - Second => 3, - Ampere => 2, - others => 0); - - subtype Electric_Potential_Difference is Mks_Type - with - Dimension => (Symbol => 'V', - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -1, - others => 0); - - -- Note the type punning below. The Symbol is a single "ohm" character - -- encoded in UTF-8 (ce a9 in hexadecimal), but this file is not compiled - -- with -gnatW8, so we're treating the string literal as a two-character - -- String. - - subtype Electric_Resistance is Mks_Type - with - Dimension => (Symbol => "Ω", - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -2, - others => 0); - - subtype Energy is Mks_Type - with - Dimension => (Symbol => 'J', - Meter => 2, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Equivalent_Dose is Mks_Type - with - Dimension => (Symbol => "Sv", - Meter => 2, - Second => -2, - others => 0); - - subtype Force is Mks_Type - with - Dimension => (Symbol => 'N', - Meter => 1, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Frequency is Mks_Type - with - Dimension => (Symbol => "Hz", - Second => -1, - others => 0); - - subtype Illuminance is Mks_Type - with - Dimension => (Symbol => "lx", - Meter => -2, - Candela => 1, - others => 0); - - subtype Inductance is Mks_Type - with - Dimension => (Symbol => 'H', - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -2, - others => 0); - - subtype Luminous_Flux is Mks_Type - with - Dimension => (Symbol => "lm", - Candela => 1, - others => 0); - - subtype Magnetic_Flux is Mks_Type - with - Dimension => (Symbol => "Wb", - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); - - subtype Magnetic_Flux_Density is Mks_Type - with - Dimension => (Symbol => 'T', - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); - - subtype Power is Mks_Type - with - Dimension => (Symbol => 'W', - Meter => 2, - Kilogram => 1, - Second => -3, - others => 0); - - subtype Pressure is Mks_Type - with - Dimension => (Symbol => "Pa", - Meter => -1, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Radioactivity is Mks_Type - with - Dimension => (Symbol => "Bq", - Second => -1, - others => 0); - - subtype Solid_Angle is Mks_Type - with - Dimension => (Symbol => "sr", - others => 0); - - subtype Speed is Mks_Type - with - Dimension => ( - Meter => 1, - Second => -1, - others => 0); - - subtype Volume is Mks_Type - with - Dimension => ( - Meter => 3, - others => 0); - - -- Initialize derived dimension values - - -- Turn off the all the dimension warnings for these basic assignments - -- since otherwise we would get complaints about assigning dimensionless - -- values to dimensioned subtypes. - - pragma Warnings (Off, "*assumed to be*"); - - rad : constant Angle := 1.0; - sr : constant Solid_Angle := 1.0; - Hz : constant Frequency := 1.0; - N : constant Force := 1.0; - Pa : constant Pressure := 1.0; - J : constant Energy := 1.0; - W : constant Power := 1.0; - C : constant Electric_Charge := 1.0; - V : constant Electric_Potential_Difference := 1.0; - F : constant Electric_Capacitance := 1.0; - Ohm : constant Electric_Resistance := 1.0; - Si : constant Electric_Conductance := 1.0; - Wb : constant Magnetic_Flux := 1.0; - T : constant Magnetic_Flux_Density := 1.0; - H : constant Inductance := 1.0; - dC : constant Celsius_Temperature := 273.15; - lm : constant Luminous_Flux := 1.0; - lx : constant Illuminance := 1.0; - Bq : constant Radioactivity := 1.0; - Gy : constant Absorbed_Dose := 1.0; - Sv : constant Equivalent_Dose := 1.0; - kat : constant Catalytic_Activity := 1.0; - - -- SI prefixes for Meter - - um : constant Length := 1.0E-06; -- micro (u) - mm : constant Length := 1.0E-03; -- milli - cm : constant Length := 1.0E-02; -- centi - dm : constant Length := 1.0E-01; -- deci - dam : constant Length := 1.0E+01; -- deka - hm : constant Length := 1.0E+02; -- hecto - km : constant Length := 1.0E+03; -- kilo - Mem : constant Length := 1.0E+06; -- mega - - -- SI prefixes for Kilogram - - ug : constant Mass := 1.0E-09; -- micro (u) - mg : constant Mass := 1.0E-06; -- milli - cg : constant Mass := 1.0E-05; -- centi - dg : constant Mass := 1.0E-04; -- deci - g : constant Mass := 1.0E-03; -- gram - dag : constant Mass := 1.0E-02; -- deka - hg : constant Mass := 1.0E-01; -- hecto - Meg : constant Mass := 1.0E+03; -- mega - - -- SI prefixes for Second - - us : constant Time := 1.0E-06; -- micro (u) - ms : constant Time := 1.0E-03; -- milli - cs : constant Time := 1.0E-02; -- centi - ds : constant Time := 1.0E-01; -- deci - das : constant Time := 1.0E+01; -- deka - hs : constant Time := 1.0E+02; -- hecto - ks : constant Time := 1.0E+03; -- kilo - Mes : constant Time := 1.0E+06; -- mega - - -- Other constants for Second - - min : constant Time := 60.0 * s; - hour : constant Time := 60.0 * min; - day : constant Time := 24.0 * hour; - year : constant Time := 365.25 * day; - - -- SI prefixes for Ampere - - mA : constant Electric_Current := 1.0E-03; -- milli - cA : constant Electric_Current := 1.0E-02; -- centi - dA : constant Electric_Current := 1.0E-01; -- deci - daA : constant Electric_Current := 1.0E+01; -- deka - hA : constant Electric_Current := 1.0E+02; -- hecto - kA : constant Electric_Current := 1.0E+03; -- kilo - MeA : constant Electric_Current := 1.0E+06; -- mega - - pragma Warnings (On, "*assumed to be*"); -end System.Dim.Mks; +package System.Dim.Mks is new System.Dim.Generic_Mks (Long_Long_Float); diff --git a/gcc/ada/libgnat/s-dlmkio.ads b/gcc/ada/libgnat/s-dlmkio.ads new file mode 100644 index 0000000..088727a --- /dev/null +++ b/gcc/ada/libgnat/s-dlmkio.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . L O N G _ M K S _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Provides output facilities for the Long_Float MKS dimension system (see +-- System.Dim.Long_Mks and System.Dim.Float_IO). + +with System.Dim.Long_Mks; use System.Dim.Long_Mks; +with System.Dim.Float_IO; + +package System.Dim.Long_Mks_IO is new System.Dim.Float_IO (Mks_Type); diff --git a/gcc/ada/libgnat/s-dlmopr.ads b/gcc/ada/libgnat/s-dlmopr.ads new file mode 100644 index 0000000..c9280b4 --- /dev/null +++ b/gcc/ada/libgnat/s-dlmopr.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . L O N G _ M K S . O T H E R _ P R E F I X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Dim.Generic_Mks.Generic_Other_Prefixes; + +package System.Dim.Long_Mks.Other_Prefixes is + new System.Dim.Long_Mks.Generic_Other_Prefixes; diff --git a/gcc/ada/libgnat/s-dmotpr.ads b/gcc/ada/libgnat/s-dmotpr.ads index c0adcb3..041ce37 100644 --- a/gcc/ada/libgnat/s-dmotpr.ads +++ b/gcc/ada/libgnat/s-dmotpr.ads @@ -29,144 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- Package that defines some other prefixes for the MKS base unit system. - --- These prefixes have been defined in a child package in order to avoid too --- many constant declarations in System.Dim_Mks. +with System.Dim.Generic_Mks.Generic_Other_Prefixes; package System.Dim.Mks.Other_Prefixes is - - -- SI prefixes for Meter - - pragma Warnings (Off); - -- Turn off the all the dimension warnings - - ym : constant Length := 1.0E-24; -- yocto - zm : constant Length := 1.0E-21; -- zepto - am : constant Length := 1.0E-18; -- atto - fm : constant Length := 1.0E-15; -- femto - pm : constant Length := 1.0E-12; -- pico - nm : constant Length := 1.0E-09; -- nano - Gm : constant Length := 1.0E+09; -- giga - Tm : constant Length := 1.0E+12; -- tera - Pem : constant Length := 1.0E+15; -- peta - Em : constant Length := 1.0E+18; -- exa - Zem : constant Length := 1.0E+21; -- zetta - Yom : constant Length := 1.0E+24; -- yotta - - -- SI prefixes for Kilogram - - yg : constant Mass := 1.0E-27; -- yocto - zg : constant Mass := 1.0E-24; -- zepto - ag : constant Mass := 1.0E-21; -- atto - fg : constant Mass := 1.0E-18; -- femto - pg : constant Mass := 1.0E-15; -- pico - ng : constant Mass := 1.0E-12; -- nano - Gg : constant Mass := 1.0E+06; -- giga - Tg : constant Mass := 1.0E+09; -- tera - Peg : constant Mass := 1.0E+13; -- peta - Eg : constant Mass := 1.0E+15; -- exa - Zeg : constant Mass := 1.0E+18; -- zetta - Yog : constant Mass := 1.0E+21; -- yotta - - -- SI prefixes for Second - - ys : constant Time := 1.0E-24; -- yocto - zs : constant Time := 1.0E-21; -- zepto - as : constant Time := 1.0E-18; -- atto - fs : constant Time := 1.0E-15; -- femto - ps : constant Time := 1.0E-12; -- pico - ns : constant Time := 1.0E-09; -- nano - Gs : constant Time := 1.0E+09; -- giga - Ts : constant Time := 1.0E+12; -- tera - Pes : constant Time := 1.0E+15; -- peta - Es : constant Time := 1.0E+18; -- exa - Zes : constant Time := 1.0E+21; -- zetta - Yos : constant Time := 1.0E+24; -- yotta - - -- SI prefixes for Ampere - - yA : constant Electric_Current := 1.0E-24; -- yocto - zA : constant Electric_Current := 1.0E-21; -- zepto - aA : constant Electric_Current := 1.0E-18; -- atto - fA : constant Electric_Current := 1.0E-15; -- femto - nA : constant Electric_Current := 1.0E-09; -- nano - uA : constant Electric_Current := 1.0E-06; -- micro (u) - GA : constant Electric_Current := 1.0E+09; -- giga - TA : constant Electric_Current := 1.0E+12; -- tera - PeA : constant Electric_Current := 1.0E+15; -- peta - EA : constant Electric_Current := 1.0E+18; -- exa - ZeA : constant Electric_Current := 1.0E+21; -- zetta - YoA : constant Electric_Current := 1.0E+24; -- yotta - - -- SI prefixes for Kelvin - - yK : constant Thermodynamic_Temperature := 1.0E-24; -- yocto - zK : constant Thermodynamic_Temperature := 1.0E-21; -- zepto - aK : constant Thermodynamic_Temperature := 1.0E-18; -- atto - fK : constant Thermodynamic_Temperature := 1.0E-15; -- femto - pK : constant Thermodynamic_Temperature := 1.0E-12; -- pico - nK : constant Thermodynamic_Temperature := 1.0E-09; -- nano - uK : constant Thermodynamic_Temperature := 1.0E-06; -- micro (u) - mK : constant Thermodynamic_Temperature := 1.0E-03; -- milli - cK : constant Thermodynamic_Temperature := 1.0E-02; -- centi - dK : constant Thermodynamic_Temperature := 1.0E-01; -- deci - daK : constant Thermodynamic_Temperature := 1.0E+01; -- deka - hK : constant Thermodynamic_Temperature := 1.0E+02; -- hecto - kK : constant Thermodynamic_Temperature := 1.0E+03; -- kilo - MeK : constant Thermodynamic_Temperature := 1.0E+06; -- mega - GK : constant Thermodynamic_Temperature := 1.0E+09; -- giga - TK : constant Thermodynamic_Temperature := 1.0E+12; -- tera - PeK : constant Thermodynamic_Temperature := 1.0E+15; -- peta - EK : constant Thermodynamic_Temperature := 1.0E+18; -- exa - ZeK : constant Thermodynamic_Temperature := 1.0E+21; -- zetta - YoK : constant Thermodynamic_Temperature := 1.0E+24; -- yotta - - -- SI prefixes for Mole - - ymol : constant Amount_Of_Substance := 1.0E-24; -- yocto - zmol : constant Amount_Of_Substance := 1.0E-21; -- zepto - amol : constant Amount_Of_Substance := 1.0E-18; -- atto - fmol : constant Amount_Of_Substance := 1.0E-15; -- femto - pmol : constant Amount_Of_Substance := 1.0E-12; -- pico - nmol : constant Amount_Of_Substance := 1.0E-09; -- nano - umol : constant Amount_Of_Substance := 1.0E-06; -- micro (u) - mmol : constant Amount_Of_Substance := 1.0E-03; -- milli - cmol : constant Amount_Of_Substance := 1.0E-02; -- centi - dmol : constant Amount_Of_Substance := 1.0E-01; -- deci - damol : constant Amount_Of_Substance := 1.0E+01; -- deka - hmol : constant Amount_Of_Substance := 1.0E+02; -- hecto - kmol : constant Amount_Of_Substance := 1.0E+03; -- kilo - Memol : constant Amount_Of_Substance := 1.0E+06; -- mega - Gmol : constant Amount_Of_Substance := 1.0E+09; -- giga - Tmol : constant Amount_Of_Substance := 1.0E+12; -- tera - Pemol : constant Amount_Of_Substance := 1.0E+15; -- peta - Emol : constant Amount_Of_Substance := 1.0E+18; -- exa - Zemol : constant Amount_Of_Substance := 1.0E+21; -- zetta - Yomol : constant Amount_Of_Substance := 1.0E+24; -- yotta - - -- SI prefixes for Candela - - ycd : constant Luminous_Intensity := 1.0E-24; -- yocto - zcd : constant Luminous_Intensity := 1.0E-21; -- zepto - acd : constant Luminous_Intensity := 1.0E-18; -- atto - fcd : constant Luminous_Intensity := 1.0E-15; -- femto - pcd : constant Luminous_Intensity := 1.0E-12; -- pico - ncd : constant Luminous_Intensity := 1.0E-09; -- nano - ucd : constant Luminous_Intensity := 1.0E-06; -- micro (u) - mcd : constant Luminous_Intensity := 1.0E-03; -- milli - ccd : constant Luminous_Intensity := 1.0E-02; -- centi - dcd : constant Luminous_Intensity := 1.0E-01; -- deci - dacd : constant Luminous_Intensity := 1.0E+01; -- deka - hcd : constant Luminous_Intensity := 1.0E+02; -- hecto - kcd : constant Luminous_Intensity := 1.0E+03; -- kilo - Mecd : constant Luminous_Intensity := 1.0E+06; -- mega - Gcd : constant Luminous_Intensity := 1.0E+09; -- giga - Tcd : constant Luminous_Intensity := 1.0E+12; -- tera - Pecd : constant Luminous_Intensity := 1.0E+15; -- peta - Ecd : constant Luminous_Intensity := 1.0E+18; -- exa - Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta - Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta - - pragma Warnings (On); -end System.Dim.Mks.Other_Prefixes; + new System.Dim.Mks.Generic_Other_Prefixes; diff --git a/gcc/ada/sa_messages.adb b/gcc/ada/sa_messages.adb new file mode 100644 index 0000000..30ae48c --- /dev/null +++ b/gcc/ada/sa_messages.adb @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- C O D E P E E R / S P A R K -- +-- -- +-- Copyright (C) 2015-2018, AdaCore -- +-- -- +-- This is 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. This software is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY 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 this software; see file -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +with Ada.Directories; use Ada.Directories; +with Ada.Strings.Unbounded.Hash; + +with Ada.Text_IO; use Ada.Text_IO; +with GNATCOLL.JSON; use GNATCOLL.JSON; + +package body SA_Messages is + + ----------------------- + -- Local subprograms -- + ----------------------- + + function "<" (Left, Right : SA_Message) return Boolean is + (if Left.Kind /= Right.Kind then + Left.Kind < Right.Kind + else + Left.Kind in Check_Kind + and then Left.Check_Result < Right.Check_Result); + + function "<" (Left, Right : Simple_Source_Location) return Boolean is + (if Left.File_Name /= Right.File_Name then + Left.File_Name < Right.File_Name + elsif Left.Line /= Right.Line then + Left.Line < Right.Line + else + Left.Column < Right.Column); + + function "<" (Left, Right : Source_Locations) return Boolean is + (if Left'Length /= Right'Length then + Left'Length < Right'Length + elsif Left'Length = 0 then + False + elsif Left (Left'Last) /= Right (Right'Last) then + Left (Left'Last) < Right (Right'Last) + else + Left (Left'First .. Left'Last - 1) < + Right (Right'First .. Right'Last - 1)); + + function "<" (Left, Right : Source_Location) return Boolean is + (Left.Locations < Right.Locations); + + function Base_Location + (Location : Source_Location) return Simple_Source_Location is + (Location.Locations (1)); + + function Hash (Key : SA_Message) return Hash_Type; + function Hash (Key : Source_Location) return Hash_Type; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Message_And_Location) return Boolean is + (if Left.Message = Right.Message + then Left.Location < Right.Location + else Left.Message < Right.Message); + + ------------ + -- Column -- + ------------ + + function Column (Location : Source_Location) return Column_Number is + (Base_Location (Location).Column); + + --------------- + -- File_Name -- + --------------- + + function File_Name (Location : Source_Location) return String is + (To_String (Base_Location (Location).File_Name)); + + function File_Name (Location : Source_Location) return Unbounded_String is + (Base_Location (Location).File_Name); + + ------------------------ + -- Enclosing_Instance -- + ------------------------ + + function Enclosing_Instance + (Location : Source_Location) return Source_Location_Or_Null is + (Count => Location.Count - 1, + Locations => Location.Locations (2 .. Location.Count)); + + ---------- + -- Hash -- + ---------- + + function Hash (Key : Message_And_Location) return Hash_Type is + (Hash (Key.Message) + Hash (Key.Location)); + + function Hash (Key : SA_Message) return Hash_Type is + begin + return Result : Hash_Type := + Hash_Type'Mod (Message_Kind'Pos (Key.Kind)) + do + if Key.Kind in Check_Kind then + Result := Result + + Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result)); + end if; + end return; + end Hash; + + function Hash (Key : Source_Location) return Hash_Type is + begin + return Result : Hash_Type := Hash_Type'Mod (Key.Count) do + for Loc of Key.Locations loop + Result := Result + Hash (Loc.File_Name); + Result := Result + Hash_Type'Mod (Loc.Line); + Result := Result + Hash_Type'Mod (Loc.Column); + end loop; + end return; + end Hash; + + --------------- + -- Iteration -- + --------------- + + function Iteration (Location : Source_Location) return Iteration_Id is + (Base_Location (Location).Iteration); + + ---------- + -- Line -- + ---------- + + function Line (Location : Source_Location) return Line_Number is + (Base_Location (Location).Line); + + -------------- + -- Location -- + -------------- + + function Location + (Item : Message_And_Location) return Source_Location is + (Item.Location); + + ---------- + -- Make -- + ---------- + + function Make + (File_Name : String; + Line : Line_Number; + Column : Column_Number; + Iteration : Iteration_Id; + Enclosing_Instance : Source_Location_Or_Null) return Source_Location + is + begin + return Result : Source_Location + (Count => Enclosing_Instance.Count + 1) + do + Result.Locations (1) := + (File_Name => To_Unbounded_String (File_Name), + Line => Line, + Column => Column, + Iteration => Iteration); + + Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations; + end return; + end Make; + + ------------------ + -- Make_Msg_Loc -- + ------------------ + + function Make_Msg_Loc + (Msg : SA_Message; + Loc : Source_Location) return Message_And_Location + is + begin + return Message_And_Location'(Count => Loc.Count, + Message => Msg, + Location => Loc); + end Make_Msg_Loc; + + ------------- + -- Message -- + ------------- + + function Message (Item : Message_And_Location) return SA_Message is + (Item.Message); + + package Field_Names is + + -- A Source_Location value is represented in JSON as a two or three + -- field value having fields Message_Kind (a string) and Locations (an + -- array); if the Message_Kind indicates a check kind, then a third + -- field is present: Check_Result (a string). The element type of the + -- Locations array is a value having at least 4 fields: + -- File_Name (a string), Line (an integer), Column (an integer), + -- and Iteration_Kind (an integer); if the Iteration_Kind field + -- has the value corresponding to the enumeration literal Numbered, + -- then two additional integer fields are present, Iteration_Number + -- and Iteration_Of_Total. + + Check_Result : constant String := "Check_Result"; + Column : constant String := "Column"; + File_Name : constant String := "File_Name"; + Iteration_Kind : constant String := "Iteration_Kind"; + Iteration_Number : constant String := "Iteration_Number"; + Iteration_Of_Total : constant String := "Iteration_Total"; + Line : constant String := "Line"; + Locations : constant String := "Locations"; + Message_Kind : constant String := "Message_Kind"; + Messages : constant String := "Messages"; + end Field_Names; + + package body Writing is + File : File_Type; + -- The file to which output will be written (in Close, not in Write) + + Messages : JSON_Array; + -- Successive calls to Write append messages to this list + + ----------------------- + -- Local subprograms -- + ----------------------- + + function To_JSON_Array + (Locations : Source_Locations) return JSON_Array; + -- Represent a Source_Locations array as a JSON_Array + + function To_JSON_Value + (Location : Simple_Source_Location) return JSON_Value; + -- Represent a Simple_Source_Location as a JSON_Value + + ----------- + -- Close -- + ----------- + + procedure Close is + Value : constant JSON_Value := Create_Object; + + begin + -- only one field for now + Set_Field (Value, Field_Names.Messages, Messages); + Put_Line (File, Write (Item => Value, Compact => False)); + Clear (Messages); + Close (File => File); + end Close; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open return Boolean is (Is_Open (File)); + + ---------- + -- Open -- + ---------- + + procedure Open (File_Name : String) is + begin + Create (File => File, Mode => Out_File, Name => File_Name); + Clear (Messages); + end Open; + + ------------------- + -- To_JSON_Array -- + ------------------- + + function To_JSON_Array + (Locations : Source_Locations) return JSON_Array + is + begin + return Result : JSON_Array := Empty_Array do + for Location of Locations loop + Append (Result, To_JSON_Value (Location)); + end loop; + end return; + end To_JSON_Array; + + ------------------- + -- To_JSON_Value -- + ------------------- + + function To_JSON_Value + (Location : Simple_Source_Location) return JSON_Value + is + begin + return Result : constant JSON_Value := Create_Object do + Set_Field (Result, Field_Names.File_Name, Location.File_Name); + Set_Field (Result, Field_Names.Line, Integer (Location.Line)); + Set_Field (Result, Field_Names.Column, Integer (Location.Column)); + Set_Field (Result, Field_Names.Iteration_Kind, Integer'( + Iteration_Kind'Pos (Location.Iteration.Kind))); + + if Location.Iteration.Kind = Numbered then + Set_Field (Result, Field_Names.Iteration_Number, + Location.Iteration.Number); + Set_Field (Result, Field_Names.Iteration_Of_Total, + Location.Iteration.Of_Total); + end if; + end return; + end To_JSON_Value; + + ----------- + -- Write -- + ----------- + + procedure Write (Message : SA_Message; Location : Source_Location) is + Value : constant JSON_Value := Create_Object; + + begin + Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img); + + if Message.Kind in Check_Kind then + Set_Field + (Value, Field_Names.Check_Result, Message.Check_Result'Img); + end if; + + Set_Field + (Value, Field_Names.Locations, To_JSON_Array (Location.Locations)); + Append (Messages, Value); + end Write; + end Writing; + + package body Reading is + File : File_Type; + -- The file from which messages are read (in Open, not in Read) + + Messages : JSON_Array; + -- The list of messages that were read in from File + + Next_Index : Positive; + -- The index of the message in Messages which will be returned by the + -- next call to Get. + + Parse_Full_Path : Boolean := True; + -- if the full path or only the base name of the file should be parsed + + ----------- + -- Close -- + ----------- + + procedure Close is + begin + Clear (Messages); + Close (File); + end Close; + + ---------- + -- Done -- + ---------- + + function Done return Boolean is (Next_Index > Length (Messages)); + + --------- + -- Get -- + --------- + + function Get return Message_And_Location is + Value : constant JSON_Value := Get (Messages, Next_Index); + + function Get_Message (Kind : Message_Kind) return SA_Message; + -- Return SA_Message of given kind, filling in any non-discriminant + -- by reading from Value. + + function Make + (Location : Source_Location; + Message : SA_Message) return Message_And_Location; + -- Constructor + + function To_Location + (Encoded : JSON_Array; + Full_Path : Boolean) return Source_Location; + -- Decode a Source_Location from JSON_Array representation + + function To_Simple_Location + (Encoded : JSON_Value; + Full_Path : Boolean) return Simple_Source_Location; + -- Decode a Simple_Source_Location from JSON_Value representation + + ----------------- + -- Get_Message -- + ----------------- + + function Get_Message (Kind : Message_Kind) return SA_Message is + begin + -- If we had AI12-0086, then we could use aggregates here (which + -- would be better than field-by-field assignment for the usual + -- maintainability reasons). But we don't, so we won't. + + return Result : SA_Message (Kind => Kind) do + if Kind in Check_Kind then + Result.Check_Result := + SA_Check_Result'Value + (Get (Value, Field_Names.Check_Result)); + end if; + end return; + end Get_Message; + + ---------- + -- Make -- + ---------- + + function Make + (Location : Source_Location; + Message : SA_Message) return Message_And_Location + is + (Count => Location.Count, Message => Message, Location => Location); + + ----------------- + -- To_Location -- + ----------------- + + function To_Location + (Encoded : JSON_Array; + Full_Path : Boolean) return Source_Location is + begin + return Result : Source_Location (Count => Length (Encoded)) do + for I in Result.Locations'Range loop + Result.Locations (I) := + To_Simple_Location (Get (Encoded, I), Full_Path); + end loop; + end return; + end To_Location; + + ------------------------ + -- To_Simple_Location -- + ------------------------ + + function To_Simple_Location + (Encoded : JSON_Value; + Full_Path : Boolean) return Simple_Source_Location + is + function Get_Iteration_Id + (Kind : Iteration_Kind) return Iteration_Id; + -- Given the discriminant for an Iteration_Id value, return the + -- entire value. + + ---------------------- + -- Get_Iteration_Id -- + ---------------------- + + function Get_Iteration_Id (Kind : Iteration_Kind) + return Iteration_Id + is + begin + -- Initialize non-discriminant fields, if any + + return Result : Iteration_Id (Kind => Kind) do + if Kind = Numbered then + Result := + (Kind => Numbered, + Number => + Get (Encoded, Field_Names.Iteration_Number), + Of_Total => + Get (Encoded, Field_Names.Iteration_Of_Total)); + end if; + end return; + end Get_Iteration_Id; + + -- Local variables + + FN : constant Unbounded_String := + Get (Encoded, Field_Names.File_Name); + + -- Start of processing for To_Simple_Location + + begin + return + (File_Name => + (if Full_Path then + FN + else + To_Unbounded_String (Simple_Name (To_String (FN)))), + Line => + Line_Number (Integer'(Get (Encoded, Field_Names.Line))), + Column => + Column_Number (Integer'(Get (Encoded, Field_Names.Column))), + Iteration => + Get_Iteration_Id + (Kind => Iteration_Kind'Val (Integer'(Get + (Encoded, Field_Names.Iteration_Kind))))); + end To_Simple_Location; + + -- Start of processing for Get + + begin + Next_Index := Next_Index + 1; + + return Make + (Message => + Get_Message + (Message_Kind'Value (Get (Value, Field_Names.Message_Kind))), + Location => + To_Location + (Get (Value, Field_Names.Locations), Parse_Full_Path)); + end Get; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open return Boolean is (Is_Open (File)); + + ---------- + -- Open -- + ---------- + + procedure Open (File_Name : String; Full_Path : Boolean := True) is + File_Text : Unbounded_String := Null_Unbounded_String; + + begin + Parse_Full_Path := Full_Path; + Open (File => File, Mode => In_File, Name => File_Name); + + -- File read here, not in Get, but that's an implementation detail + + while not End_Of_File (File) loop + Append (File_Text, Get_Line (File)); + end loop; + + Messages := Get (Read (File_Text), Field_Names.Messages); + Next_Index := 1; + end Open; + end Reading; + +end SA_Messages; diff --git a/gcc/ada/sa_messages.ads b/gcc/ada/sa_messages.ads new file mode 100644 index 0000000..93226a7 --- /dev/null +++ b/gcc/ada/sa_messages.ads @@ -0,0 +1,267 @@ +------------------------------------------------------------------------------ +-- C O D E P E E R / S P A R K -- +-- -- +-- Copyright (C) 2015-2018, AdaCore -- +-- -- +-- This is 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. This software is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY 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 this software; see file -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +with Ada.Containers; use Ada.Containers; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +package SA_Messages is + + -- This package can be used for reading/writing a file containing a + -- sequence of static anaysis results. Each element can describe a runtime + -- check whose outcome has been statically determined, or it might be a + -- warning or diagnostic message. It is expected that typically CodePeer + -- will do the writing and SPARK will do the reading; this will allow SPARK + -- to get the benefit of CodePeer's analysis. + -- + -- Each item is represented as a pair consisting of a message and an + -- associated source location. Source locations may refer to a location + -- within the expansion of an instance of a generic; this is represented + -- by combining the corresponding location within the generic with the + -- location of the instance (repeated if the instance itself occurs within + -- a generic). In addition, the type Iteration_Id is intended for use in + -- distinguishing messages which refer to a specific iteration of a loop + -- (this case can arise, for example, if CodePeer chooses to unroll a + -- for-loop). This data structure is only general enough to support the + -- kinds of unrolling that are currently planned for CodePeer. For + -- example, an Iteration_Id can only identify an iteration of the nearest + -- enclosing loop of the associated File/Line/Column source location. + -- This is not a problem because CodePeer doesn't unroll loops which + -- contain other loops. + + type Message_Kind is ( + + -- Check kinds + + Array_Index_Check, + Divide_By_Zero_Check, + Tag_Check, + Discriminant_Check, + Range_Check, + Overflow_Check, + Assertion_Check, + + -- Warning kinds + + Suspicious_Range_Precondition_Warning, + Suspicious_First_Precondition_Warning, + Suspicious_Input_Warning, + Suspicious_Constant_Operation_Warning, + Unread_In_Out_Parameter_Warning, + Unassigned_In_Out_Parameter_Warning, + Non_Analyzed_Call_Warning, + Procedure_Does_Not_Return_Warning, + Check_Fails_On_Every_Call_Warning, + Unknown_Call_Warning, + Dead_Store_Warning, + Dead_Outparam_Store_Warning, + Potentially_Dead_Store_Warning, + Same_Value_Dead_Store_Warning, + Dead_Block_Warning, + Infinite_Loop_Warning, + Dead_Edge_Warning, + Plain_Dead_Edge_Warning, + True_Dead_Edge_Warning, + False_Dead_Edge_Warning, + True_Condition_Dead_Edge_Warning, + False_Condition_Dead_Edge_Warning, + Unrepeatable_While_Loop_Warning, + Dead_Block_Continuation_Warning, + Local_Lock_Of_Global_Object_Warning, + Analyzed_Module_Warning, + Non_Analyzed_Module_Warning, + Non_Analyzed_Procedure_Warning, + Incompletely_Analyzed_Procedure_Warning); + + -- Assertion_Check includes checks for user-defined PPCs (both specific + -- and class-wide), Assert pragma checks, subtype predicate checks, + -- type invariant checks (specific and class-wide), and checks for + -- implementation-defined assertions such as Assert_And_Cut, Assume, + -- Contract_Cases, Default_Initial_Condition, Initial_Condition, + -- Loop_Invariant, Loop_Variant, and Refined_Post. + -- + -- TBD: it might be nice to distinguish these different kinds of assertions + -- as is done in SPARK's VC_Kind enumeration type, but any distinction + -- which isn't already present in CP's BE_Message_Subkind enumeration type + -- would require more work on the CP side. + -- + -- The warning kinds are pretty much a copy of the set of + -- Be_Message_Subkind values for which CP's Is_Warning predicate returns + -- True; see descriptive comment for each in CP's message_kinds.ads . + + subtype Check_Kind is Message_Kind + range Array_Index_Check .. Assertion_Check; + subtype Warning_Kind is Message_Kind + range Message_Kind'Succ (Check_Kind'Last) .. Message_Kind'Last; + + -- Possible outcomes of the static analysis of a runtime check + -- + -- Not_Statically_Known_With_Low_Severity could be used instead of of + -- Not_Statically_Known if there is some reason to believe that (although + -- the tool couldn't prove it) the check is likely to always pass (in CP + -- terms, if the corresponding CP message has severity Low as opposed to + -- Medium). It's not clear yet whether SPARK will care about this + -- distinction. + + type SA_Check_Result is + (Statically_Known_Success, + Not_Statically_Known_With_Low_Severity, + Not_Statically_Known, + Statically_Known_Failure); + + type SA_Message (Kind : Message_Kind := Message_Kind'Last) is record + case Kind is + when Check_Kind => + Check_Result : SA_Check_Result; + + when Warning_Kind => + null; + end case; + end record; + + type Source_Location_Or_Null (<>) is private; + Null_Location : constant Source_Location_Or_Null; + subtype Source_Location is Source_Location_Or_Null with + Dynamic_Predicate => Source_Location /= Null_Location; + + type Line_Number is new Positive; + type Column_Number is new Positive; + + function File_Name (Location : Source_Location) return String; + function File_Name (Location : Source_Location) return Unbounded_String; + function Line (Location : Source_Location) return Line_Number; + function Column (Location : Source_Location) return Column_Number; + + type Iteration_Kind is (None, Initial, Subsequent, Numbered); + -- None is for the usual no-unrolling case. + -- Initial and Subsequent are for use in the case where only the first + -- iteration of a loop (or some part thereof, such as the termination + -- test of a while-loop) is unrolled. + -- Numbered is for use in the case where a for-loop with a statically + -- known number of iterations is fully unrolled. + + subtype Iteration_Number is Integer range 1 .. 255; + subtype Iteration_Total is Integer range 2 .. 255; + + type Iteration_Id (Kind : Iteration_Kind := None) is record + case Kind is + when Numbered => + Number : Iteration_Number; + Of_Total : Iteration_Total; + when others => + null; + end case; + end record; + + function Iteration (Location : Source_Location) return Iteration_Id; + + function Enclosing_Instance + (Location : Source_Location) return Source_Location_Or_Null; + -- For a source location occurring within the expansion of an instance of a + -- generic unit, the Line, Column, and File_Name selectors will indicate a + -- location within the generic; the Enclosing_Instance selector yields the + -- location of the declaration of the instance. + + function Make + (File_Name : String; + Line : Line_Number; + Column : Column_Number; + Iteration : Iteration_Id; + Enclosing_Instance : Source_Location_Or_Null) return Source_Location; + -- Constructor + + type Message_And_Location (<>) is private; + + function Location (Item : Message_And_Location) return Source_Location; + function Message (Item : Message_And_Location) return SA_Message; + + function Make_Msg_Loc + (Msg : SA_Message; + Loc : Source_Location) return Message_And_Location; + -- Selectors + + function "<" (Left, Right : Message_And_Location) return Boolean; + function Hash (Key : Message_And_Location) return Hash_Type; + -- Actuals for container instances + + File_Extension : constant String; -- ".json" (but could change in future) + -- Clients may wish to use File_Extension in constructing + -- File_Name parameters for calls to Open. + + package Writing is + function Is_Open return Boolean; + + procedure Open (File_Name : String) with + Precondition => not Is_Open, + Postcondition => Is_Open; + -- Behaves like Text_IO.Create with respect to error cases + + procedure Write (Message : SA_Message; Location : Source_Location); + + procedure Close with + Precondition => Is_Open, + Postcondition => not Is_Open; + -- Behaves like Text_IO.Close with respect to error cases + end Writing; + + package Reading is + function Is_Open return Boolean; + + procedure Open (File_Name : String; Full_Path : Boolean := True) with + Precondition => not Is_Open, + Postcondition => Is_Open; + -- Behaves like Text_IO.Open with respect to error cases + + function Done return Boolean with + Precondition => Is_Open; + + function Get return Message_And_Location with + Precondition => not Done; + + procedure Close with + Precondition => Is_Open, + Postcondition => not Is_Open; + -- Behaves like Text_IO.Close with respect to error cases + end Reading; + +private + type Simple_Source_Location is record + File_Name : Unbounded_String := Null_Unbounded_String; + Line : Line_Number := Line_Number'Last; + Column : Column_Number := Column_Number'Last; + Iteration : Iteration_Id := (Kind => None); + end record; + + type Source_Locations is + array (Natural range <>) of Simple_Source_Location; + + type Source_Location_Or_Null (Count : Natural) is record + Locations : Source_Locations (1 .. Count); + end record; + + Null_Location : constant Source_Location_Or_Null := + (Count => 0, Locations => (others => <>)); + + type Message_And_Location (Count : Positive) is record + Message : SA_Message; + Location : Source_Location (Count => Count); + end record; + + File_Extension : constant String := ".json"; +end SA_Messages; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cb1b2d5d..96eb488 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11245,6 +11245,15 @@ package body Sem_Attr is New_Occurrence_Of (Standard_Short_Integer, Loc), Expression => Make_Integer_Literal (Loc, Uint_0))); + + -- The above sets the Scope of the flag entity to the + -- current scope, in which the attribute appears, but + -- the flag declaration has been inserted after that + -- of Subp_Id, so the scope of the flag the same as + -- that of Subp_Id. This is relevant when unnesting, + -- whereh processing depends on correct scope settingl + + Set_Scope (Flag_Id, Scop); end if; -- Taking the 'Access of an expression function freezes its diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 39ed046..e6d0ba5 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -34,7 +34,6 @@ with Elists; use Elists; with Fname; use Fname; with Fname.UF; use Fname.UF; with Freeze; use Freeze; -with Ghost; use Ghost; with Impunit; use Impunit; with Inline; use Inline; with Lib; use Lib; @@ -2912,8 +2911,6 @@ package body Sem_Ch10 is Set_Fatal_Error (Current_Sem_Unit, Error_Ignored); end if; end case; - - Mark_Ghost_Clause (N); end Analyze_With_Clause; ------------------------------ diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 28a3dd8..00854c9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8765,44 +8765,45 @@ package body Sem_Ch13 is if Raise_Expression_Present then declare - Map : constant Elist_Id := New_Elmt_List; - New_V : Entity_Id := Empty; + function Reset_Loop_Variable + (N : Node_Id) return Traverse_Result; - -- The unanalyzed expression will be copied and appear in - -- both functions. Normally expressions do not declare new - -- entities, but quantified expressions do, so we need to - -- create new entities for their bound variables, to prevent - -- multiple definitions in gigi. - - function Reset_Loop_Variable (N : Node_Id) - return Traverse_Result; - - procedure Collect_Loop_Variables is + procedure Reset_Loop_Variables is new Traverse_Proc (Reset_Loop_Variable); ------------------------ -- Reset_Loop_Variable -- ------------------------ - function Reset_Loop_Variable (N : Node_Id) - return Traverse_Result + function Reset_Loop_Variable + (N : Node_Id) return Traverse_Result is begin if Nkind (N) = N_Iterator_Specification then - New_V := Make_Defining_Identifier - (Sloc (N), Chars (Defining_Identifier (N))); - - Set_Defining_Identifier (N, New_V); + Set_Defining_Identifier (N, + Make_Defining_Identifier + (Sloc (N), Chars (Defining_Identifier (N)))); end if; return OK; end Reset_Loop_Variable; + -- Local variables + + Map : constant Elist_Id := New_Elmt_List; + begin Append_Elmt (Object_Entity, Map); Append_Elmt (Object_Entity_M, Map); Expr_M := New_Copy_Tree (Expr, Map => Map); - Collect_Loop_Variables (Expr_M); + + -- The unanalyzed expression will be copied and appear in + -- both functions. Normally expressions do not declare new + -- entities, but quantified expressions do, so we need to + -- create new entities for their bound variables, to prevent + -- multiple definitions in gigi. + + Reset_Loop_Variables (Expr_M); end; end if; @@ -8856,6 +8857,43 @@ package body Sem_Ch13 is Insert_After_And_Analyze (N, FBody); + -- The defining identifier of a quantified expression carries the + -- scope in which the type appears, but when unnesting we need + -- to indicate that its proper scope is the constructed predicate + -- function. The quantified expressions have been converted into + -- loops during analysis and expansion. + + declare + function Reset_Quantified_Variable_Scope + (N : Node_Id) return Traverse_Result; + + procedure Reset_Quantified_Variables_Scope is + new Traverse_Proc (Reset_Quantified_Variable_Scope); + + ------------------------------------- + -- Reset_Quantified_Variable_Scope -- + ------------------------------------- + + function Reset_Quantified_Variable_Scope + (N : Node_Id) return Traverse_Result + is + begin + if Nkind_In (N, N_Iterator_Specification, + N_Loop_Parameter_Specification) + then + Set_Scope (Defining_Identifier (N), + Predicate_Function (Typ)); + end if; + + return OK; + end Reset_Quantified_Variable_Scope; + + begin + if Unnest_Subprogram_Mode then + Reset_Quantified_Variables_Scope (Expr); + end if; + end; + -- within a generic unit, prevent a double analysis of the body -- which will not be marked analyzed yet. This will happen when -- the freeze node is created during the preanalysis of an @@ -8972,6 +9010,8 @@ package body Sem_Ch13 is Insert_Before_And_Analyze (N, FDecl); Insert_After_And_Analyze (N, FBody); + + -- Should quantified expressions be handled here as well ??? end; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 349ece7..cc84f9c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9453,6 +9453,7 @@ package body Sem_Ch3 is (Derived_Type, Save_Discr_Constr); Set_Stored_Constraint (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); + Replace_Components (Derived_Type, New_Decl); end if; @@ -13692,7 +13693,12 @@ package body Sem_Ch3 is Related_Nod : Node_Id) return Entity_Id is T_Sub : constant Entity_Id := - Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C'); + Create_Itype + (Ekind => E_Record_Subtype, + Related_Nod => Related_Nod, + Related_Id => Corr_Rec, + Suffix => 'C', + Suffix_Index => -1); begin Set_Etype (T_Sub, Corr_Rec); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2dd9d2f..b330426 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -285,208 +285,6 @@ package body Sem_Ch6 is LocX : constant Source_Ptr := Sloc (Expr); Spec : constant Node_Id := Specification (N); - procedure Freeze_Expr_Types (Def_Id : Entity_Id); - -- N is an expression function that is a completion and Def_Id its - -- defining entity. Freeze before N all the types referenced by the - -- expression of the function. - - ----------------------- - -- Freeze_Expr_Types -- - ----------------------- - - procedure Freeze_Expr_Types (Def_Id : Entity_Id) is - function Cloned_Expression return Node_Id; - -- Build a duplicate of the expression of the return statement that - -- has no defining entities shared with the original expression. - - function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; - -- Freeze all types referenced in the subtree rooted at Node - - ----------------------- - -- Cloned_Expression -- - ----------------------- - - function Cloned_Expression return Node_Id is - function Clone_Id (Node : Node_Id) return Traverse_Result; - -- Tree traversal routine that clones the defining identifier of - -- iterator and loop parameter specification nodes. - - -------------- - -- Clone_Id -- - -------------- - - function Clone_Id (Node : Node_Id) return Traverse_Result is - begin - if Nkind_In (Node, N_Iterator_Specification, - N_Loop_Parameter_Specification) - then - Set_Defining_Identifier (Node, - New_Copy (Defining_Identifier (Node))); - end if; - - return OK; - end Clone_Id; - - procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id); - - -- Local variable - - Dup_Expr : constant Node_Id := New_Copy_Tree (Expr); - - -- Start of processing for Cloned_Expression - - begin - -- We must duplicate the expression with semantic information to - -- inherit the decoration of global entities in generic instances. - -- Set the parent of the new node to be the parent of the original - -- to get the proper context, which is needed for complete error - -- reporting and for semantic analysis. - - Set_Parent (Dup_Expr, Parent (Expr)); - - -- Replace the defining identifier of iterators and loop param - -- specifications by a clone to ensure that the cloned expression - -- and the original expression don't have shared identifiers; - -- otherwise, as part of the preanalysis of the expression, these - -- shared identifiers may be left decorated with itypes which - -- will not be available in the tree passed to the backend. - - Clone_Def_Ids (Dup_Expr); - - return Dup_Expr; - end Cloned_Expression; - - ---------------------- - -- Freeze_Type_Refs -- - ---------------------- - - function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is - procedure Check_And_Freeze_Type (Typ : Entity_Id); - -- Check that Typ is fully declared and freeze it if so - - --------------------------- - -- Check_And_Freeze_Type -- - --------------------------- - - procedure Check_And_Freeze_Type (Typ : Entity_Id) is - begin - -- Skip Itypes created by the preanalysis, and itypes whose - -- scope is another type (i.e. component subtypes that depend - -- on a discriminant), - - if Is_Itype (Typ) - and then (Scope_Within_Or_Same (Scope (Typ), Def_Id) - or else Is_Type (Scope (Typ))) - then - return; - end if; - - -- This provides a better error message than generating - -- primitives whose compilation fails much later. Refine - -- the error message if possible. - - Check_Fully_Declared (Typ, Node); - - if Error_Posted (Node) then - if Has_Private_Component (Typ) - and then not Is_Private_Type (Typ) - then - Error_Msg_NE ("\type& has private component", Node, Typ); - end if; - - else - Freeze_Before (N, Typ); - end if; - end Check_And_Freeze_Type; - - -- Start of processing for Freeze_Type_Refs - - begin - -- Check that a type referenced by an entity can be frozen - - if Is_Entity_Name (Node) and then Present (Entity (Node)) then - Check_And_Freeze_Type (Etype (Entity (Node))); - - -- Check that the enclosing record type can be frozen - - if Ekind_In (Entity (Node), E_Component, E_Discriminant) then - Check_And_Freeze_Type (Scope (Entity (Node))); - end if; - - -- Freezing an access type does not freeze the designated type, - -- but freezing conversions between access to interfaces requires - -- that the interface types themselves be frozen, so that dispatch - -- table entities are properly created. - - -- Unclear whether a more general rule is needed ??? - - elsif Nkind (Node) = N_Type_Conversion - and then Is_Access_Type (Etype (Node)) - and then Is_Interface (Designated_Type (Etype (Node))) - then - Check_And_Freeze_Type (Designated_Type (Etype (Node))); - end if; - - -- An implicit dereference freezes the designated type. In the - -- case of a dispatching call whose controlling argument is an - -- access type, the dereference is not made explicit, so we must - -- check for such a call and freeze the designated type. - - if Nkind (Node) in N_Has_Etype - and then Present (Etype (Node)) - and then Is_Access_Type (Etype (Node)) - and then Nkind (Parent (Node)) = N_Function_Call - and then Node = Controlling_Argument (Parent (Node)) - then - Check_And_Freeze_Type (Designated_Type (Etype (Node))); - end if; - - -- No point in posting several errors on the same expression - - if Serious_Errors_Detected > 0 then - return Abandon; - else - return OK; - end if; - end Freeze_Type_Refs; - - procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); - - -- Local variables - - Saved_First_Entity : constant Entity_Id := First_Entity (Def_Id); - Saved_Last_Entity : constant Entity_Id := Last_Entity (Def_Id); - Dup_Expr : constant Node_Id := Cloned_Expression; - - -- Start of processing for Freeze_Expr_Types - - begin - -- Preanalyze a duplicate of the expression to have available the - -- minimum decoration needed to locate referenced unfrozen types - -- without adding any decoration to the function expression. - - Push_Scope (Def_Id); - Install_Formals (Def_Id); - - Preanalyze_Spec_Expression (Dup_Expr, Etype (Def_Id)); - End_Scope; - - -- Restore certain attributes of Def_Id since the preanalysis may - -- have introduced itypes to this scope, thus modifying attributes - -- First_Entity and Last_Entity. - - Set_First_Entity (Def_Id, Saved_First_Entity); - Set_Last_Entity (Def_Id, Saved_Last_Entity); - - if Present (Last_Entity (Def_Id)) then - Set_Next_Entity (Last_Entity (Def_Id), Empty); - end if; - - -- Freeze all types referenced in the expression - - Freeze_References (Dup_Expr); - end Freeze_Expr_Types; - -- Local variables Asp : Node_Id; @@ -600,7 +398,11 @@ package body Sem_Ch6 is -- As elsewhere, we do not emit freeze nodes within a generic unit. if not Inside_A_Generic then - Freeze_Expr_Types (Def_Id); + Freeze_Expr_Types + (Def_Id => Def_Id, + Typ => Etype (Def_Id), + Expr => Expr, + N => N); end if; -- For navigation purposes, indicate that the function is a body @@ -3347,8 +3149,12 @@ package body Sem_Ch6 is end if; if not Is_Frozen (Typ) then - Set_Is_Frozen (Typ); - Append_New_Elmt (Typ, Result); + if Scope (Typ) /= Current_Scope then + Set_Is_Frozen (Typ); + Append_New_Elmt (Typ, Result); + else + Freeze_Before (N, Typ); + end if; end if; end Mask_Type; @@ -3838,28 +3644,28 @@ package body Sem_Ch6 is -- They are necessary in any case to insure order of elaboration -- in gigi. - if not Is_Frozen (Spec_Id) + if Nkind (N) = N_Subprogram_Body + and then Was_Expression_Function (N) + and then not Has_Completion (Spec_Id) + and then Serious_Errors_Detected = 0 and then (Expander_Active or else ASIS_Mode - or else (Operating_Mode = Check_Semantics - and then Serious_Errors_Detected = 0)) + or else Operating_Mode = Check_Semantics) then -- The body generated for an expression function that is not a -- completion is a freeze point neither for the profile nor for -- anything else. That's why, in order to prevent any freezing -- during analysis, we need to mask types declared outside the - -- expression that are not yet frozen. + -- expression (and in an outer scope) that are not yet frozen. - if Nkind (N) = N_Subprogram_Body - and then Was_Expression_Function (N) - and then not Has_Completion (Spec_Id) - then - Set_Is_Frozen (Spec_Id); - Mask_Types := Mask_Unfrozen_Types (Spec_Id); - else - Set_Has_Delayed_Freeze (Spec_Id); - Freeze_Before (N, Spec_Id); - end if; + Set_Is_Frozen (Spec_Id); + Mask_Types := Mask_Unfrozen_Types (Spec_Id); + + elsif not Is_Frozen (Spec_Id) + and then Serious_Errors_Detected = 0 + then + Set_Has_Delayed_Freeze (Spec_Id); + Freeze_Before (N, Spec_Id); end if; end if; @@ -7439,14 +7245,16 @@ package body Sem_Ch6 is end if; end; - -- Functions can override abstract interface functions + -- Functions can override abstract interface functions. Return + -- types must be subtype conformant. elsif Ekind (Def_Id) = E_Function and then Ekind (Subp) = E_Function and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), Parameter_Specifications (Parent (Subp))) - and then Etype (Def_Id) = Etype (Subp) + and then Conforming_Types + (Etype (Def_Id), Etype (Subp), Subtype_Conformant) then Candidate := Subp; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ddfa543..2002b75 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6067,7 +6067,10 @@ package body Sem_Res is -- (including the body of another expression function) which would -- place the freeze node in the wrong scope. An expression function -- is frozen in the usual fashion, by the appearance of a real body, - -- or at the end of a declarative part. + -- or at the end of a declarative part. However an implcit call to + -- an expression function may appear when it is part of a default + -- expression in a call to an initialiation procedure, and must be + -- frozen now, even if the body is inserted at a later point. if Is_Entity_Name (Subp) and then not In_Spec_Expression @@ -6076,12 +6079,20 @@ package body Sem_Res is (not Is_Expression_Function_Or_Completion (Entity (Subp)) or else Scope (Entity (Subp)) = Current_Scope) then + if Is_Expression_Function (Entity (Subp)) then + + -- Force freeze of expression function in call + + Set_Comes_From_Source (Subp, True); + Set_Must_Not_Freeze (Subp, False); + end if; + Freeze_Expression (Subp); end if; -- For a predefined operator, the type of the result is the type imposed -- by context, except for a predefined operation on universal fixed. - -- Otherwise The type of the call is the type returned by the subprogram + -- Otherwise the type of the call is the type returned by the subprogram -- being called. if Is_Predefined_Op (Nam) then @@ -6117,7 +6128,25 @@ package body Sem_Res is Ret_Type : constant Entity_Id := Etype (Nam); begin - if Is_Access_Type (Ret_Type) + -- If this is a parameterless call there is no ambiguity and the + -- call has the type of the function. + + if No (First_Actual (N)) then + Set_Etype (N, Etype (Nam)); + + if Present (First_Formal (Nam)) then + Resolve_Actuals (N, Nam); + end if; + + -- Annotate the tree by creating a call marker in case the + -- original call is transformed by expansion. The call marker + -- is automatically saved for later examination by the ABE + -- Processing phase. + + Build_Call_Marker (N); + + elsif Is_Access_Type (Ret_Type) + and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) then Error_Msg_N diff --git a/gcc/ada/sem_spark.adb b/gcc/ada/sem_spark.adb index 3abfd99..e522620 100644 --- a/gcc/ada/sem_spark.adb +++ b/gcc/ada/sem_spark.adb @@ -52,15 +52,16 @@ package body Sem_SPARK is type Elaboration_Context_Index is range 0 .. Elaboration_Context_Max - 1; - function Elaboration_Context_Hash - (Key : Entity_Id) return Elaboration_Context_Index; + function Elaboration_Context_Hash (Key : Entity_Id) + return Elaboration_Context_Index; -- Function to hash any node of the AST - type Perm_Kind is (No_Access, Read_Only, Read_Write, Write_Only); - -- Permission type associated with paths - - subtype Read_Perm is Perm_Kind range Read_Only .. Read_Write; - subtype Write_Perm is Perm_Kind range Read_Write .. Write_Only; + type Perm_Kind is (Borrowed, Observed, Unrestricted, Moved); + -- Permission type associated with paths. The Moved permission is + -- equivalent to the Unrestricted one (same permissions). The Moved is + -- however used to mark the RHS after a move (which still unrestricted). + -- This way, we may generate warnings when manipulating the RHS + -- afterwads since it is set to Null after the assignment. type Perm_Tree_Wrapper; @@ -94,6 +95,7 @@ package body Sem_SPARK is -- The definition of permission trees. This is a tree, which has a -- permission at each node, and depending on the type of the node, -- can have zero, one, or more children pointed to by an access to tree. + type Perm_Tree (Kind : Path_Kind := Entire_Object) is record Permission : Perm_Kind; -- Permission at this level in the path @@ -103,7 +105,6 @@ package body Sem_SPARK is -- path. case Kind is - -- An entire object is either a leaf (an object which cannot be -- extended further in a path) or a subtree in folded form (which -- could later be unfolded further in another kind of node). The @@ -111,19 +112,19 @@ package body Sem_SPARK is -- extension of that node if that permission is different from -- the node's permission. - when Entire_Object => + when Entire_Object => Children_Permission : Perm_Kind; -- Unfolded path of access type. The permission of the object -- pointed to is given in Get_All. - when Reference => + when Reference => Get_All : Perm_Tree_Access; -- Unfolded path of array type. The permission of the elements is -- given in Get_Elem. - when Array_Component => + when Array_Component => Get_Elem : Perm_Tree_Access; -- Unfolded path of record type. The permission of the regular @@ -229,7 +230,7 @@ package body Sem_SPARK is -------------------- procedure Perm_Mismatch - (Exp_Perm, Act_Perm : Perm_Kind; + (Exp_Perm, Act_Perm : Perm_Kind; N : Node_Id); -- Issues a continuation error message about a mismatch between a -- desired permission Exp_Perm and a permission obtained Act_Perm. N @@ -243,10 +244,7 @@ package body Sem_SPARK is -- Children_Permission -- ------------------------- - function Children_Permission - (T : Perm_Tree_Access) - return Perm_Kind - is + function Children_Permission (T : Perm_Tree_Access) return Perm_Kind is begin return T.all.Tree.Children_Permission; end Children_Permission; @@ -257,7 +255,7 @@ package body Sem_SPARK is function Component (T : Perm_Tree_Access) - return Perm_Tree_Maps.Instance + return Perm_Tree_Maps.Instance is begin return T.all.Tree.Component; @@ -267,13 +265,10 @@ package body Sem_SPARK is -- Copy_Env -- -------------- - procedure Copy_Env - (From : Perm_Env; - To : in out Perm_Env) - is + procedure Copy_Env (From : Perm_Env; To : in out Perm_Env) is Comp_From : Perm_Tree_Access; - Key_From : Perm_Tree_Maps.Key_Option; - Son : Perm_Tree_Access; + Key_From : Perm_Tree_Maps.Key_Option; + Son : Perm_Tree_Access; begin Reset (To); @@ -296,7 +291,7 @@ package body Sem_SPARK is procedure Copy_Init_Map (From : Initialization_Map; - To : in out Initialization_Map) + To : in out Initialization_Map) is Comp_From : Boolean; Key_From : Boolean_Variables_Maps.Key_Option; @@ -315,25 +310,19 @@ package body Sem_SPARK is -- Copy_Tree -- --------------- - procedure Copy_Tree - (From : Perm_Tree_Access; - To : Perm_Tree_Access) - is + procedure Copy_Tree (From : Perm_Tree_Access; To : Perm_Tree_Access) is begin To.all := From.all; - case Kind (From) is when Entire_Object => null; when Reference => To.all.Tree.Get_All := new Perm_Tree_Wrapper; - Copy_Tree (Get_All (From), Get_All (To)); when Array_Component => To.all.Tree.Get_Elem := new Perm_Tree_Wrapper; - Copy_Tree (Get_Elem (From), Get_Elem (To)); when Record_Component => @@ -346,31 +335,26 @@ package body Sem_SPARK is -- We put a new hash table, so that it gets dealiased from the -- Component (From) hash table. To.all.Tree.Component := Hash_Table; - To.all.Tree.Other_Components := new Perm_Tree_Wrapper'(Other_Components (From).all); - Copy_Tree (Other_Components (From), Other_Components (To)); - Key_From := Perm_Tree_Maps.Get_First_Key (Component (From)); + while Key_From.Present loop Comp_From := Perm_Tree_Maps.Get (Component (From), Key_From.K); - pragma Assert (Comp_From /= null); Son := new Perm_Tree_Wrapper; - Copy_Tree (Comp_From, Son); - Perm_Tree_Maps.Set (To.all.Tree.Component, Key_From.K, Son); - Key_From := Perm_Tree_Maps.Get_Next_Key (Component (From)); end loop; end; end case; + end Copy_Tree; ------------------------------ @@ -402,9 +386,7 @@ package body Sem_SPARK is -- Free_Perm_Tree -- -------------------- - procedure Free_Perm_Tree - (PT : in out Perm_Tree_Access) - is + procedure Free_Perm_Tree (PT : in out Perm_Tree_Access) is procedure Free_Perm_Tree_Dealloc is new Ada.Unchecked_Deallocation (Perm_Tree_Wrapper, Perm_Tree_Access); @@ -430,6 +412,7 @@ package body Sem_SPARK is Free_Perm_Tree (PT.all.Tree.Other_Components); Comp := Perm_Tree_Maps.Get_First (Component (PT)); while Comp /= null loop + -- Free every Component subtree Free_Perm_Tree (Comp); @@ -444,10 +427,7 @@ package body Sem_SPARK is -- Get_All -- ------------- - function Get_All - (T : Perm_Tree_Access) - return Perm_Tree_Access - is + function Get_All (T : Perm_Tree_Access) return Perm_Tree_Access is begin return T.all.Tree.Get_All; end Get_All; @@ -456,10 +436,7 @@ package body Sem_SPARK is -- Get_Elem -- -------------- - function Get_Elem - (T : Perm_Tree_Access) - return Perm_Tree_Access - is + function Get_Elem (T : Perm_Tree_Access) return Perm_Tree_Access is begin return T.all.Tree.Get_Elem; end Get_Elem; @@ -468,10 +445,7 @@ package body Sem_SPARK is -- Is_Node_Deep -- ------------------ - function Is_Node_Deep - (T : Perm_Tree_Access) - return Boolean - is + function Is_Node_Deep (T : Perm_Tree_Access) return Boolean is begin return T.all.Tree.Is_Node_Deep; end Is_Node_Deep; @@ -480,10 +454,7 @@ package body Sem_SPARK is -- Kind -- ---------- - function Kind - (T : Perm_Tree_Access) - return Path_Kind - is + function Kind (T : Perm_Tree_Access) return Path_Kind is begin return T.all.Tree.Kind; end Kind; @@ -494,7 +465,7 @@ package body Sem_SPARK is function Other_Components (T : Perm_Tree_Access) - return Perm_Tree_Access + return Perm_Tree_Access is begin return T.all.Tree.Other_Components; @@ -504,10 +475,7 @@ package body Sem_SPARK is -- Permission -- ---------------- - function Permission - (T : Perm_Tree_Access) - return Perm_Kind - is + function Permission (T : Perm_Tree_Access) return Perm_Kind is begin return T.all.Tree.Permission; end Permission; @@ -516,13 +484,10 @@ package body Sem_SPARK is -- Perm_Mismatch -- ------------------- - procedure Perm_Mismatch - (Exp_Perm, Act_Perm : Perm_Kind; - N : Node_Id) - is + procedure Perm_Mismatch (Exp_Perm, Act_Perm : Perm_Kind; N : Node_Id) is begin - Error_Msg_N ("\expected at least `" - & Perm_Kind'Image (Exp_Perm) & "`, got `" + Error_Msg_N ("\expected state `" + & Perm_Kind'Image (Exp_Perm) & "` at least, got `" & Perm_Kind'Image (Act_Perm) & "`", N); end Perm_Mismatch; @@ -543,34 +508,29 @@ package body Sem_SPARK is -- Default mode. Checks that paths have Read_Perm permission. Move, - -- Regular moving semantics (not under 'Access). Checks that paths have - -- Read_Write permission. After moving a path, its permission is set to - -- Write_Only and the permission of its extensions is set to No_Access. + -- Regular moving semantics. Checks that paths have + -- Unrestricted permission. After moving a path, its permission is set + -- to Unrestricted and the permission of its extensions is set + -- to Unrestricted. Assign, -- Used for the target of an assignment, or an actual parameter with - -- mode OUT. Checks that paths have Write_Perm permission. After - -- assigning to a path, its permission is set to Read_Write. - - Super_Move, - -- Enhanced moving semantics (under 'Access). Checks that paths have - -- Read_Write permission (shallow types may have only Write permission). - -- After moving a path, its permission is set to No_Access, as well as - -- the permission of its extensions and the permission of its prefixes - -- up to the first Reference node. - - Borrow_Out, - -- Used for actual OUT parameters. Checks that paths have Write_Perm - -- permission. After checking a path, its permission is set to Read_Only - -- when of a by-copy type, to No_Access otherwise. After the call, its - -- permission is set to Read_Write. + -- mode OUT. Checks that paths have Unrestricted permission. After + -- assigning to a path, its permission is set to Unrestricted. + + Borrow, + -- Used for the source of an assignement when initializes a stand alone + -- object of anonymous type, constant, or IN parameter and also OUT + -- or IN OUT composite object. + -- In the borrowed state, the access object is completely "dead". Observe -- Used for actual IN parameters of a scalar type. Checks that paths -- have Read_Perm permission. After checking a path, its permission - -- is set to Read_Only. + -- is set to Observed. -- -- Also used for formal IN parameters + ); type Result_Kind is (Folded, Unfolded, Function_Call); @@ -593,11 +553,6 @@ package body Sem_SPARK is -- Local subprograms -- ----------------------- - function "<=" (P1, P2 : Perm_Kind) return Boolean; - function ">=" (P1, P2 : Perm_Kind) return Boolean; - function Glb (P1, P2 : Perm_Kind) return Perm_Kind; - function Lub (P1, P2 : Perm_Kind) return Perm_Kind; - -- Checking proceduress for safe pointer usage. These procedures traverse -- the AST, check nodes for correct permissions according to SPARK RM -- 6.4.2, and update permissions depending on the node kind. @@ -608,24 +563,15 @@ package body Sem_SPARK is -- We are not in End_Of_Callee mode, hence we will save the environment -- and start from a new one. We will add in the environment all formal -- parameters as well as global used during the subprogram, with the - -- appropriate permissions (write-only for out, read-only for observed, - -- read-write for others). - -- - -- After that we analyze the body of the function, and finaly, we check - -- that each borrowed parameter and global has read-write permission. We - -- then clean up the environment and put back the saved environment. + -- appropriate permissions (unrestricted for borrowed and moved, observed + -- for observed names). procedure Check_Declaration (Decl : Node_Id); procedure Check_Expression (Expr : Node_Id); - procedure Check_Globals (N : Node_Id; Check_Mode : Checking_Mode); - -- This procedure takes a global pragma and checks depending on mode: - -- Mode Read: every in global is readable - -- Mode Observe: same as Check_Param_Observes but on globals - -- Mode Borrow_Out: Check_Param_Outs for globals - -- Mode Move: Check_Param for globals with mode Read - -- Mode Assign: Check_Param for globals with mode Assign + procedure Check_Globals (N : Node_Id); + -- This procedure takes a global pragma and checks it procedure Check_List (L : List_Id); -- Calls Check_Node on each element of the list @@ -638,25 +584,15 @@ package body Sem_SPARK is procedure Check_Package_Body (Pack : Node_Id); - procedure Check_Param (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and calls the - -- analyze node if the parameter is borrowed with mode in out, with the - -- appropriate Checking_Mode (Move). - - procedure Check_Param_Observes (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and calls - -- the analyze node if the parameter is observed, with the appropriate - -- Checking_Mode. - - procedure Check_Param_Outs (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and calls the - -- analyze node if the parameter is of mode out, with the appropriate - -- Checking_Mode. + procedure Check_Param_In (Formal : Entity_Id; Actual : Node_Id); + -- This procedure takes a formal and an actual parameter and checks the + -- permission of every in-mode parameter. This includes Observing and + -- Borrowing. - procedure Check_Param_Read (Formal : Entity_Id; Actual : Node_Id); + procedure Check_Param_Out (Formal : Entity_Id; Actual : Node_Id); -- This procedure takes a formal and an actual parameter and checks the - -- readability of every in-mode parameter. This includes observed in, and - -- also borrowed in, that are then checked afterwards. + -- state of every out-mode and in out-mode parameter. This includes + -- Moving and Borrowing. procedure Check_Statement (Stmt : Node_Id); @@ -674,20 +610,6 @@ package body Sem_SPARK is -- appropriate subtree for that Node_Id. If the tree is folded, then -- it unrolls the tree up to the appropriate level. - function Has_Alias - (N : Node_Id) - return Boolean; - -- Function that returns whether the path given as parameter contains an - -- extension that is declared as aliased. - - function Has_Array_Component (N : Node_Id) return Boolean; - -- This function gets a Node_Id and looks recursively to find if the given - -- path has any array component. - - function Has_Function_Component (N : Node_Id) return Boolean; - -- This function gets a Node_Id and looks recursively to find if the given - -- path has any function component. - procedure Hp (P : Perm_Env); -- A procedure that outputs the hash table. This function is used only in -- the debugger to look into a hash table. @@ -698,28 +620,13 @@ package body Sem_SPARK is -- A procedure that is called when deep globals or aliased globals are used -- without any global aspect. - function Is_Borrowed_In (E : Entity_Id) return Boolean; - -- Function that tells if the given entity is a borrowed in a formal - -- parameter, that is, if it is an access-to-variable type. - function Is_Deep (E : Entity_Id) return Boolean; -- A function that can tell if a type is deep or not. Returns true if the -- type passed as argument is deep. - function Is_Shallow (E : Entity_Id) return Boolean; - -- A function that can tell if a type is shallow or not. Returns true if - -- the type passed as argument is shallow. - - function Loop_Of_Exit (N : Node_Id) return Entity_Id; - -- A function that takes an exit statement node and returns the entity of - -- the loop that this statement is exiting from. - - procedure Merge_Envs (Target : in out Perm_Env; Source : in out Perm_Env); - -- Merge Target and Source into Target, and then deallocate the Source - procedure Perm_Error - (N : Node_Id; - Perm : Perm_Kind; + (N : Node_Id; + Perm : Perm_Kind; Found_Perm : Perm_Kind); -- A procedure that is called when the permissions found contradict the -- rules established by the RM. This function is called with the node, its @@ -742,7 +649,7 @@ package body Sem_SPARK is procedure Return_Declarations (L : List_Id); -- Check correct permissions on every declared object at the end of a -- callee. Used at the end of the body of a callable entity. Checks that - -- paths of all borrowed formal parameters and global have Read_Write + -- paths of all borrowed formal parameters and global have Unrestricted -- permission. procedure Return_Globals (Subp : Entity_Id); @@ -750,65 +657,32 @@ package body Sem_SPARK is -- of the subprogram indeed have RW permission at the end of the subprogram -- execution. - procedure Return_Parameter_Or_Global - (Id : Entity_Id; - Mode : Formal_Kind; - Subp : Entity_Id; - Global_Var : Boolean); - -- Auxiliary procedure to Return_Parameters and Return_Globals - - procedure Return_Parameters (Subp : Entity_Id); - -- Takes a subprogram as input, and checks that all borrowed parameters of - -- the subprogram indeed have RW permission at the end of the subprogram - -- execution. + procedure Return_The_Global + (Id : Entity_Id; + Mode : Formal_Kind; + Subp : Entity_Id); + -- Auxiliary procedure to Return_Globals + -- There is no need to return parameters because they will be reassigned + -- their state once the subprogram returns. Local variables that have + -- borrowed, observed, or moved an actual parameter go out of the scope. procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind); -- This procedure takes an access to a permission tree and modifies the -- tree so that any strict extensions of the given tree become of the -- access specified by parameter P. - procedure Set_Perm_Extensions_Move (T : Perm_Tree_Access; E : Entity_Id); - -- Set permissions to - -- No for any extension with more .all - -- W for any deep extension with same number of .all - -- RW for any shallow extension with same number of .all - - function Set_Perm_Prefixes_Assign (N : Node_Id) return Perm_Tree_Access; - -- This function takes a name as an input and sets in the permission - -- tree the given permission to the given name. The general rule here is - -- that everybody updates the permission of the subtree it is returning. - -- The permission of the assigned path has been set to RW by the caller. - -- - -- Case where we have to normalize a tree after the correct permissions - -- have been assigned already. We look for the right subtree at the given - -- path, actualize its permissions, and then call the normalization on its - -- parent. - -- - -- Example: We assign x.y and x.z then during Set_Perm_Prefixes_Move will - -- change the permission of x to RW because all of its components have - -- permission have permission RW. - - function Set_Perm_Prefixes_Borrow_Out (N : Node_Id) return Perm_Tree_Access; + function Set_Perm_Prefixes_Borrow (N : Node_Id) return Perm_Tree_Access; -- This function modifies the permissions of a given node_id in the -- permission environment as well as in all the prefixes of the path, -- given that the path is borrowed with mode out. - function Set_Perm_Prefixes_Move - (N : Node_Id; Mode : Checking_Mode) + function Set_Perm_Prefixes + (N : Node_Id; + New_Perm : Perm_Kind) return Perm_Tree_Access; - pragma Precondition (Mode = Move or Mode = Super_Move); - -- Given a node and a mode (that can be either Move or Super_Move), this - -- function modifies the permissions of a given node_id in the permission - -- environment as well as all the prefixes of the path, given that the path - -- is moved with or without 'Access. The general rule here is everybody - -- updates the permission of the subtree they are returning. - -- - -- This case describes a move either under 'Access or without 'Access. - - function Set_Perm_Prefixes_Observe (N : Node_Id) return Perm_Tree_Access; - -- This function modifies the permissions of a given node_id in the - -- permission environment as well as all the prefixes of the path, - -- given that the path is observed. + -- This function sets the permissions of a given node_id in the + -- permission environment as well as in all the prefixes of the path + -- to the one given in parameter (P). procedure Setup_Globals (Subp : Entity_Id); -- Takes a subprogram as input, and sets up the environment by adding @@ -824,6 +698,15 @@ package body Sem_SPARK is -- Takes a subprogram as input, and sets up the environment by adding -- formal parameters with appropriate permissions. + function Has_Ownership_Aspect_True + (N : Node_Id; + Msg : String) + return Boolean; + -- Takes a node as an input, and finds out whether it has ownership aspect + -- True or False. This function is recursive whenever the node has a + -- composite type. Access-to-objects have ownership aspect False if they + -- have a general access type. + ---------------------- -- Global Variables -- ---------------------- @@ -861,31 +744,6 @@ package body Sem_SPARK is -- after declaration. Hence we can exclude from analysis variables that -- are just declared and never accessed, typically at package declaration. - ---------- - -- "<=" -- - ---------- - - function "<=" (P1, P2 : Perm_Kind) return Boolean - is - begin - return P2 >= P1; - end "<="; - - ---------- - -- ">=" -- - ---------- - - function ">=" (P1, P2 : Perm_Kind) return Boolean - is - begin - case P2 is - when No_Access => return True; - when Read_Only => return P1 in Read_Perm; - when Write_Only => return P1 in Write_Perm; - when Read_Write => return P1 = Read_Write; - end case; - end ">="; - -------------------------- -- Check_Call_Statement -- -------------------------- @@ -893,64 +751,40 @@ package body Sem_SPARK is procedure Check_Call_Statement (Call : Node_Id) is Saved_Env : Perm_Env; - procedure Iterate_Call is new - Iterate_Call_Parameters (Check_Param); - procedure Iterate_Call_Observes is new - Iterate_Call_Parameters (Check_Param_Observes); - procedure Iterate_Call_Outs is new - Iterate_Call_Parameters (Check_Param_Outs); - procedure Iterate_Call_Read is new - Iterate_Call_Parameters (Check_Param_Read); + procedure Iterate_Call_In is new + Iterate_Call_Parameters (Check_Param_In); + procedure Iterate_Call_Out is new + Iterate_Call_Parameters (Check_Param_Out); begin -- Save environment, so that the modifications done by analyzing the -- parameters are not kept at the end of the call. - Copy_Env (Current_Perm_Env, - Saved_Env); - - -- We first check the Read access on every in parameter - - Current_Checking_Mode := Read; - Iterate_Call_Read (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), Read); - - -- We first observe, then borrow with mode out, and then with other - -- modes. This ensures that we do not have to check for by-copy types - -- specially, because we read them before borrowing them. - Iterate_Call_Observes (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), - Observe); + Copy_Env (Current_Perm_Env, Saved_Env); - Iterate_Call_Outs (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), - Borrow_Out); + -- We first check the globals then parameters to handle the + -- No_Parameter_Aliasing Restriction. An out or in-out global is + -- considered as borrowing while a parameter with the same mode is + -- a move. This order disallow passing a part of a variable to a + -- subprogram if it is referenced as a global by the callable (when + -- writable). + -- For paremeters, we fisrt check in parameters and then the out ones. + -- This is to avoid Observing or Borrowing objects that are already + -- moved. This order is not mandatory but allows to catch runtime + -- errors like null pointer dereferencement at the analysis time. - Iterate_Call (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), Move); + Current_Checking_Mode := Read; + Check_Globals (Get_Pragma (Get_Called_Entity (Call), Pragma_Global)); + Iterate_Call_In (Call); + Iterate_Call_Out (Call); -- Restore environment, because after borrowing/observing actual -- parameters, they get their permission reverted to the ones before -- the call. Free_Env (Current_Perm_Env); - - Copy_Env (Saved_Env, - Current_Perm_Env); - + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (Saved_Env); - - -- We assign the out parameters (necessarily borrowed per RM) - Current_Checking_Mode := Assign; - Iterate_Call (Call); - Check_Globals (Get_Pragma - (Get_Called_Entity (Call), Pragma_Global), - Assign); - end Check_Call_Statement; ------------------------- @@ -959,15 +793,12 @@ package body Sem_SPARK is procedure Check_Callable_Body (Body_N : Node_Id) is - Mode_Before : constant Checking_Mode := Current_Checking_Mode; - - Saved_Env : Perm_Env; + Mode_Before : constant Checking_Mode := Current_Checking_Mode; + Saved_Env : Perm_Env; Saved_Init_Map : Initialization_Map; - - New_Env : Perm_Env; - - Body_Id : constant Entity_Id := Defining_Entity (Body_N); - Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); + New_Env : Perm_Env; + Body_Id : constant Entity_Id := Defining_Entity (Body_N); + Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); begin -- Check if SPARK pragma is not set to Off @@ -989,9 +820,8 @@ package body Sem_SPARK is -- Save initialization map Copy_Init_Map (Current_Initialization_Map, Saved_Init_Map); - Current_Checking_Mode := Read; - Current_Perm_Env := New_Env; + Current_Perm_Env := New_Env; -- Add formals and globals to the environment with adequate permissions @@ -1010,23 +840,18 @@ package body Sem_SPARK is if Ekind_In (Spec_Id, E_Procedure, E_Entry) and then not No_Return (Spec_Id) then - Return_Parameters (Spec_Id); Return_Globals (Spec_Id); end if; -- Free the environments Free_Env (Current_Perm_Env); - - Copy_Env (Saved_Env, - Current_Perm_Env); - + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (Saved_Env); -- Restore initialization map Copy_Init_Map (Saved_Init_Map, Current_Initialization_Map); - Reset (Saved_Init_Map); -- The assignment of all out parameters will be done by caller @@ -1039,51 +864,248 @@ package body Sem_SPARK is ----------------------- procedure Check_Declaration (Decl : Node_Id) is + + Target_Ent : constant Entity_Id := Defining_Identifier (Decl); + Target_Typ : Node_Id renames Etype (Target_Ent); + Check : Boolean := True; begin case N_Declaration'(Nkind (Decl)) is when N_Full_Type_Declaration => + if not Has_Ownership_Aspect_True (Target_Ent, "type declaration") + then + Check := False; + end if; - -- Nothing to do here ??? NOT TRUE IF CONSTRAINT ON TYPE - - null; + -- ??? What about component declarations with defaults. when N_Object_Declaration => + if (Is_Access_Type (Target_Typ) + or else Is_Deep (Target_Typ)) + and then not Has_Ownership_Aspect_True + (Target_Ent, "Object declaration ") + then + Check := False; + end if; + + if Is_Anonymous_Access_Type (Target_Typ) + and then not Present (Expression (Decl)) + then + + -- ??? Check the case of default value (AI) + -- ??? How an anonymous access type can be with default exp? + + Error_Msg_NE ("? object declaration & has OAF (Anonymous " + & "access-to-object with no initialization)", + Decl, Target_Ent); + + -- If it it an initialization + + elsif Present (Expression (Decl)) and Check then + + -- Find out the operation to be done on the right-hand side + + -- Initializing object, access type + + if Is_Access_Type (Target_Typ) then + + -- Initializing object, constant access type - -- First move the right-hand side + if Is_Constant_Object (Target_Ent) then - Current_Checking_Mode := Move; - Check_Node (Expression (Decl)); + -- Initializing object, constant access to variable type + + if not Is_Access_Constant (Target_Typ) then + Current_Checking_Mode := Borrow; + + -- Initializing object, constant access to constant type + + -- Initializing object, + -- constant access to constant anonymous type. + + elsif Is_Anonymous_Access_Type (Target_Typ) then + + -- This is an object declaration so the target + -- of the assignement is a stand-alone object. + + Current_Checking_Mode := Observe; + + -- Initializing object, constant access to constant + -- named type. + + else + -- If named then it is a general access type + -- Hence, Has_Ownership_Aspec_True is False. + + raise Program_Error; + end if; + + -- Initializing object, variable access type + + else + -- Initializing object, variable access to variable type + + if not Is_Access_Constant (Target_Typ) then + + -- Initializing object, variable named access to + -- variable type. + + if not Is_Anonymous_Access_Type (Target_Typ) then + Current_Checking_Mode := Move; + + -- Initializing object, variable anonymous access to + -- variable type. + + else + -- This is an object declaration so the target + -- object of the assignement is a stand-alone + -- object. + + Current_Checking_Mode := Borrow; + end if; + + -- Initializing object, variable access to constant type + + else + -- Initializing object, + -- variable named access to constant type. + + if not Is_Anonymous_Access_Type (Target_Typ) then + Error_Msg_N ("assignment not allowed, Ownership " + & "Aspect False (Anonymous Access " + & "Object)", Decl); + Check := False; + + -- Initializing object, + -- variable anonymous access to constant type. + + else + -- This is an object declaration so the target + -- of the assignement is a stand-alone object. + + Current_Checking_Mode := Observe; + end if; + end if; + end if; + + -- Initializing object, composite (deep) type + + elsif Is_Deep (Target_Typ) then + + -- Initializing object, constant composite type + + if Is_Constant_Object (Target_Ent) then + Current_Checking_Mode := Observe; + + -- Initializing object, variable composite type + + else + + -- Initializing object, variable anonymous composite type + + if Nkind (Object_Definition (Decl)) = + N_Constrained_Array_Definition + + -- An N_Constrained_Array_Definition is an anonymous + -- array (to be checked). Record types are always + -- named and are considered in the else part. + + then + declare + Com_Ty : constant Node_Id := + Component_Type (Etype (Target_Typ)); + begin + + if Is_Access_Type (Com_Ty) then + + -- If components are of anonymous type + + if Is_Anonymous_Access_Type (Com_Ty) then + if Is_Access_Constant (Com_Ty) then + Current_Checking_Mode := Observe; + + else + Current_Checking_Mode := Borrow; + end if; + + else + Current_Checking_Mode := Move; + end if; + + elsif Is_Deep (Com_Ty) then + + -- This is certainly named so it is a move + + Current_Checking_Mode := Move; + end if; + end; + + else + Current_Checking_Mode := Move; + end if; + end if; + + elsif Nkind_In (Expression (Decl), + N_Attribute_Reference, + N_Attribute_Reference, + N_Expanded_Name, + N_Explicit_Dereference, + N_Indexed_Component, + N_Reference, + N_Selected_Component, + N_Slice) + then + if Is_Access_Type (Etype (Prefix (Expression (Decl)))) + or else Is_Deep (Etype (Prefix (Expression (Decl)))) + then + Current_Checking_Mode := Observe; + Check := True; + end if; + end if; + end if; + + if Check then + Check_Node (Expression (Decl)); + end if; + + -- If lhs is not a pointer, we still give it the appropriate + -- state which is useless but not harmful. declare - Deep : constant Boolean := - Is_Deep (Etype (Defining_Identifier (Decl))); Elem : Perm_Tree_Access; + Deep : constant Boolean := Is_Deep (Target_Typ); begin - Elem := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Deep, - Permission => Read_Write, - Children_Permission => Read_Write)); - - -- If unitialized declaration, then set to Write_Only. If a - -- pointer declaration, it has a null default initialization. - - if No (Expression (Decl)) - and then not Has_Full_Default_Initialization - (Etype (Defining_Identifier (Decl))) - and then not Is_Access_Type - (Etype (Defining_Identifier (Decl))) - - -- Objects of shallow types are considered as always - -- initialized, leaving the checking of initialization to - -- flow analysis. - - and then Deep - then - Elem.all.Tree.Permission := Write_Only; - Elem.all.Tree.Children_Permission := Write_Only; + -- Note that all declared variables are set to the unrestricted + -- state. + -- + -- If variables are not initialized: + -- unrestricted to every declared object. + -- Exp: + -- R : Rec + -- S : Rec := (...) + -- R := S + -- The assignement R := S is not allowed in the new rules + -- if R is not unrestricted. + -- + -- If variables are initialized: + -- If it is a move, then the target is unrestricted + -- If it is a borrow, then the target is unrestricted + -- If it is an observe, then the target should be observed + + if Current_Checking_Mode = Observe then + Elem := new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Deep, + Permission => Observed, + Children_Permission => Observed)); + else + Elem := new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Deep, + Permission => Unrestricted, + Children_Permission => Unrestricted)); end if; -- Create new tree for defining identifier @@ -1091,7 +1113,6 @@ package body Sem_SPARK is Set (Current_Perm_Env, Unique_Entity (Defining_Identifier (Decl)), Elem); - pragma Assert (Get_First (Current_Perm_Env) /= null); end; @@ -1099,19 +1120,17 @@ package body Sem_SPARK is Check_Node (Subtype_Indication (Decl)); when N_Iterator_Specification => - pragma Assert (Is_Shallow (Etype (Defining_Identifier (Decl)))); null; when N_Loop_Parameter_Specification => - pragma Assert (Is_Shallow (Etype (Defining_Identifier (Decl)))); null; -- Checking should not be called directly on these nodes - when N_Component_Declaration - | N_Function_Specification + when N_Function_Specification | N_Entry_Declaration | N_Procedure_Specification + | N_Component_Declaration => raise Program_Error; @@ -1141,29 +1160,33 @@ package body Sem_SPARK is Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin case N_Subexpr'(Nkind (Expr)) is - when N_Procedure_Call_Statement => + when N_Procedure_Call_Statement + | N_Function_Call + => Check_Call_Statement (Expr); when N_Identifier | N_Expanded_Name => -- Check if identifier is pointing to nothing (On/Off/...) + if not Present (Entity (Expr)) then return; end if; -- Do not analyze things that are not of object Kind + if Ekind (Entity (Expr)) not in Object_Kind then return; end if; -- Consider as ident + Process_Path (Expr); -- Switch to read mode and then check the readability of each operand when N_Binary_Op => - Current_Checking_Mode := Read; Check_Node (Left_Opnd (Expr)); Check_Node (Right_Opnd (Expr)); @@ -1175,7 +1198,6 @@ package body Sem_SPARK is | N_Op_Not | N_Op_Plus => - pragma Assert (Is_Shallow (Etype (Expr))); Current_Checking_Mode := Read; Check_Node (Right_Opnd (Expr)); @@ -1184,32 +1206,7 @@ package body Sem_SPARK is when N_Attribute_Reference => case Attribute_Name (Expr) is when Name_Access => - case Current_Checking_Mode is - when Read => - Check_Node (Prefix (Expr)); - - when Move => - Current_Checking_Mode := Super_Move; - Check_Node (Prefix (Expr)); - - -- Only assign names, not expressions - - when Assign => - raise Program_Error; - - -- Prefix in Super_Move should be a name, error here - - when Super_Move => - raise Program_Error; - - -- Could only borrow names of mode out, not n'Access - - when Borrow_Out => - raise Program_Error; - - when Observe => - Check_Node (Prefix (Expr)); - end case; + Error_Msg_N ("access attribute not allowed in SPARK", Expr); when Name_Last | Name_First @@ -1239,7 +1236,7 @@ package body Sem_SPARK is Check_Node (Prefix (Expr)); when Name_Pred - | Name_Succ + | Name_Succ => Check_List (Expressions (Expr)); Check_Node (Prefix (Expr)); @@ -1254,12 +1251,12 @@ package body Sem_SPARK is -- analysis. when Name_Address - | Name_Alignment - | Name_Component_Size - | Name_First_Bit - | Name_Last_Bit - | Name_Size - | Name_Position + | Name_Alignment + | Name_Component_Size + | Name_First_Bit + | Name_Last_Bit + | Name_Size + | Name_Position => null; @@ -1270,7 +1267,6 @@ package body Sem_SPARK is | Name_Val => null; - -- Other attributes that fall out of the scope of the analysis when others => @@ -1292,17 +1288,12 @@ package body Sem_SPARK is when N_And_Then | N_Or_Else => - pragma Assert (Is_Shallow (Etype (Expr))); Current_Checking_Mode := Read; Check_Node (Left_Opnd (Expr)); Check_Node (Right_Opnd (Expr)); -- Check the arguments of the call - when N_Function_Call => - Current_Checking_Mode := Read; - Check_List (Parameter_Associations (Expr)); - when N_Explicit_Dereference => Process_Path (Expr); @@ -1315,20 +1306,16 @@ package body Sem_SPARK is -- Accumulator for the different branches New_Env : Perm_Env; - - Elmt : Node_Id := First (Expressions (Expr)); + Elmt : Node_Id := First (Expressions (Expr)); begin Current_Checking_Mode := Read; - Check_Node (Elmt); - Current_Checking_Mode := Mode_Before; -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy, and new aliased. @@ -1341,15 +1328,10 @@ package body Sem_SPARK is -- Here the new_environment contains curr env after then block -- ELSE part - -- Restore environment before if - Copy_Env (Current_Perm_Env, - New_Env); - + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); - - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); -- Here new environment contains the environment after then and -- current the fresh copy of old one. @@ -1357,14 +1339,9 @@ package body Sem_SPARK is Next (Elmt); Check_Node (Elmt); - Merge_Envs (New_Env, - Current_Perm_Env); - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); - + Copy_Env (New_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); end; @@ -1380,6 +1357,7 @@ package body Sem_SPARK is when N_Quantified_Expression => declare Saved_Env : Perm_Env; + begin Copy_Env (Current_Perm_Env, Saved_Env); Current_Checking_Mode := Read; @@ -1391,7 +1369,6 @@ package body Sem_SPARK is Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (Saved_Env); end; - -- Analyze the list of associations in the aggregate when N_Aggregate => @@ -1408,19 +1385,16 @@ package body Sem_SPARK is -- Accumulator for the different branches New_Env : Perm_Env; - Elmt : Node_Id := First (Alternatives (Expr)); begin Current_Checking_Mode := Read; Check_Node (Expression (Expr)); - Current_Checking_Mode := Mode_Before; -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy, and new aliased. @@ -1429,43 +1403,29 @@ package body Sem_SPARK is Check_Node (Elmt); Next (Elmt); - - Copy_Env (Current_Perm_Env, - New_Env); - + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); -- Other alternatives while Present (Elmt) loop - -- Restore environment - Copy_Env (Saved_Env, - Current_Perm_Env); + -- Restore environment + Copy_Env (Saved_Env, Current_Perm_Env); Check_Node (Elmt); - - -- Merge Current_Perm_Env into New_Env - - Merge_Envs (New_Env, - Current_Perm_Env); - Next (Elmt); end loop; - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); end; - -- Analyze the list of associates in the aggregate as well as the -- ancestor part. when N_Extension_Aggregate => - Check_Node (Ancestor_Part (Expr)); Check_List (Expressions (Expr)); @@ -1507,7 +1467,6 @@ package body Sem_SPARK is | N_Raise_xxx_Error => null; - -- The following nodes are never generated in GNATprove mode when N_Expression_With_Actions @@ -1515,7 +1474,6 @@ package body Sem_SPARK is | N_Unchecked_Expression => raise Program_Error; - end case; end Check_Expression; @@ -1523,150 +1481,63 @@ package body Sem_SPARK is -- Check_Globals -- ------------------- - procedure Check_Globals (N : Node_Id; Check_Mode : Checking_Mode) is + procedure Check_Globals (N : Node_Id) is begin if Nkind (N) = N_Empty then return; end if; declare - pragma Assert - (List_Length (Pragma_Argument_Associations (N)) = 1); - - PAA : constant Node_Id := - First (Pragma_Argument_Associations (N)); + pragma Assert (List_Length (Pragma_Argument_Associations (N)) = 1); + PAA : constant Node_Id := First (Pragma_Argument_Associations (N)); pragma Assert (Nkind (PAA) = N_Pragma_Argument_Association); - Row : Node_Id; The_Mode : Name_Id; RHS : Node_Id; - procedure Process (Mode : Name_Id; - The_Global : Entity_Id); - - procedure Process (Mode : Name_Id; - The_Global : Node_Id) - is - Ident_Elt : constant Entity_Id := + procedure Process (Mode : Name_Id; The_Global : Entity_Id); + procedure Process (Mode : Name_Id; The_Global : Node_Id) is + Ident_Elt : constant Entity_Id := Unique_Entity (Entity (The_Global)); - Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin if Ekind (Ident_Elt) = E_Abstract_State then return; end if; - - case Check_Mode is - when Read => - case Mode is - when Name_Input - | Name_Proof_In - => - Check_Node (The_Global); - - when Name_Output - | Name_In_Out - => - null; - - when others => - raise Program_Error; - - end case; - - when Observe => - case Mode is - when Name_Input - | Name_Proof_In - => - if not Is_Borrowed_In (Ident_Elt) then - -- Observed in - - Current_Checking_Mode := Observe; - Check_Node (The_Global); - end if; - - when others => - null; - - end case; - - when Borrow_Out => - - case Mode is - when Name_Output => - -- Borrowed out - Current_Checking_Mode := Borrow_Out; - Check_Node (The_Global); - - when others => - null; - - end case; - - when Move => - case Mode is - when Name_Input - | Name_Proof_In - => - if Is_Borrowed_In (Ident_Elt) then - -- Borrowed in - - Current_Checking_Mode := Move; - else - -- Observed - - return; - end if; - - when Name_Output => - return; - - when Name_In_Out => - -- Borrowed in out - - Current_Checking_Mode := Move; - - when others => - raise Program_Error; - end case; - + case Mode is + when Name_Input + | Name_Proof_In + => + Current_Checking_Mode := Observe; Check_Node (The_Global); - when Assign => - case Mode is - when Name_Input - | Name_Proof_In - => - null; - - when Name_Output - | Name_In_Out - => - -- Borrowed out or in out - - Process_Path (The_Global); - when others => - raise Program_Error; - end case; + when Name_Output + | Name_In_Out + => + -- ??? Borrow not Move? + Current_Checking_Mode := Borrow; + Check_Node (The_Global); when others => raise Program_Error; end case; - Current_Checking_Mode := Mode_Before; end Process; begin if Nkind (Expression (PAA)) = N_Null then + -- global => null -- No globals, nothing to do + return; elsif Nkind_In (Expression (PAA), N_Identifier, N_Expanded_Name) then + -- global => foo -- A single input + Process (Name_Input, Expression (PAA)); elsif Nkind (Expression (PAA)) = N_Aggregate @@ -1674,6 +1545,7 @@ package body Sem_SPARK is then -- global => (foo, bar) -- Inputs + RHS := First (Expressions (Expression (PAA))); while Present (RHS) loop case Nkind (RHS) is @@ -1687,7 +1559,6 @@ package body Sem_SPARK is when others => raise Program_Error; - end case; RHS := Next (RHS); end loop; @@ -1707,8 +1578,8 @@ package body Sem_SPARK is while Present (Row) loop pragma Assert (List_Length (Choices (Row)) = 1); The_Mode := Chars (First (Choices (Row))); - RHS := Expression (Row); + case Nkind (RHS) is when N_Aggregate => RHS := First (Expressions (RHS)); @@ -1719,7 +1590,6 @@ package body Sem_SPARK is when others => Process (The_Mode, RHS); - end case; RHS := Next (RHS); end loop; @@ -1737,9 +1607,7 @@ package body Sem_SPARK is when others => raise Program_Error; - end case; - Row := Next (Row); end loop; end; @@ -1770,339 +1638,6 @@ package body Sem_SPARK is procedure Check_Loop_Statement (Loop_N : Node_Id) is - -- Local Subprograms - - procedure Check_Is_Less_Restrictive_Env - (Exiting_Env : Perm_Env; - Entry_Env : Perm_Env); - -- This procedure checks that the Exiting_Env environment is less - -- restrictive than the Entry_Env environment. - - procedure Check_Is_Less_Restrictive_Tree - (New_Tree : Perm_Tree_Access; - Orig_Tree : Perm_Tree_Access; - E : Entity_Id); - -- Auxiliary procedure to check that the tree New_Tree is less - -- restrictive than the tree Orig_Tree for the entity E. - - procedure Perm_Error_Loop_Exit - (E : Entity_Id; - Loop_Id : Node_Id; - Perm : Perm_Kind; - Found_Perm : Perm_Kind); - -- A procedure that is called when the permissions found contradict - -- the rules established by the RM at the exit of loops. This function - -- is called with the entity, the node of the enclosing loop, the - -- permission that was expected and the permission found, and issues - -- an appropriate error message. - - ----------------------------------- - -- Check_Is_Less_Restrictive_Env -- - ----------------------------------- - - procedure Check_Is_Less_Restrictive_Env - (Exiting_Env : Perm_Env; - Entry_Env : Perm_Env) - is - Comp_Entry : Perm_Tree_Maps.Key_Option; - Iter_Entry, Iter_Exit : Perm_Tree_Access; - - begin - Comp_Entry := Get_First_Key (Entry_Env); - while Comp_Entry.Present loop - Iter_Entry := Get (Entry_Env, Comp_Entry.K); - pragma Assert (Iter_Entry /= null); - Iter_Exit := Get (Exiting_Env, Comp_Entry.K); - pragma Assert (Iter_Exit /= null); - Check_Is_Less_Restrictive_Tree - (New_Tree => Iter_Exit, - Orig_Tree => Iter_Entry, - E => Comp_Entry.K); - Comp_Entry := Get_Next_Key (Entry_Env); - end loop; - end Check_Is_Less_Restrictive_Env; - - ------------------------------------ - -- Check_Is_Less_Restrictive_Tree -- - ------------------------------------ - - procedure Check_Is_Less_Restrictive_Tree - (New_Tree : Perm_Tree_Access; - Orig_Tree : Perm_Tree_Access; - E : Entity_Id) - is - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Check_Is_Less_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id); - -- Auxiliary procedure to check that the tree N is less restrictive - -- than the given permission P. - - procedure Check_Is_More_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id); - -- Auxiliary procedure to check that the tree N is more restrictive - -- than the given permission P. - - ----------------------------------------- - -- Check_Is_Less_Restrictive_Tree_Than -- - ----------------------------------------- - - procedure Check_Is_Less_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id) - is - begin - if not (Permission (Tree) >= Perm) then - Perm_Error_Loop_Exit - (E, Loop_N, Permission (Tree), Perm); - end if; - - case Kind (Tree) is - when Entire_Object => - if not (Children_Permission (Tree) >= Perm) then - Perm_Error_Loop_Exit - (E, Loop_N, Children_Permission (Tree), Perm); - - end if; - - when Reference => - Check_Is_Less_Restrictive_Tree_Than - (Get_All (Tree), Perm, E); - - when Array_Component => - Check_Is_Less_Restrictive_Tree_Than - (Get_Elem (Tree), Perm, E); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First (Component (Tree)); - while Comp /= null loop - Check_Is_Less_Restrictive_Tree_Than (Comp, Perm, E); - Comp := - Perm_Tree_Maps.Get_Next (Component (Tree)); - end loop; - - Check_Is_Less_Restrictive_Tree_Than - (Other_Components (Tree), Perm, E); - end; - end case; - end Check_Is_Less_Restrictive_Tree_Than; - - ----------------------------------------- - -- Check_Is_More_Restrictive_Tree_Than -- - ----------------------------------------- - - procedure Check_Is_More_Restrictive_Tree_Than - (Tree : Perm_Tree_Access; - Perm : Perm_Kind; - E : Entity_Id) - is - begin - if not (Perm >= Permission (Tree)) then - Perm_Error_Loop_Exit - (E, Loop_N, Permission (Tree), Perm); - end if; - - case Kind (Tree) is - when Entire_Object => - if not (Perm >= Children_Permission (Tree)) then - Perm_Error_Loop_Exit - (E, Loop_N, Children_Permission (Tree), Perm); - end if; - - when Reference => - Check_Is_More_Restrictive_Tree_Than - (Get_All (Tree), Perm, E); - - when Array_Component => - Check_Is_More_Restrictive_Tree_Than - (Get_Elem (Tree), Perm, E); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First (Component (Tree)); - while Comp /= null loop - Check_Is_More_Restrictive_Tree_Than (Comp, Perm, E); - Comp := - Perm_Tree_Maps.Get_Next (Component (Tree)); - end loop; - - Check_Is_More_Restrictive_Tree_Than - (Other_Components (Tree), Perm, E); - end; - end case; - end Check_Is_More_Restrictive_Tree_Than; - - -- Start of processing for Check_Is_Less_Restrictive_Tree - - begin - if not (Permission (New_Tree) <= Permission (Orig_Tree)) then - Perm_Error_Loop_Exit - (E => E, - Loop_Id => Loop_N, - Perm => Permission (New_Tree), - Found_Perm => Permission (Orig_Tree)); - end if; - - case Kind (New_Tree) is - - -- Potentially folded tree. We check the other tree Orig_Tree to - -- check whether it is folded or not. If folded we just compare - -- their Permission and Children_Permission, if not, then we - -- look at the Children_Permission of the folded tree against - -- the unfolded tree Orig_Tree. - - when Entire_Object => - case Kind (Orig_Tree) is - when Entire_Object => - if not (Children_Permission (New_Tree) <= - Children_Permission (Orig_Tree)) - then - Perm_Error_Loop_Exit - (E, Loop_N, - Children_Permission (New_Tree), - Children_Permission (Orig_Tree)); - end if; - - when Reference => - Check_Is_More_Restrictive_Tree_Than - (Get_All (Orig_Tree), Children_Permission (New_Tree), E); - - when Array_Component => - Check_Is_More_Restrictive_Tree_Than - (Get_Elem (Orig_Tree), Children_Permission (New_Tree), E); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First - (Component (Orig_Tree)); - while Comp /= null loop - Check_Is_More_Restrictive_Tree_Than - (Comp, Children_Permission (New_Tree), E); - Comp := Perm_Tree_Maps.Get_Next - (Component (Orig_Tree)); - end loop; - - Check_Is_More_Restrictive_Tree_Than - (Other_Components (Orig_Tree), - Children_Permission (New_Tree), E); - end; - end case; - - when Reference => - case Kind (Orig_Tree) is - when Entire_Object => - Check_Is_Less_Restrictive_Tree_Than - (Get_All (New_Tree), Children_Permission (Orig_Tree), E); - - when Reference => - Check_Is_Less_Restrictive_Tree - (Get_All (New_Tree), Get_All (Orig_Tree), E); - - when others => - raise Program_Error; - end case; - - when Array_Component => - case Kind (Orig_Tree) is - when Entire_Object => - Check_Is_Less_Restrictive_Tree_Than - (Get_Elem (New_Tree), Children_Permission (Orig_Tree), E); - - when Array_Component => - Check_Is_Less_Restrictive_Tree - (Get_Elem (New_Tree), Get_Elem (Orig_Tree), E); - - when others => - raise Program_Error; - end case; - - when Record_Component => - declare - CompN : Perm_Tree_Access; - begin - CompN := - Perm_Tree_Maps.Get_First (Component (New_Tree)); - case Kind (Orig_Tree) is - when Entire_Object => - while CompN /= null loop - Check_Is_Less_Restrictive_Tree_Than - (CompN, Children_Permission (Orig_Tree), E); - - CompN := - Perm_Tree_Maps.Get_Next (Component (New_Tree)); - end loop; - - Check_Is_Less_Restrictive_Tree_Than - (Other_Components (New_Tree), - Children_Permission (Orig_Tree), - E); - - when Record_Component => - declare - - KeyO : Perm_Tree_Maps.Key_Option; - CompO : Perm_Tree_Access; - begin - KeyO := Perm_Tree_Maps.Get_First_Key - (Component (Orig_Tree)); - while KeyO.Present loop - pragma Assert (CompO /= null); - - Check_Is_Less_Restrictive_Tree (CompN, CompO, E); - - KeyO := Perm_Tree_Maps.Get_Next_Key - (Component (Orig_Tree)); - CompN := Perm_Tree_Maps.Get - (Component (New_Tree), KeyO.K); - CompO := Perm_Tree_Maps.Get - (Component (Orig_Tree), KeyO.K); - end loop; - - Check_Is_Less_Restrictive_Tree - (Other_Components (New_Tree), - Other_Components (Orig_Tree), - E); - end; - - when others => - raise Program_Error; - end case; - end; - end case; - end Check_Is_Less_Restrictive_Tree; - - -------------------------- - -- Perm_Error_Loop_Exit -- - -------------------------- - - procedure Perm_Error_Loop_Exit - (E : Entity_Id; - Loop_Id : Node_Id; - Perm : Perm_Kind; - Found_Perm : Perm_Kind) - is - begin - Error_Msg_Node_2 := Loop_Id; - Error_Msg_N ("insufficient permission for & when exiting loop &", E); - Perm_Mismatch (Exp_Perm => Perm, - Act_Perm => Found_Perm, - N => Loop_Id); - end Perm_Error_Loop_Exit; - -- Local variables Loop_Name : constant Entity_Id := Entity (Identifier (Loop_N)); @@ -2126,6 +1661,7 @@ package body Sem_SPARK is if Present (Iteration_Scheme (Loop_N)) then declare Exit_Env : constant Perm_Env_Access := new Perm_Env; + begin Copy_Env (From => Current_Perm_Env, To => Exit_Env.all); Set (Current_Loops_Accumulators, Loop_Name, Exit_Env); @@ -2137,12 +1673,6 @@ package body Sem_SPARK is Check_Node (Iteration_Scheme (Loop_N)); Check_List (Statements (Loop_N)); - -- Check that environment gets less restrictive at end of loop - - Check_Is_Less_Restrictive_Env - (Exiting_Env => Current_Perm_Env, - Entry_Env => Loop_Env.all); - -- Set environment to the one for exiting the loop declare @@ -2208,6 +1738,7 @@ package body Sem_SPARK is when N_Package_Declaration => declare Spec : constant Node_Id := Specification (N); + begin Current_Checking_Mode := Read; Check_List (Visible_Declarations (Spec)); @@ -2274,7 +1805,6 @@ package body Sem_SPARK is | N_Delay_Alternative | N_Derived_Type_Definition | N_Designator - | N_Discriminant_Association | N_Discriminant_Specification | N_Elsif_Part | N_Entry_Body_Formal_Part @@ -2366,9 +1896,12 @@ package body Sem_SPARK is | N_Use_Type_Clause | N_Validate_Unchecked_Conversion | N_Variable_Reference_Marker + | N_Discriminant_Association + + -- ??? check whether we should do sth special for + -- N_Discriminant_Association, or maybe raise a program error. => null; - -- The following nodes are rewritten by semantic analysis when N_Single_Protected_Declaration @@ -2408,15 +1941,12 @@ package body Sem_SPARK is -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); - + Copy_Env (Current_Perm_Env, Saved_Env); Check_List (Private_Declarations (CorSp)); -- Set mode to Read, and then analyze declarations and statements Current_Checking_Mode := Read; - Check_List (Declarations (Pack)); Check_Node (Handled_Statement_Sequence (Pack)); @@ -2430,137 +1960,129 @@ package body Sem_SPARK is -- declaration) from environment. Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); end Check_Package_Body; - ----------------- - -- Check_Param -- - ----------------- + -------------------- + -- Check_Param_In -- + -------------------- - procedure Check_Param (Formal : Entity_Id; Actual : Node_Id) is + procedure Check_Param_In (Formal : Entity_Id; Actual : Node_Id) is Mode : constant Entity_Kind := Ekind (Formal); Mode_Before : constant Checking_Mode := Current_Checking_Mode; - begin - case Current_Checking_Mode is - when Read => - case Formal_Kind'(Mode) is - when E_In_Parameter => - if Is_Borrowed_In (Formal) then - -- Borrowed in - - Current_Checking_Mode := Move; - else - -- Observed + case Formal_Kind'(Mode) is - return; - end if; + -- Formal IN parameter - when E_Out_Parameter => - return; + when E_In_Parameter => - when E_In_Out_Parameter => - -- Borrowed in out + -- Formal IN parameter, access type - Current_Checking_Mode := Move; + if Is_Access_Type (Etype (Formal)) then - end case; + -- Formal IN parameter, access to variable type - Check_Node (Actual); + if not Is_Access_Constant (Etype (Formal)) then - when Assign => - case Formal_Kind'(Mode) is - when E_In_Parameter => - null; + -- Formal IN parameter, named/anonymous access to variable + -- type. - when E_Out_Parameter - | E_In_Out_Parameter - => - -- Borrowed out or in out + Current_Checking_Mode := Borrow; + Check_Node (Actual); - Process_Path (Actual); + -- Formal IN parameter, access to constant type + -- Formal IN parameter, access to named constant type - end case; + elsif not Is_Anonymous_Access_Type (Etype (Formal)) then + Error_Msg_N ("assignment not allowed, Ownership Aspect" + & " False (Named general access type)", + Formal); - when others => - raise Program_Error; + -- Formal IN parameter, access to anonymous constant type - end case; - Current_Checking_Mode := Mode_Before; - end Check_Param; + else + Current_Checking_Mode := Observe; + Check_Node (Actual); + end if; - -------------------------- - -- Check_Param_Observes -- - -------------------------- + -- Formal IN parameter, composite type - procedure Check_Param_Observes (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); - Mode_Before : constant Checking_Mode := Current_Checking_Mode; + elsif Is_Deep (Etype (Formal)) then - begin - case Mode is - when E_In_Parameter => - if not Is_Borrowed_In (Formal) then - -- Observed in + -- Composite formal types should be named + -- Formal IN parameter, composite named type Current_Checking_Mode := Observe; Check_Node (Actual); end if; - when others => + when E_Out_Parameter + | E_In_Out_Parameter + => null; - end case; Current_Checking_Mode := Mode_Before; - end Check_Param_Observes; + end Check_Param_In; ---------------------- - -- Check_Param_Outs -- + -- Check_Param_Out -- ---------------------- - procedure Check_Param_Outs (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); + procedure Check_Param_Out (Formal : Entity_Id; Actual : Node_Id) is + Mode : constant Entity_Kind := Ekind (Formal); Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin + case Formal_Kind'(Mode) is - case Mode is - when E_Out_Parameter => - -- Borrowed out - Current_Checking_Mode := Borrow_Out; - Check_Node (Actual); + -- Formal OUT/IN OUT parameter - when others => - null; + when E_Out_Parameter + | E_In_Out_Parameter + => - end case; + -- Formal OUT/IN OUT parameter, access type - Current_Checking_Mode := Mode_Before; - end Check_Param_Outs; + if Is_Access_Type (Etype (Formal)) then - ---------------------- - -- Check_Param_Read -- - ---------------------- + -- Formal OUT/IN OUT parameter, access to variable type - procedure Check_Param_Read (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); + if not Is_Access_Constant (Etype (Formal)) then - begin - pragma Assert (Current_Checking_Mode = Read); + -- Cannot have anonymous out access parameter + -- Formal out/in out parameter, access to named variable + -- type. - case Formal_Kind'(Mode) is - when E_In_Parameter => - Check_Node (Actual); + Current_Checking_Mode := Move; + Check_Node (Actual); - when E_Out_Parameter - | E_In_Out_Parameter - => - null; + -- Formal out/in out parameter, access to constant type + + else + Error_Msg_N ("assignment not allowed, Ownership Aspect False" + & " (Named general access type)", Formal); + + end if; + -- Formal out/in out parameter, composite type + + elsif Is_Deep (Etype (Formal)) then + + -- Composite formal types should be named + -- Formal out/in out Parameter, Composite Named type. + + Current_Checking_Mode := Borrow; + Check_Node (Actual); + end if; + + when E_In_Parameter => + null; end case; - end Check_Param_Read; + + Current_Checking_Mode := Mode_Before; + end Check_Param_Out; ------------------------- -- Check_Safe_Pointers -- @@ -2605,13 +2127,13 @@ package body Sem_SPARK is -- Local variables Prag : Node_Id; + -- SPARK_Mode pragma in application -- Start of processing for Check_Safe_Pointers begin Initialize; - case Nkind (N) is when N_Compilation_Unit => Check_Safe_Pointers (Unit (N)); @@ -2647,6 +2169,42 @@ package body Sem_SPARK is procedure Check_Statement (Stmt : Node_Id) is Mode_Before : constant Checking_Mode := Current_Checking_Mode; + State_N : Perm_Kind; + Check : Boolean := True; + St_Name : Node_Id; + Ty_St_Name : Node_Id; + + function Get_Root (Comp_Stmt : Node_Id) return Node_Id; + -- Return the root of the name given as input + + function Get_Root (Comp_Stmt : Node_Id) return Node_Id is + begin + case Nkind (Comp_Stmt) is + when N_Identifier + | N_Expanded_Name + => return Comp_Stmt; + + when N_Type_Conversion + | N_Unchecked_Type_Conversion + | N_Qualified_Expression + => + return Get_Root (Expression (Comp_Stmt)); + + when N_Parameter_Specification => + return Get_Root (Defining_Identifier (Comp_Stmt)); + + when N_Selected_Component + | N_Indexed_Component + | N_Slice + | N_Explicit_Dereference + => + return Get_Root (Prefix (Comp_Stmt)); + + when others => + raise Program_Error; + end case; + end Get_Root; + begin case N_Statement_Other_Than_Procedure_Call'(Nkind (Stmt)) is when N_Entry_Call_Statement => @@ -2655,25 +2213,189 @@ package body Sem_SPARK is -- Move right-hand side first, and then assign left-hand side when N_Assignment_Statement => - if Is_Deep (Etype (Expression (Stmt))) then - Current_Checking_Mode := Move; - else - Current_Checking_Mode := Read; - end if; - Check_Node (Expression (Stmt)); - Current_Checking_Mode := Assign; - Check_Node (Name (Stmt)); + St_Name := Name (Stmt); + Ty_St_Name := Etype (Name (Stmt)); + + -- Check that is not a *general* access type + + if Has_Ownership_Aspect_True (St_Name, "assigning to") then + + -- Assigning to access type + + if Is_Access_Type (Ty_St_Name) then + + -- Assigning to access to variable type + + if not Is_Access_Constant (Ty_St_Name) then + + -- Assigning to named access to variable type + + if not Is_Anonymous_Access_Type (Ty_St_Name) then + Current_Checking_Mode := Move; + + -- Assigning to anonymous access to variable type + + else + -- Target /= source root + + if Nkind_In (Expression (Stmt), N_Allocator, N_Null) + or else St_Name /= Get_Root (Expression (Stmt)) + then + Error_Msg_N ("assignment not allowed, anonymous " + & "access Object with Different Root", + Stmt); + Check := False; + + -- Target = source root + + else + -- Here we do nothing on the source nor on the + -- target. However, we check the the legality rule: + -- "The source shall be an owning access object + -- denoted by a name that is not in the observed + -- state". + + State_N := Get_Perm (Expression (Stmt)); + if State_N = Observed then + Error_Msg_N ("assignment not allowed, Anonymous " + & "access object with the same root" + & " but source Observed", Stmt); + Check := False; + end if; + end if; + end if; + + -- else access-to-constant + + -- Assigning to anonymous access-to-constant type + + elsif Is_Anonymous_Access_Type (Ty_St_Name) then + + -- ??? Check the follwing condition. We may have to + -- add that the root is in the observed state too. + + State_N := Get_Perm (Expression (Stmt)); + if State_N /= Observed then + Error_Msg_N ("assignment not allowed, anonymous " + & "access-to-constant object not in " + & "the observed state)", Stmt); + Check := False; + + else + Error_Msg_N ("?here check accessibility level cited in" + & " the second legality rule of assign", + Stmt); + Check := False; + end if; + + -- Assigning to named access-to-constant type: + -- This case should have been detected when checking + -- Has_Onwership_Aspect_True (Name (Stmt), "msg"). + + else + raise Program_Error; + end if; + + -- Assigning to composite (deep) type. + + elsif Is_Deep (Ty_St_Name) then + if Ekind (Ty_St_Name) = E_Record_Type then + declare + Elmt : Entity_Id := + First_Component_Or_Discriminant (Ty_St_Name); + + begin + while Present (Elmt) loop + if Is_Anonymous_Access_Type (Etype (Elmt)) or + Ekind (Elmt) = E_General_Access_Type + then + Error_Msg_N ("assignment not allowed, Ownership " + & "Aspect False (Components have " + & "Ownership Aspect False)", Stmt); + Check := False; + exit; + end if; + + Next_Component_Or_Discriminant (Elmt); + end loop; + end; + + -- Record types are always named so this is a move + + if Check then + Current_Checking_Mode := Move; + end if; + end if; + + -- Now handle legality rules of using a borrowed, observed, + -- or moved name as a prefix in an assignment. + + else + if Nkind_In (St_Name, + N_Attribute_Reference, + N_Expanded_Name, + N_Explicit_Dereference, + N_Indexed_Component, + N_Reference, + N_Selected_Component, + N_Slice) + then + + if Is_Access_Type (Etype (Prefix (St_Name))) or + Is_Deep (Etype (Prefix (St_Name))) + then + + -- We set the Check variable to True so that we can + -- Check_Node of the expression and the name first + -- under the assumption of Current_Checking_Mode = + -- Read => nothing to be done for the RHS if the + -- following check on the expression fails, and + -- Current_Checking_Mode := Assign => the name should + -- not be borrowed or observed so that we can use it + -- as a prefix in the target of an assignement. + -- + -- Note that we do not need to check the OA here + -- because we are allowed to read and write "through" + -- an object of OAF (example: traversing a DS). + + Check := True; + end if; + end if; + + if Nkind_In (Expression (Stmt), + N_Attribute_Reference, + N_Expanded_Name, + N_Explicit_Dereference, + N_Indexed_Component, + N_Reference, + N_Selected_Component, + N_Slice) + then + + if Is_Access_Type (Etype (Prefix (Expression (Stmt)))) + or else Is_Deep (Etype (Prefix (Expression (Stmt)))) + then + Current_Checking_Mode := Observe; + Check := True; + end if; + end if; + end if; + + if Check then + Check_Node (Expression (Stmt)); + Current_Checking_Mode := Assign; + Check_Node (St_Name); + end if; + end if; when N_Block_Statement => declare Saved_Env : Perm_Env; - begin -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Analyze declarations and Handled_Statement_Sequences @@ -2684,8 +2406,7 @@ package body Sem_SPARK is -- Restore environment Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); end; when N_Case_Statement => @@ -2695,7 +2416,6 @@ package body Sem_SPARK is -- Accumulator for the different branches New_Env : Perm_Env; - Elmt : Node_Id := First (Alternatives (Stmt)); begin @@ -2705,8 +2425,7 @@ package body Sem_SPARK is -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy, and new aliased. @@ -2715,33 +2434,21 @@ package body Sem_SPARK is Check_Node (Elmt); Next (Elmt); - - Copy_Env (Current_Perm_Env, - New_Env); + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); -- Other alternatives while Present (Elmt) loop - -- Restore environment - Copy_Env (Saved_Env, - Current_Perm_Env); + -- Restore environment + Copy_Env (Saved_Env, Current_Perm_Env); Check_Node (Elmt); - - -- Merge Current_Perm_Env into New_Env - - Merge_Envs (New_Env, - Current_Perm_Env); - Next (Elmt); end loop; - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); - + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); end; @@ -2755,7 +2462,7 @@ package body Sem_SPARK is when N_Loop_Statement => Check_Loop_Statement (Stmt); - -- If deep type expression, then move, else read + -- If deep type expression, then move, else read when N_Simple_Return_Statement => case Nkind (Expression (Stmt)) is @@ -2767,65 +2474,42 @@ package body Sem_SPARK is Subp : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (Stmt)); begin - Return_Parameters (Subp); Return_Globals (Subp); end; when others => if Is_Deep (Etype (Expression (Stmt))) then Current_Checking_Mode := Move; - elsif Is_Shallow (Etype (Expression (Stmt))) then - Current_Checking_Mode := Read; else - raise Program_Error; + Check := False; end if; - Check_Node (Expression (Stmt)); + if Check then + Check_Node (Expression (Stmt)); + end if; end case; when N_Extended_Return_Statement => Check_List (Return_Object_Declarations (Stmt)); Check_Node (Handled_Statement_Sequence (Stmt)); - Return_Declarations (Return_Object_Declarations (Stmt)); - declare -- ??? This does not take into account the fact that a simple -- return inside an extended return statement applies to the -- extended return statement. Subp : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (Stmt)); + begin - Return_Parameters (Subp); Return_Globals (Subp); end; - -- Merge the current_Perm_Env with the accumulator for the given loop + -- Nothing to do when exiting a loop. No merge needed when N_Exit_Statement => - declare - Loop_Name : constant Entity_Id := Loop_Of_Exit (Stmt); - - Saved_Accumulator : constant Perm_Env_Access := - Get (Current_Loops_Accumulators, Loop_Name); - - Environment_Copy : constant Perm_Env_Access := - new Perm_Env; - begin - - Copy_Env (Current_Perm_Env, - Environment_Copy.all); - - if Saved_Accumulator = null then - Set (Current_Loops_Accumulators, - Loop_Name, Environment_Copy); - else - Merge_Envs (Saved_Accumulator.all, - Environment_Copy.all); - end if; - end; + null; - -- Copy environment, run on each branch, and then merge + -- Copy environment, run on each branch when N_If_Statement => declare @@ -2836,13 +2520,11 @@ package body Sem_SPARK is New_Env : Perm_Env; begin - Check_Node (Condition (Stmt)); -- Save environment - Copy_Env (Current_Perm_Env, - Saved_Env); + Copy_Env (Current_Perm_Env, Saved_Env); -- Here we have the original env in saved, current with a fresh -- copy. @@ -2850,34 +2532,25 @@ package body Sem_SPARK is -- THEN PART Check_List (Then_Statements (Stmt)); - - Copy_Env (Current_Perm_Env, - New_Env); - + Copy_Env (Current_Perm_Env, New_Env); Free_Env (Current_Perm_Env); -- Here the new_environment contains curr env after then block -- ELSIF part + declare Elmt : Node_Id; begin Elmt := First (Elsif_Parts (Stmt)); while Present (Elmt) loop - -- Transfer into accumulator, and restore from save - Copy_Env (Saved_Env, - Current_Perm_Env); + -- Transfer into accumulator, and restore from save + Copy_Env (Saved_Env, Current_Perm_Env); Check_Node (Condition (Elmt)); Check_List (Then_Statements (Stmt)); - - -- Merge Current_Perm_Env into New_Env - - Merge_Envs (New_Env, - Current_Perm_Env); - Next (Elmt); end loop; end; @@ -2886,21 +2559,16 @@ package body Sem_SPARK is -- Restore environment before if - Copy_Env (Saved_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); -- Here new environment contains the environment after then and -- current the fresh copy of old one. Check_List (Else_Statements (Stmt)); - Merge_Envs (New_Env, - Current_Perm_Env); - -- CLEANUP - Copy_Env (New_Env, - Current_Perm_Env); + Copy_Env (Saved_Env, Current_Perm_Env); Free_Env (New_Env); Free_Env (Saved_Env); @@ -2956,8 +2624,7 @@ package body Sem_SPARK is -- which means that the association permission is RW. when Function_Call => - return Read_Write; - + return Unrestricted; end case; end Get_Perm; @@ -2980,7 +2647,6 @@ package body Sem_SPARK is => declare P : constant Entity_Id := Entity (N); - C : constant Perm_Tree_Access := Get (Current_Perm_Env, Unique_Entity (P)); @@ -2990,13 +2656,13 @@ package body Sem_SPARK is -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); - if C = null then -- No null possible here, there are no parents for the path. -- This means we are using a global variable without adding -- it in environment with a global aspect. Illegal_Global_Usage (N); + else return (R => Unfolded, Tree_Access => C); end if; @@ -3023,8 +2689,7 @@ package body Sem_SPARK is when N_Selected_Component => declare - C : constant Perm_Or_Tree := - Get_Perm_Or_Tree (Prefix (N)); + C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); begin case C.R is @@ -3035,7 +2700,6 @@ package body Sem_SPARK is when Unfolded => pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object or else Kind (C.Tree_Access) = Record_Component); @@ -3044,30 +2708,32 @@ package body Sem_SPARK is declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - Selected_C : constant Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C.Tree_Access), Selected_Component); begin if Selected_C = null then - return (R => Unfolded, + return (R => Unfolded, Tree_Access => Other_Components (C.Tree_Access)); + else - return (R => Unfolded, + return (R => Unfolded, Tree_Access => Selected_C); end if; end; + elsif Kind (C.Tree_Access) = Entire_Object then - return (R => Folded, Found_Permission => + return (R => Folded, + Found_Permission => Children_Permission (C.Tree_Access)); + else raise Program_Error; end if; end case; end; - -- We get the permission tree of its prefix, and then get either the -- subtree associated with that specific selection, or if we have a -- leaf that folds its children, we take the children's permission @@ -3077,8 +2743,7 @@ package body Sem_SPARK is | N_Slice => declare - C : constant Perm_Or_Tree := - Get_Perm_Or_Tree (Prefix (N)); + C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); begin case C.R is @@ -3089,25 +2754,24 @@ package body Sem_SPARK is when Unfolded => pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object or else Kind (C.Tree_Access) = Array_Component); if Kind (C.Tree_Access) = Array_Component then pragma Assert (Get_Elem (C.Tree_Access) /= null); - return (R => Unfolded, Tree_Access => Get_Elem (C.Tree_Access)); + elsif Kind (C.Tree_Access) = Entire_Object then return (R => Folded, Found_Permission => Children_Permission (C.Tree_Access)); + else raise Program_Error; end if; end case; end; - -- We get the permission tree of its prefix, and then get either the -- subtree associated with that specific selection, or if we have a -- leaf that folds its children, we take the children's permission @@ -3115,8 +2779,7 @@ package body Sem_SPARK is when N_Explicit_Dereference => declare - C : constant Perm_Or_Tree := - Get_Perm_Or_Tree (Prefix (N)); + C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); begin case C.R is @@ -3127,29 +2790,32 @@ package body Sem_SPARK is when Unfolded => pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object or else Kind (C.Tree_Access) = Reference); if Kind (C.Tree_Access) = Reference then if Get_All (C.Tree_Access) = null then + -- Hash_Table_Error + raise Program_Error; + else return (R => Unfolded, Tree_Access => Get_All (C.Tree_Access)); end if; + elsif Kind (C.Tree_Access) = Entire_Object then return (R => Folded, Found_Permission => Children_Permission (C.Tree_Access)); + else raise Program_Error; end if; end case; end; - -- The name contains a function call, hence the given path is always -- new. We do not have to check for anything. @@ -3165,10 +2831,7 @@ package body Sem_SPARK is -- Get_Perm_Tree -- ------------------- - function Get_Perm_Tree - (N : Node_Id) - return Perm_Tree_Access - is + function Get_Perm_Tree (N : Node_Id) return Perm_Tree_Access is begin case Nkind (N) is @@ -3183,7 +2846,6 @@ package body Sem_SPARK is => declare P : constant Node_Id := Entity (N); - C : constant Perm_Tree_Access := Get (Current_Perm_Env, Unique_Entity (P)); @@ -3193,13 +2855,13 @@ package body Sem_SPARK is -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); - if C = null then -- No null possible here, there are no parents for the path. -- This means we are using a global variable without adding -- it in environment with a global aspect. Illegal_Global_Usage (N); + else return C; end if; @@ -3220,11 +2882,11 @@ package body Sem_SPARK is when N_Selected_Component => declare - C : constant Perm_Tree_Access := - Get_Perm_Tree (Prefix (N)); + C : constant Perm_Tree_Access := Get_Perm_Tree (Prefix (N)); begin if C = null then + -- If null then it means we went through a function call return null; @@ -3234,6 +2896,7 @@ package body Sem_SPARK is or else Kind (C) = Record_Component); if Kind (C) = Record_Component then + -- The tree is unfolded. We just return the subtree. declare @@ -3247,9 +2910,9 @@ package body Sem_SPARK is if Selected_C = null then return Other_Components (C); end if; - return Selected_C; end; + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with @@ -3265,7 +2928,6 @@ package body Sem_SPARK is Children_Permission (C); begin - -- We change the current node from Entire_Object to -- Record_Component with same permission and an empty -- hash table as component list. @@ -3288,6 +2950,7 @@ package body Sem_SPARK is -- We fill the hash table with all sons of the record, -- with basic Entire_Objects nodes. + Elem := First_Component_Or_Discriminant (Etype (Prefix (N))); @@ -3301,10 +2964,8 @@ package body Sem_SPARK is Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); - Next_Component_Or_Discriminant (Elem); end loop; - -- we return the tree to the sons, so that the recursion -- can continue. @@ -3318,16 +2979,13 @@ package body Sem_SPARK is begin pragma Assert (Selected_C /= null); - return Selected_C; end; - end; else raise Program_Error; end if; end; - -- We set the permission tree of its prefix, and then we extract from -- the returned pointer the subtree. If folded, we unroll the tree at -- one step. @@ -3336,8 +2994,7 @@ package body Sem_SPARK is | N_Slice => declare - C : constant Perm_Tree_Access := - Get_Perm_Tree (Prefix (N)); + C : constant Perm_Tree_Access := Get_Perm_Tree (Prefix (N)); begin if C = null then @@ -3345,16 +3002,16 @@ package body Sem_SPARK is return null; end if; - pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); if Kind (C) = Array_Component then + -- The tree is unfolded. We just return the elem subtree pragma Assert (Get_Elem (C) = null); - return Get_Elem (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace node with Array_Component. @@ -3377,14 +3034,12 @@ package body Sem_SPARK is Is_Node_Deep => Is_Node_Deep (C), Permission => Permission (C), Get_Elem => Son); - return Get_Elem (C); end; else raise Program_Error; end if; end; - -- We get the permission tree of its prefix, and then get either the -- subtree associated with that specific selection, or if we have a -- leaf that folds its children, we unroll the tree. @@ -3397,6 +3052,7 @@ package body Sem_SPARK is C := Get_Perm_Tree (Prefix (N)); if C = null then + -- If null, we went through a function call return null; @@ -3406,14 +3062,17 @@ package body Sem_SPARK is or else Kind (C) = Reference); if Kind (C) = Reference then + -- The tree is unfolded. We return the elem subtree if Get_All (C) = null then + -- Hash_Table_Error + raise Program_Error; end if; - return Get_All (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with Reference. @@ -3432,19 +3091,16 @@ package body Sem_SPARK is -- Reference with same permission and the previous son. pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), Permission => Permission (C), Get_All => Son); - return Get_All (C); end; else raise Program_Error; end if; end; - -- No permission tree for function calls when N_Function_Call => @@ -3455,245 +3111,6 @@ package body Sem_SPARK is end case; end Get_Perm_Tree; - --------- - -- Glb -- - --------- - - function Glb (P1, P2 : Perm_Kind) return Perm_Kind - is - begin - case P1 is - when No_Access => - return No_Access; - - when Read_Only => - case P2 is - when No_Access - | Write_Only - => - return No_Access; - - when Read_Perm => - return Read_Only; - end case; - - when Write_Only => - case P2 is - when No_Access - | Read_Only - => - return No_Access; - - when Write_Perm => - return Write_Only; - end case; - - when Read_Write => - return P2; - end case; - end Glb; - - --------------- - -- Has_Alias -- - --------------- - - function Has_Alias - (N : Node_Id) - return Boolean - is - function Has_Alias_Deep (Typ : Entity_Id) return Boolean; - function Has_Alias_Deep (Typ : Entity_Id) return Boolean - is - Comp : Node_Id; - begin - - if Is_Array_Type (Typ) - and then Has_Aliased_Components (Typ) - then - return True; - - -- Note: Has_Aliased_Components applies only to arrays - - elsif Is_Record_Type (Typ) then - -- It is possible to have an aliased discriminant, so they must be - -- checked along with normal components. - - Comp := First_Component_Or_Discriminant (Typ); - while Present (Comp) loop - if Is_Aliased (Comp) - or else Is_Aliased (Etype (Comp)) - then - return True; - end if; - - if Has_Alias_Deep (Etype (Comp)) then - return True; - end if; - - Next_Component_Or_Discriminant (Comp); - end loop; - return False; - else - return Is_Aliased (Typ); - end if; - end Has_Alias_Deep; - - begin - case Nkind (N) is - - when N_Identifier - | N_Expanded_Name - => - return Is_Aliased (Entity (N)) or else Has_Alias_Deep (Etype (N)); - - when N_Defining_Identifier => - return Is_Aliased (N) or else Has_Alias_Deep (Etype (N)); - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Has_Alias (Expression (N)); - - when N_Parameter_Specification => - return Has_Alias (Defining_Identifier (N)); - - when N_Selected_Component => - case Nkind (Selector_Name (N)) is - when N_Identifier => - if Is_Aliased (Entity (Selector_Name (N))) then - return True; - end if; - - when others => null; - - end case; - - return Has_Alias (Prefix (N)); - - when N_Indexed_Component - | N_Slice - => - return Has_Alias (Prefix (N)); - - when N_Explicit_Dereference => - return True; - - when N_Function_Call => - return False; - - when N_Attribute_Reference => - if Is_Deep (Etype (Prefix (N))) then - raise Program_Error; - end if; - return False; - - when others => - return False; - end case; - end Has_Alias; - - ------------------------- - -- Has_Array_Component -- - ------------------------- - - function Has_Array_Component (N : Node_Id) return Boolean is - begin - case Nkind (N) is - -- Base identifier. There is no array component here. - - when N_Identifier - | N_Expanded_Name - | N_Defining_Identifier - => - return False; - - -- We check if the expression inside the conversion has an array - -- component. - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Has_Array_Component (Expression (N)); - - -- We check if the prefix has an array component - - when N_Selected_Component => - return Has_Array_Component (Prefix (N)); - - -- We found the array component, return True - - when N_Indexed_Component - | N_Slice - => - return True; - - -- We check if the prefix has an array component - - when N_Explicit_Dereference => - return Has_Array_Component (Prefix (N)); - - when N_Function_Call => - return False; - - when others => - raise Program_Error; - end case; - end Has_Array_Component; - - ---------------------------- - -- Has_Function_Component -- - ---------------------------- - - function Has_Function_Component (N : Node_Id) return Boolean is - begin - case Nkind (N) is - -- Base identifier. There is no function component here. - - when N_Identifier - | N_Expanded_Name - | N_Defining_Identifier - => - return False; - - -- We check if the expression inside the conversion has a function - -- component. - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Has_Function_Component (Expression (N)); - - -- We check if the prefix has a function component - - when N_Selected_Component => - return Has_Function_Component (Prefix (N)); - - -- We check if the prefix has a function component - - when N_Indexed_Component - | N_Slice - => - return Has_Function_Component (Prefix (N)); - - -- We check if the prefix has a function component - - when N_Explicit_Dereference => - return Has_Function_Component (Prefix (N)); - - -- We found the function component, return True - - when N_Function_Call => - return True; - - when others => - raise Program_Error; - - end case; - end Has_Function_Component; - -------- -- Hp -- -------- @@ -3717,29 +3134,17 @@ package body Sem_SPARK is begin Error_Msg_NE ("cannot use global variable & of deep type", N, N); Error_Msg_N ("\without prior declaration in a Global aspect", N); - Errout.Finalize (Last_Call => True); Errout.Output_Messages; Exit_Program (E_Errors); end Illegal_Global_Usage; - -------------------- - -- Is_Borrowed_In -- - -------------------- - - function Is_Borrowed_In (E : Entity_Id) return Boolean is - begin - return Is_Access_Type (Etype (E)) - and then not Is_Access_Constant (Etype (E)); - end Is_Borrowed_In; - ------------- -- Is_Deep -- ------------- function Is_Deep (E : Entity_Id) return Boolean is function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean; - function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean is Decl : Node_Id; Pack_Decl : Node_Id; @@ -3762,9 +3167,9 @@ package body Sem_SPARK is and then Get_SPARK_Mode_From_Annotation (SPARK_Aux_Pragma (Defining_Entity (Pack_Decl))) = Off; end Is_Private_Entity_Mode_Off; + begin pragma Assert (Is_Type (E)); - case Ekind (E) is when Scalar_Kind => return False; @@ -3793,7 +3198,7 @@ package body Sem_SPARK is when E_Record_Type | E_Record_Subtype - => + => declare Elmt : Entity_Id; @@ -3806,7 +3211,6 @@ package body Sem_SPARK is Next_Component_Or_Discriminant (Elmt); end if; end loop; - return False; end; @@ -3821,10 +3225,9 @@ package body Sem_SPARK is end if; end if; - when E_Incomplete_Type => - return True; - - when E_Incomplete_Subtype => + when E_Incomplete_Type + | E_Incomplete_Subtype + => return True; -- No problem with synchronized types @@ -3845,311 +3248,6 @@ package body Sem_SPARK is end Is_Deep; ---------------- - -- Is_Shallow -- - ---------------- - - function Is_Shallow (E : Entity_Id) return Boolean is - begin - pragma Assert (Is_Type (E)); - return not Is_Deep (E); - end Is_Shallow; - - ------------------ - -- Loop_Of_Exit -- - ------------------ - - function Loop_Of_Exit (N : Node_Id) return Entity_Id is - Nam : Node_Id := Name (N); - Stmt : Node_Id := N; - begin - if No (Nam) then - while Present (Stmt) loop - Stmt := Parent (Stmt); - if Nkind (Stmt) = N_Loop_Statement then - Nam := Identifier (Stmt); - exit; - end if; - end loop; - end if; - return Entity (Nam); - end Loop_Of_Exit; - --------- - -- Lub -- - --------- - - function Lub (P1, P2 : Perm_Kind) return Perm_Kind - is - begin - case P1 is - when No_Access => - return P2; - - when Read_Only => - case P2 is - when No_Access - | Read_Only - => - return Read_Only; - - when Write_Perm => - return Read_Write; - end case; - - when Write_Only => - case P2 is - when No_Access - | Write_Only - => - return Write_Only; - - when Read_Perm => - return Read_Write; - end case; - - when Read_Write => - return Read_Write; - end case; - end Lub; - - ---------------- - -- Merge_Envs -- - ---------------- - - procedure Merge_Envs - (Target : in out Perm_Env; - Source : in out Perm_Env) - is - procedure Merge_Trees - (Target : Perm_Tree_Access; - Source : Perm_Tree_Access); - - procedure Merge_Trees - (Target : Perm_Tree_Access; - Source : Perm_Tree_Access) - is - procedure Apply_Glb_Tree - (A : Perm_Tree_Access; - P : Perm_Kind); - - procedure Apply_Glb_Tree - (A : Perm_Tree_Access; - P : Perm_Kind) - is - begin - A.all.Tree.Permission := Glb (Permission (A), P); - - case Kind (A) is - when Entire_Object => - A.all.Tree.Children_Permission := - Glb (Children_Permission (A), P); - - when Reference => - Apply_Glb_Tree (Get_All (A), P); - - when Array_Component => - Apply_Glb_Tree (Get_Elem (A), P); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - begin - Comp := Perm_Tree_Maps.Get_First (Component (A)); - while Comp /= null loop - Apply_Glb_Tree (Comp, P); - Comp := Perm_Tree_Maps.Get_Next (Component (A)); - end loop; - - Apply_Glb_Tree (Other_Components (A), P); - end; - end case; - end Apply_Glb_Tree; - - Perm : constant Perm_Kind := - Glb (Permission (Target), Permission (Source)); - - begin - pragma Assert (Is_Node_Deep (Target) = Is_Node_Deep (Source)); - Target.all.Tree.Permission := Perm; - - case Kind (Target) is - when Entire_Object => - declare - Child_Perm : constant Perm_Kind := - Children_Permission (Target); - - begin - case Kind (Source) is - when Entire_Object => - Target.all.Tree.Children_Permission := - Glb (Child_Perm, Children_Permission (Source)); - - when Reference => - Copy_Tree (Source, Target); - Target.all.Tree.Permission := Perm; - Apply_Glb_Tree (Get_All (Target), Child_Perm); - - when Array_Component => - Copy_Tree (Source, Target); - Target.all.Tree.Permission := Perm; - Apply_Glb_Tree (Get_Elem (Target), Child_Perm); - - when Record_Component => - Copy_Tree (Source, Target); - Target.all.Tree.Permission := Perm; - declare - Comp : Perm_Tree_Access; - - begin - Comp := - Perm_Tree_Maps.Get_First (Component (Target)); - while Comp /= null loop - -- Apply glb tree on every component subtree - - Apply_Glb_Tree (Comp, Child_Perm); - Comp := Perm_Tree_Maps.Get_Next - (Component (Target)); - end loop; - end; - Apply_Glb_Tree (Other_Components (Target), Child_Perm); - - end case; - end; - when Reference => - case Kind (Source) is - when Entire_Object => - Apply_Glb_Tree (Get_All (Target), - Children_Permission (Source)); - - when Reference => - Merge_Trees (Get_All (Target), Get_All (Source)); - - when others => - raise Program_Error; - - end case; - - when Array_Component => - case Kind (Source) is - when Entire_Object => - Apply_Glb_Tree (Get_Elem (Target), - Children_Permission (Source)); - - when Array_Component => - Merge_Trees (Get_Elem (Target), Get_Elem (Source)); - - when others => - raise Program_Error; - - end case; - - when Record_Component => - case Kind (Source) is - when Entire_Object => - declare - Child_Perm : constant Perm_Kind := - Children_Permission (Source); - - Comp : Perm_Tree_Access; - - begin - Comp := Perm_Tree_Maps.Get_First - (Component (Target)); - while Comp /= null loop - -- Apply glb tree on every component subtree - - Apply_Glb_Tree (Comp, Child_Perm); - Comp := - Perm_Tree_Maps.Get_Next (Component (Target)); - end loop; - Apply_Glb_Tree (Other_Components (Target), Child_Perm); - end; - - when Record_Component => - declare - Key_Source : Perm_Tree_Maps.Key_Option; - CompTarget : Perm_Tree_Access; - CompSource : Perm_Tree_Access; - - begin - Key_Source := Perm_Tree_Maps.Get_First_Key - (Component (Source)); - - while Key_Source.Present loop - CompSource := Perm_Tree_Maps.Get - (Component (Source), Key_Source.K); - CompTarget := Perm_Tree_Maps.Get - (Component (Target), Key_Source.K); - - pragma Assert (CompSource /= null); - Merge_Trees (CompTarget, CompSource); - - Key_Source := Perm_Tree_Maps.Get_Next_Key - (Component (Source)); - end loop; - - Merge_Trees (Other_Components (Target), - Other_Components (Source)); - end; - - when others => - raise Program_Error; - - end case; - end case; - end Merge_Trees; - - CompTarget : Perm_Tree_Access; - CompSource : Perm_Tree_Access; - KeyTarget : Perm_Tree_Maps.Key_Option; - - begin - KeyTarget := Get_First_Key (Target); - -- Iterate over every tree of the environment in the target, and merge - -- it with the source if there is such a similar one that exists. If - -- there is none, then skip. - while KeyTarget.Present loop - - CompSource := Get (Source, KeyTarget.K); - CompTarget := Get (Target, KeyTarget.K); - - pragma Assert (CompTarget /= null); - - if CompSource /= null then - Merge_Trees (CompTarget, CompSource); - Remove (Source, KeyTarget.K); - end if; - - KeyTarget := Get_Next_Key (Target); - end loop; - - -- Iterate over every tree of the environment of the source. And merge - -- again. If there is not any tree of the target then just copy the tree - -- from source to target. - declare - KeySource : Perm_Tree_Maps.Key_Option; - begin - KeySource := Get_First_Key (Source); - while KeySource.Present loop - - CompSource := Get (Source, KeySource.K); - CompTarget := Get (Target, KeySource.K); - - if CompTarget = null then - CompTarget := new Perm_Tree_Wrapper'(CompSource.all); - Copy_Tree (CompSource, CompTarget); - Set (Target, KeySource.K, CompTarget); - else - Merge_Trees (CompTarget, CompSource); - end if; - - KeySource := Get_Next_Key (Source); - end loop; - end; - - Free_Env (Source); - end Merge_Envs; - - ---------------- -- Perm_Error -- ---------------- @@ -4202,7 +3300,6 @@ package body Sem_SPARK is raise Program_Error; end case; end Set_Root_Object; - -- Local variables Root : Entity_Id; @@ -4245,8 +3342,8 @@ package body Sem_SPARK is ------------------ procedure Process_Path (N : Node_Id) is - Root : constant Entity_Id := Get_Enclosing_Object (N); - + Root : constant Entity_Id := Get_Enclosing_Object (N); + State_N : Perm_Kind; begin -- We ignore if yielding to synchronized @@ -4256,200 +3353,153 @@ package body Sem_SPARK is return; end if; - -- We ignore shallow unaliased. They are checked in flow analysis, - -- allowing backward compatibility. + State_N := Get_Perm (N); - if Current_Checking_Mode /= Super_Move - and then not Has_Alias (N) - and then Is_Shallow (Etype (N)) - then - return; - end if; - - declare - Perm_N : constant Perm_Kind := Get_Perm (N); + case Current_Checking_Mode is - begin + -- Check permission R, do nothing - case Current_Checking_Mode is - -- Check permission R, do nothing + when Read => - when Read => - if Perm_N not in Read_Perm then - Perm_Error (N, Read_Only, Perm_N); - return; - end if; + -- This condition should be removed when removing the read + -- checking mode. - -- If shallow type no need for RW, only R + return; - when Move => - if Is_Shallow (Etype (N)) then - if Perm_N not in Read_Perm then - Perm_Error (N, Read_Only, Perm_N); - return; - end if; - else - -- Check permission RW if deep + when Move => - if Perm_N /= Read_Write then - Perm_Error (N, Read_Write, Perm_N); - return; - end if; + -- The rhs object in an assignment statement (including copy in + -- and copy back) should be in the Unrestricted or Moved state. + -- Otherwise the move is not allowed. + -- This applies to both stand-alone and composite objects. + -- If the state of the source is Moved, then a warning message + -- is prompt to make the user aware of reading a nullified + -- object. - declare - -- Set permission to W to the path and any of its prefix - - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (N, Move); + if State_N /= Unrestricted and State_N /= Moved then + Perm_Error (N, Unrestricted, State_N); + return; + end if; - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. + -- In the AI, after moving a path nothing to do since the rhs + -- object was in the Unrestricted state and it shall be + -- refreshed to Unrestricted. The object should be nullified + -- however. To avoid moving again a name that has already been + -- moved, in this implementation we set the state of the moved + -- object to "Moved". This shall be used to prompt a warning + -- when manipulating a null pointer and also to implement + -- the no aliasing parameter restriction. + + if State_N = Moved then + Error_Msg_N ("?the source or one of its extensions has" + & " already been moved", N); + end if; - return; - end if; + declare + -- Set state to Borrowed to the path and any of its prefixes - -- Set permissions to - -- No for any extension with more .all - -- W for any deep extension with same number of .all - -- RW for any shallow extension with same number of .all + Tree : constant Perm_Tree_Access := + Set_Perm_Prefixes (N, Moved); - Set_Perm_Extensions_Move (Tree, Etype (N)); - end; - end if; + begin + if Tree = null then - -- Check permission RW + -- We went through a function call, no permission to + -- modify. - when Super_Move => - if Perm_N /= Read_Write then - Perm_Error (N, Read_Write, Perm_N); return; end if; - declare - -- Set permission to No to the path and any of its prefix up - -- to the first .all and then W. - - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (N, Super_Move); + -- Set state to Borrowed on any strict extension of the path - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. - - return; - end if; - - -- Set permissions to No on any strict extension of the path + Set_Perm_Extensions (Tree, Moved); + end; - Set_Perm_Extensions (Tree, No_Access); - end; + when Assign => - -- Check permission W + -- The lhs object in an assignment statement (including copy in + -- and copy back) should be in the Unrestricted state. + -- Otherwise the move is not allowed. + -- This applies to both stand-alone and composite objects. - when Assign => - if Perm_N not in Write_Perm then - Perm_Error (N, Write_Only, Perm_N); - return; - end if; + if State_N /= Unrestricted and State_N /= Moved then + Perm_Error (N, Unrestricted, State_N); + return; + end if; - -- If the tree has an array component, then the permissions do - -- not get modified by the assignment. + -- After assigning to a path nothing to do since it was in the + -- Unrestricted state and it would be refreshed to + -- Unrestricted. - if Has_Array_Component (N) then - return; - end if; + when Borrow => - -- Same if has function component + -- Borrowing is only allowed on Unrestricted objects. - if Has_Function_Component (N) then -- Dead code? - return; - end if; + if State_N /= Unrestricted and State_N /= Moved then + Perm_Error (N, Unrestricted, State_N); + end if; - declare - -- Get the permission tree for the path + if State_N = Moved then + Error_Msg_N ("?the source or one of its extensions has" + & " already been moved", N); + end if; - Tree : constant Perm_Tree_Access := - Get_Perm_Tree (N); + declare + -- Set state to Borrowed to the path and any of its prefixes - Dummy : Perm_Tree_Access; + Tree : constant Perm_Tree_Access := + Set_Perm_Prefixes (N, Borrowed); - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. + begin + if Tree = null then - return; - end if; + -- We went through a function call, no permission to + -- modify. - -- Set permission RW for it and all of its extensions + return; + end if; - Tree.all.Tree.Permission := Read_Write; + -- Set state to Borrowed on any strict extension of the path - Set_Perm_Extensions (Tree, Read_Write); + Set_Perm_Extensions (Tree, Borrowed); + end; - -- Normalize the permission tree + when Observe => + if State_N /= Unrestricted + and then State_N /= Observed + then + Perm_Error (N, Observed, State_N); + end if; - Dummy := Set_Perm_Prefixes_Assign (N); - end; + declare + -- Set permission to Observed on the path and any of its + -- prefixes if it is of a deep type. Actually, some operation + -- like reading from an object of access type is considered as + -- observe while it should not affect the permissions of + -- the considered tree. - -- Check permission W + Tree : Perm_Tree_Access; - when Borrow_Out => - if Perm_N not in Write_Perm then - Perm_Error (N, Write_Only, Perm_N); + begin + if Is_Deep (Etype (N)) then + Tree := Set_Perm_Prefixes (N, Observed); + else + Tree := null; end if; - declare - -- Set permission to No to the path and any of its prefixes - - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (N); - - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. - - return; - end if; - - -- Set permissions to No on any strict extension of the path + if Tree = null then - Set_Perm_Extensions (Tree, No_Access); - end; + -- We went through a function call, no permission to + -- modify. - when Observe => - if Perm_N not in Read_Perm then - Perm_Error (N, Read_Only, Perm_N); - end if; - - if Is_By_Copy_Type (Etype (N)) then return; end if; - declare - -- Set permission to No on the path and any of its prefixes - - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (N); - - begin - if Tree = null then - -- We went through a function call, no permission to - -- modify. + -- Set permissions to No on any strict extension of the path - return; - end if; - - -- Set permissions to No on any strict extension of the path - - Set_Perm_Extensions (Tree, Read_Only); - end; - end case; - end; + Set_Perm_Extensions (Tree, Observed); + end; + end case; end Process_Path; ------------------------- @@ -4457,7 +3507,6 @@ package body Sem_SPARK is ------------------------- procedure Return_Declarations (L : List_Id) is - procedure Return_Declaration (Decl : Node_Id); -- Check correct permissions for every declared object @@ -4468,6 +3517,7 @@ package body Sem_SPARK is procedure Return_Declaration (Decl : Node_Id) is begin if Nkind (Decl) = N_Object_Declaration then + -- Check RW for object declared, unless the object has never been -- initialized. @@ -4477,15 +3527,6 @@ package body Sem_SPARK is return; end if; - -- We ignore shallow unaliased. They are checked in flow analysis, - -- allowing backward compatibility. - - if not Has_Alias (Defining_Identifier (Decl)) - and then Is_Shallow (Etype (Defining_Identifier (Decl))) - then - return; - end if; - declare Elem : constant Perm_Tree_Access := Get (Current_Perm_Env, @@ -4493,22 +3534,23 @@ package body Sem_SPARK is begin if Elem = null then + -- Here we are on a declaration. Hence it should have been -- added in the environment when analyzing this node with -- mode Read. Hence it is not possible to find a null -- pointer here. -- Hash_Table_Error + raise Program_Error; end if; - if Permission (Elem) /= Read_Write then - Perm_Error (Decl, Read_Write, Permission (Elem)); + if Permission (Elem) /= Unrestricted then + Perm_Error (Decl, Unrestricted, Permission (Elem)); end if; end; end if; end Return_Declaration; - -- Local Variables N : Node_Id; @@ -4528,7 +3570,6 @@ package body Sem_SPARK is -------------------- procedure Return_Globals (Subp : Entity_Id) is - procedure Return_Globals_From_List (First_Item : Node_Id; Kind : Formal_Kind); @@ -4557,7 +3598,7 @@ package body Sem_SPARK is if Ekind (E) = E_Abstract_State then null; else - Return_Parameter_Or_Global (E, Kind, Subp, Global_Var => True); + Return_The_Global (E, Kind, Subp); end if; Next_Global (Item); end loop; @@ -4572,7 +3613,9 @@ package body Sem_SPARK is begin case Global_Mode is - when Name_Input | Name_Proof_In => + when Name_Input + | Name_Proof_In + => Kind := E_In_Parameter; when Name_Output => Kind := E_Out_Parameter; @@ -4602,71 +3645,54 @@ package body Sem_SPARK is -- Return_Parameter_Or_Global -- -------------------------------- - procedure Return_Parameter_Or_Global - (Id : Entity_Id; - Mode : Formal_Kind; - Subp : Entity_Id; - Global_Var : Boolean) + procedure Return_The_Global + (Id : Entity_Id; + Mode : Formal_Kind; + Subp : Entity_Id) is Elem : constant Perm_Tree_Access := Get (Current_Perm_Env, Id); pragma Assert (Elem /= null); begin - -- Shallow unaliased parameters and globals cannot introduce pointer - -- aliasing. - - if not Has_Alias (Id) and then Is_Shallow (Etype (Id)) then - null; - -- Observed IN parameters and globals need not return a permission to -- the caller. - elsif Mode = E_In_Parameter - and then (not Is_Borrowed_In (Id) or else Global_Var) + if Mode = E_In_Parameter + + -- Check this for read-only globals. + then - null; + if Permission (Elem) /= Unrestricted + and then Permission (Elem) /= Observed + then + Perm_Error_Subprogram_End + (E => Id, + Subp => Subp, + Perm => Observed, + Found_Perm => Permission (Elem)); + end if; - -- All other parameters and globals should return with mode RW to the - -- caller. + -- All globals of mode out or in/out should return with mode + -- Unrestricted. else - if Permission (Elem) /= Read_Write then + if Permission (Elem) /= Unrestricted then Perm_Error_Subprogram_End (E => Id, Subp => Subp, - Perm => Read_Write, + Perm => Unrestricted, Found_Perm => Permission (Elem)); end if; end if; - end Return_Parameter_Or_Global; - - ----------------------- - -- Return_Parameters -- - ----------------------- - - procedure Return_Parameters (Subp : Entity_Id) is - Formal : Entity_Id; - - begin - Formal := First_Formal (Subp); - while Present (Formal) loop - Return_Parameter_Or_Global (Formal, Ekind (Formal), Subp, False); - Next_Formal (Formal); - end loop; - end Return_Parameters; + end Return_The_Global; ------------------------- -- Set_Perm_Extensions -- ------------------------- - procedure Set_Perm_Extensions - (T : Perm_Tree_Access; - P : Perm_Kind) - is + procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind) is procedure Free_Perm_Tree_Children (T : Perm_Tree_Access); - - procedure Free_Perm_Tree_Children (T : Perm_Tree_Access) - is + procedure Free_Perm_Tree_Children (T : Perm_Tree_Access) is begin case Kind (T) is when Entire_Object => @@ -4709,316 +3735,59 @@ package body Sem_SPARK is end Set_Perm_Extensions; ------------------------------ - -- Set_Perm_Extensions_Move -- + -- Set_Perm_Prefixes -- ------------------------------ - procedure Set_Perm_Extensions_Move - (T : Perm_Tree_Access; - E : Entity_Id) + function Set_Perm_Prefixes + (N : Node_Id; + New_Perm : Perm_Kind) + return Perm_Tree_Access is begin - if not Is_Node_Deep (T) then - -- We are a shallow extension with same number of .all - - Set_Perm_Extensions (T, Read_Write); - return; - end if; - - -- We are a deep extension here (or the moved deep path) - - T.all.Tree.Permission := Write_Only; - - case T.all.Tree.Kind is - -- Unroll the tree depending on the type - - when Entire_Object => - case Ekind (E) is - when Scalar_Kind - | E_String_Literal_Subtype - => - Set_Perm_Extensions (T, No_Access); - - -- No need to unroll here, directly put sons to No_Access - - when Access_Kind => - if Ekind (E) in Access_Subprogram_Kind then - null; - else - Set_Perm_Extensions (T, No_Access); - end if; - - -- No unrolling done, too complicated - - when E_Class_Wide_Subtype - | E_Class_Wide_Type - | E_Incomplete_Type - | E_Incomplete_Subtype - | E_Exception_Type - | E_Task_Type - | E_Task_Subtype - => - Set_Perm_Extensions (T, No_Access); - - -- Expand the tree. Replace the node with Array component. - - when E_Array_Type - | E_Array_Subtype => - declare - Son : Perm_Tree_Access; - - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Read_Write, - Children_Permission => Read_Write)); - - Set_Perm_Extensions_Move (Son, Component_Type (E)); - - -- We change the current node from Entire_Object to - -- Reference with Write_Only and the previous son. - - pragma Assert (Is_Node_Deep (T)); - - T.all.Tree := (Kind => Array_Component, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Write_Only, - Get_Elem => Son); - end; - - -- Unroll, and set permission extensions with component type - - when E_Record_Type - | E_Record_Subtype - | E_Record_Type_With_Private - | E_Record_Subtype_With_Private - | E_Protected_Type - | E_Protected_Subtype - => - declare - -- Expand the tree. Replace the node with - -- Record_Component. - - Elem : Node_Id; - - Son : Perm_Tree_Access; - - begin - -- We change the current node from Entire_Object to - -- Record_Component with same permission and an empty - -- hash table as component list. - - pragma Assert (Is_Node_Deep (T)); - - T.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Write_Only, - Component => Perm_Tree_Maps.Nil, - Other_Components => - new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => True, - Permission => Read_Write, - Children_Permission => Read_Write) - ) - ); - - -- We fill the hash table with all sons of the record, - -- with basic Entire_Objects nodes. - Elem := First_Component_Or_Discriminant (E); - while Present (Elem) loop - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Read_Write, - Children_Permission => Read_Write)); - - Set_Perm_Extensions_Move (Son, Etype (Elem)); - - Perm_Tree_Maps.Set - (T.all.Tree.Component, Elem, Son); - - Next_Component_Or_Discriminant (Elem); - end loop; - end; - - when E_Private_Type - | E_Private_Subtype - | E_Limited_Private_Type - | E_Limited_Private_Subtype - => - Set_Perm_Extensions_Move (T, Underlying_Type (E)); - - when others => - raise Program_Error; - end case; - - when Reference => - -- Now the son does not have the same number of .all - Set_Perm_Extensions (T, No_Access); - - when Array_Component => - Set_Perm_Extensions_Move (Get_Elem (T), Component_Type (E)); - - when Record_Component => - declare - Comp : Perm_Tree_Access; - It : Node_Id; - - begin - It := First_Component_Or_Discriminant (E); - while It /= Empty loop - Comp := Perm_Tree_Maps.Get (Component (T), It); - pragma Assert (Comp /= null); - Set_Perm_Extensions_Move (Comp, It); - It := Next_Component_Or_Discriminant (E); - end loop; - - Set_Perm_Extensions (Other_Components (T), No_Access); - end; - end case; - end Set_Perm_Extensions_Move; - - ------------------------------ - -- Set_Perm_Prefixes_Assign -- - ------------------------------ - - function Set_Perm_Prefixes_Assign (N : Node_Id) return Perm_Tree_Access is - C : constant Perm_Tree_Access := Get_Perm_Tree (N); - - begin - pragma Assert (Current_Checking_Mode = Assign); - - -- The function should not be called if has_function_component - - pragma Assert (C /= null); - - case Kind (C) is - when Entire_Object => - pragma Assert (Children_Permission (C) = Read_Write); - - -- Maroua: Children could have read_only perm. Why Read_Write? - - C.all.Tree.Permission := Read_Write; - - when Reference => - pragma Assert (Get_All (C) /= null); - - C.all.Tree.Permission := - Lub (Permission (C), Permission (Get_All (C))); - - when Array_Component => - pragma Assert (C.all.Tree.Get_Elem /= null); - - -- Given that it is not possible to know which element has been - -- assigned, then the permissions do not get changed in case of - -- Array_Component. - - null; - - when Record_Component => - declare - Comp : Perm_Tree_Access; - Perm : Perm_Kind := Read_Write; - - begin - -- We take the Glb of all the descendants, and then update the - -- permission of the node with it. - - Comp := Perm_Tree_Maps.Get_First (Component (C)); - while Comp /= null loop - Perm := Glb (Perm, Permission (Comp)); - Comp := Perm_Tree_Maps.Get_Next (Component (C)); - end loop; - - Perm := Glb (Perm, Permission (Other_Components (C))); - - C.all.Tree.Permission := Lub (Permission (C), Perm); - end; - end case; case Nkind (N) is - -- Base identifier. End recursion here. - when N_Identifier | N_Expanded_Name | N_Defining_Identifier => - return null; - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Set_Perm_Prefixes_Assign (Expression (N)); - - when N_Parameter_Specification => - raise Program_Error; - - -- Continue recursion on prefix - - when N_Selected_Component => - return Set_Perm_Prefixes_Assign (Prefix (N)); - - -- Continue recursion on prefix - - when N_Indexed_Component - | N_Slice - => - return Set_Perm_Prefixes_Assign (Prefix (N)); - - -- Continue recursion on prefix - - when N_Explicit_Dereference => - return Set_Perm_Prefixes_Assign (Prefix (N)); - - when N_Function_Call => - raise Program_Error; - - when others => - raise Program_Error; - - end case; - end Set_Perm_Prefixes_Assign; - - ---------------------------------- - -- Set_Perm_Prefixes_Borrow_Out -- - ---------------------------------- - - function Set_Perm_Prefixes_Borrow_Out - (N : Node_Id) - return Perm_Tree_Access - is - begin - pragma Assert (Current_Checking_Mode = Borrow_Out); - - case Nkind (N) is - -- Base identifier. Set permission to No. + if Nkind (N) = N_Defining_Identifier + and then New_Perm = Borrowed + then + raise Program_Error; + end if; - when N_Identifier - | N_Expanded_Name - => declare - P : constant Node_Id := Entity (N); + P : Node_Id; + C : Perm_Tree_Access; - C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); + begin + if Nkind (N) = N_Defining_Identifier then + P := N; + else + P := Entity (N); + end if; + C := Get (Current_Perm_Env, Unique_Entity (P)); pragma Assert (C /= null); - begin -- Setting the initialization map to True, so that this -- variable cannot be ignored anymore when looking at end -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); + if New_Perm = Observed + and then C = null + then - C.all.Tree.Permission := No_Access; + -- No null possible here, there are no parents for the path. + -- This means we are using a global variable without adding + -- it in environment with a global aspect. + + Illegal_Global_Usage (N); + end if; + + C.all.Tree.Permission := New_Perm; return C; end; @@ -5026,11 +3795,9 @@ package body Sem_SPARK is | N_Unchecked_Type_Conversion | N_Qualified_Expression => - return Set_Perm_Prefixes_Borrow_Out (Expression (N)); + return Set_Perm_Prefixes (Expression (N), New_Perm); - when N_Parameter_Specification - | N_Defining_Identifier - => + when N_Parameter_Specification => raise Program_Error; -- We set the permission tree of its prefix, and then we extract @@ -5041,19 +3808,16 @@ package body Sem_SPARK is when N_Selected_Component => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (Prefix (N)); + Set_Perm_Prefixes (Prefix (N), New_Perm); begin if C = null then + -- We went through a function call, do nothing return null; end if; - -- The permission of the returned node should be No - - pragma Assert (Permission (C) = No_Access); - pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Record_Component); @@ -5075,11 +3839,10 @@ package body Sem_SPARK is end if; pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := No_Access; - + Selected_C.all.Tree.Permission := New_Perm; return Selected_C; end; + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with @@ -5094,9 +3857,8 @@ package body Sem_SPARK is -- We create the unrolled nodes, that will all have same -- permission than parent. - Son : Perm_Tree_Access; - - ChildrenPerm : constant Perm_Kind := + Son : Perm_Tree_Access; + Children_Perm : constant Perm_Kind := Children_Permission (C); begin @@ -5114,12 +3876,13 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => True, - Permission => ChildrenPerm, - Children_Permission => ChildrenPerm) + Permission => Children_Perm, + Children_Permission => Children_Perm) )); -- We fill the hash table with all sons of the record, -- with basic Entire_Objects nodes. + Elem := First_Component_Or_Discriminant (Etype (Prefix (N))); @@ -5128,23 +3891,19 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => ChildrenPerm, - Children_Permission => ChildrenPerm)); - - Perm_Tree_Maps.Set - (C.all.Tree.Component, Elem, Son); + Permission => Children_Perm, + Children_Permission => Children_Perm)); + Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); Next_Component_Or_Discriminant (Elem); end loop; - - -- Now we set the right field to No_Access, and then we + -- Now we set the right field to Borrowed, and then we -- return the tree to the sons, so that the recursion can -- continue. declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - Selected_C : Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C), Selected_Component); @@ -5155,9 +3914,7 @@ package body Sem_SPARK is end if; pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := No_Access; - + Selected_C.all.Tree.Permission := New_Perm; return Selected_C; end; end; @@ -5176,33 +3933,28 @@ package body Sem_SPARK is => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (Prefix (N)); + Set_Perm_Prefixes (Prefix (N), New_Perm); begin if C = null then + -- We went through a function call, do nothing return null; end if; - -- The permission of the returned node should be either W - -- (because the recursive call sets <= Write_Only) or No - -- (if another path has been moved with 'Access). - - pragma Assert (Permission (C) = No_Access); - pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); if Kind (C) = Array_Component then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. pragma Assert (Get_Elem (C) /= null); - - C.all.Tree.Get_Elem.all.Tree.Permission := No_Access; - + C.all.Tree.Get_Elem.all.Tree.Permission := New_Perm; return Get_Elem (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace node with Array_Component. @@ -5214,18 +3966,21 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Node_Deep (C), - Permission => No_Access, + Permission => New_Perm, Children_Permission => Children_Permission (C))); + -- Children_Permission => Children_Permission (C) + -- this line should be checked maybe New_Perm + -- instead of Children_Permission (C) + -- We change the current node from Entire_Object -- to Array_Component with same permission and the -- previously defined son. C.all.Tree := (Kind => Array_Component, Is_Node_Deep => Is_Node_Deep (C), - Permission => No_Access, + Permission => New_Perm, Get_Elem => Son); - return Get_Elem (C); end; else @@ -5241,30 +3996,28 @@ package body Sem_SPARK is when N_Explicit_Dereference => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow_Out (Prefix (N)); + Set_Perm_Prefixes (Prefix (N), New_Perm); begin if C = null then + -- We went through a function call. Do nothing. return null; end if; - -- The permission of the returned node should be No - - pragma Assert (Permission (C) = No_Access); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Reference); if Kind (C) = Reference then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. pragma Assert (Get_All (C) /= null); - - C.all.Tree.Get_All.all.Tree.Permission := No_Access; - + C.all.Tree.Get_All.all.Tree.Permission := New_Perm; return Get_All (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with Reference. @@ -5276,21 +4029,20 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (N)), - Permission => No_Access, + Permission => New_Perm, Children_Permission => Children_Permission (C))); -- We change the current node from Entire_Object to - -- Reference with No_Access and the previous son. + -- Reference with Borrowed and the previous son. pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), - Permission => No_Access, + Permission => New_Perm, Get_All => Son); - return Get_All (C); end; + else raise Program_Error; end if; @@ -5302,59 +4054,34 @@ package body Sem_SPARK is when others => raise Program_Error; end case; - end Set_Perm_Prefixes_Borrow_Out; + end Set_Perm_Prefixes; - ---------------------------- - -- Set_Perm_Prefixes_Move -- - ---------------------------- + ------------------------------ + -- Set_Perm_Prefixes_Borrow -- + ------------------------------ - function Set_Perm_Prefixes_Move - (N : Node_Id; Mode : Checking_Mode) - return Perm_Tree_Access + function Set_Perm_Prefixes_Borrow (N : Node_Id) return Perm_Tree_Access is begin + pragma Assert (Current_Checking_Mode = Borrow); case Nkind (N) is - -- Base identifier. Set permission to W or No depending on Mode. - when N_Identifier | N_Expanded_Name => declare P : constant Node_Id := Entity (N); C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); + Get (Current_Perm_Env, Unique_Entity (P)); + pragma Assert (C /= null); begin - -- The base tree can be RW (first move from this base path) or - -- W (already some extensions values moved), or even No_Access - -- (extensions moved with 'Access). But it cannot be Read_Only - -- (we get an error). - - if Permission (C) = Read_Only then - raise Unrecoverable_Error; - end if; - -- Setting the initialization map to True, so that this -- variable cannot be ignored anymore when looking at end -- of elaboration of package. Set (Current_Initialization_Map, Unique_Entity (P), True); - - if C = null then - -- No null possible here, there are no parents for the path. - -- This means we are using a global variable without adding - -- it in environment with a global aspect. - - Illegal_Global_Usage (N); - end if; - - if Mode = Super_Move then - C.all.Tree.Permission := No_Access; - else - C.all.Tree.Permission := Glb (Write_Only, Permission (C)); - end if; - + C.all.Tree.Permission := Borrowed; return C; end; @@ -5362,7 +4089,7 @@ package body Sem_SPARK is | N_Unchecked_Type_Conversion | N_Qualified_Expression => - return Set_Perm_Prefixes_Move (Expression (N), Mode); + return Set_Perm_Prefixes_Borrow (Expression (N)); when N_Parameter_Specification | N_Defining_Identifier @@ -5370,79 +4097,51 @@ package body Sem_SPARK is raise Program_Error; -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer our subtree and assign an adequate + -- our subtree from the returned pointer and assign an adequate -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. + -- in one step. when N_Selected_Component => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (Prefix (N), Mode); + Set_Perm_Prefixes_Borrow (Prefix (N)); begin if C = null then + -- We went through a function call, do nothing return null; end if; - -- The permission of the returned node should be either W - -- (because the recursive call sets <= Write_Only) or No - -- (if another path has been moved with 'Access). - - pragma Assert (Permission (C) = No_Access - or else Permission (C) = Write_Only); - - if Mode = Super_Move then - -- The permission of the returned node should be No (thanks - -- to the recursion). - - pragma Assert (Permission (C) = No_Access); - null; - end if; + -- The permission of the returned node should be No + pragma Assert (Permission (C) = Borrowed); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Record_Component); if Kind (C) = Record_Component then + -- The tree is unfolded. We just modify the permission and -- return the record subtree. declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - Selected_C : Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C), Selected_Component); begin if Selected_C = null then - -- If the hash table returns no element, then we fall - -- into the part of Other_Components. - pragma Assert (Is_Tagged_Type (Etype (Prefix (N)))); - Selected_C := Other_Components (C); end if; pragma Assert (Selected_C /= null); - - -- The Selected_C can have permissions: - -- RW : first move in this path - -- W : Already other moves in this path - -- No : Already other moves with 'Access - - pragma Assert (Permission (Selected_C) /= Read_Only); - if Mode = Super_Move then - Selected_C.all.Tree.Permission := No_Access; - else - Selected_C.all.Tree.Permission := - Glb (Write_Only, Permission (Selected_C)); - - end if; - + Selected_C.all.Tree.Permission := Borrowed; return Selected_C; end; + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with @@ -5454,17 +4153,12 @@ package body Sem_SPARK is Hashtbl : Perm_Tree_Maps.Instance; - -- We are in Move or Super_Move mode, hence we can assume - -- that the Children_permission is RW, given that there - -- are no other paths that could have been moved. - - pragma Assert (Children_Permission (C) = Read_Write); - - -- We create the unrolled nodes, that will all have RW - -- permission given that we are in move mode. We will - -- then set the right node to W. + -- We create the unrolled nodes, that will all have same + -- permission than parent. Son : Perm_Tree_Access; + ChildrenPerm : constant Perm_Kind := + Children_Permission (C); begin -- We change the current node from Entire_Object to @@ -5472,21 +4166,22 @@ package body Sem_SPARK is -- hash table as component list. C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Hashtbl, + (Kind => Record_Component, + Is_Node_Deep => Is_Node_Deep (C), + Permission => Permission (C), + Component => Hashtbl, Other_Components => new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, Is_Node_Deep => True, - Permission => Read_Write, - Children_Permission => Read_Write) + Permission => ChildrenPerm, + Children_Permission => ChildrenPerm) )); -- We fill the hash table with all sons of the record, -- with basic Entire_Objects nodes. + Elem := First_Component_Or_Discriminant (Etype (Prefix (N))); @@ -5495,26 +4190,21 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Read_Write, - Children_Permission => Read_Write)); - - Perm_Tree_Maps.Set - (C.all.Tree.Component, Elem, Son); - + Permission => ChildrenPerm, + Children_Permission => ChildrenPerm)); + Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); Next_Component_Or_Discriminant (Elem); end loop; - -- Now we set the right field to Write_Only or No_Access - -- depending on mode, and then we return the tree to the - -- sons, so that the recursion can continue. + -- Now we set the right field to Borrowed, and then we + -- return the tree to the sons, so that the recursion can + -- continue. declare Selected_Component : constant Entity_Id := Entity (Selector_Name (N)); - - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); + Selected_C : Perm_Tree_Access := Perm_Tree_Maps.Get + (Component (C), Selected_Component); begin if Selected_C = null then @@ -5522,22 +4212,11 @@ package body Sem_SPARK is end if; pragma Assert (Selected_C /= null); - - -- Given that this is a newly created Select_C, we can - -- safely assume that its permission is Read_Write. - - pragma Assert (Permission (Selected_C) = - Read_Write); - - if Mode = Super_Move then - Selected_C.all.Tree.Permission := No_Access; - else - Selected_C.all.Tree.Permission := Write_Only; - end if; - + Selected_C.all.Tree.Permission := Borrowed; return Selected_C; end; end; + else raise Program_Error; end if; @@ -5545,72 +4224,41 @@ package body Sem_SPARK is -- We set the permission tree of its prefix, and then we extract -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. + -- permission to it, if unfolded. If folded, we unroll the tree in + -- one step. when N_Indexed_Component | N_Slice => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (Prefix (N), Mode); + Set_Perm_Prefixes_Borrow (Prefix (N)); begin if C = null then + -- We went through a function call, do nothing return null; end if; - -- The permission of the returned node should be either - -- W (because the recursive call sets <= Write_Only) - -- or No (if another path has been moved with 'Access) - - if Mode = Super_Move then - pragma Assert (Permission (C) = No_Access); - null; - else - pragma Assert (Permission (C) = Write_Only - or else Permission (C) = No_Access); - null; - end if; - + pragma Assert (Permission (C) = Borrowed); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); if Kind (C) = Array_Component then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. - if Get_Elem (C) = null then - -- Hash_Table_Error - raise Program_Error; - end if; - - -- The Get_Elem can have permissions : - -- RW : first move in this path - -- W : Already other moves in this path - -- No : Already other moves with 'Access - - pragma Assert (Permission (Get_Elem (C)) /= Read_Only); - - if Mode = Super_Move then - C.all.Tree.Get_Elem.all.Tree.Permission := No_Access; - else - C.all.Tree.Get_Elem.all.Tree.Permission := - Glb (Write_Only, Permission (Get_Elem (C))); - end if; - + pragma Assert (Get_Elem (C) /= null); + C.all.Tree.Get_Elem.all.Tree.Permission := Borrowed; return Get_Elem (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace node with Array_Component. - -- We are in move mode, hence we can assume that the - -- Children_permission is RW. - - pragma Assert (Children_Permission (C) = Read_Write); - Son : Perm_Tree_Access; begin @@ -5618,14 +4266,8 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Node_Deep (C), - Permission => Read_Write, - Children_Permission => Read_Write)); - - if Mode = Super_Move then - Son.all.Tree.Permission := No_Access; - else - Son.all.Tree.Permission := Write_Only; - end if; + Permission => Borrowed, + Children_Permission => Children_Permission (C))); -- We change the current node from Entire_Object -- to Array_Component with same permission and the @@ -5633,11 +4275,11 @@ package body Sem_SPARK is C.all.Tree := (Kind => Array_Component, Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), + Permission => Borrowed, Get_Elem => Son); - return Get_Elem (C); end; + else raise Program_Error; end if; @@ -5651,415 +4293,56 @@ package body Sem_SPARK is when N_Explicit_Dereference => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Move (Prefix (N), Move); + Set_Perm_Prefixes_Borrow (Prefix (N)); begin if C = null then - -- We went through a function call: do nothing - - return null; - end if; - - -- The permission of the returned node should be only - -- W (because the recursive call sets <= Write_Only) - -- No is NOT POSSIBLE here - - pragma Assert (Permission (C) = Write_Only); - - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Reference); - - if Kind (C) = Reference then - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. - - if Get_All (C) = null then - -- Hash_Table_Error - raise Program_Error; - end if; - - -- The Get_All can have permissions : - -- RW : first move in this path - -- W : Already other moves in this path - -- No : Already other moves with 'Access - - pragma Assert (Permission (Get_All (C)) /= Read_Only); - - if Mode = Super_Move then - C.all.Tree.Get_All.all.Tree.Permission := No_Access; - else - Get_All (C).all.Tree.Permission := - Glb (Write_Only, Permission (Get_All (C))); - end if; - return Get_All (C); - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with Reference. - - -- We are in Move or Super_Move mode, hence we can assume - -- that the Children_permission is RW. - - pragma Assert (Children_Permission (C) = Read_Write); - - Son : Perm_Tree_Access; - - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (N)), - Permission => Read_Write, - Children_Permission => Read_Write)); - - if Mode = Super_Move then - Son.all.Tree.Permission := No_Access; - else - Son.all.Tree.Permission := Write_Only; - end if; - - -- We change the current node from Entire_Object to - -- Reference with Write_Only and the previous son. - - pragma Assert (Is_Node_Deep (C)); - - C.all.Tree := (Kind => Reference, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Write_Only, - -- Write_only is equal to C.Permission - Get_All => Son); - - return Get_All (C); - end; - else - raise Program_Error; - end if; - end; - - when N_Function_Call => - return null; - - when others => - raise Program_Error; - end case; - - end Set_Perm_Prefixes_Move; - - ------------------------------- - -- Set_Perm_Prefixes_Observe -- - ------------------------------- - - function Set_Perm_Prefixes_Observe - (N : Node_Id) - return Perm_Tree_Access - is - begin - pragma Assert (Current_Checking_Mode = Observe); - - case Nkind (N) is - -- Base identifier. Set permission to R. - - when N_Identifier - | N_Expanded_Name - | N_Defining_Identifier - => - declare - P : Node_Id; - C : Perm_Tree_Access; - - begin - if Nkind (N) = N_Defining_Identifier then - P := N; - else - P := Entity (N); - end if; - - C := Get (Current_Perm_Env, Unique_Entity (P)); - -- Setting the initialization map to True, so that this - -- variable cannot be ignored anymore when looking at end - -- of elaboration of package. - - Set (Current_Initialization_Map, Unique_Entity (P), True); - - if C = null then - -- No null possible here, there are no parents for the path. - -- This means we are using a global variable without adding - -- it in environment with a global aspect. - - Illegal_Global_Usage (N); - end if; - - C.all.Tree.Permission := Glb (Read_Only, Permission (C)); - - return C; - end; - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Set_Perm_Prefixes_Observe (Expression (N)); - - when N_Parameter_Specification => - raise Program_Error; - - -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer our subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. - - when N_Selected_Component => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (Prefix (N)); - - begin - if C = null then - -- We went through a function call, do nothing - - return null; - end if; - - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Record_Component); - - if Kind (C) = Record_Component then - -- The tree is unfolded. We just modify the permission and - -- return the record subtree. We put the permission to the - -- glb of read_only and its current permission, to consider - -- the case of observing x.y while x.z has been moved. Then - -- x should be No_Access. - - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); - - begin - if Selected_C = null then - Selected_C := Other_Components (C); - end if; - - pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := - Glb (Read_Only, Permission (Selected_C)); - - return Selected_C; - end; - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with - -- Record_Component. - - Elem : Node_Id; - - -- Create an empty hash table - - Hashtbl : Perm_Tree_Maps.Instance; - - -- We create the unrolled nodes, that will all have RW - -- permission given that we are in move mode. We will - -- then set the right node to W. - - Son : Perm_Tree_Access; - - Child_Perm : constant Perm_Kind := - Children_Permission (C); - - begin - -- We change the current node from Entire_Object to - -- Record_Component with same permission and an empty - -- hash table as component list. - C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Hashtbl, - Other_Components => - new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => True, - Permission => Child_Perm, - Children_Permission => Child_Perm) - )); - - -- We fill the hash table with all sons of the record, - -- with basic Entire_Objects nodes. - Elem := First_Component_Or_Discriminant - (Etype (Prefix (N))); - - while Present (Elem) loop - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Child_Perm, - Children_Permission => Child_Perm)); - - Perm_Tree_Maps.Set - (C.all.Tree.Component, Elem, Son); - - Next_Component_Or_Discriminant (Elem); - end loop; - - -- Now we set the right field to Read_Only. and then we - -- return the tree to the sons, so that the recursion can - -- continue. - - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); - - begin - if Selected_C = null then - Selected_C := Other_Components (C); - end if; - - pragma Assert (Selected_C /= null); - - Selected_C.all.Tree.Permission := - Glb (Read_Only, Child_Perm); - - return Selected_C; - end; - end; - else - raise Program_Error; - end if; - end; - - -- We set the permission tree of its prefix, and then we extract from - -- the returned pointer the subtree and assign an adequate permission - -- to it, if unfolded. If folded, we unroll the tree at one step. - - when N_Indexed_Component - | N_Slice - => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (Prefix (N)); - - begin - if C = null then - -- We went through a function call, do nothing + -- We went through a function call. Do nothing. return null; end if; - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Array_Component); - - if Kind (C) = Array_Component then - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. - - pragma Assert (Get_Elem (C) /= null); - - C.all.Tree.Get_Elem.all.Tree.Permission := - Glb (Read_Only, Permission (Get_Elem (C))); - - return Get_Elem (C); - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace node with Array_Component. - - Son : Perm_Tree_Access; - - Child_Perm : constant Perm_Kind := - Glb (Read_Only, Children_Permission (C)); - - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Child_Perm, - Children_Permission => Child_Perm)); - - -- We change the current node from Entire_Object - -- to Array_Component with same permission and the - -- previously defined son. - - C.all.Tree := (Kind => Array_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Child_Perm, - Get_Elem => Son); - - return Get_Elem (C); - end; - - else - raise Program_Error; - end if; - end; - - -- We set the permission tree of its prefix, and then we extract from - -- the returned pointer the subtree and assign an adequate permission - -- to it, if unfolded. If folded, we unroll the tree at one step. - - when N_Explicit_Dereference => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Observe (Prefix (N)); - - begin - if C = null then - -- We went through a function call, do nothing - - return null; - end if; + -- The permission of the returned node should be No + pragma Assert (Permission (C) = Borrowed); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Reference); if Kind (C) = Reference then + -- The tree is unfolded. We just modify the permission and -- return the elem subtree. pragma Assert (Get_All (C) /= null); - - C.all.Tree.Get_All.all.Tree.Permission := - Glb (Read_Only, Permission (Get_All (C))); - + C.all.Tree.Get_All.all.Tree.Permission := Borrowed; return Get_All (C); + elsif Kind (C) = Entire_Object then declare -- Expand the tree. Replace the node with Reference. Son : Perm_Tree_Access; - Child_Perm : constant Perm_Kind := - Glb (Read_Only, Children_Permission (C)); - begin Son := new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (N)), - Permission => Child_Perm, - Children_Permission => Child_Perm)); + Permission => Borrowed, + Children_Permission => Children_Permission (C))); -- We change the current node from Entire_Object to - -- Reference with Write_Only and the previous son. + -- Reference with Borrowed and the previous son. pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), - Permission => Child_Perm, + Permission => Borrowed, Get_All => Son); - return Get_All (C); end; + else raise Program_Error; end if; @@ -6070,16 +4353,14 @@ package body Sem_SPARK is when others => raise Program_Error; - end case; - end Set_Perm_Prefixes_Observe; + end Set_Perm_Prefixes_Borrow; ------------------- -- Setup_Globals -- ------------------- procedure Setup_Globals (Subp : Entity_Id) is - procedure Setup_Globals_From_List (First_Item : Node_Id; Kind : Formal_Kind); @@ -6123,12 +4404,17 @@ package body Sem_SPARK is begin case Global_Mode is - when Name_Input | Name_Proof_In => + when Name_Input + | Name_Proof_In + => Kind := E_In_Parameter; + when Name_Output => Kind := E_Out_Parameter; + when Name_In_Out => Kind := E_In_Out_Parameter; + when others => raise Program_Error; end case; @@ -6165,36 +4451,57 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (Id)), - Permission => Read_Write, - Children_Permission => Read_Write)); + Permission => Unrestricted, + Children_Permission => Unrestricted)); case Mode is - when E_In_Parameter => - -- Borrowed IN: RW for everybody + -- All out and in out parameters are considered to be unrestricted. + -- They are whether borrowed or moved. Ada Rules would restrict + -- these permissions further. For example an in parameter cannot + -- be written. - if Is_Borrowed_In (Id) and not Global_Var then - Elem.all.Tree.Permission := Read_Write; - Elem.all.Tree.Children_Permission := Read_Write; + -- In the following we deal with in parameters that can be observed. + -- We only consider the observing cases. - -- Observed IN: R for everybody + when E_In_Parameter => - else - Elem.all.Tree.Permission := Read_Only; - Elem.all.Tree.Children_Permission := Read_Only; - end if; + -- Handling global variables as in parameters here + -- Remove the following condition once decided how globals + -- should be considered. + + if not Global_Var then + if (Is_Access_Type (Etype (Id)) + and then Is_Access_Constant (Etype (Id)) + and then Is_Anonymous_Access_Type (Etype (Id))) + or else + (not Is_Access_Type (Etype (Id)) + and then Is_Deep (Etype (Id)) + and then not Is_Anonymous_Access_Type (Etype (Id))) + then + Elem.all.Tree.Permission := Observed; + Elem.all.Tree.Children_Permission := Observed; - -- OUT: borrow, but callee has W only + else + Elem.all.Tree.Permission := Unrestricted; + Elem.all.Tree.Children_Permission := Unrestricted; + end if; - when E_Out_Parameter => - Elem.all.Tree.Permission := Write_Only; - Elem.all.Tree.Children_Permission := Write_Only; + else + Elem.all.Tree.Permission := Observed; + Elem.all.Tree.Children_Permission := Observed; + end if; - -- IN OUT: borrow and callee has RW + -- When out or in/out formal or global parameters, we set them to + -- the Unrestricted state. "We want to be able to assume that all + -- relevant writable globals are unrestricted when a subprogram + -- starts executing". Formal parameters of mode out or in/out + -- are whether Borrowers or the targets of a move operation: + -- they start theirs lives in the subprogram as Unrestricted. - when E_In_Out_Parameter => - Elem.all.Tree.Permission := Read_Write; - Elem.all.Tree.Children_Permission := Read_Write; + when others => + Elem.all.Tree.Permission := Unrestricted; + Elem.all.Tree.Children_Permission := Unrestricted; end case; Set (Current_Perm_Env, Id, Elem); @@ -6204,9 +4511,7 @@ package body Sem_SPARK is -- Setup_Parameters -- ---------------------- - procedure Setup_Parameters (Subp : Entity_Id) is - Formal : Entity_Id; - + procedure Setup_Parameters (Subp : Entity_Id) is Formal : Entity_Id; begin Formal := First_Formal (Subp); while Present (Formal) loop @@ -6216,4 +4521,85 @@ package body Sem_SPARK is end loop; end Setup_Parameters; + ------------------------------- + -- Has_Ownership_Aspect_True -- + ------------------------------- + + function Has_Ownership_Aspect_True + (N : Entity_Id; + Msg : String) + return Boolean + is + begin + case Ekind (Etype (N)) is + when Access_Kind => + if Ekind (Etype (N)) = E_General_Access_Type then + Error_Msg_NE (Msg & " & not allowed " & + "(Named General Access type)", N, N); + return False; + + else + return True; + end if; + + when E_Array_Type + | E_Array_Subtype + => + declare + Com_Ty : constant Node_Id := Component_Type (Etype (N)); + Ret : Boolean := Has_Ownership_Aspect_True (Com_Ty, ""); + + begin + if Nkind (Parent (N)) = N_Full_Type_Declaration and + Is_Anonymous_Access_Type (Com_Ty) + then + Ret := False; + end if; + + if not Ret then + Error_Msg_NE (Msg & " & not allowed " + & "(Components of Named General Access type or" + & " Anonymous type)", N, N); + end if; + return Ret; + end; + + -- ??? What about hidden components + + when E_Record_Type + | E_Record_Subtype + => + declare + Elmt : Entity_Id; + Elmt_T_Perm : Boolean := True; + Elmt_Perm, Elmt_Anonym : Boolean; + + begin + Elmt := First_Component_Or_Discriminant (Etype (N)); + while Present (Elmt) loop + Elmt_Perm := Has_Ownership_Aspect_True (Elmt, + "type of component"); + Elmt_Anonym := Is_Anonymous_Access_Type (Etype (Elmt)); + if Elmt_Anonym then + Error_Msg_NE + ("type of component & not allowed" + & " (Components of Anonymous type)", Elmt, Elmt); + end if; + Elmt_T_Perm := Elmt_T_Perm and Elmt_Perm and not Elmt_Anonym; + Next_Component_Or_Discriminant (Elmt); + end loop; + if not Elmt_T_Perm then + Error_Msg_NE + (Msg & " & not allowed (One or " + & "more components have Ownership Aspect False)", + N, N); + end if; + return Elmt_T_Perm; + end; + + when others => + return True; + end case; + + end Has_Ownership_Aspect_True; end Sem_SPARK; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index bfa2b4f..2b31cf7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20997,7 +20997,7 @@ package body Sem_Util is Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Character; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Prefix : Character := ' ') return Entity_Id is N : constant Entity_Id := @@ -24039,6 +24039,14 @@ package body Sem_Util is and then Outer = Protected_Body_Subprogram (Curr) then return True; + + -- Outside of its scope, a synchronized type may just be private + + elsif Is_Private_Type (Curr) + and then Present (Full_View (Curr)) + and then Is_Concurrent_Type (Full_View (Curr)) + then + return Scope_Within (Full_View (Curr), Outer); end if; end loop; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index aec3644..74d670d 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2326,7 +2326,7 @@ package Sem_Util is Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Character; - Suffix_Index : Nat := 0; + Suffix_Index : Int := 0; Prefix : Character := ' ') return Entity_Id; -- This function creates an N_Defining_Identifier node for an internal -- created entity, such as an implicit type or subtype, or a record diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index 0340ee6..4c717c5 100755 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -917,6 +917,9 @@ begin Get_Back_End_Config_File; begin if Back_End_Config_File /= null then + pragma Gnat_Annotate + (CodePeer, Intentional, "test always false", + "some variant body will return non null"); Read_Target_Dependent_Values (Back_End_Config_File.all); -- Otherwise we get all values from the back end directly diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index ae29661..1359c94 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4674,7 +4674,7 @@ package Sinfo is -------------------------- -- 4.5.7 If Expression -- - ---------------------------- + -------------------------- -- IF_EXPRESSION ::= -- if CONDITION then DEPENDENT_EXPRESSION diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index f19629c..ab7eecb 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3540,15 +3540,14 @@ package body Sprint is -- where the aspects are printed inside the package specification. if Has_Aspects (Node) - and then not Nkind_In (Node, N_Package_Declaration, - N_Generic_Package_Declaration) + and then not Nkind_In (Node, N_Generic_Package_Declaration, + N_Package_Declaration) + and then not Is_Empty_List (Aspect_Specifications (Node)) then Sprint_Aspect_Specifications (Node, Semicolon => True); end if; - if Nkind (Node) in N_Subexpr - and then Do_Range_Check (Node) - then + if Nkind (Node) in N_Subexpr and then Do_Range_Check (Node) then Write_Str ("}"); end if; diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 7025f57..bd2cdd0 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -1107,14 +1107,6 @@ __gnat_setup_winsize (void *desc, int rows, int columns) #include <errno.h> #include <stdio.h> #include <stdlib.h> - -/* On some system termio is either absent or including it will disable termios - (HP-UX) */ -#if !defined (__hpux__) && !defined (BSD) && !defined (__APPLE__) \ - && !defined (__rtems__) && !defined (__QNXNTO__) -# include <termio.h> -#endif - #include <sys/ioctl.h> #include <termios.h> #include <fcntl.h> @@ -1130,7 +1122,6 @@ __gnat_setup_winsize (void *desc, int rows, int columns) # include <sys/signal.h> #endif #if defined (__hpux__) -# include <sys/termio.h> # include <sys/stropts.h> #endif diff --git a/gcc/ada/vxlink-bind.adb b/gcc/ada/vxlink-bind.adb new file mode 100644 index 0000000..9f45694 --- /dev/null +++ b/gcc/ada/vxlink-bind.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . B I N D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, 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. 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +with Ada.Text_IO; use Ada.Text_IO; +with Ada.IO_Exceptions; +with Ada.Strings.Fixed; + +with GNAT.Regpat; use GNAT.Regpat; + +package body VxLink.Bind is + + function Split_Lines (S : String) return Strings_List.Vector; + + function Split (S : String; C : Character) return Strings_List.Vector; + + function Parse_Nm_Output (S : String) return Symbol_Sets.Set; + + procedure Emit_Module_Dtor + (FP : File_Type); + + procedure Emit_CDtor + (FP : File_Type; + Var : String; + Set : Symbol_Sets.Set); + + ----------------- + -- Split_Lines -- + ----------------- + + function Split_Lines (S : String) return Strings_List.Vector + is + Last : Natural := S'First; + Ret : Strings_List.Vector; + begin + for J in S'Range loop + if S (J) = ASCII.CR + and then J < S'Last + and then S (J + 1) = ASCII.LF + then + Ret.Append (S (Last .. J - 1)); + Last := J + 2; + elsif S (J) = ASCII.LF then + Ret.Append (S (Last .. J - 1)); + Last := J + 1; + end if; + end loop; + + if Last <= S'Last then + Ret.Append (S (Last .. S'Last)); + end if; + + return Ret; + end Split_Lines; + + ----------- + -- Split -- + ----------- + + function Split (S : String; C : Character) return Strings_List.Vector + is + Last : Natural := S'First; + Ret : Strings_List.Vector; + begin + for J in S'Range loop + if S (J) = C then + if J > Last then + Ret.Append (S (Last .. J - 1)); + end if; + + Last := J + 1; + end if; + end loop; + + if Last <= S'Last then + Ret.Append (S (Last .. S'Last)); + end if; + + return Ret; + end Split; + + --------------------- + -- Parse_Nm_Output -- + --------------------- + + function Parse_Nm_Output (S : String) return Symbol_Sets.Set + is + Nm_Regexp : constant Pattern_Matcher := + Compile ("^[0-9A-Za-z]* ([a-zA-Z]) (.*)$"); + type CDTor_Type is + (CTOR_Diab, + CTOR_Gcc, + DTOR_Diab, + DTOR_Gcc); + subtype CTOR_Type is CDTor_Type range CTOR_Diab .. CTOR_Gcc; + CTOR_DIAB_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?STI__*([0-9]+)_"); + CTOR_GCC_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?GLOBAL_.I._*([0-9]+)_"); + DTOR_DIAB_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?STD__*([0-9]+)_"); + DTOR_GCC_Regexp : aliased constant Pattern_Matcher := + Compile ("^__?GLOBAL_.D._*([0-9]+)_"); + type Regexp_Access is access constant Pattern_Matcher; + CDTor_Regexps : constant array (CDTor_Type) of Regexp_Access := + (CTOR_Diab => CTOR_DIAB_Regexp'Access, + CTOR_Gcc => CTOR_GCC_Regexp'Access, + DTOR_Diab => DTOR_DIAB_Regexp'Access, + DTOR_Gcc => DTOR_GCC_Regexp'Access); + Result : Symbol_Sets.Set; + + begin + for Line of Split_Lines (S) loop + declare + Sym : Symbol; + Nm_Grps : Match_Array (0 .. 2); + Ctor_Grps : Match_Array (0 .. 1); + begin + Match (Nm_Regexp, Line, Nm_Grps); + + if Nm_Grps (0) /= No_Match then + declare + Sym_Type : constant Character := + Line (Nm_Grps (1).First); + Sym_Name : constant String := + Line (Nm_Grps (2).First .. Nm_Grps (2).Last); + begin + Sym := + (Name => To_Unbounded_String (Sym_Name), + Cat => Sym_Type, + Internal => False, + Kind => Sym_Other, + Priority => -1); + + for J in CDTor_Regexps'Range loop + Match (CDTor_Regexps (J).all, Sym_Name, Ctor_Grps); + + if Ctor_Grps (0) /= No_Match then + if J in CTOR_Type then + Sym.Kind := Sym_Ctor; + else + Sym.Kind := Sym_Dtor; + end if; + + Sym.Priority := Integer'Value + (Line (Ctor_Grps (1).First .. Ctor_Grps (1).Last)); + + exit; + end if; + end loop; + + Result.Include (Sym); + end; + end if; + end; + end loop; + + return Result; + end Parse_Nm_Output; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Binder : out VxLink_Binder; + Object_File : String) + is + Args : Arguments_List; + Module_Dtor_Not_Needed : Boolean := False; + Module_Dtor_Needed : Boolean := False; + + begin + Args.Append (Nm); + Args.Append (Object_File); + + declare + Output : constant String := Run (Args); + Symbols : Symbol_Sets.Set; + begin + if Is_Error_State then + return; + end if; + + Symbols := Parse_Nm_Output (Output); + + for Sym of Symbols loop + if Sym.Kind = Sym_Ctor then + Binder.Constructors.Insert (Sym); + elsif Sym.Kind = Sym_Dtor then + Binder.Destructors.Insert (Sym); + elsif Match ("_?__.*_atexit$", To_String (Sym.Name)) then + if Sym.Cat = 'T' then + Module_Dtor_Not_Needed := True; + elsif Sym.Cat = 'U' then + Module_Dtor_Needed := True; + end if; + end if; + end loop; + + Binder.Module_Dtor_Needed := + not Module_Dtor_Not_Needed and then Module_Dtor_Needed; + end; + end Initialize; + + -------------------- + -- Parse_Tag_File -- + -------------------- + + procedure Parse_Tag_File + (Binder : in out VxLink_Binder; + File : String) + is + FP : Ada.Text_IO.File_Type; + + begin + Open + (FP, + Mode => In_File, + Name => File); + loop + declare + Line : constant String := + Ada.Strings.Fixed.Trim + (Get_Line (FP), Ada.Strings.Both); + Tokens : Strings_List.Vector; + + begin + if Line'Length = 0 then + -- Skip empty lines + null; + + elsif Line (Line'First) = '#' then + -- Skip comment + null; + + else + Tokens := Split (Line, ' '); + if Tokens.First_Element = "section" then + -- Sections are not used for tags, only when building + -- kernels. So skip for now + null; + else + Binder.Tags_List.Append (Line); + end if; + end if; + end; + end loop; + + exception + when Ada.IO_Exceptions.End_Error => + Close (FP); + when others => + Log_Error ("Cannot open file " & File & + ". DKM tags won't be generated"); + end Parse_Tag_File; + + ---------------------- + -- Emit_Module_Dtor -- + ---------------------- + + procedure Emit_Module_Dtor + (FP : File_Type) + is + Dtor_Name : constant String := "_GLOBAL__D_65536_0_cxa_finalize"; + begin + Put_Line (FP, "extern void __cxa_finalize(void *);"); + Put_Line (FP, "static void " & Dtor_Name & "()"); + Put_Line (FP, "{"); + Put_Line (FP, " __cxa_finalize(&__dso_handle);"); + Put_Line (FP, "}"); + Put_Line (FP, ""); + end Emit_Module_Dtor; + + ---------------- + -- Emit_CDtor -- + ---------------- + + procedure Emit_CDtor + (FP : File_Type; + Var : String; + Set : Symbol_Sets.Set) + is + begin + for Sym of Set loop + if not Sym.Internal then + Put_Line (FP, "extern void " & To_String (Sym.Name) & "();"); + end if; + end loop; + + New_Line (FP); + + Put_Line (FP, "extern void (*" & Var & "[])();"); + Put_Line (FP, "void (*" & Var & "[])() ="); + Put_Line (FP, " {"); + for Sym of Set loop + Put_Line (FP, " " & To_String (Sym.Name) & ","); + end loop; + Put_Line (FP, " 0};"); + New_Line (FP); + end Emit_CDtor; + + --------------- + -- Emit_CTDT -- + --------------- + + procedure Emit_CTDT + (Binder : in out VxLink_Binder; + Namespace : String) + is + FP : Ada.Text_IO.File_Type; + CDtor_File : constant String := Namespace & "-cdtor.c"; + begin + Binder.CTDT_File := To_Unbounded_String (CDtor_File); + Create + (File => FP, + Name => CDtor_File); + Put_Line (FP, "#if defined(_HAVE_TOOL_XTORS)"); + Put_Line (FP, "#include <vxWorks.h>"); + if Binder.Module_Dtor_Needed then + Put_Line (FP, "#define _WRS_NEED_CALL_CXA_FINALIZE"); + end if; + Put_Line (FP, "#include TOOL_HEADER (toolXtors.h)"); + Put_Line (FP, "#else"); + Put_Line (FP, ""); + + if Binder.Module_Dtor_Needed then + Emit_Module_Dtor (FP); + end if; + + Emit_CDtor (FP, "_ctors", Binder.Constructors); + Emit_CDtor (FP, "_dtors", Binder.Destructors); + + Put_Line (FP, "#endif"); + + if not Binder.Tags_List.Is_Empty then + New_Line (FP); + Put_Line (FP, "/* build variables */"); + Put_Line (FP, "__asm("" .section \"".wrs_build_vars\"",\""a\"""");"); + for Tag of Binder.Tags_List loop + Put_Line (FP, "__asm("" .ascii \""" & Tag & "\"""");"); + Put_Line (FP, "__asm("" .byte 0"");"); + end loop; + Put_Line (FP, "__asm("" .ascii \""end\"""");"); + Put_Line (FP, "__asm("" .byte 0"");"); + end if; + + Close (FP); + + exception + when others => + Close (FP); + Set_Error_State ("Internal error"); + raise; + end Emit_CTDT; + + --------------- + -- CTDT_File -- + --------------- + + function CTDT_File (Binder : VxLink_Binder) return String + is + begin + return To_String (Binder.CTDT_File); + end CTDT_File; + +end VxLink.Bind; diff --git a/gcc/ada/vxlink-bind.ads b/gcc/ada/vxlink-bind.ads new file mode 100644 index 0000000..7e6a1b0 --- /dev/null +++ b/gcc/ada/vxlink-bind.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . B I N D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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. 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +private with Ada.Containers.Ordered_Sets; +private with Ada.Strings.Unbounded; + +package VxLink.Bind is + + type VxLink_Binder is private; + + procedure Initialize + (Binder : out VxLink_Binder; + Object_File : String); + + procedure Parse_Tag_File + (Binder : in out VxLink_Binder; + File : String); + + procedure Emit_CTDT + (Binder : in out VxLink_Binder; + Namespace : String); + + function CTDT_File (Binder : VxLink_Binder) return String; + +private + + use Ada.Strings.Unbounded; + + type Symbol_Kind is (Sym_Ctor, Sym_Dtor, Sym_Other); + + type Symbol is record + Name : Unbounded_String; + Cat : Character; + Internal : Boolean; + Kind : Symbol_Kind; + Priority : Integer; + end record; + + function "=" (S1, S2 : Symbol) return Boolean + is (S1.Name = S2.Name and then S1.Cat = S2.Cat); + + function "<" (S1, S2 : Symbol) return Boolean + is (if S1.Priority /= S2.Priority + then S1.Priority < S2.Priority + elsif S1.Name /= S2.Name + then S1.Name < S2.Name + else S1.Cat < S2.Cat); + + package Symbol_Sets is new Ada.Containers.Ordered_Sets + (Symbol, + "<" => "<", + "=" => "="); + + type VxLink_Binder is record + CTDT_File : Unbounded_String; + Constructors : Symbol_Sets.Set; + Destructors : Symbol_Sets.Set; + Module_Dtor_Needed : Boolean; + EH_Frame_Needed : Boolean; + Tags_List : Strings_List.Vector; + end record; + +end VxLink.Bind; diff --git a/gcc/ada/vxlink-link.adb b/gcc/ada/vxlink-link.adb new file mode 100644 index 0000000..5211074 --- /dev/null +++ b/gcc/ada/vxlink-link.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . L I N K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, 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. 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +package body VxLink.Link is + + Gcc : constant String := VxLink.Gcc; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Linker : out VxLink_Linker) + is + Leading : Boolean := True; + Next_Is_Object : Boolean := False; + + begin + for J in 1 .. Ada.Command_Line.Argument_Count loop + declare + Arg : String renames Argument (J); + begin + if Next_Is_Object then + Next_Is_Object := False; + Linker.Dest_Object := To_Unbounded_String (Arg); + Leading := False; + + elsif Argument (J) = "-o" then + Next_Is_Object := True; + + elsif Argument (J) = "-noauto-register" then + -- Filter out this argument, and do not generate _ctors/_dtors + Linker.Add_CDtors := False; + elsif Arg = "-v" and then not Is_Verbose then + -- first -v means VxLink should be verbose, two -v passes -v to + -- the linker. + Set_Verbose (True); + else + if Arg = "-nostdlib" or Arg = "-nostartfiles" then + Linker.Add_CDtors := False; + end if; + + if Leading then + Linker.Args_Leading.Append (Arg); + else + Linker.Args_Trailing.Append (Arg); + end if; + end if; + end; + end loop; + + if Linker.Dest_Object = Null_Unbounded_String then + Set_Error_State ("no output object is defined"); + elsif Linker.Add_CDtors then + -- We'll need to create intermediate artefacts, so we'll use the + -- destination object as base namespace just in case we have + -- several link operations in the same directory + declare + Obj : constant String := + Base_Name (To_String (Linker.Dest_Object)); + + begin + for J in reverse Obj'Range loop + if Obj (J) = '.' then + Linker.Dest_Base := + To_Unbounded_String (Obj (Obj'First .. J - 1)); + exit; + end if; + end loop; + + Linker.Partial_Obj := Linker.Dest_Base & "-partial.o"; + end; + end if; + end Initialize; + + ----------------- + -- Needs_CDtor -- + ----------------- + + function Needs_CDtor (Linker : VxLink_Linker) return Boolean is + begin + return Linker.Add_CDtors; + end Needs_CDtor; + + -------------------- + -- Partial_Object -- + -------------------- + + function Partial_Object (Linker : VxLink_Linker) return String is + begin + return To_String (Linker.Partial_Obj); + end Partial_Object; + + --------------- + -- Namespace -- + --------------- + + function Namespace (Linker : VxLink_Linker) return String is + begin + return To_String (Linker.Dest_Base); + end Namespace; + + --------------------- + -- Do_Initial_Link -- + --------------------- + + procedure Do_Initial_Link (Linker : VxLink_Linker) + is + Args : Arguments_List; + Gxx_Path : constant String := Gxx; + begin + if Is_Error_State then + return; + end if; + + if Gxx_Path'Length /= 0 then + Args.Append (Gxx); + else + Args.Append (Gcc); + end if; + Args.Append (Linker.Args_Leading); + Args.Append ("-o"); + + if Linker.Add_CDtors then + Args.Append (To_String (Linker.Partial_Obj)); + else + Args.Append (To_String (Linker.Dest_Object)); + end if; + + Args.Append (Linker.Args_Trailing); + + if not Linker.Add_CDtors then + Args.Append ("-nostartfiles"); + end if; + + Run (Args); + end Do_Initial_Link; + + ------------------- + -- Do_Final_Link -- + ------------------- + + procedure Do_Final_Link + (Linker : VxLink_Linker; + Ctdt_Obj : String) + is + Args : Arguments_List; + begin + if not Linker.Add_CDtors then + return; + end if; + + if Is_Error_State then + return; + end if; + + Args.Append (Gcc); + Args.Append ("-nostdlib"); + Args.Append (Ctdt_Obj); + Args.Append (To_String (Linker.Partial_Obj)); + Args.Append ("-o"); + Args.Append (To_String (Linker.Dest_Object)); + + Run (Args); + end Do_Final_Link; + +end VxLink.Link; diff --git a/gcc/ada/vxlink-link.ads b/gcc/ada/vxlink-link.ads new file mode 100644 index 0000000..4c46f48 --- /dev/null +++ b/gcc/ada/vxlink-link.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . L I N K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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. 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +private with Ada.Strings.Unbounded; + +package VxLink.Link is + + type VxLink_Linker is private; + + procedure Initialize + (Linker : out VxLink_Linker); + + function Needs_CDtor (Linker : VxLink_Linker) return Boolean; + + function Partial_Object (Linker : VxLink_Linker) return String; + + function Namespace (Linker : VxLink_Linker) return String; + + procedure Do_Initial_Link + (Linker : VxLink_Linker); + + procedure Do_Final_Link + (Linker : VxLink_Linker; + Ctdt_Obj : String); + +private + + use Ada.Strings.Unbounded; + + type VxLink_Linker is record + Args_Leading : Arguments_List; + Args_Trailing : Arguments_List; + Add_CDtors : Boolean := True; + Dest_Object : Unbounded_String; + Dest_Base : Unbounded_String; + Partial_Obj : Unbounded_String; + end record; + +end VxLink.Link; diff --git a/gcc/ada/vxlink-main.adb b/gcc/ada/vxlink-main.adb new file mode 100644 index 0000000..04a22c3 --- /dev/null +++ b/gcc/ada/vxlink-main.adb @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K . M A I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, 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. 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. -- +-- -- +------------------------------------------------------------------------------ + +-- VxLink is a helper tool used as a wrapper around g++/gcc to build VxWorks +-- DKM (Downloadable Kernel Modules). +-- Such DKM is a partially linked object that contains entry points for +-- constructors and destructors. This tool thus uses g++ to generate an +-- intermediate partially linked object, retrieves the list of constructors +-- and destructors in it and produces a C file that lists those ctors/dtors +-- in a way that is understood be VxWorks kernel. It then links this file +-- with the intermediate object to produce a valid DKM. + +pragma Ada_2012; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with VxLink.Link; use VxLink.Link; +with VxLink.Bind; use VxLink.Bind; + +procedure VxLink.Main is + Linker : VxLink_Linker; + Binder : VxLink_Binder; + VSB_Dir : String_Access := Getenv ("VSB_DIR"); +begin + Initialize (Linker); + + if Is_Error_State then + return; + end if; + + Do_Initial_Link (Linker); + + if Is_Error_State then + return; + end if; + + if not Needs_CDtor (Linker) then + -- Initial link is enough, let's return + return; + end if; + + if VSB_Dir /= null and then VSB_Dir'Length > 0 then + declare + DKM_Tag_File : constant String := + Normalize_Pathname + ("krnl/tags/dkm.tags", VSB_Dir.all); + begin + if Is_Regular_File (DKM_Tag_File) then + Parse_Tag_File (Binder, DKM_Tag_File); + end if; + end; + end if; + + Initialize (Binder, Object_File => Partial_Object (Linker)); + Emit_CTDT (Binder, Namespace => Namespace (Linker)); + + Do_Final_Link (Linker, CTDT_File (Binder)); + Free (VSB_Dir); +end VxLink.Main; diff --git a/gcc/ada/vxlink.adb b/gcc/ada/vxlink.adb new file mode 100644 index 0000000..400ad22 --- /dev/null +++ b/gcc/ada/vxlink.adb @@ -0,0 +1,288 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018, 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. 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +with Ada.Command_Line; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Text_IO; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.Expect; use GNAT.Expect; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body VxLink is + + Target_Triplet : Unbounded_String := Null_Unbounded_String; + Verbose : Boolean := False; + Error_State : Boolean := False; + + function Triplet return String; + + function Which (Exe : String) return String; + + ------------- + -- Triplet -- + ------------- + + function Triplet return String is + begin + if Target_Triplet = Null_Unbounded_String then + declare + Exe : constant String := File_Name (Ada.Command_Line.Command_Name); + begin + for J in reverse Exe'Range loop + if Exe (J) = '-' then + Target_Triplet := To_Unbounded_String (Exe (Exe'First .. J)); + exit; + end if; + end loop; + end; + end if; + + return To_String (Target_Triplet); + end Triplet; + + ----------- + -- Which -- + ----------- + + function Which (Exe : String) return String + is + Suffix : GNAT.OS_Lib.String_Access := Get_Executable_Suffix; + Basename : constant String := Exe & Suffix.all; + Path : GNAT.OS_Lib.String_Access := Getenv ("PATH"); + Last : Natural := Path'First; + + begin + Free (Suffix); + + for J in Path'Range loop + if Path (J) = Path_Separator then + declare + Full : constant String := Normalize_Pathname + (Name => Basename, + Directory => Path (Last .. J - 1), + Resolve_Links => False, + Case_Sensitive => True); + begin + if Is_Executable_File (Full) then + Free (Path); + + return Full; + end if; + end; + + Last := J + 1; + end if; + end loop; + + Free (Path); + + return ""; + end Which; + + ----------------- + -- Set_Verbose -- + ----------------- + + procedure Set_Verbose (Value : Boolean) + is + begin + Verbose := Value; + end Set_Verbose; + + ---------------- + -- Is_Verbose -- + ---------------- + + function Is_Verbose return Boolean + is + begin + return Verbose; + end Is_Verbose; + + --------------------- + -- Set_Error_State -- + --------------------- + + procedure Set_Error_State (Message : String) + is + begin + Log_Error ("Error: " & Message); + Error_State := True; + Ada.Command_Line.Set_Exit_Status (1); + end Set_Error_State; + + -------------------- + -- Is_Error_State -- + -------------------- + + function Is_Error_State return Boolean + is + begin + return Error_State; + end Is_Error_State; + + -------------- + -- Log_Info -- + -------------- + + procedure Log_Info (S : String) + is + begin + if Verbose then + Ada.Text_IO.Put_Line (S); + end if; + end Log_Info; + + --------------- + -- Log_Error -- + --------------- + + procedure Log_Error (S : String) + is + begin + Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, S); + end Log_Error; + + --------- + -- Run -- + --------- + + procedure Run (Arguments : Arguments_List) + is + Output : constant String := Run (Arguments); + begin + if not Is_Error_State then + -- In case of erroneous execution, the function version of run will + -- have already displayed the output + Ada.Text_IO.Put (Output); + end if; + end Run; + + --------- + -- Run -- + --------- + + function Run (Arguments : Arguments_List) return String + is + Args : GNAT.OS_Lib.Argument_List_Access := + new GNAT.OS_Lib.Argument_List + (1 .. Natural (Arguments.Length) - 1); + Base : constant String := Base_Name (Arguments.First_Element); + Status : aliased Integer := 0; + Debug_Line : Unbounded_String; + Add_Quotes : Boolean; + + begin + if Verbose then + Append (Debug_Line, Base); + end if; + + for J in Arguments.First_Index + 1 .. Arguments.Last_Index loop + declare + Arg : String renames Arguments.Element (J); + begin + Args (J - 1) := new String'(Arg); + + if Verbose then + Add_Quotes := False; + + for K in Arg'Range loop + if Arg (K) = ' ' then + Add_Quotes := True; + exit; + end if; + end loop; + + Append (Debug_Line, ' '); + + if Add_Quotes then + Append (Debug_Line, '"' & Arg & '"'); + else + Append (Debug_Line, Arg); + end if; + end if; + end; + end loop; + + if Verbose then + Ada.Text_IO.Put_Line (To_String (Debug_Line)); + end if; + + declare + Ret : constant String := + Get_Command_Output + (Command => Arguments.First_Element, + Arguments => Args.all, + Input => "", + Status => Status'Access, + Err_To_Out => True); + begin + GNAT.OS_Lib.Free (Args); + + if Status /= 0 then + Ada.Text_IO.Put_Line (Ret); + Set_Error_State + (Base_Name (Arguments.First_Element) & + " returned" & Status'Image); + end if; + + return Ret; + end; + end Run; + + --------- + -- Gcc -- + --------- + + function Gcc return String + is + begin + return Which (Triplet & "gcc"); + end Gcc; + + --------- + -- Gxx -- + --------- + + function Gxx return String + is + begin + return Which (Triplet & "g++"); + end Gxx; + + -------- + -- Nm -- + -------- + + function Nm return String + is + begin + return Which (Triplet & "nm"); + end Nm; + +end VxLink; diff --git a/gcc/ada/vxlink.ads b/gcc/ada/vxlink.ads new file mode 100644 index 0000000..37ae5d7 --- /dev/null +++ b/gcc/ada/vxlink.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V X L I N K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018, 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. 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. -- +-- -- +------------------------------------------------------------------------------ + +-- See vxlink-main.adb for a description of the tool. +-- +-- This package contains only common utility functions used by the other +-- child packages. + +pragma Ada_2012; + +with Ada.Containers.Indefinite_Vectors; + +package VxLink is + + package Strings_List is new Ada.Containers.Indefinite_Vectors + (Positive, String); + + subtype Arguments_List is Strings_List.Vector; + + procedure Set_Verbose (Value : Boolean); + function Is_Verbose return Boolean; + + procedure Set_Error_State (Message : String); + function Is_Error_State return Boolean; + + procedure Log_Info (S : String); + procedure Log_Error (S : String); + + procedure Run (Arguments : Arguments_List); + + function Run (Arguments : Arguments_List) return String; + + function Gcc return String; + -- Current toolchain's gcc command + + function Gxx return String; + -- Current toolchain's g++ command + + function Nm return String; + -- Current toolchain's nm command + + function Ends_With (Str, Suffix : String) return Boolean + is (Str'Length >= Suffix'Length + and then Str (Str'Last - Suffix'Length + 1 .. Str'Last) = Suffix); + +end VxLink; |