mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-09 17:01:06 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-02-24  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Global_Item): Emit the
	variable related checks concerning volatile objects only when
	SPARK_Mode is on.

2014-02-24  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb (Analyze_Iterator_Specification): use
	Error_Msg_Ada_2012_Feature.

2014-02-24  Jose Ruiz  <ruiz@adacore.com>

	* s-rident.ads (Profile_Info): For Ravenscar, the restrictions
	No_Local_Timing_Events and No_Specific_Termination_Handlers
	must be set, according to the Ravenscar profile definition
	in D.13(6/3).

2014-02-24  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Expression_Function): If this is a
	completion, freeze return type and its designated type if needed.

2014-02-24  Thomas Quinot  <quinot@adacore.com>

	* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case
	'Address): When moving initialization statements to a freeze
	entity, keep them under a single node (i.e. do not unwrap
	expressions with actions), and set the Initialization_Statements
	attribute again so that processing of a later pragma Import can
	still remove them.

2014-02-24  Claire Dross  <dross@adacore.com>

	* a-cfdlli.adb, a-cfdlli.ads, a-cfhama.adb, a-cfhama.ads,
	a-cfhase.adb, a-cfhase.ads, a-cforma.adb, a-cforma.ads,
	a-cforse.adb, a-cforse.ads, a-cofove.adb, a-cofove.ads: Rename
	Left/Right to First_To_Previous/Current_To_Last.

2014-02-24  Thomas Quinot  <quinot@adacore.com>

	* adaint.h (struct file_attributes): New component "error"
	(__gnat_error_attributes): Accessor for the above.
	* adaint.c (__gnat_error_attributes): New subprogram
	(__gnat_stat): Fix returned value (expect errno value)
	(__gnat_stat_to_attr): Add management of error component (set to
	stat errno value, except for missing files where it is set to 0,
	and exists is set to 0).
	* osint.ads (File_Attributes_Size): Update per change above,
	also clarify documentation.
	* s-filatt.ads: New file, binding to file attributes related
	functions.
	* Makefile.rtl (s-filatt): New runtime unit.
	* s-crtl.ads (strlen): Expose binding to GCC builtin (falls back
	to library function if not available on target).
	* s-os_lib.ads, s-os_lib.adb (Errno_Message): New subprogram.
	* s-oscons-tmplt.c (SIZEOF_struct_file_attributes,
	SIZEOF_struct_dirent_alloc): New constants.
	* Make-generated.in (s-oscons.ads): Now requires adaint.h.
	* a-direct.adb (Fetch_Next_Entry): Fix incorrect buffer sizes.
	Perform appropriate error checking if stat fails (do not just
	ignore existing files if stat fails)
	* gcc-interface/Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Update
	dependencies.

From-SVN: r208078
This commit is contained in:
Arnaud Charlet 2014-02-24 17:51:58 +01:00
parent ec77b14454
commit c6d2191a0d
30 changed files with 829 additions and 534 deletions

65
gcc/ada/ChangeLog

@ -1,3 +1,68 @@
2014-02-24 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Global_Item): Emit the
variable related checks concerning volatile objects only when
SPARK_Mode is on.
2014-02-24 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb (Analyze_Iterator_Specification): use
Error_Msg_Ada_2012_Feature.
2014-02-24 Jose Ruiz <ruiz@adacore.com>
* s-rident.ads (Profile_Info): For Ravenscar, the restrictions
No_Local_Timing_Events and No_Specific_Termination_Handlers
must be set, according to the Ravenscar profile definition
in D.13(6/3).
2014-02-24 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Expression_Function): If this is a
completion, freeze return type and its designated type if needed.
2014-02-24 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case
'Address): When moving initialization statements to a freeze
entity, keep them under a single node (i.e. do not unwrap
expressions with actions), and set the Initialization_Statements
attribute again so that processing of a later pragma Import can
still remove them.
2014-02-24 Claire Dross <dross@adacore.com>
* a-cfdlli.adb, a-cfdlli.ads, a-cfhama.adb, a-cfhama.ads,
a-cfhase.adb, a-cfhase.ads, a-cforma.adb, a-cforma.ads,
a-cforse.adb, a-cforse.ads, a-cofove.adb, a-cofove.ads: Rename
Left/Right to First_To_Previous/Current_To_Last.
2014-02-24 Thomas Quinot <quinot@adacore.com>
* adaint.h (struct file_attributes): New component "error"
(__gnat_error_attributes): Accessor for the above.
* adaint.c (__gnat_error_attributes): New subprogram
(__gnat_stat): Fix returned value (expect errno value)
(__gnat_stat_to_attr): Add management of error component (set to
stat errno value, except for missing files where it is set to 0,
and exists is set to 0).
* osint.ads (File_Attributes_Size): Update per change above,
also clarify documentation.
* s-filatt.ads: New file, binding to file attributes related
functions.
* Makefile.rtl (s-filatt): New runtime unit.
* s-crtl.ads (strlen): Expose binding to GCC builtin (falls back
to library function if not available on target).
* s-os_lib.ads, s-os_lib.adb (Errno_Message): New subprogram.
* s-oscons-tmplt.c (SIZEOF_struct_file_attributes,
SIZEOF_struct_dirent_alloc): New constants.
* Make-generated.in (s-oscons.ads): Now requires adaint.h.
* a-direct.adb (Fetch_Next_Entry): Fix incorrect buffer sizes.
Perform appropriate error checking if stat fails (do not just
ignore existing files if stat fails)
* gcc-interface/Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Update
dependencies.
2014-02-24 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Global_Item): Move the check concerning

2
gcc/ada/Make-generated.in

@ -84,7 +84,7 @@ OSCONS_EXTRACT=$(OSCONS_CC) -S s-oscons-tmplt.i
# ld -o s-oscons-tmplt.exe s-oscons-tmplt.obj; \
# ./s-oscons-tmplt.exe > s-oscons-tmplt.s
$(ADA_GEN_SUBDIR)/s-oscons.ads : $(ADA_GEN_SUBDIR)/s-oscons-tmplt.c $(ADA_GEN_SUBDIR)/gsocket.h $(ADA_GEN_SUBDIR)/xoscons.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
$(ADA_GEN_SUBDIR)/s-oscons.ads : $(ADA_GEN_SUBDIR)/s-oscons-tmplt.c $(ADA_GEN_SUBDIR)/gsocket.h $(ADA_GEN_SUBDIR)/adaint.h $(ADA_GEN_SUBDIR)/xoscons.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/oscons
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/oscons/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/oscons

