OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated cases. 

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated
	cases.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_ch9.adb (Analyze_Task_Body): Aspects are illegal
	(Analyze_Protected_Body): Aspects are illegal.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb, sem_ch13.adb: Minor reformatting.
	* sem_case.adb (Check_Choices): Fix bad listing of missing
	values from predicated subtype case (Check_Choices): List
	duplicated values.
	* errout.adb (Set_Msg_Text): Process warning tags in VMS mode
	* erroutc.adb (Output_Msg_Text): Handle VMS warning tags
	* gnat_ugn.texi: Document /WARNINGS=TAG_WARNINGS for VMS
	* ug_words: Add entries for -gnatw.d and -gnatw.D
	* vms_data.ads: Add [NO]TAG_WARNINGS for -gnatw.D/-gnatw.d
	* lib-writ.ads: Documentation fixes

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* a-wichha.adb, a-wichha.ads, a-zchhan.adb, a-zchhan.ads
	(Is_Other_Format): New name for Is_Other.
	(Is_Punctuation_Connector): New name for Is_Punctuation

From-SVN: r203366
This commit is contained in:
Robert Dewar 2013-10-10 12:38:44 +00:00 committed by Arnaud Charlet
parent ea3c0651d3
commit 882eadaf20
16 changed files with 606 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/ada/ChangeLog
View File

@ -1,3 +1,32 @@
2013-10-10 Robert Dewar <dewar@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated
cases.
2013-10-10 Robert Dewar <dewar@adacore.com>
* sem_ch9.adb (Analyze_Task_Body): Aspects are illegal
(Analyze_Protected_Body): Aspects are illegal.
2013-10-10 Robert Dewar <dewar@adacore.com>
* sem_ch6.adb, sem_ch13.adb: Minor reformatting.
* sem_case.adb (Check_Choices): Fix bad listing of missing
values from predicated subtype case (Check_Choices): List
duplicated values.
* errout.adb (Set_Msg_Text): Process warning tags in VMS mode
* erroutc.adb (Output_Msg_Text): Handle VMS warning tags
* gnat_ugn.texi: Document /WARNINGS=TAG_WARNINGS for VMS
* ug_words: Add entries for -gnatw.d and -gnatw.D
* vms_data.ads: Add [NO]TAG_WARNINGS for -gnatw.D/-gnatw.d
* lib-writ.ads: Documentation fixes
2013-10-10 Robert Dewar <dewar@adacore.com>
* a-wichha.adb, a-wichha.ads, a-zchhan.adb, a-zchhan.ads
(Is_Other_Format): New name for Is_Other.
(Is_Punctuation_Connector): New name for Is_Punctuation
2013-10-10 Hristian Kirtchev <kirtchev@adacore.com>
* aspects.adb: Add entries in table Canonical_Aspects for aspects

