Skip to content

R
riscv-gcc-1
Commit 26fd4eae by Arnaud Charlet
Options

[multiple changes] 

2004-01-26  Ed Schonberg  <schonberg@gnat.com>

	* exp_ch3.adb (Build_Slice_Assignment): New TSS procedure for
	one-dimensional array an slice assignments, when component type is
	controlled.

	* exp_ch5.adb (Expand_Assign_Array): If array is one-dimensional,
	component type is controlled, and control_actions are in effect, use
	TSS procedure rather than generating inline code.

	* exp_tss.ads (TSS_Slice_Assign): New TSS procedure for one-dimensional
	arrays with controlled components.

2004-01-26  Vincent Celier  <celier@gnat.com>

	* gnatcmd.adb (GNATCmd): Add specification of argument file on the
	command line for the non VMS case.

	* gnatlink.adb (Process_Binder_File): When building object file, if
	GNU linker is used, put all object paths between quotes, to prevent ld
	error when there are unusual characters (such as '!') in the paths.

	* Makefile.generic: When there are sources in Ada and the main is in
	C/C++, invoke gnatmake with -B, instead of -z.

	* vms_conv.adb (Preprocess_Command_Data): New procedure, extracted
	from VMS_Conversion.
	(Process_Argument): New procedure, extracted from VMS_Conversion. Add
	specification of argument file on the command line.

2004-01-26  Bernard Banner  <banner@gnat.com>

	* Makefile.in: Enable GMEM_LIB and SYMLIB for x86_64

2004-01-26  Ed Schonberg  <schonberg@gnat.com>

	* snames.adb: Update copyright notice.
	Add info on slice assignment for controlled arrays.

