+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
# 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
s-fatllf$(objext) \
s-fatsfl$(objext) \
s-ficobl$(objext) \
+ s-filatt$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
s-finmas$(objext) \
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 --
------------
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 --
----------
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 --
------------
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 --
------------
-- 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
-- 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
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 --
---------------------
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 --
----------
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 --
------------
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 --
--------------
-- 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
-- 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;
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 --
---------------------
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 --
----------
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 --
------------
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 --
------------------
-- 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
-- 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
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;
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 --
------------
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 --
-----------
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 --
--------------
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 --
---------------
-- 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
-- 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;
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;
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 --
------------
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 --
-----------
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 --
--------------
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 --
---------------
-- 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
-- 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
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 --
------------
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 --
---------------------
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 --
----------
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 --
----------------
-- 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
-- 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
-- --
-- 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- --
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.
----------------------
procedure Fetch_Next_Entry (Search : Search_Type) is
- Name : String (1 .. 255);
+ Name : String (1 .. NAME_MAX);
Last : Natural;
Kind : File_Kind := Ordinary_File;
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;
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;
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;
--------------
#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);
__gnat_reset_attributes (struct file_attributes* attr)
{
attr->exists = ATTR_UNSET;
+ attr->error = EINVAL;
attr->writable = ATTR_UNSET;
attr->readable = ATTR_UNSET;
attr->file_length = -1;
}
+int
+__gnat_error_attributes (struct file_attributes *attr) {
+ return attr->error;
+}
+
OS_Time
__gnat_current_time (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));
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)
{
name_len = _tcslen (wname);
if (name_len > GNAT_MAX_PATH_LEN)
- return -1;
+ return EINVAL;
ZeroMemory (statbuf, sizeof(GNAT_STRUCT_STAT));
return 0;
#else
- return GNAT_STAT (name, statbuf);
+ return GNAT_STAT (name, statbuf) == 0 ? 0 : errno;
#endif
}
*/
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;
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 *);
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 \
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 \
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 \
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 \
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 \
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 \
-- 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)
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");
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- 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;
---------------------
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;
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 --
---------------------
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
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
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
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
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.
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;
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
/* 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>
#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")
+
/*
---------------------
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
-- 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)
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;
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));
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
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);
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);
projects / thirdparty / gcc.git / commitdiff