18
gcc/ada/a-wichha.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -108,18 +108,18 @@ package body Ada.Wide_Characters.Handling is
function Is_Mark (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Mark;
--------------
-- Is_Other --
--------------
---------------------
-- Is_Other_Format --
---------------------
function Is_Other (Item : Wide_Character) return Boolean
function Is_Other_Format (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Other;
--------------------
-- Is_Punctuation --
--------------------
------------------------------
-- Is_Punctuation_Connector --
------------------------------
function Is_Punctuation (Item : Wide_Character) return Boolean
function Is_Punctuation_Connector (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Punctuation;
--------------

8
gcc/ada/a-wichha.ads
View File

@ -78,13 +78,13 @@ package Ada.Wide_Characters.Handling is
-- Returns True if the Wide_Character designated by Item is categorized as
-- mark_non_spacing or mark_spacing_combining, otherwise returns false.
function Is_Other (Item : Wide_Character) return Boolean;
pragma Inline (Is_Other);
function Is_Other_Format (Item : Wide_Character) return Boolean;
pragma Inline (Is_Other_Format);
-- Returns True if the Wide_Character designated by Item is categorized as
-- other_format, otherwise returns false.
function Is_Punctuation (Item : Wide_Character) return Boolean;
pragma Inline (Is_Punctuation);
function Is_Punctuation_Connector (Item : Wide_Character) return Boolean;
pragma Inline (Is_Punctuation_Connector);
-- Returns True if the Wide_Character designated by Item is categorized as
-- punctuation_connector, otherwise returns false.

19
gcc/ada/a-zchhan.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -108,18 +108,19 @@ package body Ada.Wide_Wide_Characters.Handling is
function Is_Mark (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Mark;
--------------
-- Is_Other --
--------------
---------------------
-- Is_Other_Format --
---------------------
function Is_Other (Item : Wide_Wide_Character) return Boolean
function Is_Other_Format (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Other;
--------------------
-- Is_Punctuation --
--------------------
------------------------------
-- Is_Punctuation_Connector --
------------------------------
function Is_Punctuation (Item : Wide_Wide_Character) return Boolean
function Is_Punctuation_Connector
(Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Punctuation;
--------------

9
gcc/ada/a-zchhan.ads
View File

@ -82,13 +82,14 @@ package Ada.Wide_Wide_Characters.Handling is
-- categorized as mark_non_spacing or mark_spacing_combining, otherwise
-- returns false.
function Is_Other (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Other);
function Is_Other_Format (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Other_Format);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as other_format, otherwise returns false.
function Is_Punctuation (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Punctuation);
function Is_Punctuation_Connector
(Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Punctuation_Connector);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as punctuation_connector, otherwise returns false.

6
gcc/ada/errout.adb
View File

@ -49,7 +49,6 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Uname; use Uname;
package body Errout is
@ -2705,7 +2704,7 @@ package body Errout is
Warning_Msg_Char := ' ';
if P <= Text'Last and then Text (P) = '?' then
if Warning_Doc_Switch and not OpenVMS_On_Target then
if Warning_Doc_Switch then
Warning_Msg_Char := '?';
end if;
@ -2717,7 +2716,7 @@ package body Errout is
Text (P) in 'A' .. 'Z')
and then Text (P + 1) = '?'
then
if Warning_Doc_Switch and not OpenVMS_On_Target then
if Warning_Doc_Switch then
Warning_Msg_Char := Text (P);
end if;
@ -2805,7 +2804,6 @@ package body Errout is
if Error_Msg_Warn
and Warning_Doc_Switch
and not OpenVMS_On_Target
then
Warning_Msg_Char := '?';
end if;

268
gcc/ada/erroutc.adb
View File

@ -31,6 +31,7 @@
with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Err_Vars; use Err_Vars;
with Namet; use Namet;
@ -450,6 +451,257 @@ package body Erroutc is
Split : Natural;
Start : Natural;
function Get_VMS_Warn_String (W : Character) return String;
-- On VMS, given a warning character W, returns VMS command string
-- that corresponds to that warning character
-------------------------
-- Get_VMS_Warn_String --
-------------------------
function Get_VMS_Warn_String (W : Character) return String is
S, E : Natural;
-- Start and end of VMS_QUALIFIER below
P : Natural;
-- Scans through string
-- The following is a copy of the S_GCC_Warn string from the package
-- VMS_Data. If we made that package part of the compiler sources
-- we could just with it and avoid the duplication ???
V : constant String := "/WARNINGS=" &
"DEFAULT " &
"!-gnatws,!-gnatwe " &
"ALL " &
"-gnatwa " &
"EVERY " &
"-gnatw.e " &
"OPTIONAL " &
"-gnatwa " &
"NOOPTIONAL " &
"-gnatwA " &
"NOALL " &
"-gnatwA " &
"ALL_GCC " &
"-Wall " &
"FAILING_ASSERTIONS " &
"-gnatw.a " &
"NO_FAILING_ASSERTIONS " &
"-gnatw.A " &
"BAD_FIXED_VALUES " &
"-gnatwb " &
"NO_BAD_FIXED_VALUES " &
"-gnatwB " &
"BIASED_REPRESENTATION " &
"-gnatw.b " &
"NO_BIASED_REPRESENTATION " &
"-gnatw.B " &
"CONDITIONALS " &
"-gnatwc " &
"NOCONDITIONALS " &
"-gnatwC " &
"MISSING_COMPONENT_CLAUSES " &
"-gnatw.c " &
"NOMISSING_COMPONENT_CLAUSES " &
"-gnatw.C " &
"IMPLICIT_DEREFERENCE " &
"-gnatwd " &
"NO_IMPLICIT_DEREFERENCE " &
"-gnatwD " &
"TAG_WARNINGS " &
"-gnatw.d " &
"NOTAG_WARNINGS " &
"-gnatw.D " &
"ERRORS " &
"-gnatwe " &
"UNREFERENCED_FORMALS " &
"-gnatwf " &
"NOUNREFERENCED_FORMALS " &
"-gnatwF " &
"UNRECOGNIZED_PRAGMAS " &
"-gnatwg " &
"NOUNRECOGNIZED_PRAGMAS " &
"-gnatwG " &
"HIDING " &
"-gnatwh " &
"NOHIDING " &
"-gnatwH " &
"AVOIDGAPS " &
"-gnatw.h " &
"NOAVOIDGAPS " &
"-gnatw.H " &
"IMPLEMENTATION " &
"-gnatwi " &
"NOIMPLEMENTATION " &
"-gnatwI " &
"OBSOLESCENT " &
"-gnatwj " &
"NOOBSOLESCENT " &
"-gnatwJ " &
"CONSTANT_VARIABLES " &
"-gnatwk " &
"NOCONSTANT_VARIABLES " &
"-gnatwK " &
"STANDARD_REDEFINITION " &
"-gnatw.k " &
"NOSTANDARD_REDEFINITION " &
"-gnatw.K " &
"ELABORATION " &
"-gnatwl " &
"NOELABORATION " &
"-gnatwL " &
"MODIFIED_UNREF " &
"-gnatwm " &
"NOMODIFIED_UNREF " &
"-gnatwM " &
"SUSPICIOUS_MODULUS " &
"-gnatw.m " &
"NOSUSPICIOUS_MODULUS " &
"-gnatw.M " &
"NORMAL " &
"-gnatwn " &
"OVERLAYS " &
"-gnatwo " &
"NOOVERLAYS " &
"-gnatwO " &
"OUT_PARAM_UNREF " &
"-gnatw.o " &
"NOOUT_PARAM_UNREF " &
"-gnatw.O " &
"INEFFECTIVE_INLINE " &
"-gnatwp " &
"NOINEFFECTIVE_INLINE " &
"-gnatwP " &
"MISSING_PARENS " &
"-gnatwq " &
"PARAMETER_ORDER " &
"-gnatw.p " &
"NOPARAMETER_ORDER " &
"-gnatw.P " &
"NOMISSING_PARENS " &
"-gnatwQ " &
"REDUNDANT " &
"-gnatwr " &
"NOREDUNDANT " &
"-gnatwR " &
"OBJECT_RENAMES " &
"-gnatw.r " &
"NOOBJECT_RENAMES " &
"-gnatw.R " &
"SUPPRESS " &
"-gnatws " &
"OVERRIDING_SIZE " &
"-gnatw.s " &
"NOOVERRIDING_SIZE " &
"-gnatw.S " &
"DELETED_CODE " &
"-gnatwt " &
"NODELETED_CODE " &
"-gnatwT " &
"UNINITIALIZED " &
"-Wuninitialized " &
"UNUSED " &
"-gnatwu " &
"NOUNUSED " &
"-gnatwU " &
"UNORDERED_ENUMERATIONS " &
"-gnatw.u " &
"NOUNORDERED_ENUMERATIONS " &
"-gnatw.U " &
"VARIABLES_UNINITIALIZED " &
"-gnatwv " &
"NOVARIABLES_UNINITIALIZED " &
"-gnatwV " &
"REVERSE_BIT_ORDER " &
"-gnatw.v " &
"NOREVERSE_BIT_ORDER " &
"-gnatw.V " &
"LOWBOUND_ASSUMED " &
"-gnatww " &
"NOLOWBOUND_ASSUMED " &
"-gnatwW " &
"WARNINGS_OFF_PRAGMAS " &
"-gnatw.w " &
"NO_WARNINGS_OFF_PRAGMAS " &
"-gnatw.W " &
"IMPORT_EXPORT_PRAGMAS " &
"-gnatwx " &
"NOIMPORT_EXPORT_PRAGMAS " &
"-gnatwX " &
"LOCAL_RAISE_HANDLING " &
"-gnatw.x " &
"NOLOCAL_RAISE_HANDLING " &
"-gnatw.X " &
"ADA_2005_COMPATIBILITY " &
"-gnatwy " &
"NOADA_2005_COMPATIBILITY " &
"-gnatwY " &
"UNCHECKED_CONVERSIONS " &
"-gnatwz " &
"NOUNCHECKED_CONVERSIONS " &
"-gnatwZ";
-- Start of processing for Get_VMS_Warn_String
begin
-- This function works by inspecting the string S_GCC_Warn in the
-- package VMS_Data. We are looking for
-- space VMS_QUALIFIER space -gnatwq
-- where q is the lower case letter W if W is lower case, and the
-- two character string .W if W is upper case. If we find a match
-- we return VMS_QUALIFIER, otherwise we return empty (this should
-- be an error, but no point in bombing over something so trivial).
P := 1;
-- Loop through entries in S_GCC_Warn
loop
-- Scan to next blank
loop
if P >= V'Last - 1 then
return "";
end if;
exit when V (P) = ' ' and then V (P + 1) in 'A' .. 'Z';
P := P + 1;
end loop;
P := P + 1;
S := P;
-- Scan to blank at end of VMS_QUALIFIER
loop
if P >= V'Last then
return "";
end if;
exit when V (P) = ' ';
P := P + 1;
end loop;
E := P - 1;
-- See if this entry matches, and if so, return it
if V (P + 1 .. P + 6) = "-gnatw"
and then
((W in 'a' .. 'z' and then V (P + 7) = W)
or else
(V (P + 7) = '.' and then Fold_Upper (V (P + 8)) = W))
then
return V (S .. E);
end if;
end loop;
end Get_VMS_Warn_String;
-- Start of processing for Output_Msg_Text
begin
-- Add warning doc tag if needed
@ -457,14 +709,22 @@ package body Erroutc is
if Warn_Chr = '?' then
Warn_Tag := new String'(" [enabled by default]");
elsif OpenVMS_On_Target then
declare
Qual : constant String := Get_VMS_Warn_String (Warn_Chr);
begin
if Qual = "" then
Warn_Tag := new String'(Qual);
else
Warn_Tag := new String'(" [" & Qual & ']');
end if;
end;
elsif Warn_Chr in 'a' .. 'z' then
Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']');
else pragma Assert (Warn_Chr in 'A' .. 'Z');
Warn_Tag :=
new String'(" [-gnatw."
& Character'Val (Character'Pos (Warn_Chr) + 32)
& ']');
Warn_Tag := new String'(" [-gnatw." & Fold_Lower (Warn_Chr) & ']');
end if;
else

