Skip to content

R
riscv-gcc-1
Commit def46b54 by Robert Dewar Committed by Arnaud Charlet
Options

s-osinte-lynxos-3.ads, [...]: Add missing pragma Convention C for subprogram pointers. 

2007-12-06  Robert Dewar  <dewar@adacore.com>

	* s-osinte-lynxos-3.ads, s-osinte-hpux.ads, s-osinte-solaris-posix.ads, 
	s-osinte-freebsd.ads, s-osinte-lynxos.ads, s-osinte-tru64.ads, 
	s-osinte-mingw.ads, s-osinte-aix.ads, s-osinte-hpux-dce.ads, 
	s-osinte-irix.ads, s-osinte-solaris.ads, s-intman-vms.adb,
	s-osinte-vms.ads, s-osinte-vxworks6.ads, s-osinte-vxworks.ads,
	s-auxdec.ads, s-auxdec-vms_64.ads, s-osinte-darwin.ads, 
	s-taprop-vms.adb, s-interr-sigaction.adb, s-osinte-linux-hppa.ads, 
	i-vxwork-x86.ads, s-tpopde-vms.ads: Add missing pragma Convention C
	for subprogram pointers.

	* g-ctrl_c.adb: New file.

	* g-ctrl_c.ads (Install_Handler): New body.

	* freeze.adb (Freeze_Subprogram): Use new flag Has_Pragma_Inline_Always
	instead of obsolete function Is_Always_Inlined.
	(Freeze_Entity): check for tagged type in imported C subprogram
	(Freeze_Entity): check for 8-bit boolean in imported C subprogram
	(Freeze_Entity): check for convention Ada subprogram pointer in
	imported C subprogram.
	(Freeze_Fixed_Point_Type): In the case of a base type where the low
	bound would be chopped off and go from negative to zero, force
	Loval_Excl_EP to be the same as Loval_Incl_EP (the included lower
	bound) so that the size computation for the base type will take
	negative values into account.