1
gcc/ada/Makefile.rtl

@ -535,6 +535,7 @@ GNATRTL_NONTASKING_OBJS= \
s-fatllf$(objext) \
s-fatsfl$(objext) \
s-ficobl$(objext) \
s-filatt$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
s-finmas$(objext) \

114
gcc/ada/a-cfdlli.adb

@ -257,6 +257,36 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
return P;
end Copy;
---------------------
-- Current_To_Last --
---------------------
function Current_To_Last
(Container : List;
Current : Cursor) return List is
Curs : Cursor := First (Container);
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Current /= No_Element and not Has_Element (Container, Current) then
raise Constraint_Error;
end if;
while Curs.Node /= Current.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Current_To_Last;
------------
-- Delete --
------------
@ -471,6 +501,35 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
end if;
end First_Element;
-----------------------
-- First_To_Previous --
-----------------------
function First_To_Previous
(Container : List;
Current : Cursor) return List is
Curs : Cursor := Current;
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end First_To_Previous;
----------
-- Free --
----------
@ -865,33 +924,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
end if;
end Last_Element;
----------
-- Left --
----------
function Left (Container : List; Position : Cursor) return List is
Curs : Cursor := Position;
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
------------
-- Length --
------------
@ -1172,34 +1204,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
return No_Element;
end Reverse_Find;
-----------
-- Right --
-----------
function Right (Container : List; Position : Cursor) return List is
Curs : Cursor := First (Container);
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while Curs.Node /= Position.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
------------
-- Splice --
------------

29
gcc/ada/a-cfdlli.ads

@ -48,8 +48,10 @@
-- There are three new functions:
-- function Strict_Equal (Left, Right : List) return Boolean;
-- function Left (Container : List; Position : Cursor) return List;
-- function Right (Container : List; Position : Cursor) return List;
-- function First_To_Previous (Container : List; Current : Cursor)
-- return List;
-- function Current_To_Last (Container : List; Current : Cursor)
-- return List;
-- See subprogram specifications that follow for details
@ -313,18 +315,21 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is
-- they are structurally equal (function "=" returns True) and that they
-- have the same set of cursors.
function Left (Container : List; Position : Cursor) return List with
function First_To_Previous (Container : List; Current : Cursor) return List
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
function Right (Container : List; Position : Cursor) return List with
Pre => Has_Element (Container, Current) or else Current = No_Element;
function Current_To_Last (Container : List; Current : Cursor) return List
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
-- Left returns a container containing all elements preceding Position
-- (excluded) in Container. Right returns a container containing all
-- elements following Position (included) in Container. These two new
-- functions can be used to express invariant properties in loops which
-- iterate over containers. Left returns the part of the container already
-- scanned and Right the part not scanned yet.
Pre => Has_Element (Container, Current) or else Current = No_Element;
-- First_To_Previous returns a container containing all elements preceding
-- Current (excluded) in Container. Current_To_Last returns a container
-- containing all elements following Current (included) in Container.
-- These two new functions can be used to express invariant properties in
-- loops which iterate over containers. First_To_Previous returns the part
-- of the container already scanned and Current_To_Last the part not
-- scanned yet.
private

120
gcc/ada/a-cfhama.adb

@ -235,6 +235,35 @@ package body Ada.Containers.Formal_Hashed_Maps is
return Target;
end Copy;
---------------------
-- Current_To_Last --
---------------------
function Current_To_Last (Container : Map; Current : Cursor) return Map is
Curs : Cursor := First (Container);
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Current /= No_Element and not Has_Element (Container, Current) then
raise Constraint_Error;
end if;
while Curs.Node /= Current.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Current_To_Last;
---------------------
-- Default_Modulus --
---------------------
@ -429,6 +458,38 @@ package body Ada.Containers.Formal_Hashed_Maps is
return (Node => Node);
end First;
-----------------------
-- First_To_Previous --
-----------------------
function First_To_Previous
(Container : Map;
Current : Cursor) return Map is
Curs : Cursor;
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
Curs := Current;
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end First_To_Previous;
----------
-- Free --
----------
@ -596,36 +657,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
return Container.Nodes (Position.Node).Key;
end Key;
----------
-- Left --
----------
function Left (Container : Map; Position : Cursor) return Map is
Curs : Cursor;
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
Curs := Position;
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
------------
-- Length --
------------
@ -808,35 +839,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
end Reserve_Capacity;
-----------
-- Right --
-----------
function Right (Container : Map; Position : Cursor) return Map is
Curs : Cursor := First (Container);
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while Curs.Node /= Position.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
--------------
-- Set_Next --
--------------

29
gcc/ada/a-cfhama.ads

@ -48,8 +48,10 @@
-- function Strict_Equal (Left, Right : Map) return Boolean;
-- function Overlap (Left, Right : Map) return Boolean;
-- function Left (Container : Map; Position : Cursor) return Map;
-- function Right (Container : Map; Position : Cursor) return Map;
-- function First_To_Previous (Container : Map; Current : Cursor)
-- return Map;
-- function Current_To_Last (Container : Map; Current : Cursor)
-- return Map;
-- See detailed specifications for these subprograms
@ -243,18 +245,21 @@ package Ada.Containers.Formal_Hashed_Maps is
-- they are structurally equal (function "=" returns True) and that they
-- have the same set of cursors.
function Left (Container : Map; Position : Cursor) return Map with
function First_To_Previous (Container : Map; Current : Cursor) return Map
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
function Right (Container : Map; Position : Cursor) return Map with
Pre => Has_Element (Container, Current) or else Current = No_Element;
function Current_To_Last (Container : Map; Current : Cursor) return Map
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
-- Left returns a container containing all elements preceding Position
-- (excluded) in Container. Right returns a container containing all
-- elements following Position (included) in Container. These two new
-- functions can be used to express invariant properties in loops which
-- iterate over containers. Left returns the part of the container already
-- scanned and Right the part not scanned yet.
Pre => Has_Element (Container, Current) or else Current = No_Element;
-- First_To_Previous returns a container containing all elements preceding
-- Current (excluded) in Container. Current_To_Last returns a container
-- containing all elements following Current (included) in Container.
-- These two new functions can be used to express invariant properties in
-- loops which iterate over containers. First_To_Previous returns the part
-- of the container already scanned and Current_To_Last the part not
-- scanned yet.
function Overlap (Left, Right : Map) return Boolean with
Global => null;

116
gcc/ada/a-cfhase.adb

