Commit c0dd5b38 by Arnaud Charlet

[multiple changes]

2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* contracts.adb (Add_Contract_Item): Chain pragmas Attach_Handler
	and Interrupt_Handler on the classifications list of a [generic]
	procedure N_Contract node.
	* contracts.ads (Add_Contract_Item): Update the comment on usage.
	* einfo.adb (Get_Pragma): Pragmas Attach_Handler and
	Interrupt_Handler are found on the classifications list of
	N_Contract nodes.
	* einfo.ads (Get_Pragma): Update the comment on usage.
	* sem_prag.adb (Process_Interrupt_Or_Attach_Handler): Code
	reformatting. Store the pragma as a contract item.

2015-11-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Available_Subtype): Use only in GNATprove
	mode. When generating code it may be necessary to create itypes
	at the point of use of a selected component, for example in the
	expansion of a record equality operation.

2015-11-18  Vincent Celier  <celier@adacore.com>

	* s-os_lib.adb (Normalize_Pathname.Get_Directory): When
	invoking Normalize_Pathname, use the same values for parameters
	Resolve_Links and Case_Sensitive as the parent Normalize_Pathname.

2015-11-18  Vincent Celier  <celier@adacore.com>

	* a-direct.adb (Containing_Directory): Return "." when the result
	is the current directory, not specified as an absolute path name.