20
gcc/ada/gnat_ugn.texi
View File

@ -4782,9 +4782,7 @@ individually controlled. The warnings that are not turned on by this
switch are
@option{-gnatwd} (implicit dereferencing),
@option{-gnatwh} (hiding),
@ifclear vms
@option{-gnatw.d} (tag warnings with -gnatw switch)
@end ifclear
@option{-gnatw.h} (holes (gaps) in record layouts)
@option{-gnatw.i} (overlapping actuals),
@option{-gnatw.k} (redefinition of names in standard),
@ -4951,6 +4949,24 @@ mode in which warnings are not tagged as described above for
@code{-gnatw.d}.
@end ifclear
@ifset vms
@item -gnatw.d
@emph{Activate tagging of warning messages.}
@cindex @option{-gnatw.d} (@command{gcc})
If this switch is set, then warning messages are tagged, either with
the appropriate WARNINGS qualifier string (e.g. [SUSPICIOUS_MODULUS]
or with ``[enabled by default]'' if the warning is not under control of a
specific WARNING qualifier switch. This mode is off by default, and is not
affected by the use of @code{-gnatwa}.
@item -gnatw.D
@emph{Deactivate tagging of warning messages.}
@cindex @option{-gnatw.d} (@command{gcc})
If this switch is set, then warning messages return to the default
mode in which warnings are not tagged as described above for
@code{-gnatw.d}.
@end ifset
@item -gnatwe
@emph{Treat warnings and style checks as errors.}
@cindex @option{-gnatwe} (@command{gcc})

108
gcc/ada/lib-writ.ads
View File

@ -183,55 +183,55 @@ package Lib.Writ is
-- corresponding source file. Parameters is a sequence of zero or more
-- two letter codes that indicate configuration pragmas and other
-- parameters that apply:
--
-- The arguments are as follows:
--
-- CE Compilation errors. If this is present it means that the ali
-- file resulted from a compilation with the -gnatQ switch set,
-- and illegalities were detected. The ali file contents may
-- not be completely reliable, but the format will be correct
-- and complete. Note that NO is always present if CE is
-- present.
--
-- DB Detect_Blocking pragma is in effect for all units in this
-- file.
--
-- Ex A valid Partition_Elaboration_Policy pragma applies to all
-- the units in this file, where x is the first character
-- (upper case) of the policy name (e.g. 'C' for Concurrent).
--
-- FD Configuration pragmas apply to all the units in this file
-- specifying a possibly non-standard floating point format
-- (VAX float with Long_Float using D_Float).
--
-- FG Configuration pragmas apply to all the units in this file
-- specifying a possibly non-standard floating point format
-- (VAX float with Long_Float using G_Float).
--
-- FI Configuration pragmas apply to all the units in this file
-- specifying a possibly non-standard floating point format
-- (IEEE Float).
--
-- Lx A valid Locking_Policy pragma applies to all the units in
-- this file, where x is the first character (upper case) of
-- the policy name (e.g. 'C' for Ceiling_Locking).
--
-- NO No object. This flag indicates that the units in this file
-- were not compiled to produce an object. This can occur as a
-- result of the use of -gnatc, or if no object can be produced
-- (e.g. when a package spec is compiled instead of the body,
-- or a subunit on its own).
--
-- NR No_Run_Time. Indicates that a pragma No_Run_Time applies
-- to all units in the file.
--
-- NS Normalize_Scalars pragma in effect for all units in
-- this file.
--
-- Qx A valid Queueing_Policy pragma applies to all the units
-- in this file, where x is the first character (upper case)
-- of the policy name (e.g. 'P' for Priority_Queueing).
--
-- SL Indicates that the unit is an Interface to a Standalone
-- Library. Note that this indication is never given by the
-- compiler, but is added by the Project Manager in gnatmake
@ -240,19 +240,19 @@ package Lib.Writ is
-- SS This unit references System.Secondary_Stack (that is,
-- the unit makes use of the secondary stack facilities).
--
-- Tx A valid Task_Dispatching_Policy pragma applies to all
-- the units in this file, where x is the first character
-- (upper case) of the corresponding policy name (e.g. 'F'
-- for FIFO_Within_Priorities).
--
-- UA Unreserve_All_Interrupts pragma was processed in one or
-- more units in this file
--
-- ZX Units in this file use zero-cost exceptions and have
-- generated exception tables. If ZX is not present, the
-- longjmp/setjmp exception scheme is in use.
--
-- Note that language defined units never output policy (Lx, Tx, Qx)
-- parameters. Language defined units must correctly handle all
-- possible cases. These values are checked for consistency by the
@ -513,19 +513,19 @@ package Lib.Writ is
-- The lines for each compilation unit have the following form
-- U unit-name source-name version <<attributes>>
--
-- This line identifies the unit to which this section of the library
-- information file applies. The first three parameters are the unit
-- name in internal format, as described in package Uname, and the name
-- of the source file containing the unit.
--
-- Version is the version given as eight hexadecimal characters with
-- upper case letters. This value is the exclusive or of the source
-- checksums of the unit and all its semantically dependent units.
--
-- The <<attributes>> are a series of two letter codes indicating
-- information about the unit:
--
-- BD Unit does not have pragma Elaborate_Body, but the elaboration
-- circuit has determined that it would be a good idea if this
-- pragma were present, since the body of the package contains
@ -533,7 +533,7 @@ package Lib.Writ is
-- visible part of the package. The binder will try, but does
-- not promise, to keep the elaboration of the body close to
-- the elaboration of the spec.
--
-- DE Dynamic Elaboration. This unit was compiled with the dynamic
-- elaboration model, as set by either the -gnatE switch or
-- pragma Elaboration_Checks (Dynamic).
@ -545,7 +545,7 @@ package Lib.Writ is
-- body together whenever possible, and for an instance it is
-- always possible; however setting EB ensures that this is done
-- even when using the -p gnatbind switch).
--
-- EE Elaboration entity is present which must be set true when
-- the unit is elaborated. The name of the elaboration entity is
-- formed from the unit name in the usual way. If EE is present,
@ -554,28 +554,28 @@ package Lib.Writ is
-- be set even if NE is set. This happens when the boolean is
-- needed solely for checking for the case of access before
-- elaboration.
--
-- GE Unit is a generic declaration, or corresponding body
--
-- IL Unit source uses a style with identifiers in all lower-case
-- IU (IL) or all upper case (IU). If the standard mixed-case usage
-- is detected, or the compiler cannot determine the style, then
-- no I parameter will appear.
--
-- IS Initialize_Scalars pragma applies to this unit, or else there
-- is at least one use of the Invalid_Value attribute.
--
-- KM Unit source uses a style with keywords in mixed case (KM)
-- KU or all upper case (KU). If the standard lower-case usage is
-- is detected, or the compiler cannot determine the style, then
-- no K parameter will appear.
--
-- NE Unit has no elaboration routine. All subprogram bodies and
-- specs are in this category. Package bodies and specs may or
-- may not have NE set, depending on whether or not elaboration
-- code is required. Set if N_Compilation_Unit node has flag
-- Has_No_Elaboration_Code set.
--
-- OL The units in this file are compiled with a local pragma
-- Optimize_Alignment, so no consistency requirement applies
-- to these units. All internal units have this status since
@ -584,33 +584,33 @@ package Lib.Writ is
-- OO Optimize_Alignment (Off) is the default setting for all
-- units in this file. All files in the partition that specify
-- a default must specify the same default.
--
-- OS Optimize_Alignment (Space) is the default setting for all
-- units in this file. All files in the partition that specify
-- a default must specify the same default.
--
-- OT Optimize_Alignment (Time) is the default setting for all
-- units in this file. All files in the partition that specify
-- a default must specify the same default.
--
-- PF The unit has a library-level (package) finalizer
--
-- PK Unit is package, rather than a subprogram
--
-- PU Unit has pragma Pure
--
-- PR Unit has pragma Preelaborate
--
-- RA Unit declares a Remote Access to Class-Wide (RACW) type
--
-- RC Unit has pragma Remote_Call_Interface
--
-- RT Unit has pragma Remote_Types
--
-- SP Unit has pragma Shared_Passive.
--
-- SU Unit is a subprogram, rather than a package
--
-- The attributes may appear in any order, separated by spaces.
-- -----------------------------
@ -624,7 +624,7 @@ package Lib.Writ is
-- Y unit-name [source-name lib-name] [E] [EA] [ED] [AD]
-- or
-- Z unit-name [source-name lib-name] [E] [EA] [ED] [AD]
--
-- One W line is present for each unit that is mentioned in an explicit
-- non-limited with clause by the current unit. One Y line is present
-- for each unit that is mentioned in an explicit limited with clause
@ -638,26 +638,32 @@ package Lib.Writ is
-- third parameter is the file name of the library information file
-- that contains the results of compiling this unit. The optional
-- modifiers are used as follows:
--
-- E pragma Elaborate applies to this unit
--
-- EA pragma Elaborate_All applies to this unit
--
-- ED Elaborate_Desirable set for this unit, which means that there
-- is no Elaborate, but the analysis suggests that Program_Error
-- may be raised if the Elaborate conditions cannot be satisfied.
-- The binder will attempt to treat ED as E if it can.
--
-- AD Elaborate_All_Desirable set for this unit, which means that
-- there is no Elaborate_All, but the analysis suggests that
-- Program_Error may be raised if the Elaborate_All conditions
-- cannot be satisfied. The binder will attempt to treat AD as
-- EA if it can.
--
-- The parameter source-name and lib-name are omitted for the case of a
-- generic unit compiled with earlier versions of GNAT which did not
-- generate object or ali files for generics.
--
-- generate object or ali files for generics. For compatibility in the
-- bootstrap path we continue to omit these entries for predefined
-- generic units, even though we do now generate object and ali files.
-- However, in SPARK mode, we always generate source-name and lib-name
-- parameters. Bootstrap issues do not apply there, and we need this
-- information to properly compute frame conditions of subprograms.
-- The parameter source-name and lib-name are also omitted for the W
-- lines that result from use of a Restriction_Set attribute which gets
-- a result of False from a No_Dependence check, in the case where the
@ -696,6 +702,12 @@ package Lib.Writ is
-- source file, so that this order is preserved by the binder in
-- constructing the set of linker arguments.
-- Note: Linker_Options lines never appear in the ALI file generated for
-- a predefined generic unit, and there is cicuitry in Sem_Prag to enforce
-- this restriction, which is needed because of not generating source name
-- and lib name parameters on the with lines for such files, as explained
-- above in the section on with lines.
-- --------------
-- -- N Notes --
-- --------------