@ -261,6 +261,35 @@ package body Ada.Containers.Formal_Hashed_Sets is
return Target;
end Copy;
---------------------
-- Current_To_Last --
---------------------
function Current_To_Last (Container : Set; Current : Cursor) return Set is
Curs : Cursor := First (Container);
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Current /= No_Element and not Has_Element (Container, Current) then
raise Constraint_Error;
end if;
while Curs.Node /= Current.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Current_To_Last;
---------------------
-- Default_Modulus --
---------------------
@ -626,6 +655,36 @@ package body Ada.Containers.Formal_Hashed_Sets is
return (Node => Node);
end First;
-----------------------
-- First_To_Previous --
-----------------------
function First_To_Previous
(Container : Set;
Current : Cursor) return Set is
Curs : Cursor := Current;
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end First_To_Previous;
----------
-- Free --
----------
@ -912,34 +971,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
return True;
end Is_Subset;
----------
-- Left --
----------
function Left (Container : Set; Position : Cursor) return Set is
Curs : Cursor := Position;
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
------------
-- Length --
------------
@ -1106,35 +1137,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
end Reserve_Capacity;
-----------
-- Right --
-----------
function Right (Container : Set; Position : Cursor) return Set is
Curs : Cursor := First (Container);
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while Curs.Node /= Position.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
------------------
-- Set_Element --
------------------

29
gcc/ada/a-cfhase.ads

@ -48,8 +48,10 @@
-- There are three new functions:
-- function Strict_Equal (Left, Right : Set) return Boolean;
-- function Left (Container : Set; Position : Cursor) return Set;
-- function Right (Container : Set; Position : Cursor) return Set;
-- function First_To_Previous (Container : Set; Current : Cursor)
-- return Set;
-- function Current_To_Last (Container : Set; Current : Cursor)
-- return Set;
-- See detailed specifications for these subprograms
@ -310,18 +312,21 @@ package Ada.Containers.Formal_Hashed_Sets is
-- they are structurally equal (function "=" returns True) and that they
-- have the same set of cursors.
function Left (Container : Set; Position : Cursor) return Set with
function First_To_Previous (Container : Set; Current : Cursor) return Set
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
function Right (Container : Set; Position : Cursor) return Set with
Pre => Has_Element (Container, Current) or else Current = No_Element;
function Current_To_Last (Container : Set; Current : Cursor) return Set
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
-- Left returns a container containing all elements preceding Position
-- (excluded) in Container. Right returns a container containing all
-- elements following Position (included) in Container. These two new
-- functions can be used to express invariant properties in loops which
-- iterate over containers. Left returns the part of the container already
-- scanned and Right the part not scanned yet.
Pre => Has_Element (Container, Current) or else Current = No_Element;
-- First_To_Previous returns a container containing all elements preceding
-- Current (excluded) in Container. Current_To_Last returns a container
-- containing all elements following Current (included) in Container.
-- These two new functions can be used to express invariant properties in
-- loops which iterate over containers. First_To_Previous returns the part
-- of the container already scanned and Current_To_Last the part not
-- scanned yet.
private

116
gcc/ada/a-cforma.adb

