+2014-07-18 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb, sem_attr.adb,
+ sem_aggr.adb, sinfo.ads, sem_eval.ads: Minor reformatting.
+
+2014-07-18 Pascal Obry <obry@adacore.com>
+
+ * sysdep.c (__gnat_wide_text_translation_required): Removed from here.
+ * initialize.c (__gnat_wide_text_translation_required): Defined here.
+
+2014-07-18 Pascal Obry <obry@adacore.com>
+
+ * adaint.c (__gnat_fputwc): New routine.
+ * s-crtl.ads (fputwc): Now imported as __gnat_fputwc.
+
+2014-07-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb: Flag 270 is now used as Stores_Attribute_Old_Prefix.
+ (Set_Stores_Attribute_Old_Prefix): New routine.
+ (Stores_Attribute_Old_Prefix): New routine.
+ (Write_Entity_Flags):
+ Output flag Stores_Attribute_Old_Prefix.
+ * einfo.ads Add new flag Stores_Attribute_Old_Prefix along with
+ comment on usage.
+ (Set_Stores_Attribute_Old_Prefix): New routine
+ along with pragma Inline.
+ (Stores_Attribute_Old_Prefix): New
+ routine along with pragma Inline.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Mark the generated
+ constant which captures the result of attribute 'Old's prefix.
+ * sem_util.adb (In_Assertion_Expression_Pragma): Recognize a
+ relocated expression which acted as a prefix of attribute 'Old.
+
+2014-07-18 Bob Duff <duff@adacore.com>
+
+ * s-spsufi.adb (Finalize_And_Deallocate): Set Subpool.Owner to
+ null before dispatching to Deallocate_Subpool.
+ * s-stposu.ads (Default_Subpool_For_Pool): Change mode of
+ parameter of Default_Subpool_For_Pool to 'in out'.
+ * s-stposu.adb (Set_Pool_Of_Subpool): Use raise expression. Add
+ a message to the raise.
+ * sem_util.adb: Minor reformatting.
+
2014-07-18 Robert Dewar <dewar@adacore.com>
* sem_util.adb (Check_Expression_Against_Static_Predicate):
#else
#include <utime.h>
+#include <wchar.h>
#endif
#if defined (_WIN32)
#endif
}
+int
+__gnat_fputwc(int c, FILE *stream)
+{
+#if ! defined (__vxworks) && ! defined (IS_CROSS)
+ return fputwc ((wchar_t)c, stream);
+#else
+ return fputc (c, stream);
+#endif
+}
+
FILE *
__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED,
char *vms_form ATTRIBUTE_UNUSED)
-- Generic_Renamings Elist23
-- Inner_Instances Elist23
-- Limited_View Node23
- -- Packed_Array_Impl_Type Node23
+ -- Packed_Array_Impl_Type Node23
-- Protection_Object Node23
-- Stored_Constraint Elist23
-- Has_Shift_Operator Flag267
-- Is_Independent Flag268
-- Has_Static_Predicate Flag269
+ -- Stores_Attribute_Old_Prefix Flag270
-- (unused) Flag1
-- (unused) Flag2
-- (unused) Flag3
- -- (unused) Flag270
-
-- (unused) Flag271
-- (unused) Flag272
-- (unused) Flag273
return Elist23 (Id);
end Stored_Constraint;
+ function Stores_Attribute_Old_Prefix (Id : E) return B is
+ begin
+ return Flag270 (Id);
+ end Stores_Attribute_Old_Prefix;
+
function Strict_Alignment (Id : E) return B is
begin
return Flag145 (Implementation_Base_Type (Id));
Set_Elist23 (Id, V);
end Set_Stored_Constraint;
+ procedure Set_Stores_Attribute_Old_Prefix (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Constant);
+ Set_Flag270 (Id, V);
+ end Set_Stores_Attribute_Old_Prefix;
+
procedure Set_Strict_Alignment (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
W ("SPARK_Aux_Pragma_Inherited", Flag266 (Id));
W ("SPARK_Pragma_Inherited", Flag265 (Id));
W ("Static_Elaboration_Desired", Flag77 (Id));
+ W ("Stores_Attribute_Old_Prefix", Flag270 (Id));
W ("Strict_Alignment", Flag145 (Id));
W ("Suppress_Elaboration_Warnings", Flag148 (Id));
W ("Suppress_Initialization", Flag105 (Id));
-- or the declaration of a "hook" object.
-- In which case is it a flag, or a hook object???
--- Storage_Size_Variable (Node15) [implementation base type only]
--- Defined in access types and task type entities. This flag is set
--- if a valid and effective pragma Storage_Size applies to the base
--- type. Points to the entity for a variable that is created to
--- hold the value given in a Storage_Size pragma for an access
--- collection or a task type. Note that in the access type case,
--- this field is defined only in the root type (since derived types
--- share the same storage pool).
-
-- Static_Elaboration_Desired (Flag77)
-- Defined in library-level packages. Set by the pragma of the same
-- name, to indicate that static initialization must be attempted for
-- This attribute uses the same field as Overridden_Operation, which is
-- irrelevant in init_procs.
+-- Storage_Size_Variable (Node15) [implementation base type only]
+-- Defined in access types and task type entities. This flag is set
+-- if a valid and effective pragma Storage_Size applies to the base
+-- type. Points to the entity for a variable that is created to
+-- hold the value given in a Storage_Size pragma for an access
+-- collection or a task type. Note that in the access type case,
+-- this field is defined only in the root type (since derived types
+-- share the same storage pool).
+
-- Stored_Constraint (Elist23)
-- Defined in entities that can have discriminants (concurrent types
-- subtypes, record types and subtypes, private types and subtypes,
-- to an element list containing the expressions for each of the
-- stored discriminants for the record (sub)type.
+-- Stores_Attribute_Old_Prefix (Flag270)
+-- Defined in constants. Set when the constant has been generated to save
+-- the value of attribute 'Old's prefix.
+
-- Strict_Alignment (Flag145) [implementation base type only]
-- Defined in all type entities. Indicates that some containing part
-- is either aliased or tagged. This prohibits packing the object
-- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
+ -- Stores_Attribute_Old_Prefix (Flag270) (constants only)
-- Optimize_Alignment_Space (Flag241) (constants only)
-- Optimize_Alignment_Time (Flag242) (constants only)
-- Treat_As_Volatile (Flag41)
function Status_Flag_Or_Transient_Decl (Id : E) return E;
function Storage_Size_Variable (Id : E) return E;
function Stored_Constraint (Id : E) return L;
+ function Stores_Attribute_Old_Prefix (Id : E) return B;
function Strict_Alignment (Id : E) return B;
function String_Literal_Length (Id : E) return U;
function String_Literal_Low_Bound (Id : E) return N;
procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E);
procedure Set_Storage_Size_Variable (Id : E; V : E);
procedure Set_Stored_Constraint (Id : E; V : L);
+ procedure Set_Stores_Attribute_Old_Prefix (Id : E; V : B := True);
procedure Set_Strict_Alignment (Id : E; V : B := True);
procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
pragma Inline (Status_Flag_Or_Transient_Decl);
pragma Inline (Storage_Size_Variable);
pragma Inline (Stored_Constraint);
+ pragma Inline (Stores_Attribute_Old_Prefix);
pragma Inline (Strict_Alignment);
pragma Inline (String_Literal_Length);
pragma Inline (String_Literal_Low_Bound);
pragma Inline (Set_Status_Flag_Or_Transient_Decl);
pragma Inline (Set_Storage_Size_Variable);
pragma Inline (Set_Stored_Constraint);
+ pragma Inline (Set_Stores_Attribute_Old_Prefix);
pragma Inline (Set_Strict_Alignment);
pragma Inline (Set_String_Literal_Length);
pragma Inline (Set_String_Literal_Low_Bound);
begin
Temp := Make_Temporary (Loc, 'T', Pref);
+ -- Set the entity kind now in order to mark the temporary as a
+ -- handler of attribute 'Old's prefix.
+
+ Set_Ekind (Temp, E_Constant);
+ Set_Stores_Attribute_Old_Prefix (Temp);
+
-- Climb the parent chain looking for subprogram _Postconditions
Subp := N;
/* __gnat_initialize (NT-mingw32 Version) */
/******************************************/
+char __gnat_wide_text_translation_required = 0;
+// wide text translation, 0=none, 1=activated
+
#if defined (__MINGW32__)
#include "mingw32.h"
#include <windows.h>
pragma Import (C, fputc, "fputc");
function fputwc (C : int; stream : FILEs) return int;
- pragma Import (C, fputwc, "fputwc");
+ pragma Import (C, fputwc, "__gnat_fputwc");
function fputs (Strng : chars; Stream : FILEs) return int;
pragma Import (C, fputs, "fputs");
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2014, 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- --
Free (Subpool.Node);
- -- Dispatch to the user-defined implementation of Deallocate_Subpool
-
- Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+ -- Dispatch to the user-defined implementation of Deallocate_Subpool. It
+ -- is important to first set Subpool.Owner to null, because RM-13.11.5
+ -- requires that "The subpool no longer belongs to any pool" BEFORE
+ -- calling Deallocate_Subpool. The actual dispatching call required is:
+ --
+ -- Deallocate_Subpool(Pool_of_Subpool(Subpool).all, Subpool);
+ --
+ -- but that can't be taken literally, because Pool_of_Subpool will
+ -- return null.
+
+ declare
+ Owner : constant Any_Storage_Pool_With_Subpools_Ptr := Subpool.Owner;
+ begin
+ Subpool.Owner := null;
+ Deallocate_Subpool (Owner.all, Subpool);
+ end;
Subpool := null;
end Finalize_And_Deallocate;
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2014, 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 Default_Subpool_For_Pool
- (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle
+ (Pool : in out Root_Storage_Pool_With_Subpools)
+ return not null Subpool_Handle
is
+ pragma Unreferenced (Pool);
begin
- raise Program_Error;
- return Pool.Subpools.Subpool;
+ return raise Program_Error with
+ "default Default_Subpool_For_Pool called; must be overridden";
end Default_Subpool_For_Pool;
------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2014, 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 --
(Pool : in out Root_Storage_Pool_With_Subpools;
Subpool : in out Subpool_Handle)
is abstract;
+ -- This precondition causes errors in simple tests, disabled for now???
+ -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
- -- ??? This precondition causes errors in simple tests, disabled for now
-
- -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
-- This routine requires implementation. Reclaim the storage a particular
-- subpool occupies in a pool_with_subpools. This routine is called by
-- Ada.Unchecked_Deallocate_Subpool.
function Default_Subpool_For_Pool
- (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle;
+ (Pool : in out Root_Storage_Pool_With_Subpools)
+ return not null Subpool_Handle;
-- Return a common subpool which is used for object allocations without a
-- Subpool_Handle_name in the allocator. The default implementation of this
-- routine raises Program_Error.
-- is fine, it's just the wrong length. We skip this check
-- for standard character types (since there are no literals
-- and it is too much trouble to concoct them), and also if
- -- any of the bounds have not-known-at-compile-time values.
+ -- any of the bounds have values that are not known at
+ -- compile time.
-- Another case warranting a warning is when the length is
-- right, but as above we have an index type that is an
else
Analyze_And_Resolve (Index, Etype (Index_Type));
+
if not Is_OK_Static_Expression (Index) then
Set_Do_Range_Check (Index);
end if;
function Eval_Static_Predicate_Check
(N : Node_Id;
Typ : Entity_Id) return Boolean;
- -- Evaluate a static predicate check applied to a known-at-compile-time
- -- value N, which can be of a discrete, real, or string type. The caller
- -- has checked that a static predicate does apply to Typ.
+ -- Evaluate a static predicate check applied expression which represents
+ -- a value that is known at compile time (does not have to be static). The
+ -- caller has checked that a static predicate does apply to Typ, and thus
+ -- the type is known to be scalar.
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the compile
Item_Id := Available_View (Entity_Of (Item));
- return
- Ekind (Item_Id) = E_Abstract_State
- and then Has_Null_Refinement (Item_Id);
+ return Ekind (Item_Id) = E_Abstract_State
+ and then Has_Null_Refinement (Item_Id);
+
else
return False;
end if;
if not Clause_Matched
and then Is_In_Out_State_Clause
- and then Contains
- (Matched_Items, Available_View (Entity_Of (Dep_Input)))
+ and then
+ Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
then
Clause_Matched := True;
end if;
if not Clause_Matched
and then Is_Null_Refined_State (Dep_Input)
and then Is_Entity_Name (Dep_Output)
- and then Contains
- (Matched_Items, Available_View (Entity_Of (Dep_Output)))
+ and then
+ Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
then
Clause_Matched := True;
end if;
if not Clause_Matched
and then Is_Null_Refined_State (Dep_Output)
and then Is_Entity_Name (Dep_Input)
- and then Contains
- (Matched_Items, Available_View (Entity_Of (Dep_Input)))
+ and then
+ Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
then
Clause_Matched := True;
end if;
-- In Ada 2012, If the type has an incomplete partial view, there
-- may be primitive operations declared before the full view, so
- -- we need to start scanning from the incomplete view.
+ -- we need to start scanning from the the incomplete view, which
+ -- is earlier on the entity chain.
elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
and then Present (Incomplete_View (Parent (B_Type)))
then
- Id := Defining_Entity (Next (Incomplete_View (Parent (B_Type))));
+ Id := Defining_Entity (Incomplete_View (Parent (B_Type)));
else
Id := Next_Entity (B_Type);
Prag := Original_Node (Par);
exit;
+ -- The expansion of attribute 'Old generates a constant to capture
+ -- the result of the prefix. If the parent traversal reaches
+ -- one of these constants, then the node technically came from a
+ -- postcondition-like pragma. Note that the Ekind is not tested here
+ -- because N may be the expression of an object declaration which is
+ -- currently being analyzed. Such objects carry Ekind of E_Void.
+
+ elsif Nkind (Par) = N_Object_Declaration
+ and then Constant_Present (Par)
+ and then Stores_Attribute_Old_Prefix (Defining_Entity (Par))
+ then
+ return True;
+
-- Prevent the search from going too far
elsif Is_Body_Or_Package_Declaration (Par) then
-- Parameter_List_Truncated (Flag17-Sem)
-- Present in N_Function_Call and N_Procedure_Call_Statement nodes. Set
- -- (for OpenVMS ports of GNAT only) if the parameter list is truncated as
- -- a result of a First_Optional_Parameter specification in an
- -- Import_Function, Import_Procedure, or Import_Valued_Procedure pragma.
+ -- (for OpenVMS ports of GNAT only) if the parameter list is truncated
+ -- as a result of a First_Optional_Parameter specification in one of the
+ -- pragmas Import_Function, Import_Procedure, or Import_Valued_Procedure.
-- The truncation is done by the expander by removing trailing parameters
-- from the argument list, in accordance with the set of rules allowing
-- such parameter removal. In particular, parameters can be removed
-- working from the end of the parameter list backwards up to and
-- including the entry designated by First_Optional_Parameter in the
-- Import pragma. Parameters can be removed if they are implicit and the
- -- default value is a known-at-compile-time value, including the use of
+ -- default value is known at compile time value, including the use of
-- the Null_Parameter attribute, or if explicit parameter values are
-- present that match the corresponding defaults.
#if defined (WINNT) || defined (__CYGWIN__)
const char __gnat_text_translation_required = 1;
-char __gnat_wide_text_translation_required = 0;
#ifdef __CYGWIN__
#define WIN_SETMODE setmode
#else
const char __gnat_text_translation_required = 0;
-const char __gnat_wide_text_translation_required = 0;
/* These functions do nothing in non-DOS systems. */
projects / gcc.git / commitdiff