diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 740745727de..59c7e497c73 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2013-10-10 Thomas Quinot + + * exp_ch4.adb (Process_Transient_Object): For any context other + than a simple return statement, insert the finalization action + after the context, not as an action on the context (which will + get evaluated before it). + +2013-10-10 Hristian Kirtchev + + * einfo.adb (Write_Field19_Name): Correct the + string name of attribute Default_Aspect_Value. + +2013-10-10 Ed Schonberg + + * sem_type.adb (Interface_Present_In_Ancestor): The progenitor + in a type declaration may be an interface subtype. + +2013-10-10 Robert Dewar + + * sinfo.ads (Do_Range_Check): Add special note on handling of + range checks for Succ and Pred. + +2013-10-10 Robert Dewar + + * erroutc.adb (Output_Msg_Text): Remove VMS special handling. + +2013-10-10 Robert Dewar + + * a-chahan.ads, a-chahan.adb (Is_Line_Terminator): New function + (Is_Mark): New function. + (Is_Other_Format): New function. + (Is_Punctuation_Connector): New function. + (Is_Space): New function. + 2013-10-10 Robert Dewar * sem_aggr.adb (Resolve_Array_Aggregate): Redo duplicate/missing diff --git a/gcc/ada/a-chahan.adb b/gcc/ada/a-chahan.adb index c7a77ea57dc..f95a7bb0eaf 100644 --- a/gcc/ada/a-chahan.adb +++ b/gcc/ada/a-chahan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -49,6 +49,7 @@ package body Ada.Characters.Handling is Hex_Digit : constant Character_Flags := 16; Digit : constant Character_Flags := 32; Special : constant Character_Flags := 64; + Line_Term : constant Character_Flags := 128; Letter : constant Character_Flags := Lower or Upper; Alphanum : constant Character_Flags := Letter or Digit; @@ -66,10 +67,10 @@ package body Ada.Characters.Handling is BEL => Control, BS => Control, HT => Control, - LF => Control, - VT => Control, - FF => Control, - CR => Control, + LF => Control + Line_Term, + VT => Control + Line_Term, + FF => Control + Line_Term, + CR => Control + Line_Term, SO => Control, SI => Control, @@ -141,7 +142,7 @@ package body Ada.Characters.Handling is BPH => Control, NBH => Control, Reserved_132 => Control, - NEL => Control, + NEL => Control + Line_Term, SSA => Control, ESA => Control, HTS => Control, @@ -370,6 +371,15 @@ package body Ada.Characters.Handling is return (Char_Map (Item) and Letter) /= 0; end Is_Letter; + ------------------------ + -- Is_Line_Terminator -- + ------------------------ + + function Is_Line_Terminator (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Line_Term) /= 0; + end Is_Line_Terminator; + -------------- -- Is_Lower -- -------------- @@ -379,6 +389,43 @@ package body Ada.Characters.Handling is return (Char_Map (Item) and Lower) /= 0; end Is_Lower; + ------------- + -- Is_Mark -- + ------------- + + function Is_Mark (Item : Character) return Boolean is + pragma Unreferenced (Item); + begin + return False; + end Is_Mark; + + --------------------- + -- Is_Other_Format -- + --------------------- + + function Is_Other_Format (Item : Character) return Boolean is + begin + return Item = Soft_Hyphen; + end Is_Other_Format; + + ------------------------------ + -- Is_Punctuation_Connector -- + ------------------------------ + + function Is_Punctuation_Connector (Item : Character) return Boolean is + begin + return Item = '_'; + end Is_Punctuation_Connector; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (Item : Character) return Boolean is + begin + return Item = ' ' or else Item = No_Break_Space; + end Is_Space; + ---------------- -- Is_Special -- ---------------- diff --git a/gcc/ada/a-chahan.ads b/gcc/ada/a-chahan.ads index 98f69ba29d0..ca52f94730c 100644 --- a/gcc/ada/a-chahan.ads +++ b/gcc/ada/a-chahan.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -42,18 +42,23 @@ package Ada.Characters.Handling is -- Character Classification Functions -- ---------------------------------------- - function Is_Control (Item : Character) return Boolean; - function Is_Graphic (Item : Character) return Boolean; - function Is_Letter (Item : Character) return Boolean; - function Is_Lower (Item : Character) return Boolean; - function Is_Upper (Item : Character) return Boolean; - function Is_Basic (Item : Character) return Boolean; - function Is_Digit (Item : Character) return Boolean; - function Is_Decimal_Digit (Item : Character) return Boolean + function Is_Control (Item : Character) return Boolean; + function Is_Graphic (Item : Character) return Boolean; + function Is_Letter (Item : Character) return Boolean; + function Is_Lower (Item : Character) return Boolean; + function Is_Upper (Item : Character) return Boolean; + function Is_Basic (Item : Character) return Boolean; + function Is_Digit (Item : Character) return Boolean; + function Is_Decimal_Digit (Item : Character) return Boolean renames Is_Digit; - function Is_Hexadecimal_Digit (Item : Character) return Boolean; - function Is_Alphanumeric (Item : Character) return Boolean; - function Is_Special (Item : Character) return Boolean; + function Is_Hexadecimal_Digit (Item : Character) return Boolean; + function Is_Alphanumeric (Item : Character) return Boolean; + function Is_Special (Item : Character) return Boolean; + function Is_Line_Terminator (Item : Character) return Boolean; + function Is_Mark (Item : Character) return Boolean; + function Is_Other_Format (Item : Character) return Boolean; + function Is_Punctuation_Connector (Item : Character) return Boolean; + function Is_Space (Item : Character) return Boolean; --------------------------------------------------- -- Conversion Functions for Character and String -- @@ -129,22 +134,27 @@ package Ada.Characters.Handling is (Item : String) return Wide_String; private - pragma Inline (Is_Control); - pragma Inline (Is_Graphic); - pragma Inline (Is_Letter); - pragma Inline (Is_Lower); - pragma Inline (Is_Upper); - pragma Inline (Is_Basic); - pragma Inline (Is_Digit); - pragma Inline (Is_Hexadecimal_Digit); pragma Inline (Is_Alphanumeric); + pragma Inline (Is_Basic); + pragma Inline (Is_Character); + pragma Inline (Is_Control); + pragma Inline (Is_Digit); + pragma Inline (Is_Graphic); + pragma Inline (Is_Hexadecimal_Digit); + pragma Inline (Is_ISO_646); + pragma Inline (Is_Letter); + pragma Inline (Is_Line_Terminator); + pragma Inline (Is_Lower); + pragma Inline (Is_Mark); + pragma Inline (Is_Other_Format); + pragma Inline (Is_Punctuation_Connector); + pragma Inline (Is_Space); pragma Inline (Is_Special); + pragma Inline (Is_Upper); + pragma Inline (To_Basic); + pragma Inline (To_Character); pragma Inline (To_Lower); pragma Inline (To_Upper); - pragma Inline (To_Basic); - pragma Inline (Is_ISO_646); - pragma Inline (Is_Character); - pragma Inline (To_Character); pragma Inline (To_Wide_Character); end Ada.Characters.Handling; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index f467144a3d0..8314834af68 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -8741,7 +8741,7 @@ package body Einfo is Write_Str ("Corresponding_Discriminant"); when Scalar_Kind => - Write_Str ("Default_Value"); + Write_Str ("Default_Aspect_Value"); when E_Array_Type => Write_Str ("Default_Component_Value"); diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 9007be47ce5..e2631f84e7f 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -451,257 +451,6 @@ 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 @@ -709,17 +458,6 @@ 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 & ']'); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 175f61db56b..8d6dfc4da08 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12402,15 +12402,7 @@ package body Exp_Ch4 is Name => New_Reference_To (Temp_Id, Loc), Expression => Make_Null (Loc)))); - -- Use the Actions list of logical operators when inserting the - -- finalization call. This ensures that all transient controlled - -- objects are finalized after the operators are evaluated. - - if Nkind_In (Context, N_And_Then, N_Or_Else) then - Insert_Action (Context, Fin_Call); - else - Insert_Action_After (Context, Fin_Call); - end if; + Insert_Action_After (Context, Fin_Call); end if; end Process_Transient_Object; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 78e49224e59..9b9a7090ead 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2611,8 +2611,13 @@ package body Sem_Type is begin AI := First (Interface_List (Parent (Target_Typ))); + + -- The progenitor itself may be a subtype of an interface type. + while Present (AI) loop - if Etype (AI) = Iface_Typ then + if Etype (AI) = Iface_Typ + or else Base_Type (Etype (AI)) = Iface_Typ + then return True; elsif Present (Interfaces (Etype (AI))) diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 6bf34efc69c..9d7e4422cde 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -934,6 +934,14 @@ package Sinfo is -- listed above (e.g. in a return statement), an additional type -- conversion node is introduced to represent the required check. + -- A special case arises for the arguments of the Pred/Succ attributes. + -- Here the range check needed is against First + 1 .. Last (Pred) or + -- First .. Last - 1 (Succ). Essentially these checks are what would be + -- performed within the implicit body of the functions that correspond + -- to these attributes. In these cases, the Do_Range check flag is set + -- on the argument to the attribute function, and the back end must + -- special case the appropriate range to check against. + -- Do_Storage_Check (Flag17-Sem) -- This flag is set in an N_Allocator node to indicate that a storage -- check is required for the allocation, or in an N_Subprogram_Body node