+2011-12-12 Thomas Quinot <quinot@adacore.com>
+
+ * exp_disp.adb: Minor reformatting.
+
+2011-12-12 Tristan Gingold <gingold@adacore.com>
+
+ * gnatls.adb (Search_RTS): New procedure.
+ (Scan_Ls_Arg): Move code that search the RTS.
+ (Gnatls): search the RTS later.
+ * prj-env.ads, prj-env.adb (Get_Runtime_Path): New function.
+
+2011-12-12 Ed Falis <falis@adacore.com>
+
+ * sysdep.c: Fix treatment of VxWorks task options so that run-times
+ built with __SPE__ get option VX_SPE_TASK while others get VX_FP_TASK.
+
+2011-12-12 Bob Duff <duff@adacore.com>
+
+ * sem_type.adb, sem_type.ads, sem_ch4.adb, treepr.adb, treepr.ads:
+ Minor cleanup and fiddling with debug printouts.
+
+2011-12-12 Vincent Celier <celier@adacore.com>
+
+ * prj-nmsc.adb (Get_Directories): For a non extending project,
+ always get a declared object and/or exec directory if it already
+ exists, even when there are no sources, but do not create them.
+
+2011-12-12 Bob Duff <duff@adacore.com>
+
+ * sem_res.adb (Resolve): Deal with the case where an abstract
+ operator is called with operands of type universal_integer.
+
+2011-12-12 Thomas Quinot <quinot@adacore.com>
+
+ * par_sco.adb: Minor fix to dominance marker referencing WHILE
+ decision.
+
2011-12-12 Tristan Gingold <gingold@adacore.com>
* mlib-tgt-specific-xi.adb: (Get_Target_Prefix): Simplify code.
-- Transportable => <<boolean-value>>,
-- Type_Is_Abstract => <<boolean-value>>,
-- Needs_Finalization => <<boolean-value>>,
- -- [ Size_Func => Size_Prim'Access ]
- -- [ Interfaces_Table => <<access-value>> ]
+ -- [ Size_Func => Size_Prim'Access, ]
+ -- [ Interfaces_Table => <<access-value>>, ]
-- [ SSD => SSD_Table'Address ]
-- Tags_Table => (0 => null,
-- 1 => Parent'Tag
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
+ Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address)));
-- External_Tag of a local tagged type
Value : String_Access;
Next : Dir_Ref;
end record;
- -- ??? comment needed
+ -- Simply linked list of dirs
First_Source_Dir : Dir_Ref;
Last_Source_Dir : Dir_Ref;
procedure Scan_Ls_Arg (Argv : String);
-- Scan and process lser specific arguments. Argv is a single argument
+ procedure Search_RTS (Name : String);
+ -- Find include and objects path for the RTS name.
+
procedure Usage;
-- Print usage message
end if;
end Reset_Print;
+ ----------------
+ -- Search_RTS --
+ ----------------
+
+ procedure Search_RTS (Name : String) is
+ Src_Path : String_Ptr;
+ Lib_Path : String_Ptr;
+ -- Pathes for source and include subdirs
+
+ Rts_Full_Path : String_Access;
+ -- Full path for RTS project
+ begin
+ -- Try to find the RTS
+
+ Src_Path := Get_RTS_Search_Dir (Name, Include);
+ Lib_Path := Get_RTS_Search_Dir (Name, Objects);
+
+ -- For non-project RTS, both the include and the objects directories
+ -- must be present.
+
+ if Src_Path /= null and then Lib_Path /= null then
+ Add_Search_Dirs (Src_Path, Include);
+ Add_Search_Dirs (Lib_Path, Objects);
+ return;
+ end if;
+
+ if Lib_Path /= null then
+ Osint.Fail ("RTS path not valid: missing adainclude directory");
+
+ elsif Src_Path /= null then
+ Osint.Fail ("RTS path not valid: missing adalib directory");
+
+ end if;
+
+ -- Try to find the RTS on the project path. First setup the project
+ -- path.
+
+ Initialize_Default_Project_Path
+ (Prj_Path, Target_Name => Sdefault.Target_Name.all);
+
+ Rts_Full_Path := Get_Runtime_Path (Prj_Path, Name);
+ if Rts_Full_Path /= null then
+ -- Directory name was found on the project path. Look for the
+ -- include subdir(s).
+
+ Src_Path := Get_RTS_Search_Dir (Name, Include);
+ if Src_Path /= null then
+ Add_Search_Dirs (Src_Path, Include);
+ return;
+ end if;
+ end if;
+
+ Osint.Fail ("RTS path not valid: missing " &
+ "adainclude and adalib directories");
+ end Search_RTS;
+
-------------------
-- Scan_Ls_Arg --
-------------------
Opt.No_Stdinc := True;
Opt.RTS_Switch := True;
-
- declare
- Src_Path_Name : constant String_Ptr :=
- Get_RTS_Search_Dir
- (Argv (7 .. Argv'Last), Include);
- Lib_Path_Name : constant String_Ptr :=
- Get_RTS_Search_Dir
- (Argv (7 .. Argv'Last), Objects);
-
- begin
- if Src_Path_Name /= null
- and then Lib_Path_Name /= null
- then
- Add_Search_Dirs (Src_Path_Name, Include);
- Add_Search_Dirs (Lib_Path_Name, Objects);
-
- elsif Src_Path_Name = null
- and then Lib_Path_Name = null
- then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude and adalib directories");
-
- elsif Src_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude directory");
-
- elsif Lib_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adalib directory");
- end if;
- end;
end if;
end if;
Exit_Program (E_Fatal);
end if;
+ -- Handle --RTS switch
+
+ if RTS_Specified /= null then
+ Search_RTS (RTS_Specified.all);
+ end if;
+
-- Add the source and object directories specified on the command line, if
-- any, to the searched directories.
Process_Decisions_Defer (Condition (ISC), 'W');
-- Set more specific dominant for inner statements
+ -- (the control sloc for the decision is that of
+ -- the WHILE token).
- Inner_Dominant := ('T', N);
+ Inner_Dominant := ('T', ISC);
-- For loop
end if;
end Get_Reference;
+ ----------------------
+ -- Get_Runtime_Path --
+ ----------------------
+
+ function Get_Runtime_Path (Self : Project_Search_Path; Name : String)
+ return String_Access is
+ function Is_Base_Name (Path : String) return Boolean;
+ -- Returns True if Path has no directory separator
+
+ function Is_Base_Name (Path : String) return Boolean is
+ begin
+ for I in Path'Range loop
+ if Path (I) = Directory_Separator or else Path (I) = '/' then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end Is_Base_Name;
+
+ function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
+ (Check_Filename => Is_Directory);
+ begin
+ if not Is_Base_Name (Name) then
+ return Find_Rts_In_Path (Self, Name);
+ else
+ return null;
+ end if;
+ end Get_Runtime_Path;
+
----------------
-- Initialize --
----------------
--
-- Returns No_Name if no such project was found
+ function Get_Runtime_Path (Self : Project_Search_Path; Name : String)
+ return String_Access;
+ -- Compute the full path for the project-based runtime name. It first
+ -- checks that name is not a simple name (must has a path separator in it),
+ -- and returns null in case of failure. This check might be removed in the
+ -- future. The name is simply searched on the project path.
+
private
package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
"Object_Dir cannot be empty",
Object_Dir.Location, Project);
- elsif not No_Sources then
+ elsif Setup_Projects and then
+ No_Sources and then
+ Project.Extends = No_Project
+ then
+ -- Do not create an object directory for a non extending project
+ -- with no sources.
+
+ Locate_Directory
+ (Project,
+ File_Name_Type (Object_Dir.Value),
+ Path => Project.Object_Directory,
+ Dir_Exists => Dir_Exists,
+ Data => Data,
+ Location => Object_Dir.Location,
+ Must_Exist => False,
+ Externally_Built => Project.Externally_Built);
+ else
-- We check that the specified object directory does exist.
-- However, even when it doesn't exist, we set it to a default
-- value. This is for the benefit of tools that recover from
"Exec_Dir cannot be empty",
Exec_Dir.Location, Project);
- elsif not No_Sources then
+ elsif Setup_Projects and then
+ No_Sources and then
+ Project.Extends = No_Project
+ then
+ -- Do not create an exec directory for a non extending project
+ -- with no sources.
+ Locate_Directory
+ (Project,
+ File_Name_Type (Exec_Dir.Value),
+ Path => Project.Exec_Directory,
+ Dir_Exists => Dir_Exists,
+ Data => Data,
+ Location => Exec_Dir.Location,
+ Externally_Built => Project.Externally_Built);
+
+ else
-- We check that the specified exec directory does exist
Locate_Directory
begin
if Is_Overloaded (N) then
+ if Debug_Flag_V then
+ Write_Str ("Remove_Abstract_Operations: ");
+ Write_Overloads (N);
+ end if;
+
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
end loop;
end if;
end if;
+
+ if Debug_Flag_V then
+ Write_Str ("Remove_Abstract_Operations done: ");
+ Write_Overloads (N);
+ end if;
end if;
end Remove_Abstract_Operations;
end if;
Debug_A_Entry ("resolving ", N);
+ if Debug_Flag_V then
+ Write_Overloads (N);
+ end if;
if Comes_From_Source (N) then
if Is_Fixed_Point_Type (Typ) then
Get_First_Interp (N, I, It);
Interp_Loop : while Present (It.Typ) loop
+ if Debug_Flag_V then
+ Write_Str ("Interp: ");
+ Write_Interp (It);
+ end if;
+
-- We are only interested in interpretations that are compatible
-- with the expected type, any other interpretations are ignored.
and then Typ /= Universal_Real
and then Present (It.Abstract_Op)
then
+ if Debug_Flag_V then
+ Write_Line ("Skip.");
+ end if;
+
goto Continue;
end if;
Resolution_Failed;
return;
- -- Here we have an acceptable interpretation for the context
-
else
+ -- In Ada 2005, if we have something like "X : T := 2 + 2;", where
+ -- the "+" on T is abstract, and the operands are of universal type,
+ -- the above code will have (incorrectly) resolved the "+" to the
+ -- universal one in Standard. Therefore, we check for this case, and
+ -- give an error. We can't do this earlier, because it would cause
+ -- legal cases to get errors (when some other type has an abstract
+ -- "+").
+
+ if Ada_Version >= Ada_2005 and then
+ Nkind (N) in N_Op and then
+ Is_Overloaded (N) and then
+ Is_Universal_Numeric_Type (Etype (Entity (N)))
+ then
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Present (It.Abstract_Op) and then
+ Etype (It.Abstract_Op) = Typ
+ then
+ Error_Msg_NE
+ ("cannot call abstract subprogram &!", N, It.Abstract_Op);
+ return;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+
+ -- Here we have an acceptable interpretation for the context
+
-- Propagate type information and normalize tree for various
-- predefined operations. If the context only imposes a class of
-- types, rather than a specific type, propagate the actual type
with Sinfo; use Sinfo;
with Snames; use Snames;
with Table;
+with Treepr; use Treepr;
with Uintp; use Uintp;
package body Sem_Type is
package All_Interp is new Table.Table (
Table_Component_Type => Interp,
- Table_Index_Type => Int,
+ Table_Index_Type => Interp_Index,
Table_Low_Bound => 0,
Table_Initial => Alloc.All_Interp_Initial,
Table_Increment => Alloc.All_Interp_Increment,
end if;
end Valid_Comparison_Arg;
+ ------------------
+ -- Write_Interp --
+ ------------------
+
+ procedure Write_Interp (It : Interp) is
+ begin
+ Write_Str ("Nam: ");
+ Print_Tree_Node (It.Nam);
+ Write_Str ("Typ: ");
+ Print_Tree_Node (It.Typ);
+ Write_Str ("Abstract_Op: ");
+ Print_Tree_Node (It.Abstract_Op);
+ end Write_Interp;
+
----------------------
-- Write_Interp_Ref --
----------------------
Nam : Entity_Id;
begin
+ Write_Str ("Overloads: ");
+ Print_Node_Briefly (N);
+
+ if Nkind (N) not in N_Has_Entity then
+ return;
+ end if;
+
if not Is_Overloaded (N) then
Write_Str ("Non-overloaded entity ");
Write_Eol;
No_Interp : constant Interp := (Empty, Empty, Empty);
- subtype Interp_Index is Int;
+ type Interp_Index is new Int;
---------------------
-- Error Reporting --
-- The end of the list of interpretations is signalled by It.Nam = Empty.
procedure Remove_Interp (I : in out Interp_Index);
- -- Remove an interpretation that his hidden by another, or that does not
+ -- Remove an interpretation that is hidden by another, or that does not
-- match the context. The value of I on input was set by a call to either
-- Get_First_Interp or Get_Next_Interp and references the interpretation
-- to be removed. The only allowed use of the exit value of I is as input
-- A valid argument of a boolean operator is either some boolean type, or a
-- one-dimensional array of boolean type.
+ procedure Write_Interp (It : Interp);
+ -- Debugging procedure to display an Interp
+
procedure Write_Interp_Ref (Map_Ptr : Int);
-- Debugging procedure to display entry in Interp_Map. Would not be needed
-- if it were possible to debug instantiations of Table.
the options assigned to the current task (parent), so offering some user
level control over the options for a task hierarchy. It forces VX_FP_TASK
because it is almost always required. On processors with the SPE
- category, VX_SPE_TASK is needed to enable the SPE. */
+ category, VX_SPE_TASK should be used instead to enable the SPE. */
extern int __gnat_get_task_options (void);
int
/* Get the options for the task creator */
taskOptionsGet (taskIdSelf (), &options);
- /* Force VX_FP_TASK because it is almost always required */
- options |= VX_FP_TASK;
-#if defined (__SPE__) && (! defined (__VXWORKSMILS__))
+ /* Force VX_FP_TASK or VX_SPE_TASK as needed */
+#if defined (__SPE__)
options |= VX_SPE_TASK;
+#else
+ options |= VX_FP_TASK;
#endif
/* Mask those bits that are not under user control */
-- Print name from names table if currently in print phase, noop if in
-- marking phase. Note that the name is output in mixed case mode.
+ procedure Print_Node_Header (N : Node_Id);
+ -- Print header line used by Print_Node and Print_Node_Briefly
+
procedure Print_Node_Kind (N : Node_Id);
-- Print node kind name in mixed case if in print phase, noop if in
-- marking phase.
Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1);
Sfile : Source_File_Index;
- Notes : Boolean;
Fmt : UI_Format;
begin
-- Print header line
Print_Str (Prefix_Str);
- Print_Node_Ref (N);
-
- Notes := False;
-
- if N > Atree_Private_Part.Nodes.Last then
- Print_Str (" (no such node)");
- Print_Eol;
- return;
- end if;
-
- if Comes_From_Source (N) then
- Notes := True;
- Print_Str (" (source");
- end if;
-
- if Analyzed (N) then
- if not Notes then
- Notes := True;
- Print_Str (" (");
- else
- Print_Str (",");
- end if;
-
- Print_Str ("analyzed");
- end if;
-
- if Error_Posted (N) then
- if not Notes then
- Notes := True;
- Print_Str (" (");
- else
- Print_Str (",");
- end if;
-
- Print_Str ("posted");
- end if;
-
- if Notes then
- Print_Char (')');
- end if;
-
- Print_Eol;
+ Print_Node_Header (N);
if Is_Rewrite_Substitution (N) then
Print_Str (Prefix_Str);
end if;
end Print_Node;
+ ------------------------
+ -- Print_Node_Briefly --
+ ------------------------
+
+ procedure Print_Node_Briefly (N : Node_Id) is
+ begin
+ Printing_Descendants := False;
+ Phase := Printing;
+ Print_Node_Header (N);
+ end Print_Node_Briefly;
+
+ -----------------------
+ -- Print_Node_Header --
+ -----------------------
+
+ procedure Print_Node_Header (N : Node_Id) is
+ Notes : Boolean := False;
+
+ begin
+ Print_Node_Ref (N);
+
+ if N > Atree_Private_Part.Nodes.Last then
+ Print_Str (" (no such node)");
+ Print_Eol;
+ return;
+ end if;
+
+ if Comes_From_Source (N) then
+ Notes := True;
+ Print_Str (" (source");
+ end if;
+
+ if Analyzed (N) then
+ if not Notes then
+ Notes := True;
+ Print_Str (" (");
+ else
+ Print_Str (",");
+ end if;
+
+ Print_Str ("analyzed");
+ end if;
+
+ if Error_Posted (N) then
+ if not Notes then
+ Notes := True;
+ Print_Str (" (");
+ else
+ Print_Str (",");
+ end if;
+
+ Print_Str ("posted");
+ end if;
+
+ if Notes then
+ Print_Char (')');
+ end if;
+
+ Print_Eol;
+ end Print_Node_Header;
+
---------------------
-- Print_Node_Kind --
---------------------
-- Prints a single tree node, without printing descendants. The Label
-- string is used to preface each line of the printed output.
+ procedure Print_Node_Briefly (N : Node_Id);
+ -- Terse version of Print_Tree_Node
+
procedure Print_Tree_List (L : List_Id);
-- Prints a single node list, without printing the descendants of any
-- of the nodes in the list
OSDN Git Service