From-SVN: r76634
parent ecf67f46
Showing with 405 additions and 99 deletions
gcc/ada/ChangeLog
2004-01-26 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Build_Slice_Assignment): New TSS procedure for
one-dimensional array an slice assignments, when component type is
controlled.
* exp_ch5.adb (Expand_Assign_Array): If array is one-dimensional,
component type is controlled, and control_actions are in effect, use
TSS procedure rather than generating inline code.
* exp_tss.ads (TSS_Slice_Assign): New TSS procedure for one-dimensional
arrays with controlled components.
2004-01-26 Vincent Celier <celier@gnat.com>
* gnatcmd.adb (GNATCmd): Add specification of argument file on the
command line for the non VMS case.
* gnatlink.adb (Process_Binder_File): When building object file, if
GNU linker is used, put all object paths between quotes, to prevent ld
error when there are unusual characters (such as '!') in the paths.
* Makefile.generic: When there are sources in Ada and the main is in
C/C++, invoke gnatmake with -B, instead of -z.
* vms_conv.adb (Preprocess_Command_Data): New procedure, extracted
from VMS_Conversion.
(Process_Argument): New procedure, extracted from VMS_Conversion. Add
specification of argument file on the command line.
2004-01-26 Bernard Banner <banner@gnat.com>
* Makefile.in: Enable GMEM_LIB and SYMLIB for x86_64
2004-01-26 Ed Schonberg <schonberg@gnat.com>
* snames.adb: Update copyright notice.
Add info on slice assignment for controlled arrays.
2004-01-23 Robert Dewar <dewar@gnat.com>
* exp_aggr.adb: Minor reformatting
......
gcc/ada/Makefile.generic
......@@ -337,21 +337,16 @@ internal-build: $(LINKER) archive-objects force
else
# C/C++ main
# The trick here is to force gnatmake to bind/link, even if there is no
# Ada main program. To achieve this effect, we use the -z switch, which is
# close enough to our needs, and the usual -n gnatbind switch and --LINK=
# gnatlink switch.
link: $(LINKER) archive-objects force
$(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
-bargs -n -largs $(LARGS) $(LDFLAGS)
$(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
@echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) -z \
-P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
-bargs -n \
-largs $(LARGS) $(LDFLAGS)
@echo $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) \
-B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
endif
else
......
gcc/ada/Makefile.in
......@@ -1287,11 +1287,13 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
system.ads<5nsystem.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb
MISCLIB=
SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION)
endif
# The runtime library for gnat comprises two directories. One contains the
......
gcc/ada/exp_ch5.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -32,6 +32,7 @@ with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
......@@ -160,6 +161,10 @@ package body Exp_Ch5 is
-- This switch is set to True if the array move must be done using
-- an explicit front end generated loop.
procedure Apply_Dereference (Arg : in out Node_Id);
-- If the argument is an access to an array, and the assignment is
-- converted into a procedure call, apply explicit dereference.
function Has_Address_Clause (Exp : Node_Id) return Boolean;
-- Test if Exp is a reference to an array whose declaration has
-- an address clause, or it is a slice of such an array.
......@@ -185,6 +190,20 @@ package body Exp_Ch5 is
-- generate a front end loop, which is not so terrible.
-- It would really be better if backend handled this ???
-----------------------
-- Apply_Dereference --
-----------------------
procedure Apply_Dereference (Arg : in out Node_Id) is
Typ : constant Entity_Id := Etype (Arg);
begin
if Is_Access_Type (Typ) then
Rewrite (Arg, Make_Explicit_Dereference (Loc,
Prefix => Relocate_Node (Arg)));
Analyze_And_Resolve (Arg, Designated_Type (Typ));
end if;
end Apply_Dereference;
------------------------
-- Has_Address_Clause --
------------------------
......@@ -704,10 +723,47 @@ package body Exp_Ch5 is
-- Cases where either Forwards_OK or Backwards_OK is true
if Forwards_OK (N) or else Backwards_OK (N) then
if Controlled_Type (Component_Type (L_Type))
and then Base_Type (L_Type) = Base_Type (R_Type)
and then Ndim = 1
and then not No_Ctrl_Actions (N)
then
declare
Proc : constant Entity_Id :=
TSS (Base_Type (L_Type), TSS_Slice_Assign);
Actuals : List_Id;
begin
Apply_Dereference (Larray);
Apply_Dereference (Rarray);
Actuals := New_List (
Duplicate_Subexpr (Larray, Name_Req => True),
Duplicate_Subexpr (Rarray, Name_Req => True),
Duplicate_Subexpr (Left_Lo, Name_Req => True),
Duplicate_Subexpr (Left_Hi, Name_Req => True),
Duplicate_Subexpr (Right_Lo, Name_Req => True),
Duplicate_Subexpr (Right_Hi, Name_Req => True));
if Forwards_OK (N) then
Append_To (Actuals,
New_Occurrence_Of (Standard_False, Loc));
else
Append_To (Actuals,
New_Occurrence_Of (Standard_True, Loc));
end if;
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Proc, Loc),
Parameter_Associations => Actuals));
end;
else
Rewrite (N,
Expand_Assign_Array_Loop
(N, Larray, Rarray, L_Type, R_Type, Ndim,
Rev => not Forwards_OK (N)));
end if;
-- Case of both are false with No_Implicit_Conditionals
......@@ -806,6 +862,39 @@ package body Exp_Ch5 is
Right_Opnd => Cright_Lo);
end if;
if Controlled_Type (Component_Type (L_Type))
and then Base_Type (L_Type) = Base_Type (R_Type)
and then Ndim = 1
and then not No_Ctrl_Actions (N)
then
-- Call TSS procedure for array assignment, passing the
-- the explicit bounds of right- and left-hand side.
declare
Proc : constant Node_Id :=
TSS (Base_Type (L_Type), TSS_Slice_Assign);
Actuals : List_Id;
begin
Apply_Dereference (Larray);
Apply_Dereference (Rarray);
Actuals := New_List (
Duplicate_Subexpr (Larray, Name_Req => True),
Duplicate_Subexpr (Rarray, Name_Req => True),
Duplicate_Subexpr (Left_Lo, Name_Req => True),
Duplicate_Subexpr (Left_Hi, Name_Req => True),
Duplicate_Subexpr (Right_Lo, Name_Req => True),
Duplicate_Subexpr (Right_Hi, Name_Req => True));
Append_To (Actuals, Condition);
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Proc, Loc),
Parameter_Associations => Actuals));
end;
else
Rewrite (N,
Make_Implicit_If_Statement (N,
Condition => Condition,
......@@ -820,6 +909,7 @@ package body Exp_Ch5 is
(N, Larray, Rarray, L_Type, R_Type, Ndim,
Rev => True))));
end if;
end if;
Analyze (N, Suppress => All_Checks);
end;
......
gcc/ada/exp_tss.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -81,6 +81,7 @@ package Exp_Tss is
TSS_RAS_Access : constant TNT := "RA"; -- RAs type access
TSS_RAS_Dereference : constant TNT := "RD"; -- RAs type deference
TSS_Rep_To_Pos : constant TNT := "RP"; -- Rep to Pos conversion
TSS_Slice_Assign : constant TNT := "SA"; -- Slice assignment
TSS_Stream_Input : constant TNT := "SI"; -- Stream Input attribute
TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute
TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute
......@@ -95,6 +96,7 @@ package Exp_Tss is
TSS_RAS_Access,
TSS_RAS_Dereference,
TSS_Rep_To_Pos,
TSS_Slice_Assign,
TSS_Stream_Input,
TSS_Stream_Output,
TSS_Stream_Read,
......
gcc/ada/gnatcmd.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -493,10 +493,66 @@ begin
end;
end;
-- Get the arguments from the command line and from the eventual
-- argument file(s) specified on the command line.
for Arg in Command_Arg + 1 .. Argument_Count loop
declare
The_Arg : constant String := Argument (Arg);
begin
-- Check if an argument file is specified
if The_Arg (The_Arg'First) = '@' then
declare
Arg_File : Ada.Text_IO.File_Type;
Line : String (1 .. 256);
Last : Natural;
begin
-- Open the file. Fail if the file cannot be found.
begin
Open
(Arg_File, In_File,
The_Arg (The_Arg'First + 1 .. The_Arg'Last));
exception
when others =>
Put
(Standard_Error, "Cannot open argument file """);
Put
(Standard_Error,
The_Arg (The_Arg'First + 1 .. The_Arg'Last));
Put_Line (Standard_Error, """");
raise Error_Exit;
end;
-- Read line by line and put the content of each
-- non empty line in the Last_Switches table.
while not End_Of_File (Arg_File) loop
Get_Line (Arg_File, Line, Last);
if Last /= 0 then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Argument (Arg));
new String'(Line (1 .. Last));
end if;
end loop;
Close (Arg_File);
end;
else
-- It is not an argument file; just put the argument in
-- the Last_Switches table.
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(The_Arg);
end if;
end;
end loop;
end if;
end if;
......
gcc/ada/gnatlink.adb
......@@ -673,6 +673,11 @@ procedure Gnatlink is
-- Predicate indicating whether this target uses the GNU linker. In
-- this case we must output a GNU linker compatible response file.
Opening : aliased constant String := """";
Closing : aliased constant String := '"' & ASCII.LF;
-- Needed to quote object paths in object list files when GNU linker
-- is used.
procedure Get_Next_Line;
-- Read the next line from the binder file without the line
-- terminator.
......@@ -883,6 +888,8 @@ procedure Gnatlink is
-- If target is using the GNU linker we must add a special header
-- and footer in the response file.
-- The syntax is : INPUT (object1.o object2.o ... )
-- Because the GNU linker does not like name with characters such
-- as '!', we must put the object paths between double quotes.
if Using_GNU_Linker then
declare
......@@ -895,9 +902,22 @@ procedure Gnatlink is
end if;
for J in Objs_Begin .. Objs_End loop
-- Opening quote for GNU linker
if Using_GNU_Linker then
Status := Write (Tname_FD, Opening'Address, 1);
end if;
Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address,
Linker_Objects.Table (J).all'Length);
-- Closing quote for GNU linker
if Using_GNU_Linker then
Status := Write (Tname_FD, Closing'Address, 2);
else
Status := Write (Tname_FD, ASCII.LF'Address, 1);
end if;
Response_File_Objects.Increment_Last;
Response_File_Objects.Table (Response_File_Objects.Last) :=
......
gcc/ada/snames.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -690,6 +690,7 @@ package body Snames is
-- xxxRA RAs type access routine for type xxx (Exp_TSS)
-- xxxRD RAs type dereference routine for type xxx (Exp_TSS)
-- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
-- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
-- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
-- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
-- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
......
gcc/ada/vms_conv.adb
......@@ -40,6 +40,9 @@ package body VMS_Conv is
Arg_Num : Natural;
-- Argument number
Arg_File : Ada.Text_IO.File_Type;
-- A file where arguments are read from
Commands : Item_Ptr;
-- Pointer to head of list of command items, one for each command, with
-- the end of the list marked by a null pointer.
......@@ -119,6 +122,14 @@ package body VMS_Conv is
-- updating Ptr appropriatelly. Note that in the case of use of ! the
-- result may be to remove a previously placed switch.
procedure Preprocess_Command_Data;
-- Preprocess the string form of the command and options list into the
-- internal form.
procedure Process_Argument (The_Command : in out Command_Type);
-- Process one argument from the command line, or one line from
-- from a command line file. For the first call, set The_Command.
procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr);
-- Check that N is a valid command or option name, i.e. that it is of the
-- form of an Ada identifier with upper case letters and underscores.
......@@ -736,61 +747,12 @@ package body VMS_Conv is
end loop;
end Place_Unix_Switches;
--------------------------------
-- Validate_Command_Or_Option --
--------------------------------
procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
begin
pragma Assert (N'Length > 0);
for J in N'Range loop
if N (J) = '_' then
pragma Assert (N (J - 1) /= '_');
null;
else
pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
null;
end if;
end loop;
end Validate_Command_Or_Option;
--------------------------
-- Validate_Unix_Switch --
--------------------------
-----------------------------
-- Preprocess_Command_Data --
-----------------------------
procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
procedure Preprocess_Command_Data is
begin
if S (S'First) = '`' then
return;
end if;
pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
for J in S'First + 1 .. S'Last loop
pragma Assert (S (J) /= ' ');
if S (J) = '!' then
pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
null;
end if;
end loop;
end Validate_Unix_Switch;
--------------------
-- VMS_Conversion --
--------------------
-- This function is *far* too long and *far* too heavily nested, it
-- needs procedural abstraction ???
procedure VMS_Conversion (The_Command : out Command_Type) is
begin
Buffer.Init;
-- First we must preprocess the string form of the command and options
-- list into the internal form that we use.
for C in Real_Command_Type loop
declare
Command : constant Item_Ptr := new Command_Item;
......@@ -1016,32 +978,13 @@ package body VMS_Conv is
end loop;
end;
end loop;
end Preprocess_Command_Data;
-- If no parameters, give complete list of commands
if Argument_Count = 0 then
Output_Version;
New_Line;
Put_Line ("List of available commands");
New_Line;
while Commands /= null loop
Put (Commands.Usage.all);
Set_Col (53);
Put_Line (Commands.Unix_String.all);
Commands := Commands.Next;
end loop;
raise Normal_Exit;
end if;
Arg_Num := 1;
-- Loop through arguments
while Arg_Num <= Argument_Count loop
----------------------
-- Process_Argument --
----------------------
Process_Argument : declare
procedure Process_Argument (The_Command : in out Command_Type) is
Argv : String_Access;
Arg_Idx : Integer;
......@@ -1073,9 +1016,81 @@ package body VMS_Conv is
-- Start of processing for Process_Argument
begin
-- If an argument file is open, read the next non empty line
if Is_Open (Arg_File) then
declare
Line : String (1 .. 256);
Last : Natural;
begin
loop
Get_Line (Arg_File, Line, Last);
exit when Last /= 0 or else End_Of_File (Arg_File);
end loop;
-- If the end of the argument file has been reached, close it
if End_Of_File (Arg_File) then
Close (Arg_File);
-- If the last line was empty, return after increasing Arg_Num
-- to go to the next argument on the comment line.
if Last = 0 then
Arg_Num := Arg_Num + 1;
return;
end if;
end if;
Argv := new String'(Line (1 .. Last));
Arg_Idx := 1;
if Argv (1) = '@' then
Put_Line (Standard_Error, "argument file cannot contain @cmd");
raise Error_Exit;
end if;
end;
else
-- No argument file is open, get the argument on the command line
Argv := new String'(Argument (Arg_Num));
Arg_Idx := Argv'First;
-- Check if this is the specification of an argument file
if Argv (Arg_Idx) = '@' then
-- The first argument on the command line cannot be an argument
-- file.
if Arg_Num = 1 then
Put_Line
(Standard_Error,
"Cannot specify argument line before command");
raise Error_Exit;
end if;
-- Open the file, after conversion of the name to canonical form.
-- Fail if file is not found.
declare
Canonical_File_Name : String_Access :=
To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last));
begin
Open (Arg_File, In_File, Canonical_File_Name.all);
Free (Canonical_File_Name);
return;
exception
when others =>
Put (Standard_Error, "Cannot open argument file """);
Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last));
Put_Line (Standard_Error, """");
raise Error_Exit;
end;
end if;
end if;
<<Tryagain_After_Coalesce>>
loop
declare
......@@ -1833,10 +1848,8 @@ package body VMS_Conv is
Endp := Arg'Last;
elsif Arg (Arg'Last) /= ')' then
Put
(Standard_Error,
"incorrectly parenthesized " &
"argument: ");
Put (Standard_Error,
"incorrectly parenthesized argument: ");
Put_Line (Standard_Error, Arg.all);
Errors := Errors + 1;
SwP := Endp + 1;
......@@ -1884,9 +1897,97 @@ package body VMS_Conv is
exit when Arg_Idx > Argv'Last;
end loop;
end Process_Argument;
if not Is_Open (Arg_File) then
Arg_Num := Arg_Num + 1;
end if;
end Process_Argument;
--------------------------------
-- Validate_Command_Or_Option --
--------------------------------
procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
begin
pragma Assert (N'Length > 0);
for J in N'Range loop
if N (J) = '_' then
pragma Assert (N (J - 1) /= '_');
null;
else
pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
null;
end if;
end loop;
end Validate_Command_Or_Option;
--------------------------
-- Validate_Unix_Switch --
--------------------------
procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
begin
if S (S'First) = '`' then
return;
end if;
pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
for J in S'First + 1 .. S'Last loop
pragma Assert (S (J) /= ' ');
if S (J) = '!' then
pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
null;
end if;
end loop;
end Validate_Unix_Switch;
--------------------
-- VMS_Conversion --
--------------------
procedure VMS_Conversion (The_Command : out Command_Type) is
Result : Command_Type := Undefined;
Result_Set : Boolean := False;
begin
Buffer.Init;
-- First we must preprocess the string form of the command and options
-- list into the internal form that we use.
Preprocess_Command_Data;
-- If no parameters, give complete list of commands
if Argument_Count = 0 then
Output_Version;
New_Line;
Put_Line ("List of available commands");
New_Line;
while Commands /= null loop
Put (Commands.Usage.all);
Set_Col (53);
Put_Line (Commands.Unix_String.all);
Commands := Commands.Next;
end loop;
raise Normal_Exit;
end if;
Arg_Num := 1;
-- Loop through arguments
while Arg_Num <= Argument_Count loop
Process_Argument (Result);
if not Result_Set then
The_Command := Result;
Result_Set := True;
end if;
end loop;
-- Gross error checking that the number of parameters is correct.
......
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