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));
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
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.
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)
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));
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))
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,
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);
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;
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);
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;
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;
-- 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)
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;
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;
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 --
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 --
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.
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)
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
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))
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))
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);
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);
-- 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
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
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)
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
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))
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
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);
-- 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;
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)
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))
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
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);
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
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
-- 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)
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;
-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
-- 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- --
-- 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;
-- 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;
-- --
-- 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- --
-- 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
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
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
-- 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
-- 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);
Sys_Crembx
(Status => Status,
- Prmflg => False,
+ Prmflg => 0,
Chan => Rcv_Interrupt_Chan,
Maxmsg => Interrupt_ID'Size,
Bufquo => Interrupt_Bufquo,
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);
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;
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;
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;
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);
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;
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;
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);
-- 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;
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);
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;
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);
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;
-- (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- --
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 --
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);
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;
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 --
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);
-----------
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);
-- 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;
-- 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- --
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);
-----------
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);
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;
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");
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);
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 --
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);
-----------
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);
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;
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);
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);
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;
-- 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- --
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.
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;
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#;
--
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;
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,
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;
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;
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");
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");
-- 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;
-- 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
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
-- --
-- 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- --
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);
projects / thirdparty / gcc.git / commitdiff
