+2010-01-27 Vincent Celier <celier@adacore.com>
+
+ * gnatcmd.adb: When there is only one main specified, the package
+ support Switches (<main>) and attribute Switches is specified for the
+ main, use these switches, instead of Default_Switches ("Ada").
+
+2010-01-27 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb, par-prag.adb, snames.ads-tmpl: pragma Dimension initial
+ implementation.
+ * exp_disp.adb: Minor reformatting
+
2010-01-27 Tristan Gingold <gingold@adacore.com>
* seh_init.c: Use __ImageBase instead of _ImageBase.
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Prim);
- Actuals : constant List_Id := New_List;
- Decl : constant List_Id := New_List;
- Formals : constant List_Id := New_List;
- Target : constant Entity_Id := Ultimate_Alias (Prim);
+ Loc : constant Source_Ptr := Sloc (Prim);
+ Actuals : constant List_Id := New_List;
+ Decl : constant List_Id := New_List;
+ Formals : constant List_Id := New_List;
+ Target : constant Entity_Id := Ultimate_Alias (Prim);
Controlling_Typ : Entity_Id;
Decl_1 : Node_Id;
Thunk_Id := Empty;
Thunk_Code := Empty;
- -- In case of primitives that are functions without formals and
- -- a controlling result there is no need to build the thunk.
+ -- In case of primitives that are functions without formals and a
+ -- controlling result there is no need to build the thunk.
if not Present (First_Formal (Target)) then
pragma Assert (Ekind (Target) = E_Function
-- of the controlling formal is the covered interface type (instead of
-- the target tagged type). Done to avoid problems with discriminated
-- tagged types because, if the controlling type has discriminants with
- -- default values, then the type conversions done inside the body of the
- -- thunk (after the displacement of the pointer to the base of the
+ -- default values, then the type conversions done inside the body of
+ -- the thunk (after the displacement of the pointer to the base of the
-- actual object) generate code that modify its contents.
-- Note: This special management is not done for predefined primitives
Ftyp := Etype (Formal);
-- Use the interface type as the type of the controlling formal (see
- -- comment above)
+ -- comment above).
if not Is_Controlling_Formal (Formal)
or else Is_Predefined_Dispatching_Operation (Prim)
and then Ftyp = Controlling_Typ
then
-- Generate:
-
-- type T is access all <<type of the target formal>>
-- S : Storage_Offset := Storage_Offset!(Formal)
-- - Offset_To_Top (address!(Formal))
New_Reference_To (Defining_Identifier (Decl_1), Loc)));
elsif Ftyp = Controlling_Typ then
- -- Generate:
+ -- Generate:
-- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
-- - Offset_To_Top (Formal'Address)
-- S2 : Addr_Ptr := Addr_Ptr!(S1)
Set_Is_Thunk (Thunk_Id);
+ -- Procedure case
+
if Ekind (Target) = E_Procedure then
Thunk_Code :=
Make_Subprogram_Body (Loc,
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals))));
- else pragma Assert (Ekind (Target) = E_Function);
+ -- Function case
+ else pragma Assert (Ekind (Target) = E_Function);
Thunk_Code :=
Make_Subprogram_Body (Loc,
Specification =>
Element : Package_Element;
- Default_Switches_Array : Array_Element_Id;
+ Switches_Array : Array_Element_Id;
The_Switches : Prj.Variable_Value;
Current : Prj.String_List_Id;
The_String : String_Element;
+ Main : String_Access := null;
+
begin
if Pkg /= No_Package then
Element := Project_Tree.Packages.Table (Pkg);
-- name of the programming language.
else
+ -- First check if there is a single main
+
+ for J in 1 .. Last_Switches.Last loop
+ if Last_Switches.Table (J) (1) /= '-' then
+ if Main = null then
+ Main := Last_Switches.Table (J);
+
+ else
+ Main := null;
+ exit;
+ end if;
+ end if;
+ end loop;
+
+ if Main /= null then
+ Switches_Array :=
+ Prj.Util.Value_Of
+ (Name => Name_Switches,
+ In_Arrays => Element.Decl.Arrays,
+ In_Tree => Project_Tree);
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (Main.all);
+ The_Switches := Prj.Util.Value_Of
+ (Index => Name_Find,
+ Src_Index => 0,
+ In_Array => Switches_Array,
+ In_Tree => Project_Tree);
+ end if;
+
if The_Switches.Kind = Prj.Undefined then
- Default_Switches_Array :=
+ Switches_Array :=
Prj.Util.Value_Of
(Name => Name_Default_Switches,
In_Arrays => Element.Decl.Arrays,
The_Switches := Prj.Util.Value_Of
(Index => Name_Ada,
Src_Index => 0,
- In_Array => Default_Switches_Array,
+ In_Array => Switches_Array,
In_Tree => Project_Tree);
end if;
end if;
Pragma_Convention |
Pragma_Debug_Policy |
Pragma_Detect_Blocking |
+ Pragma_Dimension |
Pragma_Discard_Names |
Pragma_Eliminate |
Pragma_Elaborate |
Check_Valid_Configuration_Pragma;
Detect_Blocking := True;
+ ---------------
+ -- Dimension --
+ ---------------
+
+ when Pragma_Dimension =>
+ GNAT_Pragma;
+ Check_Arg_Count (4);
+ Check_No_Identifiers;
+ Check_Arg_Is_Local_Name (Arg1);
+
+ if not Is_Type (Arg1) then
+ Error_Pragma ("first argument for pragma% must be subtype");
+ end if;
+
+ Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
+ Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
+ Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
+
-------------------
-- Discard_Names --
-------------------
-----------------------------------------
-- This function makes use of the following static table which indicates
- -- whether a given pragma is significant. A value of -1 in this table
- -- indicates that the reference is significant. A value of zero indicates
- -- than appearance as any argument is insignificant, a positive value
- -- indicates that appearance in that parameter position is significant.
+ -- whether a given pragma is significant.
- -- A value of 99 flags a special case requiring a special check (this is
- -- used for cases not covered by this standard encoding, e.g. pragma Check
- -- where the first argument is not significant, but the others are).
+ -- -1 indicates that references in any argument position are significant
+ -- 0 indicates that appearence in any argument is not significant
+ -- +n indicates that appearence as argument n is significant, but all
+ -- other arguments are not significant
+ -- 99 special processing required (e.g. for pragma Check)
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
+ Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
Name_Debug : constant Name_Id := N + $; -- GNAT
+ Name_Dimension : constant Name_Id := N + $; -- GNAT
Name_Elaborate : constant Name_Id := N + $; -- Ada 83
Name_Elaborate_All : constant Name_Id := N + $;
Name_Elaborate_Body : constant Name_Id := N + $;
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
Pragma_Debug,
+ Pragma_Dimension,
Pragma_Elaborate,
Pragma_Elaborate_All,
Pragma_Elaborate_Body,
projects / gcc.git / commitdiff