git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Changelog-caf: New file. 

2018-08-21  Thomas Koenig  <tkoenig@gcc.gnu.org>

        * Changelog-caf: New file.
        * Merged branch from r263319 to r263750.

From-SVN: r263753
This commit is contained in:
Thomas Koenig 2018-08-21 20:17:38 +00:00
parent dd5faf200e f7191a37ee
commit ceb3bc68d3
980 changed files with 49951 additions and 14150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
ChangeLog
View File

@ -1,3 +1,24 @@
2018-08-21 Richard Sandiford <richard.sandiford@arm.com>
* MAINTAINERS: Add self to global reviewers list.
2018-08-17 Sandra Loosemore <sandra@codesourcery.com>
MAINTAINERS: Add c-sky port maintainers.
2018-08-10 Martin Liska <mliska@suse.cz>
* MAINTAINERS: Revert change in previous commit and
join lines.
2018-08-10 Martin Liska <mliska@suse.cz>
* MAINTAINERS: Remove extra line.
2018-08-06 Naveen H.S <naveenh@marvell.com>
* MAINTAINERS: Update my email address.
2018-07-19 DJ Delorie <dj@redhat.com>
* MAINTAINERS (m32c, msp43, rl78, libiberty, build): Remove myself

4
ChangeLog-caf Normal file
View File

@ -0,0 +1,4 @@
2018-08-21 Thomas Koenig <tkoenig@gcc.gnu.org>
* Changelog-caf: New file.
* Merged branch from r263319 to r263750.

8
MAINTAINERS
View File

@ -29,6 +29,7 @@ Michael Meissner <gnu@the-meissners.org>
Jason Merrill <jason@redhat.com>
David S. Miller <davem@redhat.com>
Joseph Myers <joseph@codesourcery.com>
Richard Sandiford <richard.sandiford@arm.com>
Bernd Schmidt <bernds_cb1@t-online.de>
Ian Lance Taylor <ian@airs.com>
Jim Wilson <wilson@tuliptree.org>
@ -56,6 +57,8 @@ avr port Denis Chertykov <chertykov@gmail.com>
bfin port Jie Zhang <jzhang918@gmail.com>
c6x port Bernd Schmidt <bernds_cb1@t-online.de>
cris port Hans-Peter Nilsson <hp@axis.com>
c-sky port Xianmiao Qu <xianmiao_qu@c-sky.com>
c-sky port Yunhai Shang <yunhai_shang@c-sky.com>
epiphany port Joern Rennecke <gnu@amylaar.uk>
fr30 port Nick Clifton <nickc@redhat.com>
frv port Nick Clifton <nickc@redhat.com>
@ -188,8 +191,7 @@ c++ runtime libs Paolo Carlini <paolo.carlini@oracle.com>
c++ runtime libs Ulrich Drepper <drepper@gmail.com>
c++ runtime libs Benjamin De Kosnik <bkoz@gnu.org>
c++ runtime libs Jonathan Wakely <jwakely@redhat.com>
c++ runtime libs
special modes François Dumont <fdumont@gcc.gnu.org>
c++ runtime libs special modes François Dumont <fdumont@gcc.gnu.org>
fixincludes Bruce Korb <bkorb@gnu.org>
*gimpl* Jakub Jelinek <jakub@redhat.com>
*gimpl* Aldy Hernandez <aldyh@redhat.com>
@ -414,7 +416,7 @@ Falk Hueffner <falk@debian.org>
Andrew John Hughes <gnu_andrew@member.fsf.org>
Dominique d'Humieres <dominiq@lps.ens.fr>
Andy Hutchinson <hutchinsonandy@aim.com>
Naveen H.S <Naveen.Hurugalawadi@caviumnetworks.com>
Naveen H.S <naveenh@marvell.com>
Meador Inge <meadori@codesourcery.com>
Bernardo Innocenti <bernie@develer.com>
Alexander Ivchenko <aivchenk@gmail.com>

10
contrib/ChangeLog
View File

@ -1,3 +1,13 @@
2018-08-17 Jojo <jijie_rong@c-sky.com>
Huibin Wang <huibin_wang@c-sky.com>
Sandra Loosemore <sandra@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
Andrew Jenner <andrew@codesourcery.com>
C-SKY port: Configury
* config-list.mk (LIST): Add csky-elf and csky-linux-gnu.
2018-07-13 Tom de Vries <tdevries@suse.de>
* maintainers-verify.sh: New file.

1
contrib/config-list.mk
View File

@ -40,6 +40,7 @@ LIST = aarch64-elf aarch64-linux-gnu aarch64-rtems \
arm-symbianelf avr-elf \
bfin-elf bfin-uclinux bfin-linux-uclibc bfin-rtems bfin-openbsd \
c6x-elf c6x-uclinux cr16-elf cris-elf cris-linux crisv32-elf crisv32-linux \
csky-elf csky-linux-gnu \
epiphany-elf epiphany-elfOPT-with-stack-offset=16 fido-elf \
fr30-elf frv-elf frv-linux ft32-elf h8300-elf hppa-linux-gnu \
hppa-linux-gnuOPT-enable-sjlj-exceptions=yes hppa64-linux-gnu \

1423
gcc/ChangeLog
View File

File diff suppressed because it is too large Load Diff

2
gcc/DATESTAMP
View File

@ -1 +1 @@
20180805
20180821

7
gcc/Makefile.in
View File

@ -978,8 +978,7 @@ CPPLIB_H = $(srcdir)/../libcpp/include/line-map.h \
INPUT_H = $(srcdir)/../libcpp/include/line-map.h input.h
OPTS_H = $(INPUT_H) $(VEC_H) opts.h $(OBSTACK_H)
SYMTAB_H = $(srcdir)/../libcpp/include/symtab.h $(OBSTACK_H)
CPP_ID_DATA_H = $(CPPLIB_H) $(srcdir)/../libcpp/include/cpp-id-data.h
CPP_INTERNAL_H = $(srcdir)/../libcpp/internal.h $(CPP_ID_DATA_H)
CPP_INTERNAL_H = $(srcdir)/../libcpp/internal.h
TREE_DUMP_H = tree-dump.h $(SPLAY_TREE_H) $(DUMPFILE_H)
TREE_PASS_H = tree-pass.h $(TIMEVAR_H) $(DUMPFILE_H)
TREE_SSA_H = tree-ssa.h tree-ssa-operands.h \
@ -2504,7 +2503,7 @@ s-tm-texi: build/genhooks$(build_exeext) $(srcdir)/doc/tm.texi.in
else \
echo >&2 ; \
echo Verify that you have permission to grant a GFDL license for all >&2 ; \
echo new text in tm.texi, then copy it to $(srcdir)/doc/tm.texi. >&2 ; \
echo new text in $(objdir)/tm.texi, then copy it to $(srcdir)/doc/tm.texi. >&2 ; \
false; \
fi
@ -2522,7 +2521,7 @@ s-match: build/genmatch$(build_exeext) $(srcdir)/match.pd cfn-operators.pd
generic-match.c
$(STAMP) s-match
GTFILES = $(CPP_ID_DATA_H) $(srcdir)/input.h $(srcdir)/coretypes.h \
GTFILES = $(CPPLIB_H) $(srcdir)/input.h $(srcdir)/coretypes.h \
$(host_xm_file_list) \
$(tm_file_list) $(HASHTAB_H) $(SPLAY_TREE_H) $(srcdir)/bitmap.h \
$(srcdir)/wide-int.h $(srcdir)/alias.h \

280
gcc/ada/ChangeLog
View File

@ -1,3 +1,279 @@
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
@ -10,12 +286,12 @@
2018-07-31 Alexandre Oliva <oliva@adacore.com>
Olivier Hainque <hainque@adacore.com>
* trans.c: Include debug.h.
* 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.
* gigi.h (Sloc_to_locus): Adjust declaration.
* gcc-interface/gigi.h (Sloc_to_locus): Adjust declaration.
2018-07-31 Arnaud Charlet <charlet@adacore.com>

10
gcc/ada/Makefile.rtl
View File

@ -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) \
@ -2761,4 +2770,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)

39
gcc/ada/checks.adb
View File

@ -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 =>

18
gcc/ada/checks.ads
View File

@ -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;

45
gcc/ada/contracts.adb
View File

@ -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

33
gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
View File

@ -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:

31
gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
View File

@ -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

52
gcc/ada/einfo.adb
View File

@ -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");

50
gcc/ada/einfo.ads
View File

@ -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);

34
gcc/ada/exp_aggr.adb
View File

@ -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;

40
gcc/ada/exp_attr.adb
View File

@ -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;

9
gcc/ada/exp_cg.adb
View File

@ -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);

5
gcc/ada/exp_ch6.adb
View File

@ -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;

7
gcc/ada/exp_ch7.adb
View File

@ -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 :=

62
gcc/ada/exp_ch9.adb
View File

@ -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;
----------------------

13
gcc/ada/exp_unst.adb
View File

@ -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);

18
gcc/ada/exp_util.adb
View File

@ -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;

209
gcc/ada/freeze.adb
View File

@ -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 --
-----------------------------

11
gcc/ada/freeze.ads
View File

@ -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

1
gcc/ada/gcc-interface/Make-lang.in
View File

@ -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 \

11
gcc/ada/gcc-interface/Makefile.in
View File

@ -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)"

1
gcc/ada/gcc-interface/trans.c
View File

@ -4450,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

70
gcc/ada/gnat_ugn.texi
View File

@ -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

6
gcc/ada/gnatlink.adb
View File

@ -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.

9
gcc/ada/impunit.adb
View File

@ -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

2
gcc/ada/itypes.adb
View File

@ -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;

2
gcc/ada/itypes.ads
View File

@ -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
--

10
gcc/ada/layout.adb
View File

@ -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

22
gcc/ada/lib-writ.adb
View File

@ -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;

13
gcc/ada/lib-xref-spark_specific.adb
View File

