diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 29 | ||||
| -rw-r--r-- | gcc/ada/a-wichha.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/a-wichha.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/a-zchhan.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/a-zchhan.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 268 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 20 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.ads | 108 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 173 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 72 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/ug_words | 2 | ||||
| -rw-r--r-- | gcc/ada/vms_data.ads | 11 |
16 files changed, 599 insertions, 179 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ce65c67..5216894 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/a-wichha.adb b/gcc/ada/a-wichha.adb index 3909fcda..8cdc7ef 100644 --- a/gcc/ada/a-wichha.adb +++ b/gcc/ada/a-wichha.adb @@ -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; -------------- diff --git a/gcc/ada/a-wichha.ads b/gcc/ada/a-wichha.ads index a9cff25..7964756 100644 --- a/gcc/ada/a-wichha.ads +++ b/gcc/ada/a-wichha.ads @@ -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. diff --git a/gcc/ada/a-zchhan.adb b/gcc/ada/a-zchhan.adb index 483cfd9..54db3ba 100644 --- a/gcc/ada/a-zchhan.adb +++ b/gcc/ada/a-zchhan.adb @@ -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; -------------- diff --git a/gcc/ada/a-zchhan.ads b/gcc/ada/a-zchhan.ads index 4c78dcd..354452b 100644 --- a/gcc/ada/a-zchhan.ads +++ b/gcc/ada/a-zchhan.ads @@ -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. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 12cf828..e6ef3a7 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -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; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 97ce9d7..9007be4 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -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 diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 4906572..b15aacd 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -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}) diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index b9d69c2..ef57dfc 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -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 -- -- -------------- diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 404242f..96f1a40 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -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 + -- 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 diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 919ac8d..68ac66a 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 30c5bc4..6f5887e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 462a7f1..f138aea 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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 diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 52dcb90..b7374ba 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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; diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index d450164..e03b422 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -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 diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index f92788a..3594190 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -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"; |