+2015-10-26 Bob Duff <duff@adacore.com>
+
+ * s-fileio.adb (Fopen_Mode): Use "r+" for Out_File/Stream_IO,
+ so the file won't be truncated on 'fopen', as required by
+ AI95-00283-1.
+
+2015-10-26 Bob Duff <duff@adacore.com>
+
+ * gnat1drv.adb, prj.adb, sem_ch6.adb, s-regpat.adb,
+ sem_prag.adb: Fix typos.
+ * einfo.ads, restrict.ads: Minor comment fixes.
+ * err_vars.ads, sem_util.adb, errout.ads: Code clean up.
+
+2015-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Assignment): Do not check that the
+ Left-hand side is legal in an inlined body, check is done on
+ the original template.
+
+2015-10-26 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.ads, exp_util.adb (Find_Primitive_Operations): New
+ subprogram to retrieve by name the possibly overloaded set of
+ primitive operations of a type.
+ * sem_ch4.adb (Try_Container_Indexing): Use
+ Find_Primitive_Operations to handle overloaded indexing operations
+ of a derived type.
+
2015-10-26 Arnaud Charlet <charlet@adacore.com>
* osint-c.ads: Minor comment update.
-- delayed and is one of the characteristics that may be inherited by
-- types derived from this type if not overridden. If this flag is set,
-- then types derived from this type have May_Inherit_Delayed_Rep_Aspects
--- set, signalling that Freeze.Inhert_Delayed_Rep_Aspects must be called
+-- set, signalling that Freeze.Inherit_Delayed_Rep_Aspects must be called
-- at the freeze point of the derived type.
-- Has_Discriminants (Flag5)
-- variables are not reset by calls to the error message routines, so the
-- caller is responsible for resetting the default behavior after use.
- Error_Msg_Qual_Level : Int := 0;
+ Error_Msg_Qual_Level : Nat := 0;
-- Number of levels of qualification required for type name (see the
-- description of the } insertion character. Note that this value does
-- not get reset by any Error_Msg call, so the caller is responsible
Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2;
-- Node_Id values for & insertion characters in message
- Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level;
+ Error_Msg_Qual_Level : Nat renames Err_Vars.Error_Msg_Qual_Level;
-- Number of levels of qualification required for type name (see the
-- description of the } insertion character). Note that this value does
-- not get reset by any Error_Msg call, so the caller is responsible
end if;
end Find_Optional_Prim_Op;
+ -------------------------------
+ -- Find_Primitive_Operations --
+ -------------------------------
+
+ function Find_Primitive_Operations
+ (T : Entity_Id;
+ Name : Name_Id) return Node_Id
+ is
+ Prim_Elmt : Elmt_Id;
+ Prim_Id : Entity_Id;
+ Ref : Node_Id;
+ Typ : Entity_Id := T;
+
+ begin
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ := Underlying_Type (Typ);
+
+ Ref := Empty;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim_Id := Node (Prim_Elmt);
+ if Chars (Prim_Id) = Name then
+
+ -- If this is the first primitive operation found,
+ -- create a reference to it.
+
+ if No (Ref) then
+ Ref := New_Occurrence_Of (Prim_Id, Sloc (T));
+
+ -- Otherwise, add interpretation to existing reference
+
+ else
+ Add_One_Interp (Ref, Prim_Id, Etype (Prim_Id));
+ end if;
+ end if;
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ return Ref;
+ end Find_Primitive_Operations;
+
------------------
-- Find_Prim_Op --
------------------
-- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-- return the record component containing the tag of Iface.
+ function Find_Primitive_Operations
+ (T : Entity_Id;
+ Name : Name_Id) return Node_Id;
+ -- Return a reference to a primitive operation with given name. If
+ -- operation is overloaded, the node carries the corresponding set
+ -- of overloaded interpretations.
+
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
-- Find the first primitive operation of a tagged type T with name Name.
-- This function allows the use of a primitive operation which is not
Original_Operating_Mode := Operating_Mode;
Frontend;
- -- Exit with errors if the main source could not be parsed.
+ -- Exit with errors if the main source could not be parsed
if Sinput.Main_Source_File = No_Source_File then
Errout.Finalize (Last_Call => True);
while Last + S'Length > To'Last loop
declare
- New_Buffer : constant String_Access :=
+ New_Buffer : constant String_Access :=
new String (1 .. 2 * To'Length);
begin
New_Buffer (1 .. Last) := To (1 .. Last);
function Cunit_Boolean_Restrictions_Save
return Save_Cunit_Boolean_Restrictions;
-- This function saves the compilation unit restriction settings, leaving
- -- then unchanged. This is used e.g. at the start of processing a context
+ -- them unchanged. This is used e.g. at the start of processing a context
-- clause, so that the main unit restrictions can be restored after all
-- the with'ed units have been processed.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
-- OPEN CREATE
-- Append_File "r+" "w+"
-- In_File "r" "w+"
- -- Out_File (Direct_IO) "r+" "w"
- -- Out_File (all others) "w" "w"
+ -- Out_File (Direct_IO, Stream_IO) "r+" "w"
+ -- Out_File (others) "w" "w"
-- Inout_File "r+" "w+"
-- Note: we do not use "a" or "a+" for Append_File, since this would not
end if;
when Out_File =>
- if Amethod = 'D' and then not Creat then
+ if Amethod in 'D' | 'S' and then not Creat then
Fopstr (1) := 'r';
Fopstr (2) := '+';
Fptr := 3;
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1999-2014, AdaCore --
+-- Copyright (C) 1999-2015, AdaCore --
-- --
-- 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- --
Capturing : Boolean;
Flags : out Expression_Flags;
IP : out Pointer);
- -- Parse regular expression, i.e. main body or parenthesized thing
+ -- Parse regular expression, i.e. main body or parenthesized thing.
-- Caller must absorb opening parenthesis. Capturing should be set to
-- True when we have an open parenthesis from which we want the user
-- to extra text.
(Flags : out Expression_Flags;
First : Boolean;
IP : out Pointer);
- -- Implements the concatenation operator and handles '|'
+ -- Implements the concatenation operator and handles '|'.
-- First should be true if this is the first item of the alternative.
procedure Parse_Piece
-- However, Reference is also a primitive operation of the type, and
-- the inherited operation has a different signature. We retrieve the
- -- right one from the list of primitive operations of the derived type.
+ -- right ones (the function may be overloaded) from the list of
+ -- primitive operations of the derived type.
-- Note that predefined containers are typically all derived from one
-- of the Controlled types. The code below is motivated by containers
-- that are derived from other types with a Reference aspect.
- -- Additional machinery may be needed for types that have several user-
- -- defined Reference operations with different signatures ???
-
elsif Is_Derived_Type (C_Type)
and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix)
then
- Func := Find_Prim_Op (C_Type, Chars (Func_Name));
- Func_Name := New_Occurrence_Of (Func, Loc);
+ Func_Name := Find_Primitive_Operations (C_Type, Chars (Func_Name));
end if;
Assoc := New_List (Relocate_Node (Prefix));
-- Cases where Lhs is not a variable
- if not Is_Variable (Lhs) then
+ -- Cases where Lhs is not a variable. In an instance or an inlined body
+ -- no need for further check because assignment was legal in template.
+
+ if In_Inlined_Body then
+ null;
+
+ elsif not Is_Variable (Lhs) then
-- Ada 2005 (AI-327): Check assignment to the attribute Priority of a
-- protected object.
else
declare
- T : constant Entity_Id := Find_Dispatching_Type (New_Id);
+ T : constant Entity_Id := Find_Dispatching_Type (New_Id);
begin
if Is_Protected_Type (Corresponding_Concurrent_Type (T))
then
P : constant Node_Id := Parent (N);
begin
- -- Must be at in subprogram body
+ -- Must be in subprogram body
if Nkind (P) /= N_Subprogram_Body then
Error_Pragma ("% pragma allowed only in subprogram");
Expec_Scope := Expec_Type;
Found_Scope := Found_Type;
- for Levels in Int range 0 .. 3 loop
+ for Levels in Nat range 0 .. 3 loop
if Chars (Expec_Scope) /= Chars (Found_Scope) then
Error_Msg_Qual_Level := Levels;
exit;
projects / thirdparty / gcc.git / commitdiff
