+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
-- --
-- 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- --
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;
--------------
-- 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.
-- --
-- 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- --
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;
--------------
-- 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.
with Snames; use Snames;
with Stand; use Stand;
with Stylesw; use Stylesw;
-with Targparm; use Targparm;
with Uname; use Uname;
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;
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;
if Error_Msg_Warn
and Warning_Doc_Switch
- and not OpenVMS_On_Target
then
Warning_Msg_Char := '?';
end if;
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;
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
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
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),
@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})
-- 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
-- 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
-- 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
-- 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).
-- 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,
-- 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
-- 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.
-- -----------------------------
-- 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
-- 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
-- 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 --
-- --------------
-- 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);
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
-- 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;
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
+ -- Integer types case
- Lo_Val := Lo_Val - 1;
- Hi_Val := Hi_Val + 1;
+ else
+ Error_Msg_Uint_1 := Lo;
+ Error_Msg_Uint_2 := Hi;
- -- Enumeration type case
+ if Lo = Hi then
+ Error_Msg_N ("\\ ^!", C);
+ else
+ Error_Msg_N ("\\ ^ .. ^!", C);
+ end if;
+ end if;
+ end Output_Bad_Choices;
- if Is_Enumeration_Type (Index_Typ) then
- Error_Msg_Name_1 :=
- Chars
- (Get_Enum_Lit_From_Pos
- (Index_Typ, Hi_Val, Loc));
+ -- Start of processing for Check_Choices
- 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;
+ begin
+ Sort_Case_Table (Table);
- -- Integer types case
+ -- 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_Uint_1 := Hi_Val;
+ 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;
- if Lo_Val = Hi_Val then
- Error_Msg_N ("\ ^", N);
+ -- 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_Uint_2 := Lo_Val;
- Error_Msg_N ("\ ^ .. ^", N);
+ 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 if;
+ end loop;
end if;
- end loop Outer;
- if Missing_Values then
- Set_Etype (N, Any_Composite);
- return Failure;
- 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
-- 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
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;
-- 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));
-- 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
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 --
------------------------------
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
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;
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);
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)
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
-- 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;
-- 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;
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;
-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
"-gnatwd " &
"NO_IMPLICIT_DEREFERENCE " &
"-gnatwD " &
+ "TAG_WARNINGS " &
+ "-gnatw.d " &
+ "NOTAG_WARNINGS " &
+ "-gnatw.D " &
"ERRORS " &
"-gnatwe " &
"UNREFERENCED_FORMALS " &
--
-- 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";
projects / thirdparty / gcc.git / commitdiff