187
gcc/ada/sem_aggr.adb
View File

@ -1723,9 +1723,9 @@ package body Sem_Aggr is
-- Variables local to Resolve_Array_Aggregate
Assoc : Node_Id;
Choice : Node_Id;
Expr : Node_Id;
Assoc : Node_Id;
Choice : Node_Id;
Expr : Node_Id;
Discard : Node_Id;
pragma Warnings (Off, Discard);
@ -1900,14 +1900,6 @@ package body Sem_Aggr is
High : Node_Id;
-- Denote the lowest and highest values in an aggregate choice
Hi_Val : Uint;
Lo_Val : Uint;
-- High end of one range and Low end of the next. Should be
-- contiguous if there is no hole in the list of values.
Missing_Values : Boolean;
-- Set True if missing index values
S_Low : Node_Id := Empty;
S_High : Node_Id := Empty;
-- if a choice in an aggregate is a subtype indication these
@ -2064,14 +2056,14 @@ package body Sem_Aggr is
-- Resolve_Aggr_Expr to check the rules about
-- dimensionality.
if not Resolve_Aggr_Expr (Assoc,
Single_Elmt => Single_Choice)
if not Resolve_Aggr_Expr
(Assoc, Single_Elmt => Single_Choice)
then
return Failure;
end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => Single_Choice)
elsif not Resolve_Aggr_Expr
(Expression (Assoc), Single_Elmt => Single_Choice)
then
return Failure;
@ -2134,80 +2126,129 @@ package body Sem_Aggr is
end loop;
-- If aggregate contains more than one choice then these must be
-- static. Sort them and check that they are contiguous.
-- static. Check for duplicate and missing values.
-- Note: there is duplicated code here wrt Check_Choice_Set in
-- the body of Sem_Case, and it is possible we could just reuse
-- that procedure. To be checked ???
if Nb_Discrete_Choices > 1 then
Sort_Case_Table (Table);
Missing_Values := False;
Check_Choices : declare
Choice : Node_Id;
-- Location of choice for messages
Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop
if Expr_Value (Table (J).Choice_Hi) >=
Expr_Value (Table (J + 1).Choice_Lo)
then
Error_Msg_N
("duplicate choice values in array aggregate",
Table (J).Choice_Node);
return Failure;
Hi_Val : Uint;
Lo_Val : Uint;
-- High end of one range and Low end of the next. Should be
-- contiguous if there is no hole in the list of values.
elsif not Others_Present then
Hi_Val := Expr_Value (Table (J).Choice_Hi);
Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
Missing_Or_Duplicates : Boolean := False;
-- Set True if missing or duplicate choices found
-- If missing values, output error messages
procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id);
-- Output continuation message with a representation of the
-- bounds (just Lo if Lo = Hi, else Lo .. Hi). C is the
-- choice node where the message is to be posted.
if Lo_Val - Hi_Val > 1 then
------------------------
-- Output_Bad_Choices --
------------------------
-- Header message if not first missing value
procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id) is
begin
-- Enumeration type case
if not Missing_Values then
Error_Msg_N
("missing index value(s) in array aggregate", N);
Missing_Values := True;
if Is_Enumeration_Type (Index_Typ) then
Error_Msg_Name_1 :=
Chars (Get_Enum_Lit_From_Pos (Index_Typ, Lo, Loc));
Error_Msg_Name_2 :=
Chars (Get_Enum_Lit_From_Pos (Index_Typ, Hi, Loc));
if Lo = Hi then
Error_Msg_N ("\\ %!", C);
else
Error_Msg_N ("\\ % .. %!", C);
end if;
-- Output values of missing indexes
Lo_Val := Lo_Val - 1;
Hi_Val := Hi_Val + 1;
-- Enumeration type case
if Is_Enumeration_Type (Index_Typ) then
Error_Msg_Name_1 :=
Chars
(Get_Enum_Lit_From_Pos
(Index_Typ, Hi_Val, Loc));
if Lo_Val = Hi_Val then
Error_Msg_N ("\ %", N);
else
Error_Msg_Name_2 :=
Chars
(Get_Enum_Lit_From_Pos
(Index_Typ, Lo_Val, Loc));
Error_Msg_N ("\ % .. %", N);
end if;
-- Integer types case
else
Error_Msg_Uint_1 := Hi_Val;
else
Error_Msg_Uint_1 := Lo;
Error_Msg_Uint_2 := Hi;
if Lo_Val = Hi_Val then
Error_Msg_N ("\ ^", N);
else
Error_Msg_Uint_2 := Lo_Val;
Error_Msg_N ("\ ^ .. ^", N);
end if;
if Lo = Hi then
Error_Msg_N ("\\ ^!", C);
else
Error_Msg_N ("\\ ^ .. ^!", C);
end if;
end if;
end if;
end loop Outer;
end Output_Bad_Choices;
if Missing_Values then
Set_Etype (N, Any_Composite);
return Failure;
end if;
-- Start of processing for Check_Choices
begin
Sort_Case_Table (Table);
-- Loop through entries in table to find duplicate indexes
for J in 1 .. Nb_Discrete_Choices - 1 loop
Hi_Val := Expr_Value (Table (J).Choice_Hi);
Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
if Hi_Val >= Lo_Val then
Choice := Table (J + 1).Choice_Lo;
Error_Msg_Sloc := Sloc (Table (J).Choice_Hi);
if Hi_Val = Lo_Val then
Error_Msg_N
("index value in array aggregate duplicates "
& "the one given#",
Choice);
else
Error_Msg_N
("index values in array aggregate duplicate "
& "those given#", Choice);
end if;
Missing_Or_Duplicates := True;
Output_Bad_Choices (Lo_Val, Hi_Val, Choice);
end if;
end loop;
-- Loop through entries in table to find missing indexes.
-- Not needed if others present, since missing impossible.
if not Others_Present then
for J in 1 .. Nb_Discrete_Choices - 1 loop
Hi_Val := Expr_Value (Table (J).Choice_Hi);
Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
if Hi_Val < Lo_Val - 1 then
Choice := Table (J + 1).Choice_Lo;
if Hi_Val + 1 = Lo_Val - 1 then
Error_Msg_N
("missing index value in array aggregate!",
Choice);
else
Error_Msg_N
("missing index values in array aggregate!",
Choice);
end if;
Missing_Or_Duplicates := True;
Output_Bad_Choices (Hi_Val + 1, Lo_Val - 1, Choice);
end if;
end loop;
end if;
-- If either missing or duplicate values, return failure
if Missing_Or_Duplicates then
Set_Etype (N, Any_Composite);
return Failure;
end if;
end Check_Choices;
end if;
-- STEP 2 (B): Compute aggregate bounds and min/max choices values

