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
Arnaud Charlet
parent
ea3c0651d3
commit
882eadaf20
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
--------------
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
--------------
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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})
|
||||
|
||||
@ -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 --
|
||||
-- --------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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";
|
||||
|
||||
Loading…
Reference in New Issue
Block a user