From-SVN: r130813
parent b41ab480
Showing with 621 additions and 214 deletions
gcc/ada/freeze.adb
......@@ -243,11 +243,16 @@ package body Freeze is
O_Formal : Entity_Id;
Param_Spec : Node_Id;
Pref : Node_Id := Empty;
-- If the renamed entity is a primitive operation given in prefix form,
-- the prefix is the target object and it has to be added as the first
-- actual in the generated call.
begin
-- Determine the entity being renamed, which is the target of the
-- call statement. If the name is an explicit dereference, this is
-- a renaming of a subprogram type rather than a subprogram. The
-- name itself is fully analyzed.
-- Determine the entity being renamed, which is the target of the call
-- statement. If the name is an explicit dereference, this is a renaming
-- of a subprogram type rather than a subprogram. The name itself is
-- fully analyzed.
if Nkind (Nam) = N_Selected_Component then
Old_S := Entity (Selector_Name (Nam));
......@@ -271,8 +276,8 @@ package body Freeze is
if Is_Entity_Name (Nam) then
-- If the renamed entity is a predefined operator, retain full
-- name to ensure its visibility.
-- If the renamed entity is a predefined operator, retain full name
-- to ensure its visibility.
if Ekind (Old_S) = E_Operator
and then Nkind (Nam) = N_Expanded_Name
......@@ -283,7 +288,22 @@ package body Freeze is
end if;
else
Call_Name := New_Copy (Name (N));
if Nkind (Nam) = N_Selected_Component
and then Present (First_Formal (Old_S))
and then
(Is_Controlling_Formal (First_Formal (Old_S))
or else Is_Class_Wide_Type (Etype (First_Formal (Old_S))))
then
-- Retrieve the target object, to be added as a first actual
-- in the call.
Call_Name := New_Occurrence_Of (Old_S, Loc);
Pref := Prefix (Nam);
else
Call_Name := New_Copy (Name (N));
end if;
-- The original name may have been overloaded, but
-- is fully resolved now.
......@@ -291,9 +311,9 @@ package body Freeze is
Set_Is_Overloaded (Call_Name, False);
end if;
-- For simple renamings, subsequent calls can be expanded directly
-- as called to the renamed entity. The body must be generated in
-- any case for calls they may appear elsewhere.
-- For simple renamings, subsequent calls can be expanded directly as
-- called to the renamed entity. The body must be generated in any case
-- for calls they may appear elsewhere.
if (Ekind (Old_S) = E_Function
or else Ekind (Old_S) = E_Procedure)
......@@ -309,23 +329,55 @@ package body Freeze is
Formal := First_Formal (Defining_Entity (Decl));
if Present (Formal) then
if Present (Pref) then
declare
Pref_Type : constant Entity_Id := Etype (Pref);
Form_Type : constant Entity_Id := Etype (First_Formal (Old_S));
begin
-- The controlling formal may be an access parameter, or the
-- actual may be an access value, so ajust accordingly.
if Is_Access_Type (Pref_Type)
and then not Is_Access_Type (Form_Type)
then
Actuals := New_List
(Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
elsif Is_Access_Type (Form_Type)
and then not Is_Access_Type (Pref)
then
Actuals := New_List
(Make_Attribute_Reference (Loc,
Attribute_Name => Name_Access,
Prefix => Relocate_Node (Pref)));
else
Actuals := New_List (Pref);
end if;
end;
elsif Present (Formal) then
Actuals := New_List;
else
Actuals := No_List;
end if;
if Present (Formal) then
while Present (Formal) loop
Append (New_Reference_To (Formal, Loc), Actuals);
Next_Formal (Formal);
end loop;
end if;
-- If the renamed entity is an entry, inherit its profile. For
-- other renamings as bodies, both profiles must be subtype
-- conformant, so it is not necessary to replace the profile given
-- in the declaration. However, default values that are aggregates
-- are rewritten when partially analyzed, so we recover the original
-- aggregate to insure that subsequent conformity checking works.
-- Similarly, if the default expression was constant-folded, recover
-- the original expression.
-- If the renamed entity is an entry, inherit its profile. For other
-- renamings as bodies, both profiles must be subtype conformant, so it
-- is not necessary to replace the profile given in the declaration.
-- However, default values that are aggregates are rewritten when
-- partially analyzed, so we recover the original aggregate to insure
-- that subsequent conformity checking works. Similarly, if the default
-- expression was constant-folded, recover the original expression.
Formal := First_Formal (Defining_Entity (Decl));
......@@ -421,8 +473,8 @@ package body Freeze is
end if;
-- Link the body to the entity whose declaration it completes. If
-- the body is analyzed when the renamed entity is frozen, it may be
-- necessary to restore the proper scope (see package Exp_Ch13).
-- the body is analyzed when the renamed entity is frozen, it may
-- be necessary to restore the proper scope (see package Exp_Ch13).
if Nkind (N) = N_Subprogram_Renaming_Declaration
and then Present (Corresponding_Spec (N))
......@@ -449,18 +501,16 @@ package body Freeze is
if Present (Addr) then
Expr := Expression (Addr);
-- If we have no initialization of any kind, then we don't
-- need to place any restrictions on the address clause, because
-- the object will be elaborated after the address clause is
-- evaluated. This happens if the declaration has no initial
-- expression, or the type has no implicit initialization, or
-- the object is imported.
-- If we have no initialization of any kind, then we don't need to
-- place any restrictions on the address clause, because the object
-- will be elaborated after the address clause is evaluated. This
-- happens if the declaration has no initial expression, or the type
-- has no implicit initialization, or the object is imported.
-- The same holds for all initialized scalar types and all
-- access types. Packed bit arrays of size up to 64 are
-- represented using a modular type with an initialization
-- (to zero) and can be processed like other initialized
-- scalar types.
-- The same holds for all initialized scalar types and all access
-- types. Packed bit arrays of size up to 64 are represented using a
-- modular type with an initialization (to zero) and can be processed
-- like other initialized scalar types.
-- If the type is controlled, code to attach the object to a
-- finalization chain is generated at the point of declaration,
......@@ -487,9 +537,9 @@ package body Freeze is
then
null;
-- Otherwise, we require the address clause to be constant
-- because the call to the initialization procedure (or the
-- attach code) has to happen at the point of the declaration.
-- Otherwise, we require the address clause to be constant because
-- the call to the initialization procedure (or the attach code) has
-- to happen at the point of the declaration.
else
Check_Constant_Address_Clause (Expr, E);
......@@ -587,8 +637,8 @@ package body Freeze is
elsif not Is_Constrained (T) then
return False;
-- Don't do any recursion on type with error posted, since
-- we may have a malformed type that leads us into a loop
-- Don't do any recursion on type with error posted, since we may
-- have a malformed type that leads us into a loop.
elsif Error_Posted (T) then
return False;
......@@ -597,8 +647,8 @@ package body Freeze is
return False;
end if;
-- Check for all indexes static, and also compute possible
-- size (in case it is less than 32 and may be packable).
-- Check for all indexes static, and also compute possible size
-- (in case it is less than 32 and may be packable).
declare
Esiz : Uint := Component_Size (T);
......@@ -648,8 +698,8 @@ package body Freeze is
and then not Is_Generic_Type (T)
and then Present (Underlying_Type (T))
then
-- Don't do any recursion on type with error posted, since
-- we may have a malformed type that leads us into a loop
-- Don't do any recursion on type with error posted, since we may
-- have a malformed type that leads us into a loop.
if Error_Posted (T) then
return False;
......@@ -672,8 +722,8 @@ package body Freeze is
then
return False;
-- Don't do any recursion on type with error posted, since
-- we may have a malformed type that leads us into a loop
-- Don't do any recursion on type with error posted, since we may
-- have a malformed type that leads us into a loop.
elsif Error_Posted (T) then
return False;
......@@ -682,16 +732,15 @@ package body Freeze is
-- Now look at the components of the record
declare
-- The following two variables are used to keep track of
-- the size of packed records if we can tell the size of
-- the packed record in the front end. Packed_Size_Known
-- is True if so far we can figure out the size. It is
-- initialized to True for a packed record, unless the
-- record has discriminants. The reason we eliminate the
-- discriminated case is that we don't know the way the
-- back end lays out discriminated packed records. If
-- Packed_Size_Known is True, then Packed_Size is the
-- size in bits so far.
-- The following two variables are used to keep track of the
-- size of packed records if we can tell the size of the packed
-- record in the front end. Packed_Size_Known is True if so far
-- we can figure out the size. It is initialized to True for a
-- packed record, unless the record has discriminants. The
-- reason we eliminate the discriminated case is that we don't
-- know the way the back end lays out discriminated packed
-- records. If Packed_Size_Known is True, then Packed_Size is
-- the size in bits so far.
Packed_Size_Known : Boolean :=
Is_Packed (T)
......@@ -797,8 +846,8 @@ package body Freeze is
end;
end if;
-- Clearly size of record is not known if the size of
-- one of the components is not known.
-- Clearly size of record is not known if the size of one of
-- the components is not known.
if not Size_Known (Ctyp) then
return False;
......@@ -1063,12 +1112,11 @@ package body Freeze is
Set_Expression (Parent (E), New_Occurrence_Of (Temp, Loc));
-- To prevent the temporary from being constant-folded (which
-- would lead to the same piecemeal assignment on the original
-- target) indicate to the back-end that the temporary is a
-- variable with real storage. See description of this flag
-- in Einfo, and the notes on N_Assignment_Statement and
-- N_Object_Declaration in Sinfo.
-- To prevent the temporary from being constant-folded (which would
-- lead to the same piecemeal assignment on the original target)
-- indicate to the back-end that the temporary is a variable with
-- real storage. See description of this flag in Einfo, and the notes
-- on N_Assignment_Statement and N_Object_Declaration in Sinfo.
Set_Is_True_Constant (Temp, False);
end if;
......@@ -1091,10 +1139,10 @@ package body Freeze is
Decl : Node_Id;
procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id);
-- This is the internal recursive routine that does freezing of
-- entities (but NOT the analysis of default expressions, which
-- should not be recursive, we don't want to analyze those till
-- we are sure that ALL the types are frozen).
-- This is the internal recursive routine that does freezing of entities
-- (but NOT the analysis of default expressions, which should not be
-- recursive, we don't want to analyze those till we are sure that ALL
-- the types are frozen).
--------------------
-- Freeze_All_Ent --
......@@ -1109,8 +1157,8 @@ package body Freeze is
Lastn : Node_Id;
procedure Process_Flist;
-- If freeze nodes are present, insert and analyze, and reset
-- cursor for next insertion.
-- If freeze nodes are present, insert and analyze, and reset cursor
-- for next insertion.
-------------------
-- Process_Flist --
......@@ -1137,9 +1185,9 @@ package body Freeze is
while Present (E) loop
-- If the entity is an inner package which is not a package
-- renaming, then its entities must be frozen at this point.
-- Note that such entities do NOT get frozen at the end of
-- the nested package itself (only library packages freeze).
-- renaming, then its entities must be frozen at this point. Note
-- that such entities do NOT get frozen at the end of the nested
-- package itself (only library packages freeze).
-- Same is true for task declarations, where anonymous records
-- created for entry parameters must be frozen.
......@@ -1168,9 +1216,9 @@ package body Freeze is
End_Scope;
-- For a derived tagged type, we must ensure that all the
-- primitive operations of the parent have been frozen, so
-- that their addresses will be in the parent's dispatch table
-- at the point it is inherited.
-- primitive operations of the parent have been frozen, so that
-- their addresses will be in the parent's dispatch table at the
-- point it is inherited.
elsif Ekind (E) = E_Record_Type
and then Is_Tagged_Type (E)
......@@ -1207,13 +1255,12 @@ package body Freeze is
Process_Flist;
end if;
-- If an incomplete type is still not frozen, this may be
-- a premature freezing because of a body declaration that
-- follows. Indicate where the freezing took place.
-- If an incomplete type is still not frozen, this may be a
-- premature freezing because of a body declaration that follows.
-- Indicate where the freezing took place.
-- If the freezing is caused by the end of the current
-- declarative part, it is a Taft Amendment type, and there
-- is no error.
-- If the freezing is caused by the end of the current declarative
-- part, it is a Taft Amendment type, and there is no error.
if not Is_Frozen (E)
and then Ekind (E) = E_Incomplete_Type
......@@ -1416,7 +1463,7 @@ package body Freeze is
begin
case Nkind (N) is
when N_Attribute_Reference =>
if (Attribute_Name (N) = Name_Access
if (Attribute_Name (N) = Name_Access
or else
Attribute_Name (N) = Name_Unchecked_Access)
and then Is_Entity_Name (Prefix (N))
......@@ -1831,16 +1878,16 @@ package body Freeze is
end if;
end;
-- If the component is an access type with an allocator as
-- default value, the designated type will be frozen by the
-- corresponding expression in init_proc. In order to place the
-- freeze node for the designated type before that for the
-- current record type, freeze it now.
-- If the component is an access type with an allocator as default
-- value, the designated type will be frozen by the corresponding
-- expression in init_proc. In order to place the freeze node for
-- the designated type before that for the current record type,
-- freeze it now.
-- Same process if the component is an array of access types,
-- initialized with an aggregate. If the designated type is
-- private, it cannot contain allocators, and it is premature to
-- freeze the type, so we check for this as well.
-- private, it cannot contain allocators, and it is premature
-- to freeze the type, so we check for this as well.
elsif Is_Access_Type (Etype (Comp))
and then Present (Parent (Comp))
......@@ -1916,8 +1963,8 @@ package body Freeze is
Error_Msg_N
("\?since no component clauses were specified", ADC);
-- Here is where we do Ada 2005 processing for bit order (the
-- Ada 95 case was already taken care of above).
-- Here is where we do Ada 2005 processing for bit order (the Ada
-- 95 case was already taken care of above).
elsif Ada_Version >= Ada_05 then
Adjust_Record_For_Reverse_Bit_Order (Rec);
......@@ -1933,9 +1980,9 @@ package body Freeze is
and then Is_Packed (Rec)
and then not Unplaced_Component
then
-- Reset packed status. Probably not necessary, but we do it
-- so that there is no chance of the back end doing something
-- strange with this redundant indication of packing.
-- Reset packed status. Probably not necessary, but we do it so
-- that there is no chance of the back end doing something strange
-- with this redundant indication of packing.
Set_Is_Packed (Rec, False);
......@@ -2125,12 +2172,12 @@ package body Freeze is
-- Similarly, an inlined instance body may make reference to global
-- entities, but these references cannot be the proper freezing point
-- for them, and in the absence of inlining freezing will take place
-- in their own scope. Normally instance bodies are analyzed after
-- the enclosing compilation, and everything has been frozen at the
-- proper place, but with front-end inlining an instance body is
-- compiled before the end of the enclosing scope, and as a result
-- out-of-order freezing must be prevented.
-- for them, and in the absence of inlining freezing will take place in
-- their own scope. Normally instance bodies are analyzed after the
-- enclosing compilation, and everything has been frozen at the proper
-- place, but with front-end inlining an instance body is compiled
-- before the end of the enclosing scope, and as a result out-of-order
-- freezing must be prevented.
elsif Front_End_Inlining
and then In_Instance_Body
......@@ -2220,26 +2267,9 @@ package body Freeze is
if not Is_Internal (E) then
declare
F_Type : Entity_Id;
R_Type : Entity_Id;
Warn_Node : Node_Id;
function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean;
-- Determines if given type entity is a fat pointer type
-- used as an argument type or return type to a subprogram
-- with C or C++ convention set.
--------------------------
-- Is_Fat_C_Access_Type --
--------------------------
function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean is
begin
return (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then Is_Access_Type (T)
and then Esize (T) > Ttypes.System_Address_Size;
end Is_Fat_C_Ptr_Type;
begin
-- Loop through formals
......@@ -2277,22 +2307,72 @@ package body Freeze is
end if;
end if;
-- Check bad use of fat C pointer
-- Check suspicious parameter for C function. These tests
-- apply only to exported/imported suboprograms.
if Warn_On_Export_Import and then
Is_Fat_C_Ptr_Type (F_Type)
if Warn_On_Export_Import
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then not Warnings_Off (E)
and then not Warnings_Off (F_Type)
and then not Warnings_Off (Formal)
and then (Is_Imported (E) or else Is_Exported (E))
then
Error_Msg_Qual_Level := 1;
Error_Msg_N
("?type of & does not correspond to C pointer",
Formal);
-- Check suspicious use of fat C pointer
if Is_Access_Type (F_Type)
and then Esize (F_Type) > Ttypes.System_Address_Size
then
Error_Msg_N
("?type of & does not correspond "
& "to C pointer!", Formal);
-- Check suspicious return of boolean
elsif Root_Type (F_Type) = Standard_Boolean
and then Convention (F_Type) = Convention_Ada
then
Error_Msg_N
("?& is an 8-bit Ada Boolean, "
& "use char in C!", Formal);
-- Check suspicious tagged type
elsif (Is_Tagged_Type (F_Type)
or else (Is_Access_Type (F_Type)
and then
Is_Tagged_Type
(Designated_Type (F_Type))))
and then Convention (E) = Convention_C
then
Error_Msg_N
("?& is a tagged type which does not "
& "correspond to any C type!", Formal);
-- Check wrong convention subprogram pointer
elsif Ekind (F_Type) = E_Access_Subprogram_Type
and then not Has_Foreign_Convention (F_Type)
then
Error_Msg_N
("?subprogram pointer & should "
& "have foreign convention!", Formal);
Error_Msg_Sloc := Sloc (F_Type);
Error_Msg_NE
("\?add Convention pragma to declaration of &#",
Formal, F_Type);
end if;
Error_Msg_Qual_Level := 0;
end if;
-- Check for unconstrained array in exported foreign
-- convention case.
if Convention (E) in Foreign_Convention
if Has_Foreign_Convention (E)
and then not Is_Imported (E)
and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
......@@ -2365,22 +2445,75 @@ package body Freeze is
Next_Formal (Formal);
end loop;
-- Check return type
-- Case of function
if Ekind (E) = E_Function then
Freeze_And_Append (Etype (E), Loc, Result);
-- Freeze return type
R_Type := Etype (E);
Freeze_And_Append (R_Type, Loc, Result);
-- Check suspicious return type for C function
if Warn_On_Export_Import
and then Is_Fat_C_Ptr_Type (Etype (E))
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then not Warnings_Off (E)
and then not Warnings_Off (R_Type)
and then (Is_Imported (E) or else Is_Exported (E))
then
Error_Msg_N
("?return type of& does not correspond to C pointer",
E);
-- Check suspicious return of fat C pointer
if Is_Access_Type (R_Type)
and then Esize (R_Type) > Ttypes.System_Address_Size
then
Error_Msg_N
("?return type of& does not "
& "correspond to C pointer!", E);
-- Check suspicious return of boolean
elsif Root_Type (R_Type) = Standard_Boolean
and then Convention (R_Type) = Convention_Ada
then
Error_Msg_N
("?return type of & is an 8-bit "
& "Ada Boolean, use char in C!", E);
elsif Is_Array_Type (Etype (E))
-- Check suspicious return tagged type
elsif (Is_Tagged_Type (R_Type)
or else (Is_Access_Type (R_Type)
and then
Is_Tagged_Type
(Designated_Type (R_Type))))
and then Convention (E) = Convention_C
then
Error_Msg_N
("?return type of & does not "
& "correspond to C type!", E);
-- Check return of wrong convention subprogram pointer
elsif Ekind (R_Type) = E_Access_Subprogram_Type
and then not Has_Foreign_Convention (R_Type)
then
Error_Msg_N
("?& should return a foreign "
& "convention subprogram pointer", E);
Error_Msg_Sloc := Sloc (R_Type);
Error_Msg_NE
("\?add Convention pragma to declaration of& #",
E, R_Type);
end if;
end if;
if Is_Array_Type (Etype (E))
and then not Is_Constrained (Etype (E))
and then not Is_Imported (E)
and then Convention (E) in Foreign_Convention
and then Has_Foreign_Convention (E)
and then Warn_On_Export_Import
then
Error_Msg_N
......@@ -2451,14 +2584,14 @@ package body Freeze is
Check_Address_Clause (E);
-- For imported objects, set Is_Public unless there is also
-- an address clause, which means that there is no external
-- symbol needed for the Import (Is_Public may still be set
-- for other unrelated reasons). Note that we delayed this
-- processing till freeze time so that we can be sure not
-- to set the flag if there is an address clause. If there
-- is such a clause, then the only purpose of the Import
-- pragma is to suppress implicit initialization.
-- For imported objects, set Is_Public unless there is also an
-- address clause, which means that there is no external symbol
-- needed for the Import (Is_Public may still be set for other
-- unrelated reasons). Note that we delayed this processing
-- till freeze time so that we can be sure not to set the flag
-- if there is an address clause. If there is such a clause,
-- then the only purpose of the Import pragma is to suppress
-- implicit initialization.
if Is_Imported (E)
and then No (Address_Clause (E))
......@@ -2507,7 +2640,7 @@ package body Freeze is
then
Error_Msg_N
("stand alone atomic constant must be " &
"imported ('R'M C.6(13))", E);
"imported (RM C.6(13))", E);
elsif Has_Rep_Pragma (E, Name_Volatile)
or else
......@@ -2664,16 +2797,16 @@ package body Freeze is
end;
end if;
-- If ancestor subtype present, freeze that first.
-- Note that this will also get the base type frozen.
-- If ancestor subtype present, freeze that first. Note that this
-- will also get the base type frozen.
Atype := Ancestor_Subtype (E);
if Present (Atype) then
Freeze_And_Append (Atype, Loc, Result);
-- Otherwise freeze the base type of the entity before
-- freezing the entity itself (RM 13.14(15)).
-- Otherwise freeze the base type of the entity before freezing
-- the entity itself (RM 13.14(15)).
elsif E /= Base_Type (E) then
Freeze_And_Append (Base_Type (E), Loc, Result);
......@@ -2944,9 +3077,16 @@ package body Freeze is
-- Size information of packed array type is copied to the
-- array type, since this is really the representation. But
-- do not override explicit existing size values.
-- do not override explicit existing size values. If the
-- ancestor subtype is constrained the packed_array_type
-- will be inherited from it, but the size may have been
-- provided already, and must not be overridden either.
if not Has_Size_Clause (E) then
if not Has_Size_Clause (E)
and then
(No (Ancestor_Subtype (E))
or else not Has_Size_Clause (Ancestor_Subtype (E)))
then
Set_Esize (E, Esize (Packed_Array_Type (E)));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
end if;
......@@ -2956,10 +3096,9 @@ package body Freeze is
end if;
end if;
-- For non-packed arrays set the alignment of the array
-- to the alignment of the component type if it is unknown.
-- Skip this in the atomic case, since atomic arrays may
-- need larger alignments.
-- For non-packed arrays set the alignment of the array to the
-- alignment of the component type if it is unknown. Skip this
-- in atomic case (atomic arrays may need larger alignments).
if not Is_Packed (E)
and then Unknown_Alignment (E)
......@@ -3011,11 +3150,11 @@ package body Freeze is
end;
end if;
-- The equivalent type associated with a class-wide subtype
-- needs to be frozen to ensure that its layout is done.
-- Class-wide subtypes are currently only frozen on targets
-- requiring front-end layout (see New_Class_Wide_Subtype
-- and Make_CW_Equivalent_Type in exp_util.adb).
-- The equivalent type associated with a class-wide subtype needs
-- to be frozen to ensure that its layout is done. Class-wide
-- subtypes are currently only frozen on targets requiring
-- front-end layout (see New_Class_Wide_Subtype and
-- Make_CW_Equivalent_Type in exp_util.adb).
if Ekind (E) = E_Class_Wide_Subtype
and then Present (Equivalent_Type (E))
......@@ -3024,10 +3163,10 @@ package body Freeze is
end if;
-- For a record (sub)type, freeze all the component types (RM
-- 13.14(15). We test for E_Record_(sub)Type here, rather than
-- using Is_Record_Type, because we don't want to attempt the
-- freeze for the case of a private type with record extension
-- (we will do that later when the full type is frozen).
-- 13.14(15). We test for E_Record_(sub)Type here, rather than using
-- Is_Record_Type, because we don't want to attempt the freeze for
-- the case of a private type with record extension (we will do that
-- later when the full type is frozen).
elsif Ekind (E) = E_Record_Type
or else Ekind (E) = E_Record_Subtype
......@@ -3148,8 +3287,8 @@ package body Freeze is
Set_Entity (F_Node, E);
else
-- {Incomplete,Private}_Subtypes
-- with Full_Views constrained by discriminants
-- {Incomplete,Private}_Subtypes with Full_Views
-- constrained by discriminants.
Set_Has_Delayed_Freeze (E, False);
Set_Freeze_Node (E, Empty);
......@@ -3172,7 +3311,7 @@ package body Freeze is
Size_Known_At_Compile_Time (Full_View (E)));
-- Size information is copied from the full view to the
-- incomplete or private view for consistency
-- incomplete or private view for consistency.
-- We skip this is the full view is not a type. This is very
-- strange of course, and can only happen as a result of
......@@ -3215,7 +3354,7 @@ package body Freeze is
Freeze_Subprogram (E);
-- Ada 2005 (AI-326): Check wrong use of tag incomplete type
--
-- type T is tagged;
-- type Acc is access function (X : T) return T; -- ERROR
......@@ -3346,10 +3485,10 @@ package body Freeze is
-- AI-117), which will have occurred earlier (in Derive_Subprogram
-- and New_Overloaded_Entity). Here we set the convention of
-- primitives that are still convention Ada, which will ensure
-- that any new primitives inherit the type's convention.
-- Class-wide types can have a foreign convention inherited from
-- their specific type, but are excluded from this since they
-- don't have any associated primitives.
-- that any new primitives inherit the type's convention. Class-
-- wide types can have a foreign convention inherited from their
-- specific type, but are excluded from this since they don't have
-- any associated primitives.
if Is_Tagged_Type (E)
and then not Is_Class_Wide_Type (E)
......@@ -4255,6 +4394,19 @@ package body Freeze is
if UR_Is_Negative (Loval_Incl_EP) then
Loval_Excl_EP := Loval_Incl_EP + Small;
-- If the value went from negative to zero, then we have the
-- case where Loval_Incl_EP is the model number just below
-- zero, so we want to stick to the negative value for the
-- base type to maintain the condition that the size will
-- include signed values.
if Typ = Btyp
and then UR_Is_Zero (Loval_Excl_EP)
then
Loval_Excl_EP := Loval_Incl_EP;
end if;
else
Loval_Excl_EP := Loval_Incl_EP;
end if;
......@@ -4874,7 +5026,9 @@ package body Freeze is
-- be inlined. This is consistent with the restriction against using
-- 'Access or 'Address on an Inline_Always subprogram.
if Is_Dispatching_Operation (E) and then Is_Always_Inlined (E) then
if Is_Dispatching_Operation (E)
and then Has_Pragma_Inline_Always (E)
then
Error_Msg_N
("pragma Inline_Always not allowed for dispatching subprograms", E);
end if;
......
gcc/ada/g-ctrl_c.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . C T R L _ C --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2007, AdaCore --
-- --
-- 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body GNAT.Ctrl_C is
type C_Handler_Type is access procedure;
pragma Convention (C, C_Handler_Type);
Ada_Handler : Handler_Type;
procedure C_Handler;
pragma Convention (C, C_Handler);
procedure C_Handler is
begin
Ada_Handler.all;
end C_Handler;
procedure Install_Handler (Handler : Handler_Type) is
procedure Internal (Handler : C_Handler_Type);
pragma Import (C, Internal, "__gnat_install_int_handler");
begin
Ada_Handler := Handler;
Internal (C_Handler'Access);
end Install_Handler;
end GNAT.Ctrl_C;
gcc/ada/g-ctrl_c.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2006, AdaCore --
-- Copyright (C) 2002-2007, AdaCore --
-- --
-- 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- --
......@@ -42,12 +42,6 @@
-- The behavior of this package when using tasking depends on the interaction
-- between sigaction() and the thread library.
-- On most implementations, the interaction will be no different whether
-- tasking is involved or not. An exception is GNU/Linux systems where
-- each task/thread is considered as a separate process by the kernel,
-- meaning in particular that a Ctrl-C from the keyboard will be sent to
-- all tasks instead of only one, resulting in multiple calls to the handler.
package GNAT.Ctrl_C is
type Handler_Type is access procedure;
......@@ -63,6 +57,5 @@ package GNAT.Ctrl_C is
-- If Install_Handler has never been called, this procedure has no effect.
private
pragma Import (C, Install_Handler, "__gnat_install_int_handler");
pragma Import (C, Uninstall_Handler, "__gnat_uninstall_int_handler");
end GNAT.Ctrl_C;
gcc/ada/i-vxwork-x86.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2006, AdaCore --
-- Copyright (C) 1999-2007, AdaCore --
-- --
-- GNARL 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- --
......@@ -47,6 +47,9 @@
-- For complete documentation of the operations in this package, please
-- consult the VxWorks Programmer's Manual and VxWorks Reference Manual.
pragma Warnings (Off, "*foreign convention*");
pragma Warnings (Off, "*add Convention pragma*");
with System.VxWorks;
package Interfaces.VxWorks is
......
gcc/ada/s-auxdec-vms_64.ads
......@@ -465,28 +465,109 @@ private
pragma Inline_Always (Fetch_From_Address);
pragma Inline_Always (Assign_To_Address);
-- Synchronization related subprograms. These are declared to have
-- convention C so that the critical parameters are passed by reference.
-- Synchronization related subprograms. Mechanism is explicitly set
-- so that the critical parameters are passed by reference.
-- Without this, the parameters are passed by copy, creating load/store
-- race conditions. We also inline them, since this seems more in the
-- spirit of the original (hardware intrinsic) routines.
pragma Convention (C, Clear_Interlocked);
pragma Export_Procedure
(Clear_Interlocked,
External => "system__aux_dec__clear_interlocked__1",
Parameter_Types => (Boolean, Boolean),
Mechanism => (Reference, Reference));
pragma Export_Procedure
(Clear_Interlocked,
External => "system__aux_dec__clear_interlocked__2",
Parameter_Types => (Boolean, Boolean, Natural, Boolean),
Mechanism => (Reference, Reference, Value, Reference));
pragma Inline_Always (Clear_Interlocked);
pragma Convention (C, Set_Interlocked);
pragma Export_Procedure
(Set_Interlocked,
External => "system__aux_dec__set_interlocked__1",
Parameter_Types => (Boolean, Boolean),
Mechanism => (Reference, Reference));
pragma Export_Procedure
(Set_Interlocked,
External => "system__aux_dec__set_interlocked__2",
Parameter_Types => (Boolean, Boolean, Natural, Boolean),
Mechanism => (Reference, Reference, Value, Reference));
pragma Inline_Always (Set_Interlocked);
pragma Convention (C, Add_Interlocked);
pragma Export_Procedure
(Add_Interlocked,
External => "system__aux_dec__add_interlocked__1",
Mechanism => (Value, Reference, Reference));
pragma Inline_Always (Add_Interlocked);
pragma Convention (C, Add_Atomic);
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (Add_Atomic);
pragma Convention (C, And_Atomic);
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (And_Atomic);
pragma Convention (C, Or_Atomic);
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (Or_Atomic);
-- Provide proper unchecked conversion definitions for transfer
......
gcc/ada/s-auxdec.ads
......@@ -455,28 +455,109 @@ private
pragma Inline_Always (Fetch_From_Address);
pragma Inline_Always (Assign_To_Address);
-- Synchronization related subprograms. These are declared to have
-- convention C so that the critical parameters are passed by reference.
-- Synchronization related subprograms. Mechanism is explicitly set
-- so that the critical parameters are passed by reference.
-- Without this, the parameters are passed by copy, creating load/store
-- race conditions. We also inline them, since this seems more in the
-- spirit of the original (hardware intrinsic) routines.
pragma Convention (C, Clear_Interlocked);
pragma Export_Procedure
(Clear_Interlocked,
External => "system__aux_dec__clear_interlocked__1",
Parameter_Types => (Boolean, Boolean),
Mechanism => (Reference, Reference));
pragma Export_Procedure
(Clear_Interlocked,
External => "system__aux_dec__clear_interlocked__2",
Parameter_Types => (Boolean, Boolean, Natural, Boolean),
Mechanism => (Reference, Reference, Value, Reference));
pragma Inline_Always (Clear_Interlocked);
pragma Convention (C, Set_Interlocked);
pragma Export_Procedure
(Set_Interlocked,
External => "system__aux_dec__set_interlocked__1",
Parameter_Types => (Boolean, Boolean),
Mechanism => (Reference, Reference));
pragma Export_Procedure
(Set_Interlocked,
External => "system__aux_dec__set_interlocked__2",
Parameter_Types => (Boolean, Boolean, Natural, Boolean),
Mechanism => (Reference, Reference, Value, Reference));
pragma Inline_Always (Set_Interlocked);
pragma Convention (C, Add_Interlocked);
pragma Export_Procedure
(Add_Interlocked,
External => "system__aux_dec__add_interlocked__1",
Mechanism => (Value, Reference, Reference));
pragma Inline_Always (Add_Interlocked);
pragma Convention (C, Add_Atomic);
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (Add_Atomic);
pragma Convention (C, And_Atomic);
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (And_Atomic);
pragma Convention (C, Or_Atomic);
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (Or_Atomic);
-- Provide proper unchecked conversion definitions for transfer
......
gcc/ada/s-interr-sigaction.adb
......@@ -117,6 +117,7 @@ package body System.Interrupts is
-- that contain interrupt handlers.
procedure Signal_Handler (Sig : Interrupt_ID);
pragma Convention (C, Signal_Handler);
-- This procedure is used to handle all the signals
-- Type and Head, Tail of the list containing Registered Interrupt
......@@ -142,6 +143,7 @@ package body System.Interrupts is
-- Always consider a null handler as registered.
type Handler_Ptr is access procedure (Sig : Interrupt_ID);
pragma Convention (C, Handler_Ptr);
function TISR is new Ada.Unchecked_Conversion (Handler_Ptr, isr_address);
......
gcc/ada/s-intman-vms.adb
......@@ -59,7 +59,7 @@ package body System.Interrupt_Management is
Sys_Crembx
(Status => Status,
Prmflg => False,
Prmflg => 0,
Chan => Rcv_Interrupt_Chan,
Maxmsg => Interrupt_ID'Size,
Bufquo => Interrupt_Bufquo,
......
gcc/ada/s-osinte-aix.ads
......@@ -266,6 +266,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -506,8 +507,8 @@ package System.OS_Interface is
function pthread_getspecific (key : pthread_key_t) return System.Address;
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access
procedure (arg : System.Address);
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-darwin.ads
......@@ -239,6 +239,8 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
......@@ -475,6 +477,7 @@ package System.OS_Interface is
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-freebsd.ads
......@@ -267,6 +267,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -572,8 +573,8 @@ package System.OS_Interface is
function pthread_getspecific (key : pthread_key_t) return System.Address;
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access
procedure (arg : System.Address);
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-hpux-dce.ads
......@@ -133,6 +133,7 @@ package System.OS_Interface is
type sigset_t is private;
type isr_address is access procedure (sig : int);
pragma Convention (C, isr_address);
function intr_attach (sig : int; handler : isr_address) return long;
......@@ -238,6 +239,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -426,6 +428,7 @@ package System.OS_Interface is
-- DCE_THREADS has a nonstandard pthread_getspecific
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-hpux.ads
......@@ -256,6 +256,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -489,6 +490,7 @@ package System.OS_Interface is
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-irix.ads
......@@ -243,6 +243,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -445,6 +446,7 @@ package System.OS_Interface is
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-linux-hppa.ads
......@@ -8,7 +8,7 @@
-- (GNU/Linux-HPPA Version) --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
......@@ -255,7 +255,7 @@ package System.OS_Interface is
function To_Target_Priority
(Prio : System.Any_Priority) return Interfaces.C.int;
-- Maps System.Any_Priority to a POSIX priority.
-- Maps System.Any_Priority to a POSIX priority
-------------
-- Process --
......@@ -275,6 +275,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -455,6 +456,7 @@ package System.OS_Interface is
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-lynxos-3.ads
......@@ -211,7 +211,7 @@ package System.OS_Interface is
function To_Target_Priority
(Prio : System.Any_Priority) return Interfaces.C.int;
-- Maps System.Any_Priority to a POSIX priority.
-- Maps System.Any_Priority to a POSIX priority
-------------
-- Process --
......@@ -241,6 +241,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -266,7 +267,7 @@ package System.OS_Interface is
-----------
Stack_Base_Available : constant Boolean := False;
-- Indicates wether the stack base is available on this target.
-- Indicates wether the stack base is available on this target
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
......@@ -484,6 +485,7 @@ package System.OS_Interface is
-- LynxOS has a non standard pthread_getspecific
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-lynxos.ads
......@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
......@@ -253,6 +253,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -275,7 +276,7 @@ package System.OS_Interface is
-----------
Stack_Base_Available : constant Boolean := False;
-- Indicates whether the stack base is available on this target.
-- Indicates whether the stack base is available on this target
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
......@@ -484,6 +485,7 @@ package System.OS_Interface is
pragma Import (C, st_getspecific, "st_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function st_keycreate
(destructor : destructor_pointer;
......
gcc/ada/s-osinte-mingw.ads
......@@ -133,6 +133,7 @@ package System.OS_Interface is
type sigset_t is private;
type isr_address is access procedure (sig : int);
pragma Convention (C, isr_address);
function intr_attach (sig : int; handler : isr_address) return long;
pragma Import (C, intr_attach, "signal");
......@@ -206,6 +207,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......
gcc/ada/s-osinte-solaris-posix.ads
......@@ -220,7 +220,7 @@ package System.OS_Interface is
function To_Target_Priority
(Prio : System.Any_Priority) return Interfaces.C.int;
-- Maps System.Any_Priority to a POSIX priority.
-- Maps System.Any_Priority to a POSIX priority
-------------
-- Process --
......@@ -247,6 +247,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -271,7 +272,7 @@ package System.OS_Interface is
-----------
Stack_Base_Available : constant Boolean := False;
-- Indicates whether the stack base is available on this target.
-- Indicates whether the stack base is available on this target
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
......@@ -477,6 +478,7 @@ package System.OS_Interface is
pragma Import (C, pthread_getspecific, "pthread_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-solaris.ads
......@@ -299,6 +299,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......
gcc/ada/s-osinte-tru64.ads
......@@ -247,6 +247,7 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
......@@ -484,6 +485,7 @@ package System.OS_Interface is
pragma Import (C, pthread_getspecific, "__pthread_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-vms.ads
......@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
......@@ -42,12 +42,13 @@
with Interfaces.C;
with Ada.Unchecked_Conversion;
with System.Aux_DEC;
package System.OS_Interface is
pragma Preelaborate;
pragma Linker_Options ("--for-linker=sys$library:pthread$rtl.exe");
-- Link in the DEC threads library.
-- Link in the DEC threads library
-- pragma Linker_Options ("--for-linker=/threads_enable");
-- Enable upcalls and multiple kernel threads.
......@@ -80,7 +81,7 @@ package System.OS_Interface is
subtype Interrupt_Number_Type is unsigned_long;
-- OpenVMS system services return values of type Cond_Value_Type.
-- OpenVMS system services return values of type Cond_Value_Type
subtype Cond_Value_Type is unsigned_long;
subtype Short_Cond_Value_Type is unsigned_short;
......@@ -92,6 +93,7 @@ package System.OS_Interface is
end record;
type AST_Handler is access procedure (Param : Address);
pragma Convention (C, AST_Handler);
No_AST_Handler : constant AST_Handler := null;
CMB_M_READONLY : constant := 16#00000001#;
......@@ -173,7 +175,7 @@ package System.OS_Interface is
--
procedure Sys_Crembx
(Status : out Cond_Value_Type;
Prmflg : Boolean;
Prmflg : unsigned_char;
Chan : out unsigned_short;
Maxmsg : unsigned_long := 0;
Bufquo : unsigned_long := 0;
......@@ -184,7 +186,7 @@ package System.OS_Interface is
pragma Interface (External, Sys_Crembx);
pragma Import_Valued_Procedure
(Sys_Crembx, "SYS$CREMBX",
(Cond_Value_Type, Boolean, unsigned_short,
(Cond_Value_Type, unsigned_char, unsigned_short,
unsigned_long, unsigned_long, unsigned_short,
unsigned_short, String, unsigned_long),
(Value, Value, Reference,
......@@ -360,9 +362,10 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
......@@ -569,6 +572,7 @@ package System.OS_Interface is
pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
......
gcc/ada/s-osinte-vxworks.ads
......@@ -137,6 +137,7 @@ package System.OS_Interface is
pragma Import (C, sigaction, "sigaction");
type isr_address is access procedure (sig : int);
pragma Convention (C, isr_address);
function c_signal (sig : Signal; handler : isr_address) return isr_address;
pragma Import (C, c_signal, "signal");
......
gcc/ada/s-osinte-vxworks6.ads
......@@ -179,6 +179,7 @@ package System.OS_Interface is
pragma Import (C, sigaction, "sigaction");
type isr_address is access procedure (sig : int);
pragma Convention (C, isr_address);
function c_signal (sig : Signal; handler : isr_address) return isr_address;
pragma Import (C, c_signal, "signal");
......
gcc/ada/s-taprop-vms.adb
......@@ -54,6 +54,9 @@ with System.Soft_Links;
-- used for Get_Exc_Stack_Addr
-- Abort_Defer/Undefer
with System.Aux_DEC;
-- used for Short_Address
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
......@@ -147,6 +150,7 @@ package body System.Task_Primitives.Operations is
-- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT
procedure Timer_Sleep_AST (ID : Address);
pragma Convention (C, Timer_Sleep_AST);
-- Signal the condition variable when AST fires
procedure Timer_Sleep_AST (ID : Address) is
......@@ -822,7 +826,7 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body);
begin
-- Since the initial signal mask of a thread is inherited from the
......
gcc/ada/s-tpopde-vms.ads
......@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2005 Free Software Foundation, Inc. --
-- Copyright (C) 2000-2007, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
......@@ -38,6 +38,7 @@ with System.Aux_DEC;
package System.Task_Primitives.Operations.DEC is
procedure Interrupt_AST_Handler (ID : Address);
pragma Convention (C, Interrupt_AST_Handler);
-- Handles the AST for Ada95 Interrupts.
procedure RMS_AST_Handler (ID : Address);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment