Commit 41d8ee1d by Arnaud Charlet

[multiple changes]

2014-08-01  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Code
	reformatting. Store the generated pragma Import in the related
	subprogram as routine Wrap_Imported_Subprogram will need it later.
	* sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): An item of
	a private type with discriminants is considered to fall in the
	category of unconstrained or tagged items.

2014-08-01  Arnaud charlet  <charlet@adacore.com>

	* s-os_lib.adb (Open_Append): New functions to open a file for
	appending. This binds to the already existing (but not used)
	__gnat_open_append.
	* osint.ads, osint.adb (Open_File_To_Append_And_Check): New procedure
	to open a file for appending.
	* osint-c.ads, osint-c.adb (Open_Output_Library_Info): New procedure
	to open the ALI file for appending.

From-SVN: r213470
parent 2feb1f84
2014-08-01 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Code
reformatting. Store the generated pragma Import in the related
subprogram as routine Wrap_Imported_Subprogram will need it later.
* sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): An item of
a private type with discriminants is considered to fall in the
category of unconstrained or tagged items.
2014-08-01 Arnaud charlet <charlet@adacore.com>
* s-os_lib.adb (Open_Append): New functions to open a file for
appending. This binds to the already existing (but not used)
__gnat_open_append.
* osint.ads, osint.adb (Open_File_To_Append_And_Check): New procedure
to open a file for appending.
* osint-c.ads, osint-c.adb (Open_Output_Library_Info): New procedure
to open the ALI file for appending.
2014-08-01 Robert Dewar <dewar@adacore.com> 2014-08-01 Robert Dewar <dewar@adacore.com>
* sem_ch8.adb: Minor reformatting. * sem_ch8.adb: Minor reformatting.
......
...@@ -197,6 +197,16 @@ package body Osint.C is ...@@ -197,6 +197,16 @@ package body Osint.C is
Create_File_And_Check (Output_FD, Text); Create_File_And_Check (Output_FD, Text);
end Create_Output_Library_Info; end Create_Output_Library_Info;
------------------------------
-- Open_Output_Library_Info --
------------------------------
procedure Open_Output_Library_Info is
begin
Set_Library_Info_Name;
Open_File_To_Append_And_Check (Output_FD, Text);
end Open_Output_Library_Info;
------------------------- -------------------------
-- Create_Repinfo_File -- -- Create_Repinfo_File --
------------------------- -------------------------
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2014, 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- --
...@@ -127,6 +127,12 @@ package Osint.C is ...@@ -127,6 +127,12 @@ package Osint.C is
-- is currently being compiled (i.e. the file which was most recently -- is currently being compiled (i.e. the file which was most recently
-- returned by Next_Main_Source). -- returned by Next_Main_Source).
procedure Open_Output_Library_Info;
-- Opens the output library information file for the source file which
-- is currently being compiled (i.e. the file which was most recently
-- returned by Next_Main_Source) for appending. This is used to append
-- the globals computed in flow analysis in gnatprove mode.
procedure Write_Library_Info (Info : String); procedure Write_Library_Info (Info : String);
-- Writes the contents of the referenced string to the library information -- Writes the contents of the referenced string to the library information
-- file for the main source file currently being compiled (i.e. the file -- file for the main source file currently being compiled (i.e. the file
......
...@@ -722,6 +722,23 @@ package body Osint is ...@@ -722,6 +722,23 @@ package body Osint is
end if; end if;
end Create_File_And_Check; end Create_File_And_Check;
-----------------------------------
-- Open_File_To_Append_And_Check --
-----------------------------------
procedure Open_File_To_Append_And_Check
(Fdesc : out File_Descriptor;
Fmode : Mode)
is
begin
Output_File_Name := Name_Enter;
Fdesc := Open_Append (Name_Buffer'Address, Fmode);
if Fdesc = Invalid_FD then
Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
end if;
end Open_File_To_Append_And_Check;
------------------------ ------------------------
-- Current_File_Index -- -- Current_File_Index --
------------------------ ------------------------
......
...@@ -725,6 +725,15 @@ private ...@@ -725,6 +725,15 @@ private
-- parameter is set to either Text or Binary (for details see description -- parameter is set to either Text or Binary (for details see description
-- of System.OS_Lib.Create_File). -- of System.OS_Lib.Create_File).
procedure Open_File_To_Append_And_Check
(Fdesc : out File_Descriptor;
Fmode : Mode);
-- Opens the file whose name (NUL terminated) is in Name_Buffer (with the
-- length in Name_Len), and place the resulting descriptor in Fdesc. Issue
-- message and exit with fatal error if file cannot be opened. The Fmode
-- parameter is set to either Text or Binary (for details see description
-- of System.OS_Lib.Open_Append).
type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified); type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified);
-- Program currently running -- Program currently running
procedure Set_Program (P : Program_Type); procedure Set_Program (P : Program_Type);
......
...@@ -2257,6 +2257,33 @@ package body System.OS_Lib is ...@@ -2257,6 +2257,33 @@ package body System.OS_Lib is
return ""; return "";
end Normalize_Pathname; end Normalize_Pathname;
-----------------
-- Open_Append --
-----------------
function Open_Append
(Name : C_File_Name;
Fmode : Mode) return File_Descriptor
is
function C_Open_Append
(Name : C_File_Name;
Fmode : Mode) return File_Descriptor;
pragma Import (C, C_Open_Append, "__gnat_open_append");
begin
return C_Open_Append (Name, Fmode);
end Open_Append;
function Open_Append
(Name : String;
Fmode : Mode) return File_Descriptor
is
C_Name : String (1 .. Name'Length + 1);
begin
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
return Open_Append (C_Name (C_Name'First)'Address, Fmode);
end Open_Append;
--------------- ---------------
-- Open_Read -- -- Open_Read --
--------------- ---------------
......
...@@ -208,14 +208,22 @@ package System.OS_Lib is ...@@ -208,14 +208,22 @@ package System.OS_Lib is
function Open_Read function Open_Read
(Name : String; (Name : String;
Fmode : Mode) return File_Descriptor; Fmode : Mode) return File_Descriptor;
-- Open file Name for reading, returning file descriptor File descriptor -- Open file Name for reading, returning its file descriptor. File
-- returned is Invalid_FD if file cannot be opened. -- descriptor returned is Invalid_FD if the file cannot be opened.
function Open_Read_Write function Open_Read_Write
(Name : String; (Name : String;
Fmode : Mode) return File_Descriptor; Fmode : Mode) return File_Descriptor;
-- Open file Name for both reading and writing, returning file descriptor. -- Open file Name for both reading and writing, returning its file
-- File descriptor returned is Invalid_FD if file cannot be opened. -- descriptor. File descriptor returned is Invalid_FD if the file
-- cannot be opened.
function Open_Append
(Name : String;
Fmode : Mode) return File_Descriptor;
-- Opens file Name for appending, returning its file descriptor. File
-- descriptor returned is Invalid_FD if the file cannot be successfully
-- opened.
function Create_File function Create_File
(Name : String; (Name : String;
...@@ -642,6 +650,10 @@ package System.OS_Lib is ...@@ -642,6 +650,10 @@ package System.OS_Lib is
(Name : C_File_Name; (Name : C_File_Name;
Fmode : Mode) return File_Descriptor; Fmode : Mode) return File_Descriptor;
function Open_Append
(Name : C_File_Name;
Fmode : Mode) return File_Descriptor;
function Create_File function Create_File
(Name : C_File_Name; (Name : C_File_Name;
Fmode : Mode) return File_Descriptor; Fmode : Mode) return File_Descriptor;
......
...@@ -1859,67 +1859,92 @@ package body Sem_Ch13 is ...@@ -1859,67 +1859,92 @@ package body Sem_Ch13 is
-- pragma is one of Convention/Import/Export. -- pragma is one of Convention/Import/Export.
declare declare
P_Name : Name_Id; Args : constant List_Id := New_List (
A_Name : Name_Id; Make_Pragma_Argument_Association (Sloc (Expr),
A : Node_Id; Expression => Relocate_Node (Expr)),
Arg_List : List_Id; Make_Pragma_Argument_Association (Sloc (Ent),
Found : Boolean; Expression => Ent));
L_Assoc : Node_Id;
E_Assoc : Node_Id; Imp_Exp_Seen : Boolean := False;
-- Flag set when aspect Import or Export has been seen
Imp_Seen : Boolean := False;
-- Flag set when aspect Import has been seen
Asp : Node_Id;
Asp_Nam : Name_Id;
Extern_Arg : Node_Id;
Link_Arg : Node_Id;
Prag_Nam : Name_Id;
begin begin
P_Name := Chars (Id); Extern_Arg := Empty;
Found := False; Link_Arg := Empty;
Arg_List := New_List; Prag_Nam := Chars (Id);
L_Assoc := Empty;
E_Assoc := Empty; Asp := First (L);
while Present (Asp) loop
A := First (L); Asp_Nam := Chars (Identifier (Asp));
while Present (A) loop
A_Name := Chars (Identifier (A)); -- Aspects Import and Export take precedence over
-- aspect Convention. As a result the generated pragma
if Nam_In (A_Name, Name_Import, Name_Export) then -- must carry the proper interfacing aspect's name.
if Found then
Error_Msg_N ("conflicting", A); if Nam_In (Asp_Nam, Name_Import, Name_Export) then
if Imp_Exp_Seen then
Error_Msg_N ("conflicting", Asp);
else else
Found := True; Imp_Exp_Seen := True;
if Asp_Nam = Name_Import then
Imp_Seen := True;
end if;
end if; end if;
P_Name := A_Name; Prag_Nam := Asp_Nam;
-- Aspect External_Name adds an extra argument to the
-- generated pragma.
elsif A_Name = Name_Link_Name then elsif Asp_Nam = Name_External_Name then
L_Assoc := Extern_Arg :=
Make_Pragma_Argument_Association (Loc, Make_Pragma_Argument_Association (Loc,
Chars => A_Name, Chars => Asp_Nam,
Expression => Relocate_Node (Expression (A))); Expression => Relocate_Node (Expression (Asp)));
elsif A_Name = Name_External_Name then -- Aspect Link_Name adds an extra argument to the
E_Assoc := -- generated pragma.
elsif Asp_Nam = Name_Link_Name then
Link_Arg :=
Make_Pragma_Argument_Association (Loc, Make_Pragma_Argument_Association (Loc,
Chars => A_Name, Chars => Asp_Nam,
Expression => Relocate_Node (Expression (A))); Expression => Relocate_Node (Expression (Asp)));
end if; end if;
Next (A); Next (Asp);
end loop; end loop;
Arg_List := New_List ( -- Assemble the full argument list
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent));
if Present (L_Assoc) then if Present (Link_Arg) then
Append_To (Arg_List, L_Assoc); Append_To (Args, Link_Arg);
end if; end if;
if Present (E_Assoc) then if Present (Extern_Arg) then
Append_To (Arg_List, E_Assoc); Append_To (Args, Extern_Arg);
end if; end if;
Make_Aitem_Pragma Make_Aitem_Pragma
(Pragma_Argument_Associations => Arg_List, (Pragma_Argument_Associations => Args,
Pragma_Name => P_Name); Pragma_Name => Prag_Nam);
-- Store the generated pragma Import in the related
-- subprogram.
if Imp_Seen and then Is_Subprogram (E) then
Set_Import_Pragma (E, Aitem);
end if;
end; end;
-- CPU, Interrupt_Priority, Priority -- CPU, Interrupt_Priority, Priority
......
...@@ -25104,6 +25104,9 @@ package body Sem_Prag is ...@@ -25104,6 +25104,9 @@ package body Sem_Prag is
return Has_Unconstrained_Component (Typ); return Has_Unconstrained_Component (Typ);
end if; end if;
elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
return True;
else else
return False; return False;
end if; end if;
......
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