+2015-05-27 Robert Dewar <dewar@adacore.com>
+
+ * sem_aux.adb: Minor rewording.
+
+2015-05-27 Bob Duff <duff@adacore.com>
+
+ * exp_prag.adb (Expand_Pragma_Abort_Defer): Make
+ pragma Abort_Defer do nothing if Abort_Allowed is False.
+
+2015-05-27 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch9.adb, sem_util.adb, sem_util.ads, s-stposu.adb, s-spsufi.ads,
+ sem_elab.ads, g-comlin.ads, errout.ads, exp_ch6.adb, sem_ch4.adb,
+ opt.ads, s-bignum.adb, output.ads, sem_ch13.adb, erroutc.ads,
+ sem_disp.ads, exp_ch3.adb: Minor fixes of duplicate words in comments.
+
+2015-05-27 Doug Rupp <rupp@adacore.com>
+
+ * adaint.c (__gnat_tmp_name) [vxworks]: Robustify and use for rtp as
+ well as kernel.
+
+2015-05-27 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * par_sco.adb (Process_Decision): Store sloc to
+ condition/pragmas SCOs associations into a temporary table before
+ moving them to the SCO_Raw_Hash_Table so that we can back them
+ out just like we do for SCO entries that are simple decisions
+ in an expression context.
+
2015-05-27 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Process_Formals): A non-private formal type that
sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
close (mkstemp(tmp_filename));
-#elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
- int index;
- char * pos;
- ushort_t t;
+#elif defined (__vxworks) && !defined (VTHREADS)
+ int index;
+ char *pos;
+ char *savepos;
static ushort_t seed = 0; /* used to generate unique name */
- /* generate unique name */
+ /* Generate a unique name. */
strcpy (tmp_filename, "tmp");
- /* fill up the name buffer from the last position */
index = 5;
- pos = tmp_filename + strlen (tmp_filename) + index;
+ savepos = pos = tmp_filename + strlen (tmp_filename) + index;
*pos = '\0';
- seed++;
- for (t = seed; 0 <= --index; t >>= 3)
- *--pos = '0' + (t & 07);
+ while (1)
+ {
+ FILE *f;
+ ushort_t t;
+
+ /* Fill up the name buffer from the last position. */
+ seed++;
+ for (t = seed; 0 <= --index; t >>= 3)
+ *--pos = '0' + (t & 07);
+
+ /* Check to see if its unique, if not bump the seed and try again. */
+ f = fopen (tmp_filename, "r");
+ if (f == NULL)
+ break;
+ fclose (f);
+ pos = savepos;
+ index = 5;
+ }
#else
tmpnam (tmp_filename);
#endif
-- pragma, or the null string if no reason is given. Config is True for the
-- configuration pragma case (where there is no requirement for a matching
-- OFF pragma). Used is set True to disable the check that the warning
- -- actually has has the effect of suppressing a warning.
+ -- actually has the effect of suppressing a warning.
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
-- pragma, or the null string if no reason is given. Config is True for the
-- configuration pragma case (where there is no requirement for a matching
-- OFF pragma). Used is set True to disable the check that the warning
- -- actually has has the effect of suppressing a warning.
+ -- actually has the effect of suppressing a warning.
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
-- which generates a warning range for the whole source file). This routine
-- only deals with the general ON/OFF case, not specific warnings. The
-- returned result is No_String if warnings are not suppressed. If warnings
- -- are suppressed for the given location, then then corresponding Reason
+ -- are suppressed for the given location, then corresponding Reason
-- parameter from the pragma is returned (or the null string if no Reason
-- parameter was present).
and then not Is_Value_Type (Typ)
then
-- Do not initialize the components if No_Default_Initialization
- -- applies as the the actual restriction check will occur later
+ -- applies as the actual restriction check will occur later
-- when the object is frozen as it is not known yet whether the
-- object is imported or not.
Freeze_Expression (Ptr_Typ_Freeze_Ref);
end;
- -- If the the object is a return object of an enclosing build-in-place
+ -- If the object is a return object of an enclosing build-in-place
-- function, then the implicit build-in-place parameters of the
-- enclosing function are simply passed along to the called function.
-- (Unfortunately, this won't cover the case of extension aggregates
Append (Unprot_Call, Stmts);
end if;
- -- Historical note: Previously, call the the cleanup was inserted
+ -- Historical note: Previously, call to the cleanup was inserted
-- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
-- which is also shared by the 'not Exc_Safe' path.
-- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
-- is no delay and the triggering statements are executed. We first
- -- determine the kind of of the triggering call and then execute a
+ -- determine the kind of the triggering call and then execute a
-- synchronized operation or a direct call.
-- declare
-- end;
procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Stm : Node_Id;
- Stms : List_Id;
- HSS : Node_Id;
- Blk : constant Entity_Id :=
- New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
- AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
-
begin
- Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
- loop
- Stm := Remove_Next (N);
- exit when No (Stm);
- Append (Stm, Stms);
- end loop;
+ -- Abort_Defer has no useful effect if Abort's are not allowed
+
+ if not Abort_Allowed then
+ return;
+ end if;
+
+ -- Normal case where abort is possible
- HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stms,
- At_End_Proc => New_Occurrence_Of (AUD, Loc));
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Stm : Node_Id;
+ Stms : List_Id;
+ HSS : Node_Id;
+ Blk : constant Entity_Id :=
+ New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
+ AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
- -- Present the Abort_Undefer_Direct function to the backend so that it
- -- can inline the call to the function.
+ begin
+ Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
+ loop
+ Stm := Remove_Next (N);
+ exit when No (Stm);
+ Append (Stm, Stms);
+ end loop;
- Add_Inlined_Body (AUD, N);
+ HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stms,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
- Rewrite (N,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence => HSS));
+ -- Present the Abort_Undefer_Direct function to the backend so that
+ -- it can inline the call to the function.
- Set_Scope (Blk, Current_Scope);
- Set_Etype (Blk, Standard_Void_Type);
- Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
- Expand_At_End_Handler (HSS, Blk);
- Analyze (N);
+ Add_Inlined_Body (AUD, N);
+
+ Rewrite (N,
+ Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS));
+
+ Set_Scope (Blk, Current_Scope);
+ Set_Etype (Blk, Standard_Void_Type);
+ Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
+ Expand_At_End_Handler (HSS, Blk);
+ Analyze (N);
+ end;
end Expand_Pragma_Abort_Defer;
--------------------------
-- --
-- S p e c --
-- --
--- 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- --
-- Expansion of command line arguments --
-----------------------------------------
- -- These subprograms take care of of expanding globbing patterns on the
+ -- These subprograms take care of expanding globbing patterns on the
-- command line. On Unix, such expansion is done by the shell before your
-- application is called. But on Windows you must do this expansion
-- yourself.
---------------------------
-- The following array would more reasonably be located in Err_Vars or
- -- Errour, but but we put them here to deal with licensing issues (we need
+ -- Errour, but we put them here to deal with licensing issues (we need
-- this to have the GPL exception licensing, since these variables and
-- subprograms are accessed from units with this licensing).
-- --
-- S p e c --
-- --
--- 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- --
-- Sets subsequent output to call procedure P. If P is null, then the call
-- cancels the effect of a previous call, reverting the output to standard
-- error or standard output depending on the mode at the time of previous
- -- call. Any exception generated by by calls to P is simply propagated to
+ -- call. Any exception generated by calls to P is simply propagated to
-- the caller of the routine causing the write operation.
procedure Cancel_Special_Output;
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-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- --
-- table. We use it for backing out a simple decision in an expression
-- context that contains only NOT operators.
+ Mark_Hash : Nat;
+ -- Likewise for the putative SCO_Raw_Hash_Table entries: see below
+
+ type Hash_Entry is record
+ Sloc : Source_Ptr;
+ SCO_Index : Nat;
+ end record;
+ -- We must register all conditions/pragmas in SCO_Raw_Hash_Table.
+ -- However we cannot register them in the same time we are adding the
+ -- corresponding SCO entries to the raw table since we may discard them
+ -- later on. So instead we put all putative conditions into Hash_Entries
+ -- (see below) and register them once we are sure we keep them.
+ --
+ -- This data structure holds the conditions/pragmas to register in
+ -- SCO_Raw_Hash_Table.
+
+ package Hash_Entries is new Table.Table (
+ Table_Component_Type => Hash_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Hash_Entries");
+ -- Hold temporarily (i.e. free'd before returning) the Hash_Entry before
+ -- they are registered in SCO_Raw_Hash_Table.
+
X_Not_Decision : Boolean;
-- This flag keeps track of whether a decision sequence in the SCO table
-- contains only NOT operators, and is for an expression context (T=X).
To => No_Location,
Last => False);
- SCO_Raw_Hash_Table.Set (Sloc (N), SCO_Raw_Table.Last);
+ Hash_Entries.Append ((Sloc (N), SCO_Raw_Table.Last));
Output_Decision_Operand (L);
Output_Decision_Operand (Right_Opnd (N));
From => FSloc,
To => LSloc,
Last => False);
- SCO_Raw_Hash_Table.Set (FSloc, SCO_Raw_Table.Last);
+ Hash_Entries.Append ((FSloc, SCO_Raw_Table.Last));
end Output_Element;
-------------------
-- pragma, enter a hash table entry now.
if T = 'a' then
- SCO_Raw_Hash_Table.Set (Loc, SCO_Raw_Table.Last);
+ Hash_Entries.Append ((Loc, SCO_Raw_Table.Last));
end if;
end Output_Header;
X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
Mark := SCO_Raw_Table.Last;
+ Mark_Hash := Hash_Entries.Last;
Output_Header (T);
-- Output the decision
if X_Not_Decision then
SCO_Raw_Table.Set_Last (Mark);
+ Hash_Entries.Set_Last (Mark_Hash);
-- Otherwise, set Last in last table entry to mark end
return;
end if;
+ Hash_Entries.Init;
+
-- See if we have simple decision at outer level and if so then
-- generate the decision entry for this simple decision. A simple
-- decision is a boolean expression (which is not a logical operator
end if;
Traverse (N);
+
+ -- Now we have the definitive set of SCO entries, register them in the
+ -- corresponding hash table.
+
+ for I in 1 .. Hash_Entries.Last loop
+ SCO_Raw_Hash_Table.Set
+ (Hash_Entries.Table (I).Sloc,
+ Hash_Entries.Table (I).SCO_Index);
+ end loop;
+ Hash_Entries.Free;
end Process_Decisions;
-----------
-- --
-- B o d y --
-- --
--- Copyright (C) 2012-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-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- --
-- D3 (continued). Now test if qhat >= b or v2*qhat > (rhat,uj+2):
-- if so, decrease qhat by 1, increase rhat by v1, and repeat this
- -- test if rhat < b. [The test on v2 determines at at high speed
+ -- test if rhat < b. [The test on v2 determines at high speed
-- most of the cases in which the trial value qhat is one too
-- large, and eliminates all cases where qhat is two too large.]
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-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- --
procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle);
-- This routine performs the following actions:
-- 1) Finalize all objects chained on the subpool's master
- -- 2) Remove the the subpool from the owner's list of subpools
+ -- 2) Remove the subpool from the owner's list of subpools
-- 3) Deallocate the doubly linked list node associated with the subpool
-- 4) Call Deallocate_Subpool
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-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- --
-- Perform the following actions:
-- 1) Finalize all objects chained on the subpool's master
- -- 2) Remove the the subpool from the owner's list of subpools
+ -- 2) Remove the subpool from the owner's list of subpools
-- 3) Deallocate the doubly linked list node associated with the
-- subpool.
-- 4) Call Deallocate_Subpool
-- Call may be on a private type with unknown discriminants, in which
-- case Ent is Empty, and as per the spec, we return Empty in this case.
- -- Historical note: The revious assertion that Ent is a discriminant
- -- was overly cautious and prevented application of this function in
- -- SPARK applications.
+ -- Historical note: The assertion in previous versions that Ent is a
+ -- discriminant was overly cautious and prevented convenient application
+ -- of this function in the gnatprove context.
return Ent;
end First_Discriminant;
return;
end if;
- -- We know we have a first subtype, now possibly go the the anonymous
+ -- We know we have a first subtype, now possibly go the anonymous
-- base type to determine whether Rectype is a record extension.
Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype)));
SId : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
- -- The entity for the the function spec
+ -- The entity for the function spec
SIdB : constant Entity_Id :=
Make_Defining_Identifier (Loc,
SId : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "PredicateM"));
- -- The entity for the the function spec
+ -- The entity for the function spec
SIdB : constant Entity_Id :=
Make_Defining_Identifier (Loc,
-- for some X => (if P then Q [else True])
-- any value for X that makes P False results in the if expression being
- -- trivially True, and so also results in the the quantified expression
+ -- trivially True, and so also results in the quantified expression
-- being trivially True.
if Warn_On_Suspicious_Contract
-- Empty we are in the overriding case. If the tagged type associated with
-- Subp is a concurrent type (case that occurs when the type is declared in
-- a generic because the analysis of generics disables generation of the
- -- corresponding record) then this routine does does not add Subp to the
+ -- corresponding record) then this routine does not add Subp to the
-- list of primitive operations but leaves Subp decorated as dispatching
-- operation to enable checks associated with the Object.Operation notation
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
-- In addition, in SPARK mode, we are checking for a variable reference in
-- another package, which requires an explicit Elaborate_All pragma.
- -- The only references that we need to look at at the outer level are
+ -- The only references that we need to look at the outer level are
-- references that occur in elaboration code. There are two cases. The
-- reference can be at the outer level of elaboration code, or it can
-- be within another unit, e.g. the elaboration code of a subprogram.
function Policy_In_Effect (Policy : Name_Id) return Name_Id is
function Policy_In_List (List : Node_Id) return Name_Id;
- -- Determine the the mode of a policy in a N_Pragma list
+ -- Determine the mode of a policy in a N_Pragma list
--------------------
-- Policy_In_List --
-- 2012 stand-alone object of an anonymous access type, then return the
-- static accesssibility level of the object. In that case, the dynamic
-- accessibility level of the object may take on values in a range. The low
- -- bound of of that range is returned by Type_Access_Level; this function
+ -- bound of that range is returned by Type_Access_Level; this function
-- yields the high bound of that range. Also differs from Type_Access_Level
-- in the case of a descendant of a generic formal type (returns Int'Last
-- instead of 0).
projects / gcc.git / commitdiff