From 28a4283c747db61dedc1aaaec46de161351d3f35 Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 24 Feb 2014 16:51:58 +0000 Subject: 2014-02-24 Hristian Kirtchev * 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 * sem_ch5.adb (Analyze_Iterator_Specification): use Error_Msg_Ada_2012_Feature. 2014-02-24 Jose Ruiz * 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 * 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 * 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 * 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 * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@208078 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 65 ++++++++++++++++++++ gcc/ada/Make-generated.in | 2 +- gcc/ada/Makefile.rtl | 1 + gcc/ada/a-cfdlli.adb | 114 ++++++++++++++++++----------------- gcc/ada/a-cfdlli.ads | 29 +++++---- gcc/ada/a-cfhama.adb | 120 +++++++++++++++++++------------------ gcc/ada/a-cfhama.ads | 29 +++++---- gcc/ada/a-cfhase.adb | 116 +++++++++++++++++------------------ gcc/ada/a-cfhase.ads | 29 +++++---- gcc/ada/a-cforma.adb | 116 +++++++++++++++++------------------ gcc/ada/a-cforma.ads | 29 +++++---- gcc/ada/a-cforse.adb | 116 +++++++++++++++++------------------ gcc/ada/a-cforse.ads | 29 +++++---- gcc/ada/a-cofove.adb | 96 +++++++++++++++-------------- gcc/ada/a-cofove.ads | 33 ++++++---- gcc/ada/a-direct.adb | 78 ++++++++++++++---------- gcc/ada/adaint.c | 39 ++++++++++-- gcc/ada/adaint.h | 8 ++- gcc/ada/gcc-interface/Make-lang.in | 44 +++++++------- gcc/ada/osint.ads | 5 +- gcc/ada/s-crtl.ads | 5 ++ gcc/ada/s-filatt.ads | 67 +++++++++++++++++++++ gcc/ada/s-os_lib.adb | 73 ++++++++++++---------- gcc/ada/s-os_lib.ads | 7 +++ gcc/ada/s-oscons-tmplt.c | 45 ++++++++++++-- gcc/ada/s-rident.ads | 16 ++--- gcc/ada/sem_ch13.adb | 18 ++---- gcc/ada/sem_ch5.adb | 6 +- gcc/ada/sem_ch6.adb | 12 ++++ gcc/ada/sem_prag.adb | 16 ++--- 30 files changed, 829 insertions(+), 534 deletions(-) create mode 100644 gcc/ada/s-filatt.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 97636e9a7f5..24bac575282 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,68 @@ +2014-02-24 Hristian Kirtchev + + * 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 + + * sem_ch5.adb (Analyze_Iterator_Specification): use + Error_Msg_Ada_2012_Feature. + +2014-02-24 Jose Ruiz + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 * sem_prag.adb (Analyze_Global_Item): Move the check concerning diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in index 1ddd0b54c33..8cbc2f3c334 100644 --- a/gcc/ada/Make-generated.in +++ b/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 diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index e5c90f8d42d..e4f2a5948d9 100644 --- a/gcc/ada/Makefile.rtl +++ b/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) \ diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index 982c1b7d2f7..706bafc6de7 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/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 -- ------------ diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index 8b169e46cc7..b5ceacacfd0 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/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 diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index 365221259e5..a8fe1273751 100644 --- a/gcc/ada/a-cfhama.adb +++ b/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 -- -------------- diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index 7880ea0fe7f..9a2b37690dd 100644 --- a/gcc/ada/a-cfhama.ads +++ b/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; diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index 398fa774f75..27a02539421 100644 --- a/gcc/ada/a-cfhase.adb +++ b/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 -- ------------------ diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index 058d4503e1d..4e54ef97832 100644 --- a/gcc/ada/a-cfhase.ads +++ b/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 diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index 33cd101badc..f8aadf5bbf0 100644 --- a/gcc/ada/a-cforma.adb +++ b/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 -- --------------- diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index f927cf86da3..64d77fa4c8d 100644 --- a/gcc/ada/a-cforma.ads +++ b/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; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index 9064e7ba0c6..ac24420cbbd 100644 --- a/gcc/ada/a-cforse.adb +++ b/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 -- --------------- diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index 5035e1c85a7..8d3189edaec 100644 --- a/gcc/ada/a-cforse.ads +++ b/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 diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index d76055cc341..81990849de5 100644 --- a/gcc/ada/a-cofove.adb +++ b/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 -- ---------------- diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 727941f2258..d99041a4605 100644 --- a/gcc/ada/a-cofove.ads +++ b/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 diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index fa95d3c9cb0..c264b4c49c1 100644 --- a/gcc/ada/a-direct.adb +++ b/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; - 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); + if Filename_Len > Name'Length then + raise Use_Error with "file name too long"; + end if; - Path_Access : constant Path_String_Access := - Address_To_Access (Filename_Addr); + declare + 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; -------------- diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 3cabec95077..8d574da2cc8 100644 --- a/gcc/ada/adaint.c +++ b/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 } diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 554d848f736..28d4c8c2e2f 100644 --- a/gcc/ada/adaint.h +++ b/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 *); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 4f0ca79b097..e3c012a88c3 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/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 \ diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index dba06aad1c4..f18a5ea97cc 100644 --- a/gcc/ada/osint.ads +++ b/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) diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 390f47e02df..8e8aa2d7fc8 100644 --- a/gcc/ada/s-crtl.ads +++ b/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"); diff --git a/gcc/ada/s-filatt.ads b/gcc/ada/s-filatt.ads new file mode 100644 index 00000000000..c80626371c9 --- /dev/null +++ b/gcc/ada/s-filatt.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 42e4c549401..7b6a28b4408 100644 --- a/gcc/ada/s-os_lib.adb +++ b/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; diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 03557b65597..92bf50c8d2f 100644 --- a/gcc/ada/s-os_lib.ads +++ b/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 diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 2357d61d699..deb1855d366 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/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 #include @@ -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 diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 2fb2941811f..732ce9dbfe5 100644 --- a/gcc/ada/s-rident.ads +++ b/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) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 57abf9a4707..0defeb3efa7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index d4ca288586f..2126f706409 100644 --- a/gcc/ada/sem_ch5.adb +++ b/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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5885e3f4538..cc6795b1b53 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ba462275685..384ad0f8dd2 100644 --- a/gcc/ada/sem_prag.adb +++ b/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); -- cgit v1.2.1