diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 16102b40580..9aecfefddc1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2017-09-08 Bob Duff + + * s-ststop.ads, s-ststop.adb, rtsfind.ads (String_Input_Tag): + New routine to read the Tag robustly. + * exp_attr.adb (Input): Change the expansion of 'Input, + in the class-wide case, to call String_Input_Tag instead of + String_Input_Blk_IO. + +2017-09-08 Arnaud Charlet + + * s-rident.ads (Restriction_Id): reorder enum + literals, so that Pure_Barriers is no longer in range of the + Cunit_Boolean_Restrictions subtype. + +2017-09-08 Nicolas Roche + + * a-taster.ads, a-taster.adb: Move to libgnarl + * gcc-interface/Makefile.in: Remove obsolete targets. Code cleanups. + Add support for files in libgnarl. + +2017-09-08 Ed Schonberg + + * exp_ch4.adb (Expand_N_Type_Conversion): Do not apply + accessibility check to an interface conversion, whose purpose + is to perform a pointer adjustment in a dispatching call. + * exp_ch6.adb (Expand_Call_JHelper): Add accessibility checks + when the actual is a construct that involves a dereference of an + expression that includes a formal of the enclosing subprogram, + In such cases, the accessibility level of the actual is that of + the corresponding formal, which is passed in as an additional + actual in the outer call. + 2017-09-08 Bob Duff * exp_intr.adb (Add_Source_Info): Do not decode diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b7b35eb632a..96b70227b41 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3837,10 +3837,17 @@ package body Exp_Attr is begin -- Read the internal tag (RM 13.13.2(34)) and use it to - -- initialize a dummy tag value: - + -- initialize a dummy tag value. We used to generate: + -- -- Descendant_Tag (String'Input (Strm), P_Type); - + -- + -- which turns into a call to String_Input_Blk_IO. However, + -- if the input is malformed, that could try to read an + -- enormous String, causing chaos. So instead we call + -- String_Input_Tag, which does the same thing as + -- String_Input_Blk_IO, except that if the String is + -- absurdly long, it raises an exception. + -- -- This value is used only to provide a controlling -- argument for the eventual _Input call. Descendant_Tag is -- called rather than Internal_Tag to ensure that we have a @@ -3860,11 +3867,11 @@ package body Exp_Attr is Name => New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Standard_String, Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_String_Input_Tag), Loc), + Parameter_Associations => New_List ( Relocate_Node (Duplicate_Subexpr (Strm)))), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (P_Type, Loc), diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 91050fe6950..1f0d08e9e61 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -11230,7 +11230,8 @@ package body Exp_Ch4 is -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was - -- expanded from an Unchecked_ or Unrestricted_Access attribute. + -- expanded from an Unchecked_ or Unrestricted_Access attribute, + -- or for the actual of a class-wide interface parameter. -- Note that other checks may still need to be applied below (such -- as tagged type checks). @@ -11240,8 +11241,19 @@ package body Exp_Ch4 is and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) then - Apply_Accessibility_Check - (Operand, Target_Type, Insert_Node => Operand); + if not Comes_From_Source (N) + and then Nkind_In (Parent (N), + N_Function_Call, + N_Procedure_Call_Statement) + and then Is_Interface (Designated_Type (Target_Type)) + and then Is_Class_Wide_Type (Designated_Type (Target_Type)) + then + null; + + else + Apply_Accessibility_Check + (Operand, Target_Type, Insert_Node => Operand); + end if; -- If the level of the operand type is statically deeper than the -- level of the target type, then force Program_Error. Note that this diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d04bbb1f075..3df6410ff2c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2623,6 +2623,7 @@ package body Exp_Ch6 is Param_Count : Natural := 0; Parent_Formal : Entity_Id; Parent_Subp : Entity_Id; + Pref_Entity : Entity_Id; Scop : Entity_Id; Subp : Entity_Id; @@ -3010,6 +3011,9 @@ package body Exp_Ch6 is and then In_Open_Scopes (Scope (Entity (Actual))) then Prev_Orig := Prev; + + elsif Nkind (Prev_Orig) = N_Type_Conversion then + Prev_Orig := Expression (Prev_Orig); end if; -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of @@ -3125,6 +3129,24 @@ package body Exp_Ch6 is when Attribute_Access => + -- Accessibility level of S'Access is that of A. + + Prev_Orig := Prefix (Prev_Orig); + + -- If the expression is a view conversion, + -- the accessibility level is that of the + -- expression. + + if Nkind (Original_Node (Prev_Orig)) + = N_Type_Conversion + and then + Nkind (Expression (Original_Node (Prev_Orig))) + = N_Explicit_Dereference + then + Prev_Orig := + Expression (Original_Node (Prev_Orig)); + end if; + -- If this is an Access attribute applied to the -- the current instance object passed to a type -- initialization procedure, then use the level @@ -3140,14 +3162,41 @@ package body Exp_Ch6 is -- which can be one level too deep in some cases. -- ??? - if Is_Entity_Name (Prefix (Prev_Orig)) - and then Is_Type (Entity (Prefix (Prev_Orig))) + -- A further case that requires special handling + -- is the common idiom E.all'access. If E is a + -- formal of the enclosing subprogram, the + -- accessibility of the expression is that of E. + + if Is_Entity_Name (Prev_Orig) then + Pref_Entity := Entity (Prev_Orig); + + elsif Nkind (Prev_Orig) = N_Explicit_Dereference + and then + Is_Entity_Name (Prefix (Prev_Orig)) + then + Pref_Entity := Entity (Prefix ((Prev_Orig))); + + else + Pref_Entity := Empty; + end if; + + if Is_Entity_Name (Prev_Orig) + and then Is_Type (Entity (Prev_Orig)) then Add_Extra_Actual (Make_Integer_Literal (Loc, - Intval => - Type_Access_Level - (Entity (Prefix (Prev_Orig)))), + Intval => Type_Access_Level (Pref_Entity)), + Extra_Accessibility (Formal)); + + elsif Nkind (Prev_Orig) = N_Explicit_Dereference + and then Present (Pref_Entity) + and then Is_Formal (Pref_Entity) + and then Present + (Extra_Accessibility (Pref_Entity)) + then + Add_Extra_Actual ( + New_Occurrence_Of + (Extra_Accessibility (Pref_Entity), Loc), Extra_Accessibility (Formal)); else @@ -3155,7 +3204,7 @@ package body Exp_Ch6 is (Make_Integer_Literal (Loc, Intval => Object_Access_Level - (Prefix (Prev_Orig))), + (Prev_Orig)), Extra_Accessibility (Formal)); end if; diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 95bdb43a7e9..482259ee3cd 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -380,9 +380,6 @@ SO_OPTS = -Wl,-soname, # target when supported. GNATLIB_SHARED = gnatlib -# default value for gnatmake's target dependent file -MLIB_TGT = mlib-tgt - # By default, build socket support units. On platforms that do not support # sockets, reset this variable to empty and add DUMMY_SOCKETS_TARGET_PAIRS # to LIBGNAT_TARGET_PAIRS. @@ -466,49 +463,6 @@ GCC_SPEC_FILES= # $(strip STRING) removes leading and trailing spaces from STRING. # If what's left is null then it's a match. -# m68k VxWorks -ifeq ($(strip $(filter-out m68k% wrs vx%,$(target_cpu) $(target_vendor) $(target_os))),) - LIBGNAT_TARGET_PAIRS = \ - a-intnam.ads System_Strings_Stream_Ops, RE_String_Input_Blk_IO => System_Strings_Stream_Ops, + RE_String_Input_Tag => System_Strings_Stream_Ops, RE_String_Output => System_Strings_Stream_Ops, RE_String_Output_Blk_IO => System_Strings_Stream_Ops, RE_String_Read => System_Strings_Stream_Ops, diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index f3bd771e89e..cd88593656b 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -89,6 +89,7 @@ package System.Rident is -- does not violate the restriction. (Simple_Barriers, -- Ada 2012 (D.7 (10.9/3)) + Pure_Barriers, -- GNAT No_Abort_Statements, -- (RM D.7(5), H.4(3)) No_Access_Parameter_Allocators, -- Ada 2012 (RM H.4 (8.3/3)) No_Access_Subprograms, -- (RM H.4(17)) @@ -182,7 +183,6 @@ package System.Rident is No_Elaboration_Code, -- GNAT No_Obsolescent_Features, -- Ada 2005 AI-368 No_Wide_Characters, -- GNAT - Pure_Barriers, -- GNAT SPARK_05, -- GNAT -- The following cases require a parameter value diff --git a/gcc/ada/s-ststop.adb b/gcc/ada/s-ststop.adb index 1b8ad9696d0..cfc6f8ad8e8 100644 --- a/gcc/ada/s-ststop.adb +++ b/gcc/ada/s-ststop.adb @@ -58,8 +58,11 @@ package body System.Strings.Stream_Ops is package Stream_Ops_Internal is function Input - (Strm : access Root_Stream_Type'Class; - IO : IO_Kind) return Array_Type; + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind; + Max_Length : Long_Integer := Long_Integer'Last) return Array_Type; + -- Raises an exception if you try to read a String that is longer than + -- Max_Length. See expansion of Attribute_Input in Exp_Attr for details. procedure Output (Strm : access Root_Stream_Type'Class; @@ -125,8 +128,9 @@ package body System.Strings.Stream_Ops is ----------- function Input - (Strm : access Root_Stream_Type'Class; - IO : IO_Kind) return Array_Type + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind; + Max_Length : Long_Integer := Long_Integer'Last) return Array_Type is pragma Unsuppress (All_Checks); -- To make T'Class'Input robust in the case of bad data. The @@ -146,6 +150,10 @@ package body System.Strings.Stream_Ops is Index_Type'Read (Strm, Low); Index_Type'Read (Strm, High); + if Long_Integer (High) - Long_Integer (Low) > Max_Length then + raise Constraint_Error; + end if; + -- Read the character content of the string declare @@ -632,6 +640,17 @@ package body System.Strings.Stream_Ops is return String_Ops.Input (Strm, Block_IO); end String_Input_Blk_IO; + ------------------------- + -- String_Input_Tag -- + ------------------------- + + function String_Input_Tag + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Block_IO, Max_Length => 10_000); + end String_Input_Tag; + ------------------- -- String_Output -- ------------------- diff --git a/gcc/ada/s-ststop.ads b/gcc/ada/s-ststop.ads index 8a58356e0bd..f8164002899 100644 --- a/gcc/ada/s-ststop.ads +++ b/gcc/ada/s-ststop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2017, 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- -- @@ -155,6 +155,12 @@ package System.Strings.Stream_Ops is (Strm : access Ada.Streams.Root_Stream_Type'Class) return String; + function String_Input_Tag + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + -- Same as String_Input_Blk_IO, except raises an exception for overly long + -- Strings. See expansion of Attribute_Input in Exp_Attr for details. + procedure String_Output (Strm : access Ada.Streams.Root_Stream_Type'Class; Item : String);