72
gcc/ada/sem_case.adb
View File

@ -126,6 +126,10 @@ package body Sem_Case is
-- choice that covered a predicate set. Error denotes whether the check
-- found an illegal intersection.
procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
-- Post message "duplication of choice value(s) bla bla at xx". Message
-- is posted at location C. Caller sets Error_Msg_Sloc for xx.
procedure Explain_Non_Static_Bound;
-- Called when we find a non-static bound, requiring the base type to
-- be covered. Provides where possible a helpful explanation of why the
@ -237,6 +241,7 @@ package body Sem_Case is
Choice_Hi : constant Uint := Expr_Value (Choice.Hi);
Choice_Lo : constant Uint := Expr_Value (Choice.Lo);
Loc : Source_Ptr;
LocN : Node_Id;
Next_Hi : Uint;
Next_Lo : Uint;
Pred_Hi : Uint;
@ -248,11 +253,13 @@ package body Sem_Case is
-- Find the proper error message location
if Present (Choice.Node) then
Loc := Sloc (Choice.Node);
LocN := Choice.Node;
else
Loc := Sloc (Case_Node);
LocN := Case_Node;
end if;
Loc := Sloc (LocN);
if Present (Pred) then
Pred_Lo := Expr_Value (Low_Bound (Pred));
Pred_Hi := Expr_Value (High_Bound (Pred));
@ -267,10 +274,12 @@ package body Sem_Case is
-- Step 1: Detect duplicate choices
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
then
Error_Msg ("duplication of choice value", Loc);
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
Error := True;
elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then
Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN);
Error := True;
-- Step 2: Detect full coverage
@ -420,6 +429,45 @@ package body Sem_Case is
end if;
end Check_Against_Predicate;
----------------
-- Dup_Choice --
----------------
procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is
begin
-- In some situations, we call this with a null range, and obviously
-- we don't want to complain in this case.
if Lo > Hi then
return;
end if;
-- Case of only one value that is missing
if Lo = Hi then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Lo;
Error_Msg_N ("duplication of choice value: ^#!", C);
else
Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
Error_Msg_N ("duplication of choice value: %#!", C);
end if;
-- More than one choice value, so print range of values
else
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Lo;
Error_Msg_Uint_2 := Hi;
Error_Msg_N ("duplication of choice values: ^ .. ^#!", C);
else
Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type);
Error_Msg_N ("duplication of choice values: % .. %#!", C);
end if;
end if;
end Dup_Choice;
------------------------------
-- Explain_Non_Static_Bound --
------------------------------
@ -691,10 +739,12 @@ package body Sem_Case is
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Error_Msg_N ("duplication of choice value#", Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Error_Msg_N ("duplication of choice value#", Prev_Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
end if;
elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
@ -706,10 +756,10 @@ package body Sem_Case is
end if;
end loop;
if not Others_Present and then Expr_Value (Bounds_Hi) > Choice_Hi then
Missing_Choice (Choice_Hi + 1, Bounds_Hi);
if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then
Missing_Choice (Prev_Hi + 1, Bounds_Hi);
if Expr_Value (Bounds_Hi) > Choice_Hi + 1 then
if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then
Explain_Non_Static_Bound;
end if;
end if;

6
gcc/ada/sem_ch13.adb
View File

@ -1422,9 +1422,9 @@ package body Sem_Ch13 is
goto Continue;
end if;
-- Skip looking at aspect if it is totally disabled. Just mark
-- it as such for later reference in the tree. This also sets
-- the Is_Ignored and Is_Checked flags appropriately.
-- Skip looking at aspect if it is totally disabled. Just mark it
-- as such for later reference in the tree. This also sets the
-- Is_Ignored and Is_Checked flags appropriately.
Check_Applicable_Policy (Aspect);

6
gcc/ada/sem_ch6.adb
View File

@ -2691,8 +2691,8 @@ package body Sem_Ch6 is
end if;
-- Language-defined aspects cannot appear in a subprogram body [stub] if
-- the corresponding spec already has aspects. An exception to this rule
-- are certain user-defined aspects.
-- the subprogram has a separate spec. Certainly implementation-defined
-- aspects are allowed to appear (per Aspects_On_Body_Of_Stub_OK).
if Has_Aspects (N) then
if Present (Spec_Id)
@ -2705,7 +2705,7 @@ package body Sem_Ch6 is
then
Error_Msg_N
("aspect specifications must appear in subprogram declaration",
N);
N);
-- Delay the analysis of aspect specifications that apply to a body
-- stub until the proper body is analyzed. If the corresponding body

23
gcc/ada/sem_ch9.adb
View File

@ -1736,16 +1736,16 @@ package body Sem_Ch9 is
-- Protected bodies are currently removed by the expander. Since there
-- are no language-defined aspects that apply to a protected body, it is
-- not worth changing the whole expansion to accomodate user-defined
-- aspects. Plus we cannot possibly known the semantics of user-defined
-- aspects in order to plan ahead.
-- not worth changing the whole expansion to accomodate implementation-
-- defined aspects. Plus we cannot possibly known the semantics of such
-- future implementation defined aspects in order to plan ahead.
if Has_Aspects (N) then
Error_Msg_N
("?user-defined aspects on protected bodies are not supported", N);
("aspects on protected bodies are not allowed",
First (Aspect_Specifications (N)));
-- The aspects are removed for now to prevent cascading errors down
-- stream.
-- Remove illegal aspects to prevent cascaded errors later on
Remove_Aspects (N);
end if;
@ -2726,15 +2726,15 @@ package body Sem_Ch9 is
-- Task bodies are transformed into a subprogram spec and body pair by
-- the expander. Since there are no language-defined aspects that apply
-- to a task body, it is not worth changing the whole expansion to
-- accomodate user-defined aspects. Plus we cannot possibly known the
-- semantics of user-defined aspects in order to plan ahead.
-- accomodate implementation-defined aspects. Plus we cannot possibly
-- know semantics of such aspects in order to plan ahead.
if Has_Aspects (N) then
Error_Msg_N
("?user-defined aspects on task bodies are not supported", N);
("aspects on task bodies are not allowed",
First (Aspect_Specifications (N)));
-- The aspects are removed for now to prevent cascading errors down
-- stream.
-- Remove illegal aspects to prevent cascaded errors later on
Remove_Aspects (N);
end if;
@ -2763,7 +2763,6 @@ package body Sem_Ch9 is
then
if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
else
Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
end if;

2
gcc/ada/ug_words
View File

@ -142,6 +142,8 @@ gcc -c ^ GNAT COMPILE
-gnatwC ^ /WARNINGS=NOCONDITIONALS
-gnatw.c ^ /WARNINGS=MISSING_COMPONENT_CLAUSES
-gnatw.C ^ /WARNINGS=NOMISSING_COMPONENT_CLAUSES
-gnatw.d ^ /WARNINGS=TAG_WARNINGS
-gnatw.D ^ /WARNINGS=NOTAG_WARNINGS
-gnatwd ^ /WARNINGS=IMPLICIT_DEREFERENCE
-gnatwD ^ /WARNINGS=NOIMPLICIT_DEREFERENCE
-gnatwe ^ /WARNINGS=ERRORS

11
gcc/ada/vms_data.ads
View File

@ -3094,6 +3094,10 @@ package VMS_Data is
"-gnatwd " &
"NO_IMPLICIT_DEREFERENCE " &
"-gnatwD " &
"TAG_WARNINGS " &
"-gnatw.d " &
"NOTAG_WARNINGS " &
"-gnatw.D " &
"ERRORS " &
"-gnatwe " &
"UNREFERENCED_FORMALS " &
@ -3489,6 +3493,13 @@ package VMS_Data is
--
-- NOVARIABLES_UNINITIALIZED Suppress warnings for uninitialized
-- variables.
--
-- TAG_WARNINGS Causes the string [xxx] to be added to warnings
-- that are controlled by the warning string xxx,
-- e.g. [REDUNDANT], or if the warning is enabled
-- by default, the tag is [enabled by default].
--
-- NOTAG_WARNINGS Turns off warning tag output (default setting).
S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
"-gnatws";