@ -48,13 +48,13 @@ package body Ada.Containers.Formal_Ordered_Maps is
pragma Inline (Color);
function Left_Son (Node : Node_Type) return Count_Type;
pragma Inline (Left);
pragma Inline (Left_Son);
function Parent (Node : Node_Type) return Count_Type;
pragma Inline (Parent);
function Right_Son (Node : Node_Type) return Count_Type;
pragma Inline (Right);
pragma Inline (Right_Son);
procedure Set_Color
(Node : in out Node_Type;
@ -322,6 +322,34 @@ package body Ada.Containers.Formal_Ordered_Maps is
end return;
end Copy;
---------------------
-- Current_To_Last --
---------------------
function Current_To_Last (Container : Map; Current : Cursor) return Map is
Curs : Cursor := First (Container);
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Current /= No_Element and not Has_Element (Container, Current) then
raise Constraint_Error;
end if;
while Curs.Node /= Current.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Current_To_Last;
------------
-- Delete --
------------
@ -490,6 +518,35 @@ package body Ada.Containers.Formal_Ordered_Maps is
return Container.Nodes (First (Container).Node).Key;
end First_Key;
-----------------------
-- First_To_Previous --
-----------------------
function First_To_Previous
(Container : Map;
Current : Cursor) return Map is
Curs : Cursor := Current;
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end First_To_Previous;
-----------
-- Floor --
-----------
@ -725,33 +782,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
return Container.Nodes (Last (Container).Node).Key;
end Last_Key;
----------
-- Left --
----------
function Left (Container : Map; Position : Cursor) return Map is
Curs : Cursor := Position;
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
--------------
-- Left_Son --
--------------
@ -964,34 +994,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
Container.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
-----------
-- Right --
-----------
function Right (Container : Map; Position : Cursor) return Map is
Curs : Cursor := First (Container);
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while Curs.Node /= Position.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
---------------
-- Right_Son --
---------------

29
gcc/ada/a-cforma.ads

@ -50,8 +50,10 @@
-- function Strict_Equal (Left, Right : Map) return Boolean;
-- function Overlap (Left, Right : Map) return Boolean;
-- function Left (Container : Map; Position : Cursor) return Map;
-- function Right (Container : Map; Position : Cursor) return Map;
-- function First_To_Previous (Container : Map; Current : Cursor)
-- return Map;
-- function Current_To_Last (Container : Map; Current : Cursor)
-- return Map;
-- See detailed specifications for these subprograms
@ -244,18 +246,21 @@ package Ada.Containers.Formal_Ordered_Maps is
-- they are structurally equal (function "=" returns True) and that they
-- have the same set of cursors.
function Left (Container : Map; Position : Cursor) return Map with
function First_To_Previous (Container : Map; Current : Cursor) return Map
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
function Right (Container : Map; Position : Cursor) return Map with
Pre => Has_Element (Container, Current) or else Current = No_Element;
function Current_To_Last (Container : Map; Current : Cursor) return Map
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
-- Left returns a container containing all elements preceding Position
-- (excluded) in Container. Right returns a container containing all
-- elements following Position (included) in Container. These two new
-- functions can be used to express invariant properties in loops which
-- iterate over containers. Left returns the part of the container already
-- scanned and Right the part not scanned yet.
Pre => Has_Element (Container, Current) or else Current = No_Element;
-- First_To_Previous returns a container containing all elements preceding
-- Current (excluded) in Container. Current_To_Last returns a container
-- containing all elements following Current (included) in Container.
-- These two new functions can be used to express invariant properties in
-- loops which iterate over containers. First_To_Previous returns the part
-- of the container already scanned and Current_To_Last the part not
-- scanned yet.
function Overlap (Left, Right : Map) return Boolean with
Global => null;

116
gcc/ada/a-cforse.adb

@ -51,13 +51,13 @@ package body Ada.Containers.Formal_Ordered_Sets is
pragma Inline (Color);
function Left_Son (Node : Node_Type) return Count_Type;
pragma Inline (Left);
pragma Inline (Left_Son);
function Parent (Node : Node_Type) return Count_Type;
pragma Inline (Parent);
function Right_Son (Node : Node_Type) return Count_Type;
pragma Inline (Right);
pragma Inline (Right_Son);
procedure Set_Color
(Node : in out Node_Type;
@ -358,6 +358,34 @@ package body Ada.Containers.Formal_Ordered_Sets is
return Target;
end Copy;
---------------------
-- Current_To_Last --
---------------------
function Current_To_Last (Container : Set; Current : Cursor) return Set is
Curs : Cursor := First (Container);
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Current /= No_Element and not Has_Element (Container, Current) then
raise Constraint_Error;
end if;
while Curs.Node /= Current.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Current_To_Last;
------------
-- Delete --
------------
@ -566,6 +594,35 @@ package body Ada.Containers.Formal_Ordered_Sets is
end;
end First_Element;
-----------------------
-- First_To_Previous --
-----------------------
function First_To_Previous
(Container : Set;
Current : Cursor) return Set is
Curs : Cursor := Current;
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end First_To_Previous;
-----------
-- Floor --
-----------
@ -1091,33 +1148,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end;
end Last_Element;
----------
-- Left --
----------
function Left (Container : Set; Position : Cursor) return Set is
Curs : Cursor := Position;
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
while Curs.Node /= 0 loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
--------------
-- Left_Son --
--------------
@ -1360,34 +1390,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Replace_Element (Container, Position.Node, New_Item);
end Replace_Element;
-----------
-- Right --
-----------
function Right (Container : Set; Position : Cursor) return Set is
Curs : Cursor := First (Container);
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while Curs.Node /= Position.Node loop
Node := Curs.Node;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
---------------
-- Right_Son --
---------------

29
gcc/ada/a-cforse.ads

@ -49,8 +49,10 @@
-- There are three new functions:
-- function Strict_Equal (Left, Right : Set) return Boolean;
-- function Left (Container : Set; Position : Cursor) return Set;
-- function Right (Container : Set; Position : Cursor) return Set;
-- function First_To_Previous (Container : Set; Current : Cursor)
-- return Set;
-- function Current_To_Last (Container : Set; Current : Cursor)
-- return Set;
-- See detailed specifications for these subprograms
@ -328,18 +330,21 @@ package Ada.Containers.Formal_Ordered_Sets is
-- they are structurally equal (function "=" returns True) and that they
-- have the same set of cursors.
function Left (Container : Set; Position : Cursor) return Set with
function First_To_Previous (Container : Set; Current : Cursor) return Set
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
function Right (Container : Set; Position : Cursor) return Set with
Pre => Has_Element (Container, Current) or else Current = No_Element;
function Current_To_Last (Container : Set; Current : Cursor) return Set
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
-- Left returns a container containing all elements preceding Position
-- (excluded) in Container. Right returns a container containing all
-- elements following Position (included) in Container. These two new
-- functions can be used to express invariant properties in loops which
-- iterate over containers. Left returns the part of the container already
-- scanned and Right the part not scanned yet.
Pre => Has_Element (Container, Current) or else Current = No_Element;
-- First_To_Previous returns a container containing all elements preceding
-- Current (excluded) in Container. Current_To_Last returns a container
-- containing all elements following Current (included) in Container.
-- These two new functions can be used to express invariant properties in
-- loops which iterate over containers. First_To_Previous returns the part
-- of the container already scanned and Current_To_Last the part not
-- scanned yet.
private

96
gcc/ada/a-cofove.adb

@ -313,6 +313,32 @@ package body Ada.Containers.Formal_Vectors is
end return;
end Copy;
---------------------
-- Current_To_Last --
---------------------
function Current_To_Last
(Container : Vector;
Current : Cursor) return Vector is
C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
begin
if Current = No_Element then
Clear (C);
return C;
end if;
if not Has_Element (Container, Current) then
raise Constraint_Error;
end if;
while C.Last /= Container.Last - Current.Index + 1 loop
Delete_First (C);
end loop;
return C;
end Current_To_Last;
------------
-- Delete --
------------
@ -578,6 +604,30 @@ package body Ada.Containers.Formal_Vectors is
return Index_Type'First;
end First_Index;
-----------------------
-- First_To_Previous --
-----------------------
function First_To_Previous
(Container : Vector;
Current : Cursor) return Vector is
C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
begin
if Current = No_Element then
return C;
end if;
if not Has_Element (Container, Current) then
raise Constraint_Error;
end if;
while C.Last /= Current.Index - 1 loop
Delete_Last (C);
end loop;
return C;
end First_To_Previous;
---------------------
-- Generic_Sorting --
---------------------
@ -1164,28 +1214,6 @@ package body Ada.Containers.Formal_Vectors is
return Count_Type (N);
end Length;
----------
-- Left --
----------
function Left (Container : Vector; Position : Cursor) return Vector is
C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
begin
if Position = No_Element then
return C;
end if;
if not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while C.Last /= Position.Index - 1 loop
Delete_Last (C);
end loop;
return C;
end Left;
----------
-- Move --
----------
@ -1459,30 +1487,6 @@ package body Ada.Containers.Formal_Vectors is
return No_Index;
end Reverse_Find_Index;
-----------
-- Right --
-----------
function Right (Container : Vector; Position : Cursor) return Vector is
C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
begin
if Position = No_Element then
Clear (C);
return C;
end if;
if not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while C.Last /= Container.Last - Position.Index + 1 loop
Delete_First (C);
end loop;
return C;
end Right;
----------------
-- Set_Length --
----------------

33
gcc/ada/a-cofove.ads

@ -48,8 +48,10 @@
-- There are three new functions:
-- function Strict_Equal (Left, Right : Vector) return Boolean;
-- function Left (Container : Vector; Position : Cursor) return Vector;
-- function Right (Container : Vector; Position : Cursor) return Vector;
-- function First_To_Previous (Container : Vector; Current : Cursor)
-- return Vector;
-- function Current_To_Last (Container : Vector; Current : Cursor)
-- return Vector;
-- See detailed specifications for these subprograms
@ -430,18 +432,25 @@ package Ada.Containers.Formal_Vectors is
-- they are structurally equal (function "=" returns True) and that they
-- have the same set of cursors.
function Left (Container : Vector; Position : Cursor) return Vector with
function First_To_Previous
(Container : Vector;
Current : Cursor) return Vector
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
function Right (Container : Vector; Position : Cursor) return Vector with
Pre => Has_Element (Container, Current) or else Current = No_Element;
function Current_To_Last
(Container : Vector;
Current : Cursor) return Vector
with
Global => null,
Pre => Has_Element (Container, Position) or else Position = No_Element;
-- Left returns a container containing all elements preceding Position
-- (excluded) in Container. Right returns a container containing all
-- elements following Position (included) in Container. These two new
-- functions can be used to express invariant properties in loops which
-- iterate over containers. Left returns the part of the container already
-- scanned and Right the part not scanned yet.
Pre => Has_Element (Container, Current) or else Current = No_Element;
-- First_To_Previous returns a container containing all elements preceding
-- Current (excluded) in Container. Current_To_Last returns a container
-- containing all elements following Current (included) in Container.
-- These two new functions can be used to express invariant properties in
-- loops which iterate over containers. First_To_Previous returns the part
-- of the container already scanned and Current_To_Last the part not
-- scanned yet.
private

78
gcc/ada/a-direct.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2013, 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- --
@ -36,21 +36,18 @@ with Ada.Directories.Validity; use Ada.Directories.Validity;
with Ada.Strings.Fixed;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System; use System;
with System.CRTL; use System.CRTL;
with System.File_IO; use System.File_IO;
with System.OS_Constants; use System.OS_Constants;
with System.OS_Lib; use System.OS_Lib;
with System.Regexp; use System.Regexp;
with System; use System;
with System.CRTL; use System.CRTL;
with System.File_Attributes; use System.File_Attributes;
with System.File_IO; use System.File_IO;
with System.OS_Constants; use System.OS_Constants;
with System.OS_Lib; use System.OS_Lib;
with System.Regexp; use System.Regexp;
package body Ada.Directories is
Filename_Max : constant Integer := 1024;
-- 1024 is the value of FILENAME_MAX in stdio.h
type Dir_Type_Value is new Address;
-- This is the low-level address directory structure as returned by the C
-- opendir routine.
@ -708,7 +705,7 @@ package body Ada.Directories is
----------------------
procedure Fetch_Next_Entry (Search : Search_Type) is
Name : String (1 .. 255);
Name : String (1 .. NAME_MAX);
Last : Natural;
Kind : File_Kind := Ordinary_File;
@ -717,9 +714,7 @@ package body Ada.Directories is
Filename_Addr : Address;
Filename_Len : aliased Integer;
Buffer : array (0 .. Filename_Max + 12) of Character;
-- 12 is the size of the dirent structure (see dirent.h), without the
-- field for the filename.
Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character;
function readdir_gnat
(Directory : Address;
@ -744,43 +739,60 @@ package body Ada.Directories is
exit;
end if;
if Filename_Len > Name'Length then
raise Use_Error with "file name too long";
end if;
declare
subtype Path_String is String (1 .. Filename_Len);
type Path_String_Access is access Path_String;
function Address_To_Access is new
Ada.Unchecked_Conversion
(Source => Address,
Target => Path_String_Access);
Path_Access : constant Path_String_Access :=
Address_To_Access (Filename_Addr);
subtype Name_String is String (1 .. Filename_Len);
Dent_Name : Name_String;
for Dent_Name'Address use Filename_Addr;
pragma Import (Ada, Dent_Name);
begin
Last := Filename_Len;
Name (1 .. Last) := Path_Access.all;
Name (1 .. Last) := Dent_Name;
end;
-- Check if the entry matches the pattern
if Match (Name (1 .. Last), Search.Value.Pattern) then
declare
Full_Name : constant String :=
Compose (To_String (Search.Value.Name), Name (1 .. Last));
Found : Boolean := False;
C_Full_Name : constant String :=
Compose (To_String (Search.Value.Name), Name (1 .. Last))
& ASCII.NUL;
Full_Name : String renames C_Full_Name
(C_Full_Name'First .. C_Full_Name'Last - 1);
Found : Boolean := False;
Attr : aliased File_Attributes;
Exists : Integer;
Error : Integer;
begin
if File_Exists (Full_Name) then
Reset_Attributes (Attr'Access);
Exists := File_Exists_Attr (C_Full_Name'Address, Attr'Access);
Error := Error_Attributes (Attr'Access);
if Error /= 0 then
raise Use_Error
with Full_Name & ": " & Errno_Message (Err => Error);
end if;
if Exists = 1 then
-- Now check if the file kind matches the filter
if Is_Regular_File (Full_Name) then
if Is_Regular_File_Attr
(C_Full_Name'Address, Attr'Access) = 1
then
if Search.Value.Filter (Ordinary_File) then
Kind := Ordinary_File;
Found := True;
end if;
elsif Is_Directory (Full_Name) then
elsif Is_Directory_Attr
(C_Full_Name'Address, Attr'Access) = 1
then
if Search.Value.Filter (Directory) then
Kind := Directory;
Found := True;
@ -821,7 +833,7 @@ package body Ada.Directories is
begin
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
return C_File_Exists (C_Name (1)'Address) = 1;
return C_File_Exists (C_Name'Address) = 1;
end File_Exists;
--------------

39
gcc/ada/adaint.c

@ -350,7 +350,9 @@ int __gnat_vmsp = 0;
#endif
/* Used for Ada bindings */
/* Used for runtime check that Ada constant File_Attributes_Size is no
less than the actual size of struct file_attributes (see Osint
initialization). */
int __gnat_size_of_file_attributes = sizeof (struct file_attributes);
void __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr);
@ -411,6 +413,7 @@ void
__gnat_reset_attributes (struct file_attributes* attr)
{
attr->exists = ATTR_UNSET;
attr->error = EINVAL;
attr->writable = ATTR_UNSET;
attr->readable = ATTR_UNSET;
@ -424,6 +427,11 @@ __gnat_reset_attributes (struct file_attributes* attr)
attr->file_length = -1;
}
int
__gnat_error_attributes (struct file_attributes *attr) {
return attr->error;
}
OS_Time
__gnat_current_time (void)
{
@ -1170,12 +1178,28 @@ void
__gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr)
{
GNAT_STRUCT_STAT statbuf;
int ret;
int ret, error;
if (fd != -1)
if (fd != -1) {
/* GNAT_FSTAT returns -1 and sets errno for failure */
ret = GNAT_FSTAT (fd, &statbuf);
error = ret ? errno : 0;
} else {
/* __gnat_stat returns errno value directly */
error = __gnat_stat (name, &statbuf);
ret = error ? -1 : 0;
}
/*
* A missing file is reported as an attr structure with error == 0 and
* exists == 0.
*/
if (error == 0 || error == ENOENT)
attr->error = 0;
else
ret = __gnat_stat (name, &statbuf);
attr->error = error;
attr->regular = (!ret && S_ISREG (statbuf.st_mode));
attr->directory = (!ret && S_ISDIR (statbuf.st_mode));
@ -1793,6 +1817,9 @@ __gnat_get_libraries_from_registry (void)
return result;
}
/* Query information for the given file NAME and return it in STATBUF.
* Returns 0 for success, or errno value for failure.
*/
int
__gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
{
@ -1807,7 +1834,7 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
name_len = _tcslen (wname);
if (name_len > GNAT_MAX_PATH_LEN)
return -1;
return EINVAL;
ZeroMemory (statbuf, sizeof(GNAT_STRUCT_STAT));
@ -1860,7 +1887,7 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
return 0;
#else
return GNAT_STAT (name, statbuf);
return GNAT_STAT (name, statbuf) == 0 ? 0 : errno;
#endif
}

8
gcc/ada/adaint.h

@ -78,6 +78,11 @@ typedef long OS_Time;
*/
struct file_attributes {
int error;
/* Errno value returned by stat()/fstat(). If non-zero, other fields should
* be considered as invalid.
*/
unsigned char exists;
unsigned char writable;
@ -163,7 +168,8 @@ extern int __gnat_is_writable_file (char *);
extern int __gnat_is_readable_file (char *name);
extern int __gnat_is_executable_file (char *name);
extern void __gnat_reset_attributes (struct file_attributes* attr);
extern void __gnat_reset_attributes (struct file_attributes *);
extern int __gnat_error_attributes (struct file_attributes *);
extern long __gnat_file_length_attr (int, char *, struct file_attributes *);
extern OS_Time __gnat_file_time_name_attr (char *, struct file_attributes *);
extern OS_Time __gnat_file_time_fd_attr (int, struct file_attributes *);

44
gcc/ada/gcc-interface/Make-lang.in

@ -350,6 +350,7 @@ GNAT_ADA_OBJS = \
ada/s-htable.o \
ada/s-imenne.o \
ada/s-imgenu.o \
ada/s-imgint.o \
ada/s-mastop.o \
ada/s-memory.o \
ada/s-os_lib.o \
@ -457,27 +458,16 @@ GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o
GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) ada/b_gnat1.o
GNATBIND_OBJS = \
ada/adaint.o \
ada/argv.o \
ada/cio.o \
ada/cstreams.o \
ada/env.o \
ada/exit.o \
ada/final.o \
ada/init.o \
ada/initialize.o \
ada/link.o \
ada/raise.o \
ada/seh_init.o \
ada/targext.o \
ada/ada.o \
ada/a-clrefi.o \
ada/a-comlin.o \
ada/a-elchha.o \
ada/a-except.o \
ada/ada.o \
ada/adaint.o \
ada/ali-util.o \
ada/ali.o \
ada/alloc.o \
ada/argv.o \
ada/aspects.o \
ada/atree.o \
ada/bcheck.o \
@ -487,34 +477,41 @@ GNATBIND_OBJS = \
ada/bindusg.o \
ada/butil.o \
ada/casing.o \
ada/cio.o \
ada/csets.o \
ada/cstreams.o \
ada/debug.o \
ada/einfo.o \
ada/elists.o \
ada/env.o \
ada/err_vars.o \
ada/errout.o \
ada/erroutc.o \
ada/exit.o \
ada/final.o \
ada/fmap.o \
ada/fname.o \
ada/fname-uf.o \
ada/fname.o \
ada/g-byorma.o \
ada/g-hesora.o \
ada/g-htable.o \
ada/s-os_lib.o \
ada/s-string.o \
ada/gnat.o \
ada/gnatbind.o \
ada/gnatvsn.o \
ada/hostparm.o \
ada/init.o \
ada/initialize.o \
ada/interfac.o \
ada/krunch.o \
ada/lib.o \
ada/link.o \
ada/namet.o \
ada/nlists.o \
ada/opt.o \
ada/osint-b.o \
ada/osint.o \
ada/output.o \
ada/raise.o \
ada/restrict.o \
ada/rident.o \
ada/s-addope.o \
@ -537,8 +534,10 @@ GNATBIND_OBJS = \
ada/s-htable.o \
ada/s-imenne.o \
ada/s-imgenu.o \
ada/s-imgint.o \
ada/s-mastop.o \
ada/s-memory.o \
ada/s-os_lib.o \
ada/s-parame.o \
ada/s-restri.o \
ada/s-secsta.o \
@ -550,6 +549,7 @@ GNATBIND_OBJS = \
ada/s-stalib.o \
ada/s-stoele.o \
ada/s-strhas.o \
ada/s-string.o \
ada/s-strops.o \
ada/s-traent.o \
ada/s-unstyp.o \
@ -557,24 +557,26 @@ GNATBIND_OBJS = \
ada/s-wchcnv.o \
ada/s-wchcon.o \
ada/s-wchjis.o \
ada/scng.o \
ada/scans.o \
ada/scil_ll.o \
ada/scng.o \
ada/sdefault.o \
ada/seh_init.o \
ada/sem_aux.o \
ada/sinfo.o \
ada/sinput.o \
ada/sinput-c.o \
ada/sinput.o \
ada/snames.o \
ada/stand.o \
ada/stringt.o \
ada/switch-b.o \
ada/switch.o \
ada/style.o \
ada/styleg.o \
ada/stylesw.o \
ada/switch-b.o \
ada/switch.o \
ada/system.o \
ada/table.o \
ada/targext.o \
ada/targparm.o \
ada/tree_io.o \
ada/types.o \

5
gcc/ada/osint.ads

@ -758,13 +758,14 @@ private
-- detected, the file being written is deleted, and a fatal error is
-- signalled.
File_Attributes_Size : constant Natural := 24;
File_Attributes_Size : constant Natural := 32;
-- This should be big enough to fit a "struct file_attributes" on any
-- system. It doesn't cause any malfunction if it is too big (which avoids
-- the need for either mapping the struct exactly or importing the sizeof
-- from C, which would result in dynamic code). However, it does waste
-- space (e.g. when a component of this type appears in a record, if it is
-- unnecessarily large).
-- unnecessarily large). Note: for runtime units, use System.OS_Constants.
-- SIZEOF_struct_file_attributes instead, which has the exact value.
type File_Attributes is
array (1 .. File_Attributes_Size)

5
gcc/ada/s-crtl.ads

@ -70,6 +70,11 @@ package System.CRTL is
function atoi (A : System.Address) return Integer;
pragma Import (C, atoi, "atoi");
function strlen (A : System.Address) return size_t;
pragma Import (Intrinsic, strlen, "strlen");
-- Import with convention Intrinsic so that we take advantage of the GCC
-- builtin where available (and fall back to the library function if not).
procedure clearerr (stream : FILEs);
pragma Import (C, clearerr, "clearerr");

67
gcc/ada/s-filatt.ads Normal file

@ -0,0 +1,67 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . F I L E _ A T T R I B U T E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2013, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a binding to the GNAT file attribute query functions
with System.OS_Constants;
with System.Storage_Elements;
package System.File_Attributes is
type File_Attributes is private;
procedure Reset_Attributes (A : access File_Attributes);
function Error_Attributes (A : access File_Attributes) return Integer;
function File_Exists_Attr
(N : System.Address;
A : access File_Attributes) return Integer;
function Is_Regular_File_Attr
(N : System.Address;
A : access File_Attributes) return Integer;
function Is_Directory_Attr
(N : System.Address;
A : access File_Attributes) return Integer;
private
package SOSC renames System.OS_Constants;
type File_Attributes is new System.Storage_Elements.Storage_Array
(1 .. SOSC.SIZEOF_struct_file_attributes);
for File_Attributes'Alignment use Standard'Maximum_Alignment;
pragma Import (C, Reset_Attributes, "__gnat_reset_attributes");
pragma Import (C, Error_Attributes, "__gnat_error_attributes");
pragma Import (C, File_Exists_Attr, "__gnat_file_exists_attr");
pragma Import (C, Is_Regular_File_Attr, "__gnat_is_regular_file_attr");
pragma Import (C, Is_Directory_Attr, "__gnat_is_directory_attr");
end System.File_Attributes;

73
gcc/ada/s-os_lib.adb

@ -88,8 +88,8 @@ package body System.OS_Lib is
-- parameters are as in Create_Temp_File.
function C_String_Length (S : Address) return Integer;
-- Returns the length of a C string. Does check for null address
-- (returns 0).
-- Returns the length of C (null-terminated) string at S, or 0 for
-- Null_Address.
procedure Spawn_Internal
(Program_Name : String;
@ -252,13 +252,11 @@ package body System.OS_Lib is
---------------------
function C_String_Length (S : Address) return Integer is
function Strlen (S : Address) return Integer;
pragma Import (C, Strlen, "strlen");
begin
if S = Null_Address then
return 0;
else
return Strlen (S);
return Integer (CRTL.strlen (S));
end if;
end C_String_Length;
@ -912,6 +910,38 @@ package body System.OS_Lib is
Delete_File (C_Name'Address, Success);
end Delete_File;
-------------------
-- Errno_Message --
-------------------
function Errno_Message
(Err : Integer := Errno;
Default : String := "") return String
is
function strerror (errnum : Integer) return System.Address;
pragma Import (C, strerror, "strerror");
C_Msg : constant System.Address := strerror (Err);
begin
if C_Msg = Null_Address then
if Default /= "" then
return Default;
else
return "errno =" & Err'Img;
end if;
else
declare
Msg : String (1 .. Integer (CRTL.strlen (C_Msg)));
for Msg'Address use C_Msg;
pragma Import (Ada, Msg);
begin
return Msg;
end;
end if;
end Errno_Message;
---------------------
-- File_Time_Stamp --
---------------------
@ -1028,14 +1058,11 @@ package body System.OS_Lib is
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
function Strlen (Cstring : Address) return Integer;
pragma Import (C, Strlen, "strlen");
Suffix_Length : Integer;
Result : String_Access;
begin
Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
@ -1057,14 +1084,11 @@ package body System.OS_Lib is
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
function Strlen (Cstring : Address) return Integer;
pragma Import (C, Strlen, "strlen");
Suffix_Length : Integer;
Result : String_Access;
begin
Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
@ -1086,14 +1110,11 @@ package body System.OS_Lib is
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
function Strlen (Cstring : Address) return Integer;
pragma Import (C, Strlen, "strlen");
Suffix_Length : Integer;
Result : String_Access;
begin
Suffix_Length := Strlen (Target_Object_Ext_Ptr);
Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr));
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
@ -1792,9 +1813,6 @@ package body System.OS_Lib is
Canonical_File_Addr : System.Address;
Canonical_File_Len : Integer;
function Strlen (S : System.Address) return Integer;
pragma Import (C, Strlen, "strlen");
function Final_Value (S : String) return String;
-- Make final adjustment to the returned string. This function strips
-- trailing directory separators, and folds returned string to lower
@ -1926,7 +1944,7 @@ package body System.OS_Lib is
The_Name (The_Name'Last) := ASCII.NUL;
Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
Canonical_File_Len := Strlen (Canonical_File_Addr);
Canonical_File_Len := Integer (CRTL.strlen (Canonical_File_Addr));
-- If VMS syntax conversion has failed, return an empty string
-- to indicate the failure.
@ -1937,17 +1955,12 @@ package body System.OS_Lib is
declare
subtype Path_String is String (1 .. Canonical_File_Len);
type Path_String_Access is access Path_String;
function Address_To_Access is new
Ada.Unchecked_Conversion (Source => Address,
Target => Path_String_Access);
Path_Access : constant Path_String_Access :=
Address_To_Access (Canonical_File_Addr);
Canonical_File : Path_String;
for Canonical_File'Address use Canonical_File_Addr;
pragma Import (Ada, Canonical_File);
begin
Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
Path_Buffer (1 .. Canonical_File_Len) := Canonical_File;
End_Path := Canonical_File_Len;
Last := 1;
end;

7
gcc/ada/s-os_lib.ads

@ -962,6 +962,13 @@ package System.OS_Lib is
pragma Import (C, Set_Errno, "__set_errno");
-- Set the task-safe error number
function Errno_Message
(Err : Integer := Errno;
Default : String := "") return String;
-- Return a message describing the given Errno value. If none is provided
-- by the system, return Default if not empty, else return a generic
-- message indicating the numeric errno value.
Directory_Separator : constant Character;
-- The character that is used to separate parts of a pathname

45
gcc/ada/s-oscons-tmplt.c

@ -89,6 +89,7 @@ pragma Style_Checks ("M32766");
/* Include gsocket.h before any system header so it can redefine FD_SETSIZE */
#include "gsocket.h"
#include "adaint.h"
#include <stdlib.h>
#include <string.h>
@ -310,6 +311,16 @@ CND(SIZEOF_unsigned_int, "Size of unsigned int")
#endif
CND(IOV_MAX, "Maximum writev iovcnt")
#ifndef NAME_MAX
# define NAME_MAX 255
#endif
CND(NAME_MAX, "Maximum file name length")
#ifndef PATH_MAX
# define PATH_MAX 1024
#endif
CND(FILENAME_MAX, "Maximum file path length")
/*
---------------------
@ -1319,20 +1330,44 @@ CND(SIZEOF_sockaddr_in, "struct sockaddr_in")
CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6")
#define SIZEOF_fd_set (sizeof (fd_set))
CND(SIZEOF_fd_set, "fd_set");
CND(FD_SETSIZE, "Max fd value");
CND(SIZEOF_fd_set, "fd_set")
CND(FD_SETSIZE, "Max fd value")
#define SIZEOF_struct_hostent (sizeof (struct hostent))
CND(SIZEOF_struct_hostent, "struct hostent");
CND(SIZEOF_struct_hostent, "struct hostent")
#define SIZEOF_struct_servent (sizeof (struct servent))
CND(SIZEOF_struct_servent, "struct servent");
CND(SIZEOF_struct_servent, "struct servent")
#if defined (__linux__)
#define SIZEOF_sigset (sizeof (sigset_t))
CND(SIZEOF_sigset, "sigset");
CND(SIZEOF_sigset, "sigset")
#endif
/**
** Note: this constant can be used in the GNAT runtime library. In compiler
** units on the other hand, System.OS_Constants is not available, so we
** declare an Ada constant (Osint.File_Attributes_Size) independently, which
** is at least as large as sizeof (struct file_attributes), and we have an
** assertion at initialization of Osint checking that the size is indeed at
** least sufficient.
**/
#define SIZEOF_struct_file_attributes (sizeof (struct file_attributes))
CND(SIZEOF_struct_file_attributes, "struct file_attributes")
/**
** Maximal size of buffer for struct dirent. Note: Since POSIX.1 does not
** specify the size of the d_name field, and other nonstandard fields may
** precede that field within the dirent structure, we must make a conservative
** computation.
**/
{
struct dirent dent;
#define SIZEOF_struct_dirent_alloc \
((char*) &dent.d_name - (char*) &dent) + NAME_MAX + 1
CND(SIZEOF_struct_dirent_alloc, "struct dirent allocation")
}
/*
-- Fields of struct msghdr

16
gcc/ada/s-rident.ads

@ -476,13 +476,15 @@ package System.Rident is
-- plus these additional restrictions:
No_Calendar => True,
No_Implicit_Heap_Allocations => True,
No_Relative_Delay => True,
No_Select_Statements => True,
No_Task_Termination => True,
Simple_Barriers => True,
others => False),
No_Calendar => True,
No_Implicit_Heap_Allocations => True,
No_Local_Timing_Events => True,
No_Relative_Delay => True,
No_Select_Statements => True,
No_Specific_Termination_Handlers => True,
No_Task_Termination => True,
Simple_Barriers => True,
others => False),
-- Value settings for Ravenscar (same as Restricted)

18
gcc/ada/sem_ch13.adb

@ -3874,21 +3874,13 @@ package body Sem_Ch13 is
begin
if Present (Init_Call) then
Append_Freeze_Action (U_Ent, Init_Call);
-- If the init call is an expression with actions with
-- null expression, just extract the actions.
-- Reset Initialization_Statements pointer so that
-- if there is a pragma Import further down, it can
-- clear any default initialization.
if Nkind (Init_Call) = N_Expression_With_Actions
and then
Nkind (Expression (Init_Call)) = N_Null_Statement
then
Append_Freeze_Actions (U_Ent, Actions (Init_Call));
-- General case: move Init_Call to freeze actions
else
Append_Freeze_Action (U_Ent, Init_Call);
end if;
Set_Initialization_Statements (U_Ent, Init_Call);
end if;
end;

6
gcc/ada/sem_ch5.adb

@ -1688,7 +1688,7 @@ package body Sem_Ch5 is
if Present (Subt) then
Analyze (Subt);
-- Save type of subtype indication for subsequent check.
-- Save type of subtype indication for subsequent check
if Nkind (Subt) = N_Subtype_Indication then
Bas := Entity (Subtype_Mark (Subt));
@ -1855,9 +1855,7 @@ package body Sem_Ch5 is
else
Set_Ekind (Def_Id, E_Loop_Parameter);
if Ada_Version < Ada_2012 then
Error_Msg_N ("container iterators are an Ada 2012 feature", N);
end if;
Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N));
-- OF present

12
gcc/ada/sem_ch6.adb

@ -369,6 +369,18 @@ package body Sem_Ch6 is
elsif Present (Prev) and then Comes_From_Source (Prev) then
Set_Has_Completion (Prev, False);
-- An expression function that is a completion freezes the
-- expression. This means freezing the return type, and if it is
-- an access type, freezing its designated type as well.
-- Note that we cannot defer this freezing to the analysis of the
-- expression itself, because a freeze node might appear in a
-- nested scope, leading to an elaboration order issue in gigi.
Freeze_Before (N, Etype (Prev));
if Is_Access_Type (Etype (Prev)) then
Freeze_Before (N, Designated_Type (Etype (Prev)));
end if;
-- For navigation purposes, indicate that the function is a body
Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True);

16
gcc/ada/sem_prag.adb

@ -2058,17 +2058,17 @@ package body Sem_Prag is
Ref => Item);
end if;
-- Variable related checks
elsif Is_SPARK_Volatile_Object (Item_Id) then
-- Variable related checks. These are only relevant when
-- SPARK_Mode is on as they are not standard Ada legality
-- rules.
elsif SPARK_Mode = On
and then Is_SPARK_Volatile_Object (Item_Id)
then
-- A volatile object cannot appear as a global item of a
-- function. This check is only relevant when SPARK_Mode is
-- on as it is not a standard Ada legality rule.
-- function.
if SPARK_Mode = On
and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
then
if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
Error_Msg_NE
("volatile object & cannot act as global item of a "
& "function (SPARK RM 7.1.3(9))", Item, Item_Id);