@ -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

5
gcc/ada/lib-xref.ads
View File

@ -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;

2
gcc/ada/libgnarl/a-intnam__dragonfly.ads
View File

@ -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- --

2
gcc/ada/libgnarl/s-osinte__dragonfly.adb
View File

@ -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- --

2
gcc/ada/libgnarl/s-osinte__dragonfly.ads
View File

@ -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- --

2
gcc/ada/libgnarl/s-osinte__gnu.adb
View File

@ -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- --

2
gcc/ada/libgnarl/s-osinte__gnu.ads
View File

@ -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- --

2
gcc/ada/libgnarl/s-osinte__hpux-dce.adb
View File

@ -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- --

2
gcc/ada/libgnarl/s-osinte__hpux-dce.ads
View File

@ -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- --

2
gcc/ada/libgnarl/s-taprop__hpux-dce.adb
View File

@ -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- --

2
gcc/ada/libgnarl/s-taspri__hpux-dce.ads
View File

@ -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- --

834
gcc/ada/libgnat/g-dynhta.adb
View File

@ -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;

310
gcc/ada/libgnat/g-dynhta.ads
View File

@ -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;

635
gcc/ada/libgnat/g-lists.adb Normal file
View File

@ -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;

245
gcc/ada/libgnat/g-lists.ads Normal file
View File

@ -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;

38
gcc/ada/libgnat/s-dfmkio.ads Normal file
View File

@ -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);

35
gcc/ada/libgnat/s-dfmopr.ads Normal file
View File

@ -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;

174
gcc/ada/libgnat/s-dgmgop.ads Normal file
View File

@ -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;

34
gcc/ada/libgnat/s-diflmk.ads Normal file
View File

@ -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);

396
gcc/ada/libgnat/s-digemk.ads Normal file
View File

@ -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;

34
gcc/ada/libgnat/s-dilomk.ads Normal file
View File

@ -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);

363
gcc/ada/libgnat/s-dimmks.ads
View File

@ -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);

38
gcc/ada/libgnat/s-dlmkio.ads Normal file
View File

@ -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);

35
gcc/ada/libgnat/s-dlmopr.ads Normal file
View File

@ -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;

141
gcc/ada/libgnat/s-dmotpr.ads
View File

@ -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;

539
gcc/ada/sa_messages.adb Normal file
View File

@ -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;

267
gcc/ada/sa_messages.ads Normal file
View File

@ -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;

9
gcc/ada/sem_attr.adb
View File

@ -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

3
gcc/ada/sem_ch10.adb
View File

@ -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;
------------------------------

102
gcc/ada/sem_ch13.adb
View File

@ -8765,8 +8765,37 @@ 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;
procedure Reset_Loop_Variables is
new Traverse_Proc (Reset_Loop_Variable);
------------------------
-- Reset_Loop_Variable --
------------------------
function Reset_Loop_Variable
(N : Node_Id) return Traverse_Result
is
begin
if Nkind (N) = N_Iterator_Specification then
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);
-- The unanalyzed expression will be copied and appear in
-- both functions. Normally expressions do not declare new
@ -8774,35 +8803,7 @@ package body Sem_Ch13 is
-- 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
new Traverse_Proc (Reset_Loop_Variable);
------------------------
-- Reset_Loop_Variable --
------------------------
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);
end if;
return OK;
end Reset_Loop_Variable;
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);
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;

8
gcc/ada/sem_ch3.adb
View File

@ -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);

250
gcc/ada/sem_ch6.adb
View File

@ -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;

35
gcc/ada/sem_res.adb
View File

@ -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

4482
gcc/ada/sem_spark.adb
View File

File diff suppressed because it is too large Load Diff

10
gcc/ada/sem_util.adb
View File

@ -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;

2
gcc/ada/sem_util.ads
View File

@ -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

3
gcc/ada/set_targ.adb
View File

@ -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

2
gcc/ada/sinfo.ads
View File

@ -4674,7 +4674,7 @@ package Sinfo is
--------------------------
-- 4.5.7 If Expression --
----------------------------
--------------------------
-- IF_EXPRESSION ::=
-- if CONDITION then DEPENDENT_EXPRESSION

9
gcc/ada/sprint.adb
View File

@ -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;

390
gcc/ada/vxlink-bind.adb Normal file
View File

@ -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;

87
gcc/ada/vxlink-bind.ads Normal file
View File

@ -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;

194
gcc/ada/vxlink-link.adb Normal file
View File

@ -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;

63
gcc/ada/vxlink-link.ads Normal file
View File

@ -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;

81
gcc/ada/vxlink-main.adb Normal file
View File

@ -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;

288
gcc/ada/vxlink.adb Normal file
View File

@ -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;

68
gcc/ada/vxlink.ads Normal file
View File

@ -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;

11
gcc/alias.c
View File

@ -1554,6 +1554,17 @@ record_set (rtx dest, const_rtx set, void *data ATTRIBUTE_UNUSED)
new_reg_base_value[regno] = 0;
return;
}
/* A CLOBBER_HIGH only wipes out the old value if the mode of the old
value is greater than that of the clobber. */
else if (GET_CODE (set) == CLOBBER_HIGH)
{
if (new_reg_base_value[regno] != 0
&& reg_is_clobbered_by_clobber_high (
regno, GET_MODE (new_reg_base_value[regno]), XEXP (set, 0)))
new_reg_base_value[regno] = 0;
return;
}
src = SET_SRC (set);
}
else

3
gcc/attribs.c
View File

