[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
This commit is contained in:
parent
ecf67f46ef
commit
26fd4eae69
|
@ -1,3 +1,42 @@
|
|||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -114,6 +114,12 @@ package body Exp_Ch3 is
|
|||
-- Build record initialization procedure. N is the type declaration
|
||||
-- node, and Pe is the corresponding entity for the record type.
|
||||
|
||||
procedure Build_Slice_Assignment (Typ : Entity_Id);
|
||||
-- Build assignment procedure for one-dimensional arrays of controlled
|
||||
-- types. Other array and slice assignments are expanded in-line, but
|
||||
-- the code expansion for controlled components (when control actions
|
||||
-- are active) can lead to very large blocks that GCC3 handles poorly.
|
||||
|
||||
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
|
||||
-- Create An Equality function for the non-tagged variant record 'Typ'
|
||||
-- and attach it to the TSS list
|
||||
|
@ -2474,6 +2480,287 @@ package body Exp_Ch3 is
|
|||
end if;
|
||||
end Build_Record_Init_Proc;
|
||||
|
||||
----------------------------
|
||||
-- Build_Slice_Assignment --
|
||||
----------------------------
|
||||
|
||||
-- Generates the following subprogram:
|
||||
-- procedure Assign
|
||||
-- (Source, Target : Array_Type,
|
||||
-- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index;
|
||||
-- Rev : Boolean)
|
||||
-- is
|
||||
-- Li1 : Index;
|
||||
-- Ri1 : Index;
|
||||
-- begin
|
||||
-- if Rev then
|
||||
-- Li1 := Left_Hi;
|
||||
-- Ri1 := Right_Hi;
|
||||
-- else
|
||||
-- Li1 := Left_Lo;
|
||||
-- Ri1 := Right_Lo;
|
||||
-- end if;
|
||||
--
|
||||
-- loop
|
||||
-- Target (Li1) := Source (Ri1);
|
||||
-- if Rev then
|
||||
-- exit when Li2 = Left_Lo;
|
||||
-- Li2 := Index'pred (Li2);
|
||||
-- Ri2 := Index'pred (Ri2);
|
||||
-- else
|
||||
-- exit when Li2 = Left_Hi;
|
||||
-- Li2 := Index'succ (Li2);
|
||||
-- Ri2 := Index'succ (Ri2);
|
||||
-- end if;
|
||||
-- end loop;
|
||||
-- end Assign;
|
||||
|
||||
procedure Build_Slice_Assignment (Typ : Entity_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (Typ);
|
||||
Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
|
||||
|
||||
-- Build formal parameters of procedure
|
||||
|
||||
Larray : constant Entity_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, Chars => New_Internal_Name ('A'));
|
||||
Rarray : constant Entity_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, Chars => New_Internal_Name ('R'));
|
||||
Left_Lo : constant Entity_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, Chars => New_Internal_Name ('L'));
|
||||
Left_Hi : constant Entity_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, Chars => New_Internal_Name ('L'));
|
||||
Right_Lo : constant Entity_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, Chars => New_Internal_Name ('R'));
|
||||
Right_Hi : constant Entity_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, Chars => New_Internal_Name ('R'));
|
||||
Rev : constant Entity_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, Chars => New_Internal_Name ('D'));
|
||||
Proc_Name : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
|
||||
|
||||
Lnn : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
|
||||
Rnn : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
|
||||
-- subscripts for left and right sides
|
||||
|
||||
Decls : List_Id;
|
||||
Loops : Node_Id;
|
||||
Stats : List_Id;
|
||||
|
||||
begin
|
||||
|
||||
-- Build declarations for indices.
|
||||
|
||||
Decls := New_List;
|
||||
|
||||
Append_To (Decls,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Lnn,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Index, Loc)));
|
||||
|
||||
Append_To (Decls,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Rnn,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Index, Loc)));
|
||||
|
||||
Stats := New_List;
|
||||
|
||||
-- Build initializations for indices.
|
||||
|
||||
declare
|
||||
F_Init : constant List_Id := New_List;
|
||||
B_Init : constant List_Id := New_List;
|
||||
|
||||
begin
|
||||
Append_To (F_Init,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Lnn, Loc),
|
||||
Expression => New_Occurrence_Of (Left_Lo, Loc)));
|
||||
|
||||
Append_To (F_Init,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Rnn, Loc),
|
||||
Expression => New_Occurrence_Of (Right_Lo, Loc)));
|
||||
|
||||
Append_To (B_Init,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Lnn, Loc),
|
||||
Expression => New_Occurrence_Of (Left_Hi, Loc)));
|
||||
|
||||
Append_To (B_Init,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Rnn, Loc),
|
||||
Expression => New_Occurrence_Of (Right_Hi, Loc)));
|
||||
|
||||
Append_To (Stats,
|
||||
Make_If_Statement (Loc,
|
||||
Condition => New_Occurrence_Of (Rev, Loc),
|
||||
Then_Statements => B_Init,
|
||||
Else_Statements => F_Init));
|
||||
end;
|
||||
|
||||
-- Now construct the assignment statement
|
||||
|
||||
Loops :=
|
||||
Make_Loop_Statement (Loc,
|
||||
Statements => New_List (
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Larray, Loc),
|
||||
Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
|
||||
Expression =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Rarray, Loc),
|
||||
Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
|
||||
End_Label => Empty);
|
||||
|
||||
-- Build the increment/decrement statements.
|
||||
|
||||
declare
|
||||
F_Ass : constant List_Id := New_List;
|
||||
B_Ass : constant List_Id := New_List;
|
||||
|
||||
begin
|
||||
Append_To (F_Ass,
|
||||
Make_Exit_Statement (Loc,
|
||||
Condition =>
|
||||
Make_Op_Eq (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
|
||||
Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
|
||||
|
||||
Append_To (B_Ass,
|
||||
Make_Exit_Statement (Loc,
|
||||
Condition =>
|
||||
Make_Op_Eq (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
|
||||
Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
|
||||
|
||||
Append_To (F_Ass,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Lnn, Loc),
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Index, Loc),
|
||||
Attribute_Name => Name_Succ,
|
||||
Expressions => New_List (
|
||||
New_Occurrence_Of (Lnn, Loc)))));
|
||||
|
||||
Append_To (F_Ass,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Rnn, Loc),
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Index, Loc),
|
||||
Attribute_Name => Name_Succ,
|
||||
Expressions => New_List (
|
||||
New_Occurrence_Of (Rnn, Loc)))));
|
||||
|
||||
Append_To (B_Ass,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Lnn, Loc),
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Index, Loc),
|
||||
Attribute_Name => Name_Pred,
|
||||
Expressions => New_List (
|
||||
New_Occurrence_Of (Lnn, Loc)))));
|
||||
|
||||
Append_To (B_Ass,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Rnn, Loc),
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Index, Loc),
|
||||
Attribute_Name => Name_Pred,
|
||||
Expressions => New_List (
|
||||
New_Occurrence_Of (Rnn, Loc)))));
|
||||
|
||||
Append_To (Statements (Loops),
|
||||
Make_If_Statement (Loc,
|
||||
Condition => New_Occurrence_Of (Rev, Loc),
|
||||
Then_Statements => B_Ass,
|
||||
Else_Statements => F_Ass));
|
||||
end;
|
||||
|
||||
Append_To (Stats, Loops);
|
||||
|
||||
declare
|
||||
Spec : Node_Id;
|
||||
Formals : List_Id := New_List;
|
||||
|
||||
begin
|
||||
Formals := New_List (
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Larray,
|
||||
Out_Present => True,
|
||||
Parameter_Type =>
|
||||
New_Reference_To (Base_Type (Typ), Loc)),
|
||||
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Rarray,
|
||||
Parameter_Type =>
|
||||
New_Reference_To (Base_Type (Typ), Loc)),
|
||||
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Left_Lo,
|
||||
Parameter_Type =>
|
||||
New_Reference_To (Index, Loc)),
|
||||
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Left_Hi,
|
||||
Parameter_Type =>
|
||||
New_Reference_To (Index, Loc)),
|
||||
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Right_Lo,
|
||||
Parameter_Type =>
|
||||
New_Reference_To (Index, Loc)),
|
||||
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Right_Hi,
|
||||
Parameter_Type =>
|
||||
New_Reference_To (Index, Loc)));
|
||||
|
||||
Append_To (Formals,
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Rev,
|
||||
Parameter_Type =>
|
||||
New_Reference_To (Standard_Boolean, Loc)));
|
||||
|
||||
Spec :=
|
||||
Make_Procedure_Specification (Loc,
|
||||
Defining_Unit_Name => Proc_Name,
|
||||
Parameter_Specifications => Formals);
|
||||
|
||||
Discard_Node (
|
||||
Make_Subprogram_Body (Loc,
|
||||
Specification => Spec,
|
||||
Declarations => Decls,
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => Stats)));
|
||||
end;
|
||||
|
||||
Set_TSS (Typ, Proc_Name);
|
||||
Set_Is_Pure (Proc_Name);
|
||||
end Build_Slice_Assignment;
|
||||
|
||||
------------------------------------
|
||||
-- Build_Variant_Record_Equality --
|
||||
------------------------------------
|
||||
|
@ -3483,6 +3770,12 @@ package body Exp_Ch3 is
|
|||
|
||||
if Typ = Base and then Has_Controlled_Component (Base) then
|
||||
Build_Controlling_Procs (Base);
|
||||
|
||||
if not Is_Limited_Type (Component_Type (Typ))
|
||||
and then Number_Dimensions (Typ) = 1
|
||||
then
|
||||
Build_Slice_Assignment (Typ);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- For packed case, there is a default initialization, except
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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) :=
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 --
|
||||
--------------------------------
|
||||
-----------------------------
|
||||
-- Preprocess_Command_Data --
|
||||
-----------------------------
|
||||
|
||||
procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
|
||||
procedure Preprocess_Command_Data 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 --
|
||||
--------------------
|
||||
|
||||
-- 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
|
||||
----------------------
|
||||
-- Process_Argument --
|
||||
----------------------
|
||||
|
||||
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 : 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;
|
||||
|
||||
if not Is_Open (Arg_File) then
|
||||
Arg_Num := Arg_Num + 1;
|
||||
end if;
|
||||
end Process_Argument;
|
||||
|
||||
Arg_Num := Arg_Num + 1;
|
||||
--------------------------------
|
||||
-- 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.
|
||||
|
|
Loading…
Reference in New Issue