+2011-08-01 Geert Bosch <bosch@adacore.com>
+
+ * par-ch3.adb (P_Discrete_Choice_List): Improve error message for extra
+ "," in choice list.
+
+2011-08-01 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch11.adb (Expand_N_Raise_Statement): Mark N_Raise_xxx_Error for
+ explicit raise of a predefined exception as Comes_From_Source if the
+ original N_Raise_Statement comes from source.
+
+2011-08-01 Robert Dewar <dewar@adacore.com>
+
+ * sinfo.ads: Add comment.
+ * sem_ch6.adb: Minor reformatting.
+
+2011-08-01 Robert Dewar <dewar@adacore.com>
+
+ * freeze.adb (Freeze_Entity): Refine check for bad component size
+ clause to avoid rejecting confirming clause when atomic/aliased present.
+
+2011-08-01 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Find_Direct_Name, Analyze_Expanded_Name): use Is_LHS to
+ better determine whether an entity reference is a write.
+ * sem_util.adb (Is_LHS): refine predicate to handle assignment to a
+ subcomponent.
+ * lib-xref.adb (Output_References): Do no suppress a read reference at
+ the same location as an immediately preceeding modify-reference, to
+ handle properly in-out actuals.
+
+2011-08-01 Tristan Gingold <gingold@adacore.com>
+
+ * env.c (__gnat_setenv) [VMS]: Refine previous change.
+
+2011-08-01 Quentin Ochem <ochem@adacore.com>
+
+ * i-cstrin.adb (New_String): Changed implementation, now uses only the
+ heap to compute the result.
+
2011-08-01 Robert Dewar <dewar@adacore.com>
* atree.ads: Minor reformatting.
#include <time.h>
#ifdef VMS
#include <unixio.h>
-#include <vms/descrip.h>
#endif
#if defined (__MINGW32__)
#include <crt_externs.h>
#endif
+#ifdef VMS
+#include <vms/descrip.h>
+#endif
+
#include "env.h"
void
E : Entity_Id;
Str : String_Id;
H : Node_Id;
+ Src : Boolean;
begin
-- Processing for locally handled exception (exclude reraise case)
return;
end if;
- -- Remaining processing is for the case where no string expression
- -- is present.
+ -- Remaining processing is for the case where no string expression is
+ -- present.
- -- Don't expand a raise statement that does not come from source
- -- if we have already had configurable run-time violations, since
- -- most likely it will be junk cascaded nonsense.
+ -- Don't expand a raise statement that does not come from source if we
+ -- have already had configurable run-time violations, since most likely
+ -- it will be junk cascaded nonsense.
if Configurable_Run_Time_Violations > 0
and then not Comes_From_Source (N)
-- Convert explicit raise of Program_Error, Constraint_Error, and
-- Storage_Error into the corresponding raise (in High_Integrity_Mode
-- all other raises will get normal expansion and be disallowed,
- -- but this is also faster in all modes).
+ -- but this is also faster in all modes). Propagate Comes_From_Source
+ -- flag to the new node.
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
+ Src := Comes_From_Source (N);
if Entity (Name (N)) = Standard_Constraint_Error then
Rewrite (N,
- Make_Raise_Constraint_Error (Loc,
- Reason => CE_Explicit_Raise));
+ Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise));
+ Set_Comes_From_Source (N, Src);
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Program_Error then
Rewrite (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Explicit_Raise));
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ Set_Comes_From_Source (N, Src);
Analyze (N);
return;
elsif Entity (Name (N)) = Standard_Storage_Error then
Rewrite (N,
- Make_Raise_Storage_Error (Loc,
- Reason => SE_Explicit_Raise));
+ Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise));
+ Set_Comes_From_Source (N, Src);
Analyze (N);
return;
end if;
-- Start of processing for Alias_Atomic_Check
begin
- -- Case where component size has no effect
+ -- Case where component size has no effect. First
+ -- check for object size of component type known
+ -- and a multiple of the storage unit size.
if Known_Static_Esize (Ctyp)
- and then Known_Static_RM_Size (Ctyp)
- and then Esize (Ctyp) = RM_Size (Ctyp)
- and then Esize (Ctyp) mod 8 = 0
+ and then Esize (Ctyp) mod System_Storage_Unit = 0
+
+ -- OK in both packing case and component size case
+ -- if RM size is known and static and the same as
+ -- the object size.
+
+ and then
+ ((Known_Static_RM_Size (Ctyp)
+ and then Esize (Ctyp) = RM_Size (Ctyp))
+
+ -- Or if we have an explicit component size
+ -- clause and the component size and object size
+ -- are equal.
+
+ or else
+ (Has_Component_Size_Clause (E)
+ and then Component_Size (E) = Esize (Ctyp)))
then
null;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 New_String (Str : String) return chars_ptr is
+ -- It's important that this subprogram uses directly the heap to compute
+ -- the result, and doesn't copy the string on the stack, otherwise its
+ -- use is limited when used from tasks on large strings.
+
+ Result : constant chars_ptr := Memory_Alloc (Str'Length + 1);
+ Result_Array : char_array (1 .. Str'Length + 1);
+ for Result_Array'Address use To_Address (Result);
+ pragma Import (Ada, Result_Array);
+
+ Count : size_t;
begin
- return New_Char_Array (To_C (Str));
+ To_C
+ (Item => Str,
+ Target => Result_Array,
+ Count => Count,
+ Append_Nul => True);
+
+ return Result;
end New_String;
----------
Ctyp : Character;
-- Entity type character
+ Prevt : Character;
+ -- reference kind of previous reference
+
Tref : Entity_Id;
-- Type reference
Curdef := No_Location;
Curru := No_Unit;
Crloc := No_Location;
+ Prevt := 'm';
-- Loop to output references
Crloc := No_Location;
end if;
- -- Output the reference
+ -- Output the reference if it is not as the same location
+ -- as the previous one, or it is a read-reference that
+ -- indicates that the entity is an in-out actual in a call.
if XE.Loc /= No_Location
- and then XE.Loc /= Crloc
+ and then
+ (XE.Loc /= Crloc
+ or else (Prevt = 'm' and then XE.Typ = 'r'))
then
Crloc := XE.Loc;
+ Prevt := XE.Typ;
-- Start continuation if line full, else blank
end if;
if Token = Tok_Comma then
- Error_Msg_SC -- CODEFIX
- (""","" should be ""'|""");
+ Scan; -- past comma
+
+ if Token = Tok_Vertical_Bar then
+ Error_Msg_SP -- CODEFIX
+ ("|extra "","" ignored");
+ Scan; -- past |
+
+ else
+ Error_Msg_SP -- CODEFIX
+ (""","" should be ""'|""");
+ end if;
+
else
exit when Token /= Tok_Vertical_Bar;
+ Scan; -- past |
end if;
- Scan; -- past | or comma
end loop;
return Choices;
procedure Analyze_Parameterized_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
LocX : constant Source_Ptr := Sloc (Expression (N));
- Def_Id : constant Entity_Id := Defining_Entity (Specification (N));
- Prev : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
+ Def_Id : constant Entity_Id := Defining_Entity (Specification (N));
+ New_Body : Node_Id;
+
+ Prev : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
-- If the expression is a completion, Prev is the entity whose
-- declaration is completed.
- New_Body : Node_Id;
begin
-- This is one of the occasions on which we transform the tree during
-- semantic analysis. Transform the parameterized expression into an
if Present (Prev)
and then Ekind (Prev) = E_Generic_Function
then
-
-- If the expression completes a generic subprogram, we must create
-- a separate node for the body, because at instantiation the
-- original node of the generic copy must be a generic subprogram
--
-- The Is_Actual_Parameter routine takes care of one of these
-- cases but there are others probably ???
+ --
+ -- If the entity is the LHS of an assignment, and is a variable
+ -- (rather than a package prefix), we can mark it as a
+ -- modification right away, to avoid duplicate references.
else
if not Is_Actual_Parameter then
- Generate_Reference (E, N);
+ if Is_LHS (N)
+ and then Ekind (E) /= E_Package
+ and then Ekind (E) /= E_Generic_Package
+ then
+ Generate_Reference (E, N, 'm');
+ else
+ Generate_Reference (E, N);
+ end if;
end if;
Check_Nested_Access (E);
Set_Entity (N, Id);
else
Set_Entity_Or_Discriminal (N, Id);
- Generate_Reference (Id, N);
+
+ if Is_LHS (N) then
+ Generate_Reference (Id, N, 'm');
+ else
+ Generate_Reference (Id, N);
+ end if;
end if;
if Is_Type (Id) then
function Is_LHS (N : Node_Id) return Boolean is
P : constant Node_Id := Parent (N);
begin
- return Nkind (P) = N_Assignment_Statement
- and then Name (P) = N;
+ if Nkind (P) = N_Assignment_Statement then
+ return Name (P) = N;
+
+ elsif
+ Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
+ then
+ return N = Prefix (P) and then Is_LHS (P);
+
+ else
+ return False;
+ end if;
end Is_LHS;
----------------------------
-- N_Has_Etype, N_Has_Chars
+ -- Note: of course N_Error does not really have Etype or Chars fields,
+ -- and any attempt to access these fields in N_Error will cause an
+ -- error, but historically this always has been positioned so that an
+ -- "in N_Has_Chars" or "in N_Has_Etype" test yields true for N_Error.
+ -- Most likely this makes coding easier somewhere but still seems
+ -- undesirable. To be investigated some time ???
+
N_Error,
-- N_Entity, N_Has_Etype, N_Has_Chars
projects / gcc.git / commitdiff