@ -430,7 +430,7 @@ diag_attr_exclusions (tree last_decl, tree node, tree attrname,
/* Print a note? */
bool note = last_decl != NULL_TREE;
auto_diagnostic_group d;
if (TREE_CODE (node) == FUNCTION_DECL
&& DECL_BUILT_IN (node))
note &= warning (OPT_Wattributes,
@ -587,6 +587,7 @@ decl_attributes (tree *node, tree attributes, int flags,
/* This is a c++11 attribute that appertains to a
type-specifier, outside of the definition of, a class
type. Ignore it. */
auto_diagnostic_group d;
if (warning (OPT_Wattributes, "attribute ignored"))
inform (input_location,
"an attribute that appertains to a type-specifier "

2
gcc/builtin-types.def
View File

@ -531,6 +531,8 @@ DEF_FUNCTION_TYPE_3 (BT_FN_ULONG_ULONG_ULONG_ULONG,
BT_ULONG, BT_ULONG, BT_ULONG, BT_ULONG)
DEF_FUNCTION_TYPE_3 (BT_FN_LONG_LONG_UINT_UINT,
BT_LONG, BT_LONG, BT_UINT, BT_UINT)
DEF_FUNCTION_TYPE_3 (BT_FN_LONG_LONG_LONG_DOUBLE,
BT_LONG, BT_LONG, BT_LONG, BT_DOUBLE)
DEF_FUNCTION_TYPE_3 (BT_FN_ULONG_ULONG_UINT_UINT,
BT_ULONG, BT_ULONG, BT_UINT, BT_UINT)
DEF_FUNCTION_TYPE_3 (BT_FN_STRING_CONST_STRING_CONST_STRING_INT,

135
gcc/builtins.c
View File

@ -148,6 +148,7 @@ static rtx expand_builtin_unop (machine_mode, tree, rtx, rtx, optab);
static rtx expand_builtin_frame_address (tree, tree);
static tree stabilize_va_list_loc (location_t, tree, int);
static rtx expand_builtin_expect (tree, rtx);
static rtx expand_builtin_expect_with_probability (tree, rtx);
static tree fold_builtin_constant_p (tree);
static tree fold_builtin_classify_type (tree);
static tree fold_builtin_strlen (location_t, tree, tree);
@ -567,41 +568,43 @@ string_length (const void *ptr, unsigned eltsize, unsigned maxelts)
accesses. Note that this implies the result is not going to be emitted
into the instruction stream.
The value returned is of type `ssizetype'.
ELTSIZE is 1 for normal single byte character strings, and 2 or
4 for wide characer strings. ELTSIZE is by default 1.
Unfortunately, string_constant can't access the values of const char
arrays with initializers, so neither can we do so here. */
The value returned is of type `ssizetype'. */
tree
c_strlen (tree src, int only_value)
c_strlen (tree src, int only_value, unsigned eltsize)
{
gcc_assert (eltsize == 1 || eltsize == 2 || eltsize == 4);
STRIP_NOPS (src);
if (TREE_CODE (src) == COND_EXPR
&& (only_value || !TREE_SIDE_EFFECTS (TREE_OPERAND (src, 0))))
{
tree len1, len2;
len1 = c_strlen (TREE_OPERAND (src, 1), only_value);
len2 = c_strlen (TREE_OPERAND (src, 2), only_value);
len1 = c_strlen (TREE_OPERAND (src, 1), only_value, eltsize);
len2 = c_strlen (TREE_OPERAND (src, 2), only_value, eltsize);
if (tree_int_cst_equal (len1, len2))
return len1;
}
if (TREE_CODE (src) == COMPOUND_EXPR
&& (only_value || !TREE_SIDE_EFFECTS (TREE_OPERAND (src, 0))))
return c_strlen (TREE_OPERAND (src, 1), only_value);
return c_strlen (TREE_OPERAND (src, 1), only_value, eltsize);
location_t loc = EXPR_LOC_OR_LOC (src, input_location);
/* Offset from the beginning of the string in bytes. */
tree byteoff;
src = string_constant (src, &byteoff);
tree memsize;
src = string_constant (src, &byteoff, &memsize);
if (src == 0)
return NULL_TREE;
/* Determine the size of the string element. */
unsigned eltsize
= tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (src))));
if (eltsize != tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (src)))))
return NULL_TREE;
/* Set MAXELTS to sizeof (SRC) / sizeof (*SRC) - 1, the maximum possible
length of SRC. Prefer TYPE_SIZE() to TREE_STRING_LENGTH() if possible
@ -612,14 +615,10 @@ c_strlen (tree src, int only_value)
HOST_WIDE_INT strelts = TREE_STRING_LENGTH (src);
strelts = strelts / eltsize - 1;
HOST_WIDE_INT maxelts = strelts;
tree type = TREE_TYPE (src);
if (tree size = TYPE_SIZE_UNIT (type))
if (tree_fits_shwi_p (size))
{
maxelts = tree_to_uhwi (size);
maxelts = maxelts / eltsize - 1;
}
if (!tree_fits_uhwi_p (memsize))
return NULL_TREE;
HOST_WIDE_INT maxelts = tree_to_uhwi (memsize) / eltsize - 1;
/* PTR can point to the byte representation of any string type, including
char* and wchar_t*. */
@ -627,19 +626,23 @@ c_strlen (tree src, int only_value)
if (byteoff && TREE_CODE (byteoff) != INTEGER_CST)
{
/* For empty strings the result should be zero. */
if (maxelts == 0)
return ssize_int (0);
/* The code below works only for single byte character types. */
if (eltsize != 1)
return NULL_TREE;
/* If the string has an internal NUL character followed by any
non-NUL characters (e.g., "foo\0bar"), we can't compute
the offset to the following NUL if we don't know where to
start searching for it. */
unsigned len = string_length (ptr, eltsize, strelts);
if (len < strelts)
{
/* Return when an embedded null character is found. */
return NULL_TREE;
}
if (!maxelts)
return ssize_int (0);
/* Return when an embedded null character is found or none at all. */
if (len < strelts || len > maxelts)
return NULL_TREE;
/* We don't know the starting offset, but we do know that the string
has no internal zero bytes. If the offset falls within the bounds
@ -649,8 +652,8 @@ c_strlen (tree src, int only_value)
tree offsave = TREE_SIDE_EFFECTS (byteoff) ? save_expr (byteoff) : byteoff;
offsave = fold_convert (ssizetype, offsave);
tree condexp = fold_build2_loc (loc, LE_EXPR, boolean_type_node, offsave,
build_int_cst (ssizetype, len * eltsize));
tree lenexp = size_diffop_loc (loc, ssize_int (strelts * eltsize), offsave);
build_int_cst (ssizetype, len));
tree lenexp = size_diffop_loc (loc, ssize_int (strelts), offsave);
return fold_build3_loc (loc, COND_EXPR, ssizetype, condexp, lenexp,
build_zero_cst (ssizetype));
}
@ -683,6 +686,11 @@ c_strlen (tree src, int only_value)
return NULL_TREE;
}
/* If eltoff is larger than strelts but less than maxelts the
string length is zero, since the excess memory will be zero. */
if (eltoff > strelts)
return ssize_int (0);
/* Use strlen to search for the first zero byte. Since any strings
constructed with build_string will have nulls appended, we win even
if we get handed something like (char[4])"abcd".
@ -690,7 +698,7 @@ c_strlen (tree src, int only_value)
Since ELTOFF is our starting index into the string, no further
calculation is needed. */
unsigned len = string_length (ptr + eltoff * eltsize, eltsize,
maxelts - eltoff);
strelts - eltoff);
return ssize_int (len);
}
@ -4480,11 +4488,16 @@ expand_builtin_memcmp (tree exp, rtx target, bool result_eq)
/*objsize=*/NULL_TREE);
}
/* If the specified length exceeds the size of either object,
call the function. */
if (!no_overflow)
return NULL_RTX;
/* Due to the performance benefit, always inline the calls first
when result_eq is false. */
rtx result = NULL_RTX;
if (!result_eq && fcode != BUILT_IN_BCMP && no_overflow)
if (!result_eq && fcode != BUILT_IN_BCMP)
{
result = inline_expand_builtin_string_cmp (exp, target);
if (result)
@ -5251,6 +5264,27 @@ expand_builtin_expect (tree exp, rtx target)
return target;
}
/* Expand a call to __builtin_expect_with_probability. We just return our
argument as the builtin_expect semantic should've been already executed by
tree branch prediction pass. */
static rtx
expand_builtin_expect_with_probability (tree exp, rtx target)
{
tree arg;
if (call_expr_nargs (exp) < 3)
return const0_rtx;
arg = CALL_EXPR_ARG (exp, 0);
target = expand_expr (arg, target, VOIDmode, EXPAND_NORMAL);
/* When guessing was done, the hints should be already stripped away. */
gcc_assert (!flag_guess_branch_prob
|| optimize == 0 || seen_error ());
return target;
}
/* Expand a call to __builtin_assume_aligned. We just return our first
argument as the builtin_assume_aligned semantic should've been already
executed by CCP. */
@ -7562,6 +7596,8 @@ expand_builtin (tree exp, rtx target, rtx subtarget, machine_mode mode,
return expand_builtin_va_copy (exp);
case BUILT_IN_EXPECT:
return expand_builtin_expect (exp, target);
case BUILT_IN_EXPECT_WITH_PROBABILITY:
return expand_builtin_expect_with_probability (exp, target);
case BUILT_IN_ASSUME_ALIGNED:
return expand_builtin_assume_aligned (exp, target);
case BUILT_IN_PREFETCH:
@ -8213,16 +8249,20 @@ fold_builtin_constant_p (tree arg)
return NULL_TREE;
}
/* Create builtin_expect with PRED and EXPECTED as its arguments and
return it as a truthvalue. */
/* Create builtin_expect or builtin_expect_with_probability
with PRED and EXPECTED as its arguments and return it as a truthvalue.
Fortran FE can also produce builtin_expect with PREDICTOR as third argument.
builtin_expect_with_probability instead uses third argument as PROBABILITY
value. */
static tree
build_builtin_expect_predicate (location_t loc, tree pred, tree expected,
tree predictor)
tree predictor, tree probability)
{
tree fn, arg_types, pred_type, expected_type, call_expr, ret_type;
fn = builtin_decl_explicit (BUILT_IN_EXPECT);
fn = builtin_decl_explicit (probability == NULL_TREE ? BUILT_IN_EXPECT
: BUILT_IN_EXPECT_WITH_PROBABILITY);
arg_types = TYPE_ARG_TYPES (TREE_TYPE (fn));
ret_type = TREE_TYPE (TREE_TYPE (fn));
pred_type = TREE_VALUE (arg_types);
@ -8230,18 +8270,23 @@ build_builtin_expect_predicate (location_t loc, tree pred, tree expected,
pred = fold_convert_loc (loc, pred_type, pred);
expected = fold_convert_loc (loc, expected_type, expected);
call_expr = build_call_expr_loc (loc, fn, predictor ? 3 : 2, pred, expected,
predictor);
if (probability)
call_expr = build_call_expr_loc (loc, fn, 3, pred, expected, probability);
else
call_expr = build_call_expr_loc (loc, fn, predictor ? 3 : 2, pred, expected,
predictor);
return build2 (NE_EXPR, TREE_TYPE (pred), call_expr,
build_int_cst (ret_type, 0));
}
/* Fold a call to builtin_expect with arguments ARG0 and ARG1. Return
/* Fold a call to builtin_expect with arguments ARG0, ARG1, ARG2, ARG3. Return
NULL_TREE if no simplification is possible. */
tree
fold_builtin_expect (location_t loc, tree arg0, tree arg1, tree arg2)
fold_builtin_expect (location_t loc, tree arg0, tree arg1, tree arg2,
tree arg3)
{
tree inner, fndecl, inner_arg0;
enum tree_code code;
@ -8265,8 +8310,9 @@ fold_builtin_expect (location_t loc, tree arg0, tree arg1, tree arg2)
if (TREE_CODE (inner) == CALL_EXPR
&& (fndecl = get_callee_fndecl (inner))
&& DECL_BUILT_IN_CLASS (fndecl) == BUILT_IN_NORMAL
&& DECL_FUNCTION_CODE (fndecl) == BUILT_IN_EXPECT)
&& (DECL_BUILT_IN_P (fndecl, BUILT_IN_NORMAL, BUILT_IN_EXPECT)
|| DECL_BUILT_IN_P (fndecl, BUILT_IN_NORMAL,
BUILT_IN_EXPECT_WITH_PROBABILITY)))
return arg0;
inner = inner_arg0;
@ -8277,8 +8323,8 @@ fold_builtin_expect (location_t loc, tree arg0, tree arg1, tree arg2)
tree op1 = TREE_OPERAND (inner, 1);
arg1 = save_expr (arg1);
op0 = build_builtin_expect_predicate (loc, op0, arg1, arg2);
op1 = build_builtin_expect_predicate (loc, op1, arg1, arg2);
op0 = build_builtin_expect_predicate (loc, op0, arg1, arg2, arg3);
op1 = build_builtin_expect_predicate (loc, op1, arg1, arg2, arg3);
inner = build2 (code, TREE_TYPE (inner), op0, op1);
return fold_convert_loc (loc, TREE_TYPE (arg0), inner);
@ -9374,7 +9420,7 @@ fold_builtin_2 (location_t loc, tree fndecl, tree arg0, tree arg1)
return fold_builtin_strpbrk (loc, arg0, arg1, type);
case BUILT_IN_EXPECT:
return fold_builtin_expect (loc, arg0, arg1, NULL_TREE);
return fold_builtin_expect (loc, arg0, arg1, NULL_TREE, NULL_TREE);
case BUILT_IN_ISGREATER:
return fold_builtin_unordered_cmp (loc, fndecl,
@ -9452,7 +9498,10 @@ fold_builtin_3 (location_t loc, tree fndecl,
return fold_builtin_memcmp (loc, arg0, arg1, arg2);
case BUILT_IN_EXPECT:
return fold_builtin_expect (loc, arg0, arg1, arg2);
return fold_builtin_expect (loc, arg0, arg1, arg2, NULL_TREE);
case BUILT_IN_EXPECT_WITH_PROBABILITY:
return fold_builtin_expect (loc, arg0, arg1, NULL_TREE, arg2);
case BUILT_IN_ADD_OVERFLOW:
case BUILT_IN_SUB_OVERFLOW:

1
gcc/builtins.def
View File

@ -848,6 +848,7 @@ DEF_EXT_LIB_BUILTIN (BUILT_IN_EXECVP, "execvp", BT_FN_INT_CONST_STRING_PT
DEF_EXT_LIB_BUILTIN (BUILT_IN_EXECVE, "execve", BT_FN_INT_CONST_STRING_PTR_CONST_STRING_PTR_CONST_STRING, ATTR_NOTHROW_LIST)
DEF_LIB_BUILTIN (BUILT_IN_EXIT, "exit", BT_FN_VOID_INT, ATTR_NORETURN_NOTHROW_LIST)
DEF_GCC_BUILTIN (BUILT_IN_EXPECT, "expect", BT_FN_LONG_LONG_LONG, ATTR_CONST_NOTHROW_LEAF_LIST)
DEF_GCC_BUILTIN (BUILT_IN_EXPECT_WITH_PROBABILITY, "expect_with_probability", BT_FN_LONG_LONG_LONG_DOUBLE, ATTR_CONST_NOTHROW_LEAF_LIST)
DEF_GCC_BUILTIN (BUILT_IN_ASSUME_ALIGNED, "assume_aligned", BT_FN_PTR_CONST_PTR_SIZE_VAR, ATTR_CONST_NOTHROW_LEAF_LIST)
DEF_GCC_BUILTIN (BUILT_IN_EXTEND_POINTER, "extend_pointer", BT_FN_UNWINDWORD_PTR, ATTR_CONST_NOTHROW_LEAF_LIST)
DEF_GCC_BUILTIN (BUILT_IN_EXTRACT_RETURN_ADDR, "extract_return_addr", BT_FN_PTR_PTR, ATTR_LEAF_LIST)

4
gcc/builtins.h
View File

@ -58,7 +58,7 @@ extern bool get_pointer_alignment_1 (tree, unsigned int *,
unsigned HOST_WIDE_INT *);
extern unsigned int get_pointer_alignment (tree);
extern unsigned string_length (const void*, unsigned, unsigned);
extern tree c_strlen (tree, int);
extern tree c_strlen (tree, int, unsigned = 1);
extern void expand_builtin_setjmp_setup (rtx, rtx);
extern void expand_builtin_setjmp_receiver (rtx);
extern void expand_builtin_update_setjmp_buf (rtx);
@ -77,7 +77,7 @@ extern void expand_ifn_atomic_compare_exchange (gcall *);
extern rtx expand_builtin (tree, rtx, rtx, machine_mode, int);
extern rtx expand_builtin_with_bounds (tree, rtx, rtx, machine_mode, int);
extern enum built_in_function builtin_mathfn_code (const_tree);
extern tree fold_builtin_expect (location_t, tree, tree, tree);
extern tree fold_builtin_expect (location_t, tree, tree, tree, tree);
extern bool avoid_folding_inline_builtin (tree);
extern tree fold_call_expr (location_t, tree, bool);
extern tree fold_builtin_call_array (location_t, tree, tree, int, tree *);

114
gcc/c-family/ChangeLog
View File

@ -1,3 +1,117 @@
2018-08-21 Marek Polacek <polacek@redhat.com>
PR c++/86981, Implement -Wpessimizing-move.
* c.opt (Wpessimizing-move): New option.
2018-08-20 David Malcolm <dmalcolm@redhat.com>
PR other/84889
* c-attribs.c (common_handle_aligned_attribute): Add
auto_diagnostic_group instance.
* c-indentation.c (warn_for_misleading_indentation): Likewise.
* c-opts.c (c_common_post_options): Likewise.
* c-warn.c (warn_logical_not_parentheses): Likewise.
(warn_duplicated_cond_add_or_warn): Likewise.
(warn_for_multistatement_macros): Likewise.
2018-08-20 Nathan Sidwell <nathan@acm.org>
* c-ada-spec.c (macro_length, dump_ada_macros): Adjust macro parm
access.
2018-08-17 Nathan Sidwell <nathan@acm.org>
* c-cppbuiltin.c (struct lazy_hex_fp_value_struct): Remove macro
field.
(laxy_hex_fp_value_count): Make unsigned.
(lazy_hex_fp_value): Provided with macro & lazy number. Directly
manipulate the macro.
(builtin_defin_with_hex_fp_value): Adjust callback name, use
cpp_define_lazily.
2018-08-17 David Malcolm <dmalcolm@redhat.com>
* c-format.c (enum format_type): Add gcc_dump_printf_format_type.
(gcc_dump_printf_length_specs): New.
(gcc_dump_printf_flag_pairs): New.
(gcc_dump_printf_flag_specs): New.
(gcc_dump_printf_char_table): New.
(format_types_orig): Add entry for "gcc_dump_printf".
(init_dynamic_diag_info): Set up length_char_specs and
conversion_specs for gcc_dump_printf_format_type.
(handle_format_attribute): Handle gcc_dump_printf_format_type.
2018-08-17 Nathan Sidwell <nathan@acm.org>
* c-ada-spec.c (macro_length, dump_ada_macros): Constify.
* c-ada-spec.c: Don't #include "cpp-id-data.h"
* c-cppbuiltin.c: Likewise.
2018-08-17 Martin Liska <mliska@suse.cz>
* c.opt: Remove Warn, Init and Report for options with
Ignore/Deprecated flag. Warning is done automatically for
Deprecated flags.
2018-08-16 David Malcolm <dmalcolm@redhat.com>
PR c++/70693
* c-common.c (selftest::c_family_tests): Call
selftest::c_indentation_c_tests.
* c-common.h (selftest::c_indentation_c_tests): New decl.
* c-indentation.c: Include "selftest.h".
(next_tab_stop): Add "tab_width" param, rather than accessing
cpp_opts.
(get_visual_column): Likewise. Clarify comment. Bulletproof
against reading past the end of the line.
(get_first_nws_vis_column): Add "tab_width" param.
(detect_intervening_unindent): Likewise.
(should_warn_for_misleading_indentation): Read tab width from
cpp_opts and pass around.
(selftest::test_next_tab_stop): New test.
(selftest::assert_get_visual_column_succeeds): New function.
(ASSERT_GET_VISUAL_COLUMN_SUCCEEDS): New macro.
(selftest::assert_get_visual_column_fails): New function.
(ASSERT_GET_VISUAL_COLUMN_FAILS): New macro.
(selftest::test_get_visual_column): New test.
(selftest::c_indentation_c_tests): New function.
2018-08-16 Nathan Sidwell <nathan@acm.org>
* c-ada-spec.c (count_ada_macro): Use cpp_user_macro_p.
(store_ada_macro): Likewise.
* c-ppoutput.c (cb_used_define, dump_macro): Likewise.
* c-spellcheck.cc (should-suggest_as_macro_p): Likewise,
2018-08-15 David Malcolm <dmalcolm@redhat.com>
* c-format.c: Include "selftest-diagnostic.h" and
"gcc-rich-location.h".
(format_warning_at_char): Pass NULL for new label params of
format_warning_va.
(class indirection_suffix): New class.
(class range_label_for_format_type_mismatch): New class.
(format_type_warning): Move logic for generating "*" suffix to
class indirection_suffix. Create "fmt_label" and "param_label"
to show their types, and pass them to the
format_warning_at_substring calls.
(selftest::test_type_mismatch_range_labels): New test.
(selftest::c_format_c_tests): Call it.
2018-08-13 Martin Sebor <msebor@redhat.com>
PR tree-optimization/71625
* c-common.c (braced_list_to_string): New function.
* c-common.h (braced_list_to_string): Declare it.
2018-08-08 Nathan Sidwell <nathan@acm.org>
* c-common.c (try_to_locate_new_include_inertion_point): Use
linemap_included_from_linemap.
* c-lex.c (fe_file_change): Use linemap_included_from.
* c-ppoutput.c (pp_file_change): Likewise.
2018-08-01 Martin Sebor <msebor@redhat.com>
PR tree-optimization/86650

42
gcc/c-family/c-ada-spec.c
View File

@ -27,7 +27,6 @@ along with GCC; see the file COPYING3. If not see
#include "c-ada-spec.h"
#include "fold-const.h"
#include "c-pragma.h"
#include "cpp-id-data.h"
#include "stringpool.h"
#include "attribs.h"
@ -70,7 +69,7 @@ macro_length (const cpp_macro *macro, int *supported, int *buffer_len,
(*param_len)++;
for (i = 0; i < macro->paramc; i++)
{
cpp_hashnode *param = macro->params[i];
cpp_hashnode *param = macro->parm.params[i];
*param_len += NODE_LEN (param);
@ -89,7 +88,7 @@ macro_length (const cpp_macro *macro, int *supported, int *buffer_len,
for (j = 0; j < macro->count; j++)
{
cpp_token *token = &macro->exp.tokens[j];
const cpp_token *token = &macro->exp.tokens[j];
if (token->flags & PREV_WHITE)
(*buffer_len)++;
@ -102,7 +101,7 @@ macro_length (const cpp_macro *macro, int *supported, int *buffer_len,
if (token->type == CPP_MACRO_ARG)
*buffer_len +=
NODE_LEN (macro->params[token->val.macro_arg.arg_no - 1]);
NODE_LEN (macro->parm.params[token->val.macro_arg.arg_no - 1]);
else
/* Include enough extra space to handle e.g. special characters. */
*buffer_len += (cpp_token_len (token) + 1) * 8;
@ -171,13 +170,12 @@ static int
count_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *node,
void *v ATTRIBUTE_UNUSED)
{
const cpp_macro *macro = node->value.macro;
if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)
&& macro->count
&& *NODE_NAME (node) != '_'
&& LOCATION_FILE (macro->line) == macro_source_file)
max_ada_macros++;
if (cpp_user_macro_p (node) && *NODE_NAME (node) != '_')
{
const cpp_macro *macro = node->value.macro;
if (macro->count && LOCATION_FILE (macro->line) == macro_source_file)
max_ada_macros++;
}
return 1;
}
@ -190,15 +188,13 @@ static int
store_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED,
cpp_hashnode *node, void *macros)
{
const cpp_macro *macro = node->value.macro;
if (node->type == NT_MACRO
&& !(node->flags & NODE_BUILTIN)
&& macro->count
&& *NODE_NAME (node) != '_'
&& LOCATION_FILE (macro->line) == macro_source_file)
((cpp_hashnode **) macros)[store_ada_macro_index++] = node;
if (cpp_user_macro_p (node) && *NODE_NAME (node) != '_')
{
const cpp_macro *macro = node->value.macro;
if (macro->count
&& LOCATION_FILE (macro->line) == macro_source_file)
((cpp_hashnode **) macros)[store_ada_macro_index++] = node;
}
return 1;
}
@ -256,7 +252,7 @@ dump_ada_macros (pretty_printer *pp, const char* file)
*buf_param++ = '(';
for (i = 0; i < macro->paramc; i++)
{
cpp_hashnode *param = macro->params[i];
cpp_hashnode *param = macro->parm.params[i];
memcpy (buf_param, NODE_NAME (param), NODE_LEN (param));
buf_param += NODE_LEN (param);
@ -278,7 +274,7 @@ dump_ada_macros (pretty_printer *pp, const char* file)
for (i = 0; supported && i < macro->count; i++)
{
cpp_token *token = &macro->exp.tokens[i];
const cpp_token *token = &macro->exp.tokens[i];
int is_one = 0;
if (token->flags & PREV_WHITE)
@ -295,7 +291,7 @@ dump_ada_macros (pretty_printer *pp, const char* file)
case CPP_MACRO_ARG:
{
cpp_hashnode *param =
macro->params[token->val.macro_arg.arg_no - 1];
macro->parm.params[token->val.macro_arg.arg_no - 1];
memcpy (buffer, NODE_NAME (param), NODE_LEN (param));
buffer += NODE_LEN (param);
}

1
gcc/c-family/c-attribs.c
View File

@ -1881,6 +1881,7 @@ common_handle_aligned_attribute (tree *node, tree name, tree args, int flags,
bitalign /= BITS_PER_UNIT;
bool diagd = true;
auto_diagnostic_group d;
if (DECL_USER_ALIGN (decl) || DECL_USER_ALIGN (last_decl))
diagd = warning (OPT_Wattributes,
"ignoring attribute %<%E (%u)%> because it conflicts "

97
gcc/c-family/c-common.c
View File

@ -8370,6 +8370,7 @@ c_family_tests (void)
{
c_common_c_tests ();
c_format_c_tests ();
c_indentation_c_tests ();
c_pretty_print_c_tests ();
c_spellcheck_cc_tests ();
}
@ -8413,8 +8414,8 @@ try_to_locate_new_include_insertion_point (const char *file, location_t loc)
const line_map_ordinary *ord_map
= LINEMAPS_ORDINARY_MAP_AT (line_table, i);
const line_map_ordinary *from = INCLUDED_FROM (line_table, ord_map);
if (from)
if (const line_map_ordinary *from
= linemap_included_from_linemap (line_table, ord_map))
if (from->to_file == file)
{
last_include_ord_map = from;
@ -8509,4 +8510,96 @@ maybe_add_include_fixit (rich_location *richloc, const char *header)
free (text);
}
/* Attempt to convert a braced array initializer list CTOR for array
TYPE into a STRING_CST for convenience and efficiency. When non-null,
use EVAL to attempt to evalue constants (used by C++). Return
the converted string on success or null on failure. */
tree
braced_list_to_string (tree type, tree ctor, tree (*eval)(tree, tree))
{
unsigned HOST_WIDE_INT nelts = CONSTRUCTOR_NELTS (ctor);
/* If the array has an explicit bound, use it to constrain the size
of the string. If it doesn't, be sure to create a string that's
as long as implied by the index of the last zero specified via
a designator, as in:
const char a[] = { [7] = 0 }; */
unsigned HOST_WIDE_INT maxelts = HOST_WIDE_INT_M1U;
if (tree size = TYPE_SIZE_UNIT (type))
{
if (tree_fits_uhwi_p (size))
{
maxelts = tree_to_uhwi (size);
maxelts /= tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (type)));
/* Avoid converting initializers for zero-length arrays. */
if (!maxelts)
return NULL_TREE;
}
}
else if (!nelts)
/* Avoid handling the undefined/erroneous case of an empty
initializer for an arrays with unspecified bound. */
return NULL_TREE;
tree eltype = TREE_TYPE (type);
auto_vec<char> str;
str.reserve (nelts + 1);
unsigned HOST_WIDE_INT i;
tree index, value;
FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), i, index, value)
{
unsigned HOST_WIDE_INT idx = index ? tree_to_uhwi (index) : i;
/* auto_vec is limited to UINT_MAX elements. */
if (idx > UINT_MAX)
return NULL_TREE;
/* Attempt to evaluate constants. */
if (eval)
value = eval (eltype, value);
/* Avoid non-constant initializers. */
if (!tree_fits_shwi_p (value))
return NULL_TREE;
/* Skip over embedded nuls except the last one (initializer
elements are in ascending order of indices). */
HOST_WIDE_INT val = tree_to_shwi (value);
if (!val && i + 1 < nelts)
continue;
/* Bail if the CTOR has a block of more than 256 embedded nuls
due to implicitly initialized elements. */
unsigned nchars = (idx - str.length ()) + 1;
if (nchars > 256)
return NULL_TREE;
if (nchars > 1)
{
str.reserve (idx);
str.quick_grow_cleared (idx);
}
if (idx > maxelts)
return NULL_TREE;
str.safe_insert (idx, val);
}
if (!nelts)
/* Append a nul for the empty initializer { }. */
str.safe_push (0);
/* Build a STRING_CST with the same type as the array, which
may be an array of unknown bound. */
tree res = build_string (str.length (), str.begin ());
TREE_TYPE (res) = type;
return res;
}
#include "gt-c-family-c-common.h"

2
gcc/c-family/c-common.h
View File

@ -1331,12 +1331,14 @@ extern void maybe_add_include_fixit (rich_location *, const char *);
extern void maybe_suggest_missing_token_insertion (rich_location *richloc,
enum cpp_ttype token_type,
location_t prev_token_loc);
extern tree braced_list_to_string (tree, tree, tree (*)(tree, tree) = NULL);
#if CHECKING_P
namespace selftest {
/* Declarations for specific families of tests within c-family,
by source file, in alphabetical order. */
extern void c_format_c_tests (void);
extern void c_indentation_c_tests (void);
extern void c_pretty_print_c_tests (void);
extern void c_spellcheck_cc_tests (void);

58
gcc/c-family/c-cppbuiltin.c
View File

@ -31,7 +31,6 @@ along with GCC; see the file COPYING3. If not see
#include "output.h" /* For user_label_prefix. */
#include "debug.h" /* For dwarf2out_do_cfi_asm. */
#include "common/common-target.h"
#include "cpp-id-data.h"
#include "cppbuiltin.h"
#ifndef TARGET_OS_CPP_BUILTINS
@ -1571,7 +1570,6 @@ builtin_define_with_int_value (const char *macro, HOST_WIDE_INT value)
struct GTY(()) lazy_hex_fp_value_struct
{
const char *hex_str;
cpp_macro *macro;
machine_mode mode;
int digits;
const char *fp_suffix;
@ -1584,36 +1582,35 @@ struct GTY(()) lazy_hex_fp_value_struct
#define LAZY_HEX_FP_VALUES_CNT (4 * (3 + NUM_FLOATN_NX_TYPES))
static GTY(()) struct lazy_hex_fp_value_struct
lazy_hex_fp_values[LAZY_HEX_FP_VALUES_CNT];
static GTY(()) int lazy_hex_fp_value_count;
static GTY(()) unsigned lazy_hex_fp_value_count;
static bool
lazy_hex_fp_value (cpp_reader *pfile ATTRIBUTE_UNUSED,
cpp_hashnode *node)
static void
lazy_hex_fp_value (cpp_reader *, cpp_macro *macro, unsigned num)
{
REAL_VALUE_TYPE real;
char dec_str[64], buf1[256];
unsigned int idx;
if (node->value.builtin < BT_FIRST_USER
|| (int) node->value.builtin >= BT_FIRST_USER + lazy_hex_fp_value_count)
return false;
idx = node->value.builtin - BT_FIRST_USER;
real_from_string (&real, lazy_hex_fp_values[idx].hex_str);
gcc_checking_assert (num < lazy_hex_fp_value_count);
real_from_string (&real, lazy_hex_fp_values[num].hex_str);
real_to_decimal_for_mode (dec_str, &real, sizeof (dec_str),
lazy_hex_fp_values[idx].digits, 0,
lazy_hex_fp_values[idx].mode);
lazy_hex_fp_values[num].digits, 0,
lazy_hex_fp_values[num].mode);
sprintf (buf1, "%s%s", dec_str, lazy_hex_fp_values[idx].fp_suffix);
node->flags &= ~(NODE_BUILTIN | NODE_USED);
node->value.macro = lazy_hex_fp_values[idx].macro;
for (idx = 0; idx < node->value.macro->count; idx++)
if (node->value.macro->exp.tokens[idx].type == CPP_NUMBER)
break;
gcc_assert (idx < node->value.macro->count);
node->value.macro->exp.tokens[idx].val.str.len = strlen (buf1);
node->value.macro->exp.tokens[idx].val.str.text
= (const unsigned char *) ggc_strdup (buf1);
return true;
size_t len
= sprintf (buf1, "%s%s", dec_str, lazy_hex_fp_values[num].fp_suffix);
gcc_assert (len < sizeof (buf1));
for (unsigned idx = 0; idx < macro->count; idx++)
if (macro->exp.tokens[idx].type == CPP_NUMBER)
{
macro->exp.tokens[idx].val.str.len = len;
macro->exp.tokens[idx].val.str.text
= (const unsigned char *) ggc_strdup (buf1);
return;
}
/* We must have replaced a token. */
gcc_unreachable ();
}
/* Pass an object-like macro a hexadecimal floating-point value. */
@ -1632,23 +1629,18 @@ builtin_define_with_hex_fp_value (const char *macro,
&& flag_dump_macros == 0
&& !cpp_get_options (parse_in)->traditional)
{
struct cpp_hashnode *node;
if (lazy_hex_fp_value_count == 0)
cpp_get_callbacks (parse_in)->user_builtin_macro = lazy_hex_fp_value;
cpp_get_callbacks (parse_in)->user_lazy_macro = lazy_hex_fp_value;
sprintf (buf2, fp_cast, "1.1");
sprintf (buf1, "%s=%s", macro, buf2);
cpp_define (parse_in, buf1);
node = C_CPP_HASHNODE (get_identifier (macro));
struct cpp_hashnode *node = C_CPP_HASHNODE (get_identifier (macro));
lazy_hex_fp_values[lazy_hex_fp_value_count].hex_str
= ggc_strdup (hex_str);
lazy_hex_fp_values[lazy_hex_fp_value_count].mode = TYPE_MODE (type);
lazy_hex_fp_values[lazy_hex_fp_value_count].digits = digits;
lazy_hex_fp_values[lazy_hex_fp_value_count].fp_suffix = fp_suffix;
lazy_hex_fp_values[lazy_hex_fp_value_count].macro = node->value.macro;
node->flags |= NODE_BUILTIN;
node->value.builtin
= (enum cpp_builtin_type) (BT_FIRST_USER + lazy_hex_fp_value_count);
lazy_hex_fp_value_count++;
cpp_define_lazily (parse_in, node, lazy_hex_fp_value_count++);
return;
}

215
gcc/c-family/c-format.c
View File

@ -32,8 +32,10 @@ along with GCC; see the file COPYING3. If not see
#include "diagnostic.h"
#include "substring-locations.h"
#include "selftest.h"
#include "selftest-diagnostic.h"
#include "builtins.h"
#include "attribs.h"
#include "gcc-rich-location.h"
/* Handle attributes associated with format checking. */
@ -44,6 +46,7 @@ enum format_type { printf_format_type, asm_fprintf_format_type,
gcc_diag_format_type, gcc_tdiag_format_type,
gcc_cdiag_format_type,
gcc_cxxdiag_format_type, gcc_gfc_format_type,
gcc_dump_printf_format_type,
gcc_objc_string_format_type,
format_type_error = -1};
@ -97,8 +100,8 @@ format_warning_at_char (location_t fmt_string_loc, tree format_string_cst,
substring_loc fmt_loc (fmt_string_loc, string_type, char_idx, char_idx,
char_idx);
bool warned = format_warning_va (fmt_loc, UNKNOWN_LOCATION, NULL, opt,
gmsgid, &ap);
bool warned = format_warning_va (fmt_loc, NULL, UNKNOWN_LOCATION, NULL,
NULL, opt, gmsgid, &ap);
va_end (ap);
return warned;
@ -461,6 +464,7 @@ static const format_length_info gcc_diag_length_specs[] =
#define gcc_tdiag_length_specs gcc_diag_length_specs
#define gcc_cdiag_length_specs gcc_diag_length_specs
#define gcc_cxxdiag_length_specs gcc_diag_length_specs
#define gcc_dump_printf_length_specs gcc_diag_length_specs
/* This differs from printf_length_specs only in that "Z" is not accepted. */
static const format_length_info scanf_length_specs[] =
@ -550,6 +554,7 @@ static const format_flag_pair gcc_diag_flag_pairs[] =
#define gcc_cdiag_flag_pairs gcc_diag_flag_pairs
#define gcc_cxxdiag_flag_pairs gcc_diag_flag_pairs
#define gcc_gfc_flag_pairs gcc_diag_flag_pairs
#define gcc_dump_printf_flag_pairs gcc_diag_flag_pairs
static const format_flag_spec gcc_diag_flag_specs[] =
{
@ -565,6 +570,7 @@ static const format_flag_spec gcc_diag_flag_specs[] =
#define gcc_cdiag_flag_specs gcc_diag_flag_specs
#define gcc_cxxdiag_flag_specs gcc_diag_flag_specs
#define gcc_gfc_flag_specs gcc_diag_flag_specs
#define gcc_dump_printf_flag_specs gcc_diag_flag_specs
static const format_flag_spec scanf_flag_specs[] =
{
@ -786,6 +792,22 @@ static const format_char_info gcc_gfc_char_table[] =
{ NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL }
};
static const format_char_info gcc_dump_printf_char_table[] =
{
/* The conversion specifiers implemented within pp_format. */
PP_FORMAT_CHAR_TABLE,
/* Custom conversion specifiers implemented by dump_pretty_printer. */
/* E and G require a "gimple *" argument at runtime. */
{ "EG", 1, STD_C89, { T89_G, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "\"", NULL },
/* T requires a "tree" at runtime. */
{ "T", 1, STD_C89, { T89_T, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "\"", NULL },
{ NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL }
};
static const format_char_info scan_char_table[] =
{
/* C89 conversion specifiers. */
@ -885,6 +907,13 @@ static const format_kind_info format_types_orig[] =
0, 0, 0, 0, 0, 0,
NULL, NULL
},
{ "gcc_dump_printf", gcc_dump_printf_length_specs,
gcc_dump_printf_char_table, "q+#", NULL,
gcc_dump_printf_flag_specs, gcc_dump_printf_flag_pairs,
FMT_FLAG_ARG_CONVERT,
0, 0, 'p', 0, 'L', 0,
NULL, &integer_type_node
},
{ "NSString", NULL, NULL, NULL, NULL,
NULL, NULL,
FMT_FLAG_ARG_CONVERT|FMT_FLAG_PARSE_ARG_CONVERT_EXTERNAL, 0, 0, 0, 0, 0, 0,
@ -3510,6 +3539,82 @@ get_corrected_substring (const substring_loc &fmt_loc,
return result;
}
/* Helper class for adding zero or more trailing '*' to types.
The format type and name exclude any '*' for pointers, so those
must be formatted manually. For all the types we currently have,
this is adequate, but formats taking pointers to functions or
arrays would require the full type to be built up in order to
print it with %T. */
class indirection_suffix
{
public:
indirection_suffix (int pointer_count) : m_pointer_count (pointer_count) {}
/* Determine the size of the buffer (including NUL-terminator). */
size_t get_buffer_size () const
{
return m_pointer_count + 2;
}
/* Write the '*' to DST and add a NUL-terminator. */
void fill_buffer (char *dst) const
{
if (m_pointer_count == 0)
dst[0] = 0;
else if (c_dialect_cxx ())
{
memset (dst, '*', m_pointer_count);
dst[m_pointer_count] = 0;
}
else
{
dst[0] = ' ';
memset (dst + 1, '*', m_pointer_count);
dst[m_pointer_count + 1] = 0;
}
}
private:
int m_pointer_count;
};
/* Subclass of range_label for labelling the range in the format string
with the type in question, adding trailing '*' for pointer_count. */
class range_label_for_format_type_mismatch
: public range_label_for_type_mismatch
{
public:
range_label_for_format_type_mismatch (tree labelled_type, tree other_type,
int pointer_count)
: range_label_for_type_mismatch (labelled_type, other_type),
m_pointer_count (pointer_count)
{
}
label_text get_text () const FINAL OVERRIDE
{
label_text text = range_label_for_type_mismatch::get_text ();
if (text.m_buffer == NULL)
return text;
indirection_suffix suffix (m_pointer_count);
char *p = (char *) alloca (suffix.get_buffer_size ());
suffix.fill_buffer (p);
char *result = concat (text.m_buffer, p, NULL);
text.maybe_free ();
return label_text (result, true);
}
private:
int m_pointer_count;
};
/* Give a warning about a format argument of different type from that expected.
The range of the diagnostic is taken from WHOLE_FMT_LOC; the caret location
is based on the location of the char at TYPE->offset_loc.
@ -3558,7 +3663,6 @@ format_type_warning (const substring_loc &whole_fmt_loc,
int pointer_count = type->pointer_count;
int arg_num = type->arg_num;
char *p;
/* If ARG_TYPE is a typedef with a misleading name (for example,
size_t but not the standard size_t expected by printf %zu), avoid
printing the typedef name. */
@ -3570,25 +3674,10 @@ format_type_warning (const substring_loc &whole_fmt_loc,
&& !strcmp (wanted_type_name,
lang_hooks.decl_printable_name (TYPE_NAME (arg_type), 2)))
arg_type = TYPE_MAIN_VARIANT (arg_type);
/* The format type and name exclude any '*' for pointers, so those
must be formatted manually. For all the types we currently have,
this is adequate, but formats taking pointers to functions or
arrays would require the full type to be built up in order to
print it with %T. */
p = (char *) alloca (pointer_count + 2);
if (pointer_count == 0)
p[0] = 0;
else if (c_dialect_cxx ())
{
memset (p, '*', pointer_count);
p[pointer_count] = 0;
}
else
{
p[0] = ' ';
memset (p + 1, '*', pointer_count);
p[pointer_count + 1] = 0;
}
indirection_suffix suffix (pointer_count);
char *p = (char *) alloca (suffix.get_buffer_size ());
suffix.fill_buffer (p);
/* WHOLE_FMT_LOC has the caret at the end of the range.
Set the caret to be at the offset from TYPE. Subtract one
@ -3596,6 +3685,10 @@ format_type_warning (const substring_loc &whole_fmt_loc,
substring_loc fmt_loc (whole_fmt_loc);
fmt_loc.set_caret_index (type->offset_loc - 1);
range_label_for_format_type_mismatch fmt_label (wanted_type, arg_type,
pointer_count);
range_label_for_type_mismatch param_label (arg_type, wanted_type);
/* Get a string for use as a replacement fix-it hint for the range in
fmt_loc, or NULL. */
char *corrected_substring
@ -3606,7 +3699,7 @@ format_type_warning (const substring_loc &whole_fmt_loc,
{
if (arg_type)
format_warning_at_substring
(fmt_loc, param_loc,
(fmt_loc, &fmt_label, param_loc, &param_label,
corrected_substring, OPT_Wformat_,
"%s %<%s%.*s%> expects argument of type %<%s%s%>, "
"but argument %d has type %qT",
@ -3616,7 +3709,7 @@ format_type_warning (const substring_loc &whole_fmt_loc,
wanted_type_name, p, arg_num, arg_type);
else
format_warning_at_substring
(fmt_loc, param_loc,
(fmt_loc, &fmt_label, param_loc, &param_label,
corrected_substring, OPT_Wformat_,
"%s %<%s%.*s%> expects a matching %<%s%s%> argument",
gettext (kind_descriptions[kind]),
@ -3627,7 +3720,7 @@ format_type_warning (const substring_loc &whole_fmt_loc,
{
if (arg_type)
format_warning_at_substring
(fmt_loc, param_loc,
(fmt_loc, &fmt_label, param_loc, &param_label,
corrected_substring, OPT_Wformat_,
"%s %<%s%.*s%> expects argument of type %<%T%s%>, "
"but argument %d has type %qT",
@ -3637,7 +3730,7 @@ format_type_warning (const substring_loc &whole_fmt_loc,
wanted_type, p, arg_num, arg_type);
else
format_warning_at_substring
(fmt_loc, param_loc,
(fmt_loc, &fmt_label, param_loc, &param_label,
corrected_substring, OPT_Wformat_,
"%s %<%s%.*s%> expects a matching %<%T%s%> argument",
gettext (kind_descriptions[kind]),
@ -3905,6 +3998,7 @@ init_dynamic_diag_info (void)
dynamic_format_types[gcc_tdiag_format_type].length_char_specs =
dynamic_format_types[gcc_cdiag_format_type].length_char_specs =
dynamic_format_types[gcc_cxxdiag_format_type].length_char_specs =
dynamic_format_types[gcc_dump_printf_format_type].length_char_specs =
diag_ls = (format_length_info *)
xmemdup (gcc_diag_length_specs,
sizeof (gcc_diag_length_specs),
@ -3931,6 +4025,8 @@ init_dynamic_diag_info (void)
gcc_cdiag_char_table;
dynamic_format_types[gcc_cxxdiag_format_type].conversion_specs =
gcc_cxxdiag_char_table;
dynamic_format_types[gcc_dump_printf_format_type].conversion_specs =
gcc_dump_printf_char_table;
}
#ifdef TARGET_FORMAT_TYPES
@ -4085,7 +4181,8 @@ handle_format_attribute (tree *node, tree ARG_UNUSED (name), tree args,
|| info.format_type == gcc_diag_format_type
|| info.format_type == gcc_tdiag_format_type
|| info.format_type == gcc_cdiag_format_type
|| info.format_type == gcc_cxxdiag_format_type)
|| info.format_type == gcc_cxxdiag_format_type
|| info.format_type == gcc_dump_printf_format_type)
{
/* Our first time through, we have to make sure that our
format_type data is allocated dynamically and is modifiable. */
@ -4107,7 +4204,8 @@ handle_format_attribute (tree *node, tree ARG_UNUSED (name), tree args,
else if (info.format_type == gcc_diag_format_type
|| info.format_type == gcc_tdiag_format_type
|| info.format_type == gcc_cdiag_format_type
|| info.format_type == gcc_cxxdiag_format_type)
|| info.format_type == gcc_cxxdiag_format_type
|| info.format_type == gcc_dump_printf_format_type)
init_dynamic_diag_info ();
else
gcc_unreachable ();
@ -4217,6 +4315,66 @@ test_get_format_for_type_scanf ()
#undef ASSERT_FORMAT_FOR_TYPE_STREQ
/* Exercise the type-printing label code, to give some coverage
under "make selftest-valgrind" (in particular, to ensure that
the label-printing machinery doesn't leak). */
static void
test_type_mismatch_range_labels ()
{
/* Create a tempfile and write some text to it.
....................0000000001 11111111 12 22222222
....................1234567890 12345678 90 12345678. */
const char *content = " printf (\"msg: %i\\n\", msg);\n";
temp_source_file tmp (SELFTEST_LOCATION, ".c", content);
line_table_test ltt;
linemap_add (line_table, LC_ENTER, false, tmp.get_filename (), 1);
location_t c17 = linemap_position_for_column (line_table, 17);
ASSERT_EQ (LOCATION_COLUMN (c17), 17);
location_t c18 = linemap_position_for_column (line_table, 18);
location_t c24 = linemap_position_for_column (line_table, 24);
location_t c26 = linemap_position_for_column (line_table, 26);
/* Don't attempt to run the tests if column data might be unavailable. */
if (c26 > LINE_MAP_MAX_LOCATION_WITH_COLS)
return;
location_t fmt = make_location (c18, c17, c18);
ASSERT_EQ (LOCATION_COLUMN (fmt), 18);
location_t param = make_location (c24, c24, c26);
ASSERT_EQ (LOCATION_COLUMN (param), 24);
range_label_for_format_type_mismatch fmt_label (char_type_node,
integer_type_node, 1);
range_label_for_type_mismatch param_label (integer_type_node,
char_type_node);
gcc_rich_location richloc (fmt, &fmt_label);
richloc.add_range (param, false, &param_label);
test_diagnostic_context dc;
diagnostic_show_locus (&dc, &richloc, DK_ERROR);
if (c_dialect_cxx ())
/* "char*", without a space. */
ASSERT_STREQ ("\n"
" printf (\"msg: %i\\n\", msg);\n"
" ~^ ~~~\n"
" | |\n"
" char* int\n",
pp_formatted_text (dc.printer));
else
/* "char *", with a space. */
ASSERT_STREQ ("\n"
" printf (\"msg: %i\\n\", msg);\n"
" ~^ ~~~\n"
" | |\n"
" | int\n"
" char *\n",
pp_formatted_text (dc.printer));
}
/* Run all of the selftests within this file. */
void
@ -4225,6 +4383,7 @@ c_format_c_tests ()
test_get_modifier_for_format_len ();
test_get_format_for_type_printf ();
test_get_format_for_type_scanf ();
test_type_mismatch_range_labels ();
}
} // namespace selftest

193
gcc/c-family/c-indentation.c
View File

@ -23,15 +23,15 @@ along with GCC; see the file COPYING3. If not see
#include "tm.h"
#include "c-common.h"
#include "c-indentation.h"
#include "selftest.h"
extern cpp_options *cpp_opts;
/* Round up VIS_COLUMN to nearest tab stop. */
static unsigned int
next_tab_stop (unsigned int vis_column)
next_tab_stop (unsigned int vis_column, unsigned int tab_width)
{
const unsigned int tab_width = cpp_opts->tabstop;
vis_column = ((vis_column + tab_width) / tab_width) * tab_width;
return vis_column;
}
@ -43,12 +43,13 @@ next_tab_stop (unsigned int vis_column)
Returns true if a conversion was possible, writing the result to OUT,
otherwise returns false. If FIRST_NWS is not NULL, then write to it
the visual column corresponding to the first non-whitespace character
on the line. */
on the line (up to or before EXPLOC). */
static bool
get_visual_column (expanded_location exploc, location_t loc,
unsigned int *out,
unsigned int *first_nws)
unsigned int *first_nws,
unsigned int tab_width)
{
/* PR c++/68819: if the column number is zero, we presumably
had a location_t > LINE_MAP_MAX_LOCATION_WITH_COLS, and so
@ -73,6 +74,8 @@ get_visual_column (expanded_location exploc, location_t loc,
char_span line = location_get_source_line (exploc.file, exploc.line);
if (!line)
return false;
if ((size_t)exploc.column > line.length ())
return false;
unsigned int vis_column = 0;
for (int i = 1; i < exploc.column; i++)
{
@ -85,7 +88,7 @@ get_visual_column (expanded_location exploc, location_t loc,
}
if (ch == '\t')
vis_column = next_tab_stop (vis_column);
vis_column = next_tab_stop (vis_column, tab_width);
else
vis_column++;
}
@ -106,7 +109,8 @@ get_visual_column (expanded_location exploc, location_t loc,
static bool
get_first_nws_vis_column (const char *file, int line_num,
unsigned int *first_nws)
unsigned int *first_nws,
unsigned int tab_width)
{
gcc_assert (first_nws);
@ -125,7 +129,7 @@ get_first_nws_vis_column (const char *file, int line_num,
}
if (ch == '\t')
vis_column = next_tab_stop (vis_column);
vis_column = next_tab_stop (vis_column, tab_width);
else
vis_column++;
}
@ -178,7 +182,8 @@ static bool
detect_intervening_unindent (const char *file,
int body_line,
int next_stmt_line,
unsigned int vis_column)
unsigned int vis_column,
unsigned int tab_width)
{
gcc_assert (file);
gcc_assert (next_stmt_line > body_line);
@ -186,7 +191,7 @@ detect_intervening_unindent (const char *file,
for (int line = body_line + 1; line < next_stmt_line; line++)
{
unsigned int line_vis_column;
if (get_first_nws_vis_column (file, line, &line_vis_column))
if (get_first_nws_vis_column (file, line, &line_vis_column, tab_width))
if (line_vis_column < vis_column)
return true;
}
@ -289,6 +294,8 @@ should_warn_for_misleading_indentation (const token_indent_info &guard_tinfo,
expanded_location next_stmt_exploc = expand_location (next_stmt_loc);
expanded_location guard_exploc = expand_location (guard_loc);
const unsigned int tab_width = cpp_opts->tabstop;
/* They must be in the same file. */
if (next_stmt_exploc.file != body_exploc.file)
return false;
@ -334,7 +341,7 @@ should_warn_for_misleading_indentation (const token_indent_info &guard_tinfo,
unsigned int guard_line_first_nws;
if (!get_visual_column (guard_exploc, guard_loc,
&guard_vis_column,
&guard_line_first_nws))
&guard_line_first_nws, tab_width))
return false;
/* Heuristic: only warn if the guard is the first thing
on its line. */
@ -394,15 +401,15 @@ should_warn_for_misleading_indentation (const token_indent_info &guard_tinfo,
it's not clear that it's meaningful to look at indentation. */
if (!get_visual_column (next_stmt_exploc, next_stmt_loc,
&next_stmt_vis_column,
&next_stmt_line_first_nws))
&next_stmt_line_first_nws, tab_width))
return false;
if (!get_visual_column (body_exploc, body_loc,
&body_vis_column,
&body_line_first_nws))
&body_line_first_nws, tab_width))
return false;
if (!get_visual_column (guard_exploc, guard_loc,
&guard_vis_column,
&guard_line_first_nws))
&guard_line_first_nws, tab_width))
return false;
/* If the line where the next stmt starts has non-whitespace
@ -486,7 +493,7 @@ should_warn_for_misleading_indentation (const token_indent_info &guard_tinfo,
int vis_column = MIN (next_stmt_vis_column, body_vis_column);
if (detect_intervening_unindent (body_exploc.file, body_exploc.line,
next_stmt_exploc.line,
vis_column))
vis_column, tab_width))
return false;
/* Otherwise, they are visually aligned: issue a warning. */
@ -602,6 +609,7 @@ warn_for_misleading_indentation (const token_indent_info &guard_tinfo,
body_tinfo,
next_tinfo))
{
auto_diagnostic_group d;
if (warning_at (guard_tinfo.location, OPT_Wmisleading_indentation,
"this %qs clause does not guard...",
guard_tinfo_to_string (guard_tinfo.keyword)))
@ -611,3 +619,160 @@ warn_for_misleading_indentation (const token_indent_info &guard_tinfo,
guard_tinfo_to_string (guard_tinfo.keyword));
}
}
#if CHECKING_P
namespace selftest {
/* Verify that next_tab_stop works as expected. */
static void
test_next_tab_stop ()
{
const unsigned int tab_width = 8;
ASSERT_EQ (next_tab_stop (0, tab_width), 8);
ASSERT_EQ (next_tab_stop (1, tab_width), 8);
ASSERT_EQ (next_tab_stop (7, tab_width), 8);
ASSERT_EQ (next_tab_stop (8, tab_width), 16);
ASSERT_EQ (next_tab_stop (9, tab_width), 16);
ASSERT_EQ (next_tab_stop (15, tab_width), 16);
ASSERT_EQ (next_tab_stop (16, tab_width), 24);
ASSERT_EQ (next_tab_stop (17, tab_width), 24);
ASSERT_EQ (next_tab_stop (23, tab_width), 24);
}
/* Verify that the given call to get_visual_column succeeds, with
the given results. */
static void
assert_get_visual_column_succeeds (const location &loc,
const char *file, int line, int column,
const unsigned int tab_width,
unsigned int expected_visual_column,
unsigned int expected_first_nws)
{
expanded_location exploc;
exploc.file = file;
exploc.line = line;
exploc.column = column;
exploc.data = NULL;
exploc.sysp = false;
unsigned int actual_visual_column;
unsigned int actual_first_nws;
bool result = get_visual_column (exploc, UNKNOWN_LOCATION,
&actual_visual_column,
&actual_first_nws, tab_width);
ASSERT_TRUE_AT (loc, result);
ASSERT_EQ_AT (loc, actual_visual_column, expected_visual_column);
ASSERT_EQ_AT (loc, actual_first_nws, expected_first_nws);
}
/* Verify that the given call to get_visual_column succeeds, with
the given results. */
#define ASSERT_GET_VISUAL_COLUMN_SUCCEEDS(FILENAME, LINE, COLUMN, \
TAB_WIDTH, \
EXPECTED_VISUAL_COLUMN, \
EXPECTED_FIRST_NWS) \
SELFTEST_BEGIN_STMT \
assert_get_visual_column_succeeds (SELFTEST_LOCATION, \
FILENAME, LINE, COLUMN, \
TAB_WIDTH, \
EXPECTED_VISUAL_COLUMN, \
EXPECTED_FIRST_NWS); \
SELFTEST_END_STMT
/* Verify that the given call to get_visual_column fails gracefully. */
static void
assert_get_visual_column_fails (const location &loc,
const char *file, int line, int column,
const unsigned int tab_width)
{
expanded_location exploc;
exploc.file = file;
exploc.line = line;
exploc.column = column;
exploc.data = NULL;
exploc.sysp = false;
unsigned int actual_visual_column;
unsigned int actual_first_nws;
bool result = get_visual_column (exploc, UNKNOWN_LOCATION,
&actual_visual_column,
&actual_first_nws, tab_width);
ASSERT_FALSE_AT (loc, result);
}
/* Verify that the given call to get_visual_column fails gracefully. */
#define ASSERT_GET_VISUAL_COLUMN_FAILS(FILENAME, LINE, COLUMN, \
TAB_WIDTH) \
SELFTEST_BEGIN_STMT \
assert_get_visual_column_fails (SELFTEST_LOCATION, \
FILENAME, LINE, COLUMN, \
TAB_WIDTH); \
SELFTEST_END_STMT
/* Verify that get_visual_column works as expected. */
static void
test_get_visual_column ()
{
/* Create a tempfile with a mixture of tabs and spaces.
Both lines have either a space or a tab, then " line N",
for 8 characters in total.
1-based "columns" (w.r.t. to line 1):
.....................0000000001111.
.....................1234567890123. */
const char *content = (" line 1\n"
"\t line 2\n");
line_table_test ltt;
temp_source_file tmp (SELFTEST_LOCATION, ".txt", content);
const unsigned int tab_width = 8;
const char *file = tmp.get_filename ();
/* Line 1 (space-based indentation). */
{
const int line = 1;
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 1, tab_width, 0, 0);
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 2, tab_width, 1, 1);
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 3, tab_width, 2, 2);
/* first_nws should have stopped increasing. */
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 4, tab_width, 3, 2);
/* Verify the end-of-line boundary. */
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 8, tab_width, 7, 2);
ASSERT_GET_VISUAL_COLUMN_FAILS (file, line, 9, tab_width);
}
/* Line 2 (tab-based indentation). */
{
const int line = 2;
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 1, tab_width, 0, 0);
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 2, tab_width, 8, 8);
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 3, tab_width, 9, 9);
/* first_nws should have stopped increasing. */
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 4, tab_width, 10, 9);
/* Verify the end-of-line boundary. */
ASSERT_GET_VISUAL_COLUMN_SUCCEEDS (file, line, 8, tab_width, 14, 9);
ASSERT_GET_VISUAL_COLUMN_FAILS (file, line, 9, tab_width);
}
}
/* Run all of the selftests within this file. */
void
c_indentation_c_tests ()
{
test_next_tab_stop ();
test_get_visual_column ();
}
} // namespace selftest
#endif /* CHECKING_P */

2
gcc/c-family/c-lex.c
View File

@ -199,7 +199,7 @@ fe_file_change (const line_map_ordinary *new_map)
we already did in compile_file. */
if (!MAIN_FILE_P (new_map))
{
unsigned int included_at = LAST_SOURCE_LINE_LOCATION (new_map - 1);
location_t included_at = linemap_included_from (new_map);
int line = 0;
if (included_at > BUILTINS_LOCATION)
line = SOURCE_LINE (new_map - 1, included_at);

1
gcc/c-family/c-opts.c
View File

@ -931,6 +931,7 @@ c_common_post_options (const char **pfilename)
warn_abi_version = latest_abi_version;
if (flag_abi_version == latest_abi_version)
{
auto_diagnostic_group d;
if (warning (OPT_Wabi, "-Wabi won't warn about anything"))
{
inform (input_location, "-Wabi warns about differences "

23
gcc/c-family/c-ppoutput.c
View File

@ -532,13 +532,14 @@ static void
cb_used_define (cpp_reader *pfile, source_location line ATTRIBUTE_UNUSED,
cpp_hashnode *node)
{
macro_queue *q;
if (node->flags & NODE_BUILTIN)
return;
q = XNEW (macro_queue);
q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node));
q->next = define_queue;
define_queue = q;
if (cpp_user_macro_p (node))
{
macro_queue *q;
q = XNEW (macro_queue);
q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node));
q->next = define_queue;
define_queue = q;
}
}
static void
@ -663,11 +664,9 @@ pp_file_change (const line_map_ordinary *map)
/* Bring current file to correct line when entering a new file. */
if (map->reason == LC_ENTER)
{
const line_map_ordinary *from = INCLUDED_FROM (line_table, map);
maybe_print_line (LAST_SOURCE_LINE_LOCATION (from));
maybe_print_line (linemap_included_from (map));
flags = " 1";
}
if (map->reason == LC_ENTER)
flags = " 1";
else if (map->reason == LC_LEAVE)
flags = " 2";
print_line (map->start_location, flags);
@ -690,7 +689,7 @@ cb_def_pragma (cpp_reader *pfile, source_location line)
static int
dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED)
{
if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN))
if (cpp_user_macro_p (node))
{
fputs ("#define ", print.outf);
fputs ((const char *) cpp_macro_definition (pfile, node),

Some files were not shown because too many files have changed in this diff Show More