From-SVN: r230536
parent a25e72b5
2015-11-18 Hristian Kirtchev <kirtchev@adacore.com> 2015-11-18 Hristian Kirtchev <kirtchev@adacore.com>
* contracts.adb (Add_Contract_Item): Chain pragmas Attach_Handler
and Interrupt_Handler on the classifications list of a [generic]
procedure N_Contract node.
* contracts.ads (Add_Contract_Item): Update the comment on usage.
* einfo.adb (Get_Pragma): Pragmas Attach_Handler and
Interrupt_Handler are found on the classifications list of
N_Contract nodes.
* einfo.ads (Get_Pragma): Update the comment on usage.
* sem_prag.adb (Process_Interrupt_Or_Attach_Handler): Code
reformatting. Store the pragma as a contract item.
2015-11-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Available_Subtype): Use only in GNATprove
mode. When generating code it may be necessary to create itypes
at the point of use of a selected component, for example in the
expansion of a record equality operation.
2015-11-18 Vincent Celier <celier@adacore.com>
* s-os_lib.adb (Normalize_Pathname.Get_Directory): When
invoking Normalize_Pathname, use the same values for parameters
Resolve_Links and Case_Sensitive as the parent Normalize_Pathname.
2015-11-18 Vincent Celier <celier@adacore.com>
* a-direct.adb (Containing_Directory): Return "." when the result
is the current directory, not specified as an absolute path name.
2015-11-18 Hristian Kirtchev <kirtchev@adacore.com>
* exp_aggr.adb (Is_Completely_Hidden_Discriminant): New routine. * exp_aggr.adb (Is_Completely_Hidden_Discriminant): New routine.
(Init_Hidden_Discriminants): Code reformatting. Do not initialize (Init_Hidden_Discriminants): Code reformatting. Do not initialize
a completely hidden discriminant. a completely hidden discriminant.
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -208,35 +208,31 @@ package body Ada.Directories is ...@@ -208,35 +208,31 @@ package body Ada.Directories is
else else
declare declare
-- We need to resolve links because of A.16(47), since we must not
-- return alternative names for files.
Norm : constant String := Normalize_Pathname (Name);
Last_DS : constant Natural := Last_DS : constant Natural :=
Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward); Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward);
begin begin
if Last_DS = 0 then if Last_DS = 0 then
-- There is no directory separator, returns current working -- There is no directory separator, returns "." representing
-- directory. -- the current working directory.
return Current_Directory; return ".";
-- If Name indicates a root directory, raise Use_Error, because -- If Name indicates a root directory, raise Use_Error, because
-- it has no containing directory. -- it has no containing directory.
elsif Norm = "/" elsif Name = "/"
or else or else
(Windows (Windows
and then and then
(Norm = "\" (Name = "\"
or else or else
(Norm'Length = 3 (Name'Length = 3
and then Norm (Norm'Last - 1 .. Norm'Last) = ":\" and then Name (Name'Last - 1 .. Name'Last) = ":\"
and then (Norm (Norm'First) in 'a' .. 'z' and then (Name (Name'First) in 'a' .. 'z'
or else or else
Norm (Norm'First) in 'A' .. 'Z')))) Name (Name'First) in 'A' .. 'Z'))))
then then
raise Use_Error with raise Use_Error with
"directory """ & Name & """ has no containing directory"; "directory """ & Name & """ has no containing directory";
...@@ -270,15 +266,10 @@ package body Ada.Directories is ...@@ -270,15 +266,10 @@ package body Ada.Directories is
Last := Last - 1; Last := Last - 1;
end loop; end loop;
-- Special case of current directory, identified by "."
if Last = 1 and then Result (1) = '.' then
return Current_Directory;
-- Special case of "..": the current directory may be a root -- Special case of "..": the current directory may be a root
-- directory. -- directory.
elsif Last = 2 and then Result (1 .. 2) = ".." then if Last = 2 and then Result (1 .. 2) = ".." then
return Containing_Directory (Current_Directory); return Containing_Directory (Current_Directory);
else else
......
...@@ -153,10 +153,12 @@ package body Contracts is ...@@ -153,10 +153,12 @@ package body Contracts is
end if; end if;
-- Entry or subprogram declarations, the applicable pragmas are: -- Entry or subprogram declarations, the applicable pragmas are:
-- Attach_Handler
-- Contract_Cases -- Contract_Cases
-- Depends -- Depends
-- Extensions_Visible -- Extensions_Visible
-- Global -- Global
-- Interrupt_Handler
-- Postcondition -- Postcondition
-- Precondition -- Precondition
-- Test_Case -- Test_Case
...@@ -168,11 +170,10 @@ package body Contracts is ...@@ -168,11 +170,10 @@ package body Contracts is
E_Generic_Procedure, E_Generic_Procedure,
E_Procedure) E_Procedure)
then then
if Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then if Nam_In (Prag_Nam, Name_Attach_Handler, Name_Interrupt_Handler)
Add_Pre_Post_Condition; and then Ekind_In (Id, E_Generic_Procedure, E_Procedure)
then
elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then Add_Classification;
Add_Contract_Test_Case;
elsif Nam_In (Prag_Nam, Name_Depends, elsif Nam_In (Prag_Nam, Name_Depends,
Name_Extensions_Visible, Name_Extensions_Visible,
...@@ -185,6 +186,12 @@ package body Contracts is ...@@ -185,6 +186,12 @@ package body Contracts is
then then
Add_Classification; Add_Classification;
elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then
Add_Contract_Test_Case;
elsif Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then
Add_Pre_Post_Condition;
-- The pragma is not a proper contract item -- The pragma is not a proper contract item
else else
......
...@@ -38,6 +38,7 @@ package Contracts is ...@@ -38,6 +38,7 @@ package Contracts is
-- Abstract_State -- Abstract_State
-- Async_Readers -- Async_Readers
-- Async_Writers -- Async_Writers
-- Attach_Handler
-- Constant_After_Elaboration -- Constant_After_Elaboration
-- Contract_Cases -- Contract_Cases
-- Depends -- Depends
...@@ -47,6 +48,7 @@ package Contracts is ...@@ -47,6 +48,7 @@ package Contracts is
-- Global -- Global
-- Initial_Condition -- Initial_Condition
-- Initializes -- Initializes
-- Interrupt_Handler
-- Part_Of -- Part_Of
-- Postcondition -- Postcondition
-- Precondition -- Precondition
......
...@@ -7103,6 +7103,7 @@ package body Einfo is ...@@ -7103,6 +7103,7 @@ package body Einfo is
Is_CLS : constant Boolean := Is_CLS : constant Boolean :=
Id = Pragma_Abstract_State or else Id = Pragma_Abstract_State or else
Id = Pragma_Attach_Handler or else
Id = Pragma_Async_Readers or else Id = Pragma_Async_Readers or else
Id = Pragma_Async_Writers or else Id = Pragma_Async_Writers or else
Id = Pragma_Constant_After_Elaboration or else Id = Pragma_Constant_After_Elaboration or else
...@@ -7113,6 +7114,7 @@ package body Einfo is ...@@ -7113,6 +7114,7 @@ package body Einfo is
Id = Pragma_Global or else Id = Pragma_Global or else
Id = Pragma_Initial_Condition or else Id = Pragma_Initial_Condition or else
Id = Pragma_Initializes or else Id = Pragma_Initializes or else
Id = Pragma_Interrupt_Handler or else
Id = Pragma_Part_Of or else Id = Pragma_Part_Of or else
Id = Pragma_Refined_Depends or else Id = Pragma_Refined_Depends or else
Id = Pragma_Refined_Global or else Id = Pragma_Refined_Global or else
......
...@@ -8035,6 +8035,8 @@ package Einfo is ...@@ -8035,6 +8035,8 @@ package Einfo is
-- Abstract_State -- Abstract_State
-- Async_Readers -- Async_Readers
-- Async_Writers -- Async_Writers
-- Attach_Handler
-- Constant_After_Elaboration
-- Contract_Cases -- Contract_Cases
-- Depends -- Depends
-- Effective_Reads -- Effective_Reads
...@@ -8042,6 +8044,7 @@ package Einfo is ...@@ -8042,6 +8044,7 @@ package Einfo is
-- Global -- Global
-- Initial_Condition -- Initial_Condition
-- Initializes -- Initializes
-- Interrupt_Handler
-- Part_Of -- Part_Of
-- Precondition -- Precondition
-- Postcondition -- Postcondition
...@@ -8050,6 +8053,7 @@ package Einfo is ...@@ -8050,6 +8053,7 @@ package Einfo is
-- Refined_Post -- Refined_Post
-- Refined_State -- Refined_State
-- Test_Case -- Test_Case
-- Volatile_Function
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for a record -- Searches the Rep_Item chain for a given entity E, for a record
......
...@@ -2087,7 +2087,9 @@ package body System.OS_Lib is ...@@ -2087,7 +2087,9 @@ package body System.OS_Lib is
if Dir'Length > 0 then if Dir'Length > 0 then
declare declare
Result : String := Result : String :=
Normalize_Pathname (Dir, "") & Directory_Separator; Normalize_Pathname
(Dir, "", Resolve_Links, Case_Sensitive) &
Directory_Separator;
Last : Positive := Result'Last - 1; Last : Positive := Result'Last - 1;
begin begin
......
...@@ -6484,6 +6484,10 @@ package body Sem_Ch8 is ...@@ -6484,6 +6484,10 @@ package body Sem_Ch8 is
-- This simplifies value tracing in GNATProve. For consistency, both -- This simplifies value tracing in GNATProve. For consistency, both
-- the entity name and the subtype come from the constrained component. -- the entity name and the subtype come from the constrained component.
-- This is only used in GNATProve mode: when generating code it may be
-- necessary to create an itype in the scope of use of the selected
-- component, e.g. in the context of a expanded record equality.
function Is_Reference_In_Subunit return Boolean; function Is_Reference_In_Subunit return Boolean;
-- In a subunit, the scope depth is not a proper measure of hiding, -- In a subunit, the scope depth is not a proper measure of hiding,
-- because the context of the proper body may itself hide entities in -- because the context of the proper body may itself hide entities in
...@@ -6499,17 +6503,19 @@ package body Sem_Ch8 is ...@@ -6499,17 +6503,19 @@ package body Sem_Ch8 is
Comp : Entity_Id; Comp : Entity_Id;
begin begin
Comp := First_Entity (Etype (P)); if GNATprove_Mode then
while Present (Comp) loop Comp := First_Entity (Etype (P));
if Chars (Comp) = Chars (Selector_Name (N)) then while Present (Comp) loop
Set_Etype (N, Etype (Comp)); if Chars (Comp) = Chars (Selector_Name (N)) then
Set_Entity (Selector_Name (N), Comp); Set_Etype (N, Etype (Comp));
Set_Etype (Selector_Name (N), Etype (Comp)); Set_Entity (Selector_Name (N), Comp);
return True; Set_Etype (Selector_Name (N), Etype (Comp));
end if; return True;
end if;
Next_Component (Comp); Next_Component (Comp);
end loop; end loop;
end if;
return False; return False;
end Available_Subtype; end Available_Subtype;
......
...@@ -8768,30 +8768,28 @@ package body Sem_Prag is ...@@ -8768,30 +8768,28 @@ package body Sem_Prag is
----------------------------------------- -----------------------------------------
procedure Process_Interrupt_Or_Attach_Handler is procedure Process_Interrupt_Or_Attach_Handler is
Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
Handler_Proc : constant Entity_Id := Entity (Arg1_X); Prot_Typ : constant Entity_Id := Scope (Handler);
Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
begin begin
-- A pragma that applies to a Ghost entity becomes Ghost for the -- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code. -- purposes of legality checks and removal of ignored Ghost code.
Mark_Pragma_As_Ghost (N, Handler_Proc); Mark_Pragma_As_Ghost (N, Handler);
Set_Is_Interrupt_Handler (Handler_Proc); Set_Is_Interrupt_Handler (Handler);
-- If the pragma is not associated with a handler procedure within a -- If the pragma is not associated with a handler procedure within a
-- protected type, then it must be for a nonprotected procedure for -- protected type, then it must be for a nonprotected procedure for
-- the AAMP target, in which case we don't associate a representation -- the AAMP target, in which case we don't associate a representation
-- item with the procedure's scope. -- item with the procedure's scope.
if Ekind (Proc_Scope) = E_Protected_Type then if Ekind (Prot_Typ) = E_Protected_Type then
if Prag_Id = Pragma_Interrupt_Handler Record_Rep_Item (Prot_Typ, N);
or else
Prag_Id = Pragma_Attach_Handler
then
Record_Rep_Item (Proc_Scope, N);
end if;
end if; end if;
-- Chain the pragma on the contract for completeness
Add_Contract_Item (N, Handler);
end Process_Interrupt_Or_Attach_Handler; end Process_Interrupt_Or_Attach_Handler;
-------------------------------------------------- --------------------------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment