This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
committed: ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-patches at gcc dot gnu dot org
- Date: Wed, 29 Oct 2003 11:34:20 +0100
- Subject: committed: ada updates
Various improvements and fixes.
In particular, a bunch of ACATS tests are fixed by these changes.
--
2003-10-29 Robert Dewar <dewar@gnat.com>
* 3vtrasym.adb, 5vtraent.ads, sprint.adb,
sem_ch10.adb: Minor reformatting
* exp_ch5.adb (Expand_Assign_Array): Test for bit unaligned operands
(Expand_Assign_Record): Test right hand side for bit unaligned as well
2003-10-29 Vasiliy Fofanov <fofanov@act-europe.fr>
* 3vtrasym.adb, 5vtraent.adb, 5vtraent.ads,
tb-alvms.c: Support for TBK$SYMBOLIZE-based symbolic traceback.
2003-10-29 Jose Ruiz <ruiz@act-europe.fr>
* exp_disp.adb:
Revert previous change, that did not work well when pragma No_Run_Time
was used in conjunction with a run-time other than ZFP.
2003-10-29 Vincent Celier <celier@gnat.com>
* make.adb:
(Gnatmake): When there are no Ada mains in attribute Main, disable the
bind and link steps only is switch -z is not used.
2003-10-29 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic: Remove duplicated setting of CC.
* Makefile.prolog: Set CC to gcc by default, to override make's
default (cc).
* einfo.h: Regenerated.
2003-10-29 Ed Schonberg <schonberg@gnat.com>
* sem_ch10.adb (Analyze_Subunit): Restore state of suppress flags for
current body, after compiling subunit.
* itypes.adb (Create_Itype): In ASIS_Mode, do not freeze the itype
when in deleted code, because gigi needs properly ordered freeze
actions to annotate types.
* freeze.adb (Is_Fully_Defined): Predicate must be recursive, to
prevent the premature freezing of record type that contains
subcomponents with a private type that does not yet have a completion.
2003-10-29 Javier Miranda <miranda@gnat.com>
* sem_ch12.adb:
(Analyze_Package_Instantiation): Check that instances can not be used in
limited with_clauses.
* sem_ch8.adb:
(Analyze_Package_Renaming): Check that limited withed packages cannot
be renamed. Improve text on error messages related to limited
with_clauses.
* einfo.adb, einfo.ads: Remove Non_Limited_Views attribute.
* sprint.adb: (Sprint_Node_Actual): Print limited with_clauses.
Update copyright notice.
* sem_ch10.adb: (Build_Limited_Views): Complete its documentation.
(Install_Limited_Context_Clauses): New subprogram that isolates all the
checks required for limited context_clauses and installs the limited
view.
(Install_Limited_Withed_Unit): Complete its documentation.
(Analyze_Context): Check that limited with_clauses are only allowed in
package specs.
(Install_Context): Call Install_Limited_Context_Clauses after the
parents have been installed.
(Install_Limited_Withed_Unit): Add documentation. Mark the installed
package as 'From_With_Type'; this mark indicates that the limited view
is installed. Used to check bad usages of limited with_clauses.
(Build_Limited_Views): Do not add shadow entities to the scope's list
of entities. Do not add real entities to the Non_Limited_Views chain.
Improve error notification.
(Remove_Context_Clauses): Remove context clauses in two phases:
limited views first and regular views later (to maintain the
stack model).
(Remove_Limited_With_Clause): If the package is analyzed then reinstall
its visible entities.
2003-10-29 Thomas Quinot <quinot@act-europe.fr>
* sem_type.adb (Specific_Type): Type Universal_Fixed is compatible
with any type that Is_Fixed_Point_Type.
* sinfo.ads: Fix documentation for Associated_Node attribute.
2003-10-29 Sergey Rybin <rybin@act-europe.fr>
* switch-c.adb (Scan_Front_End_Switches): ASIS_Mode is set now when
both '-gnatc' and '-gnatt' are specified.
* atree.adb (Initialize): Add initialization for Node_Count (set to
zero).
2003-10-29 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, case E_Subprogram): If no return value,
do not consider as Pure.
Part of implementation of function-at-a-time:
* trans.c (gnat_to_gnu_code): If IS_STMT, call expand_expr_stmt.
(tree_transform): Add new argument to build_component_ref.
(tree_transform, case N_Assignment_Statement): Make and return an
EXPR_STMT.
(tree_transform): If result IS_STMT, set flags and return it.
(gnat_expand_stmt, set_lineno_from_sloc): New functions.
* utils2.c (build_simple_component_ref, build_component_ref): Add new
arg, NO_FOLD_P.
(build_binary_op, case EQ_EXPR): Pass additional arg to it.
(build_allocator): Likewise.
* utils.c (convert_to_fat_pointer, convert_to_thin_pointer, convert):
Add new arg to build_component_ref.
(maybe_unconstrained_array, unchecked_convert): Likewise.
* ada-tree.def (EXPR_STMT): New code.
* ada-tree.h (IS_STMT, TREE_SLOC, EXPR_STMT_EXPR): New macros.
* decl.c (gnat_to_gnu_entity, case object): Add extra arg to
build_component_ref calls.
* misc.c (gnat_expand_expr): If IS_STMT, call gnat_expand_stmt.
* gigi.h (gnat_expand_stmt, set_lineno_from_sloc): New functions.
(build_component_ref): Add new argument, NO_FOLD_P.
--
Index: 3vtrasym.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/3vtrasym.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 3vtrasym.adb
*** 3vtrasym.adb 21 Oct 2003 13:41:51 -0000 1.1
--- 3vtrasym.adb 29 Oct 2003 09:27:51 -0000
***************
*** 34,40 ****
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
with Interfaces.C;
- with Interfaces.C.Strings;
with System;
with System.Aux_DEC;
with System.Soft_Links;
--- 34,39 ----
*************** package body GNAT.Traceback.Symbolic is
*** 45,177 ****
pragma Warnings (Off);
pragma Linker_Options ("--for-linker=sys$library:trace.exe");
! use Interfaces.C.Strings;
use System;
use System.Aux_DEC;
use System.Traceback_Entries;
! type Dscdef1_Type is record
! Maxstrlen : Unsigned_Word;
! Dtype : Unsigned_Byte;
! Class : Unsigned_Byte;
! Pointer : chars_ptr;
! end record;
! for Dscdef1_Type use record
! Maxstrlen at 0 range 0 .. 15;
! Dtype at 2 range 0 .. 7;
! Class at 3 range 0 .. 7;
! Pointer at 4 range 0 .. 31;
end record;
! for Dscdef1_Type'Size use 64;
!
! Image_Buf : String (1 .. 10240);
! Image_Len : Integer;
! Image_Need_Hdr : Boolean := True;
! Image_Do_Another_Line : Boolean;
! Image_Xtra_Msg : Boolean;
!
! procedure Traceback_Image (Out_Desc : access Dscdef1_Type);
!
! procedure Traceback_Image (Out_Desc : access Dscdef1_Type) is
! Image : String (1 .. Integer (Out_Desc.Maxstrlen));
! begin
! Image := Value (Out_Desc.Pointer,
! Interfaces.C.size_t (Out_Desc.Maxstrlen));
! if Image_Do_Another_Line and then
! (Image_Need_Hdr or else
! Image (Image'First .. Image'First + 27) /=
! " image module routine")
! then
! declare
! First : Integer := Image_Len + 1;
! Last : Integer := First + Image'Length - 1;
! begin
! Image_Buf (First .. Last + 1) := Image & ASCII.LF;
! Image_Len := Last + 1;
! end;
!
! Image_Need_Hdr := False;
!
! if Image (Image'First .. Image'First + 3) = "----" then
! if Image_Xtra_Msg = False then
! Image_Xtra_Msg := True;
! else
! Image_Xtra_Msg := False;
! end if;
! end if;
!
! if Out_Desc.Maxstrlen = 79 and then not Image_Xtra_Msg then
! Image_Len := Image_Len - 1;
! Image_Do_Another_Line := False;
! end if;
! end if;
! end Traceback_Image;
! subtype User_Arg_Type is Unsigned_Longword;
! subtype Cond_Value_Type is Unsigned_Longword;
! procedure Show_Traceback
(Status : out Cond_Value_Type;
! Faulting_FP : Address;
! Faulting_SP : Address;
! Faulting_PC : Address;
! Detail_Level : Integer := Integer'Null_Parameter;
User_Act_Proc : Address := Address'Null_Parameter;
! User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter;
! Exceptionn : Unsigned_Longword := Unsigned_Longword'Null_Parameter);
! pragma Interface (External, Show_Traceback);
pragma Import_Valued_Procedure
! (Show_Traceback, "TBK$SHOW_TRACEBACK",
! (Cond_Value_Type, Address, Address, Address, Integer, Address,
! User_Arg_Type, Unsigned_Longword),
! (Value, Value, Value, Value, Reference, Value, Value, Reference),
! Detail_Level);
!
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
! Res : String (1 .. 256 * Traceback'Length);
! Len : Integer;
! Status : Cond_Value_Type;
begin
if Traceback'Length > 0 then
-
Len := 0;
-- Since image computation is not thread-safe we need task lockout
System.Soft_Links.Lock_Task.all;
- for I in Traceback'Range loop
- Image_Len := 0;
- Image_Do_Another_Line := True;
- Image_Xtra_Msg := False;
! Show_Traceback
(Status,
! FP_For (Traceback (I)),
! SP_For (Traceback (I)),
! PC_For (Traceback (I)),
! 0,
! Traceback_Image'Address);
declare
First : Integer := Len + 1;
! Last : Integer := First + Image_Len - 1;
begin
! Res (First .. Last + 1) := Image_Buf & ASCII.LF;
! Len := Last + 1;
end;
end loop;
- System.Soft_Links.Unlock_Task.all;
return Res (1 .. Len);
else
return "";
end if;
--- 44,190 ----
pragma Warnings (Off);
pragma Linker_Options ("--for-linker=sys$library:trace.exe");
! use Interfaces.C;
use System;
use System.Aux_DEC;
use System.Traceback_Entries;
! subtype User_Arg_Type is Unsigned_Longword;
! subtype Cond_Value_Type is Unsigned_Longword;
! type ASCIC is record
! Count : unsigned_char;
! Data : char_array (1 .. 255);
end record;
! pragma Convention (C, ASCIC);
! for ASCIC use record
! Count at 0 range 0 .. 7;
! Data at 1 range 0 .. 8 * 255 - 1;
! end record;
! for ASCIC'Size use 8 * 256;
! function Fetch_ASCIC is new Fetch_From_Address (ASCIC);
! procedure Symbolize
(Status : out Cond_Value_Type;
! Current_PC : in Address;
! Adjusted_PC : in Address;
! Current_FP : in Address;
! Current_R26 : in Address;
! Image_Name : out Address;
! Module_Name : out Address;
! Routine_Name : out Address;
! Line_Number : out Integer;
! Relative_PC : out Address;
! Absolute_PC : out Address;
! PC_Is_Valid : out Long_Integer;
User_Act_Proc : Address := Address'Null_Parameter;
! User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter);
! pragma Interface (External, Symbolize);
pragma Import_Valued_Procedure
! (Symbolize, "TBK$SYMBOLIZE",
! (Cond_Value_Type, Address, Address, Address, Address,
! Address, Address, Address, Integer,
! Address, Address, Long_Integer,
! Address, User_Arg_Type),
! (Value, Value, Value, Value, Value,
! Reference, Reference, Reference, Reference,
! Reference, Reference, Reference,
! Value, Value),
! User_Act_Proc);
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
! Status : Cond_Value_Type;
! Image_Name : ASCIC;
! Image_Name_Addr : Address;
! Module_Name : ASCIC;
! Module_Name_Addr : Address;
! Routine_Name : ASCIC;
! Routine_Name_Addr : Address;
! Line_Number : Integer;
! Relative_PC : Address;
! Absolute_PC : Address;
! PC_Is_Valid : Long_Integer;
! Return_Address : Address;
! Res : String (1 .. 256 * Traceback'Length);
! Len : Integer;
begin
if Traceback'Length > 0 then
Len := 0;
-- Since image computation is not thread-safe we need task lockout
+
System.Soft_Links.Lock_Task.all;
! for J in Traceback'Range loop
! if J = Traceback'Last then
! Return_Address := Address_Zero;
! else
! Return_Address := PC_For (Traceback (J + 1));
! end if;
!
! Symbolize
(Status,
! PC_For (Traceback (J)),
! PC_For (Traceback (J)),
! PV_For (Traceback (J)),
! Return_Address,
! Image_Name_Addr,
! Module_Name_Addr,
! Routine_Name_Addr,
! Line_Number,
! Relative_PC,
! Absolute_PC,
! PC_Is_Valid);
!
! Image_Name := Fetch_ASCIC (Image_Name_Addr);
! Module_Name := Fetch_ASCIC (Module_Name_Addr);
! Routine_Name := Fetch_ASCIC (Routine_Name_Addr);
declare
First : Integer := Len + 1;
! Last : Integer := First + 80 - 1;
!
begin
! Res (First .. Last) := (others => ' ');
!
! Res (First .. First + Integer (Image_Name.Count) - 1) :=
! To_Ada
! (Image_Name.Data (1 .. size_t (Image_Name.Count)),
! False);
!
! Res (First + 10 ..
! First + 10 + Integer (Module_Name.Count) - 1) :=
! To_Ada
! (Module_Name.Data (1 .. size_t (Module_Name.Count)),
! False);
!
! Res (First + 30 ..
! First + 30 + Integer (Routine_Name.Count) - 1) :=
! To_Ada
! (Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
! False);
!
! Res (First + 50 ..
! First + 50 + Integer'Image (Line_Number)'Length - 1) :=
! Integer'Image (Line_Number);
!
! Res (Last) := ASCII.LF;
! Len := Last;
end;
end loop;
+ System.Soft_Links.Unlock_Task.all;
return Res (1 .. Len);
+
else
return "";
end if;
Index: 5vtraent.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vtraent.adb,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 5vtraent.adb
*** 5vtraent.adb 21 Oct 2003 13:41:52 -0000 1.1
--- 5vtraent.adb 29 Oct 2003 09:27:51 -0000
*************** package body System.Traceback_Entries is
*** 47,68 ****
end PC_For;
------------
! -- SP_For --
------------
! function SP_For (TB_Entry : Traceback_Entry) return System.Address is
begin
! return TB_Entry.SP;
! end SP_For;
!
! ------------
! -- FP_For --
! ------------
!
! function FP_For (TB_Entry : Traceback_Entry) return System.Address is
! begin
! return TB_Entry.FP;
! end FP_For;
------------------
-- TB_Entry_For --
--- 47,59 ----
end PC_For;
------------
! -- PV_For --
------------
! function PV_For (TB_Entry : Traceback_Entry) return System.Address is
begin
! return TB_Entry.PV;
! end PV_For;
------------------
-- TB_Entry_For --
*************** package body System.Traceback_Entries is
*** 70,76 ****
function TB_Entry_For (PC : System.Address) return Traceback_Entry is
begin
! return (PC => PC, SP => System.Null_Address, FP => System.Null_Address);
end TB_Entry_For;
end System.Traceback_Entries;
--- 61,67 ----
function TB_Entry_For (PC : System.Address) return Traceback_Entry is
begin
! return (PC => PC, PV => System.Null_Address);
end TB_Entry_For;
end System.Traceback_Entries;
Index: 5vtraent.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5vtraent.ads,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 5vtraent.ads
*** 5vtraent.ads 21 Oct 2003 13:41:52 -0000 1.1
--- 5vtraent.ads 29 Oct 2003 09:27:51 -0000
***************
*** 35,68 ****
-- --
------------------------------------------------------------------------------
! -- This is the Alpha/OpenVMS version of this package.
package System.Traceback_Entries is
- type Traceback_Entry is private;
-
- Null_TB_Entry : constant Traceback_Entry;
-
- function PC_For (TB_Entry : Traceback_Entry) return System.Address;
- function SP_For (TB_Entry : Traceback_Entry) return System.Address;
- function FP_For (TB_Entry : Traceback_Entry) return System.Address;
-
- function TB_Entry_For (PC : System.Address) return Traceback_Entry;
-
- private
-
type Traceback_Entry is record
PC : System.Address;
! SP : System.Address;
! FP : System.Address;
end record;
pragma Suppress_Initialization (Traceback_Entry);
! Null_TB_Entry : constant Traceback_Entry
! := (PC => System.Null_Address,
! SP => System.Null_Address,
! FP => System.Null_Address);
end System.Traceback_Entries;
--- 35,59 ----
-- --
------------------------------------------------------------------------------
! -- This is the Alpha/OpenVMS version of this package
package System.Traceback_Entries is
type Traceback_Entry is record
PC : System.Address;
! PV : System.Address;
end record;
pragma Suppress_Initialization (Traceback_Entry);
! Null_TB_Entry : constant Traceback_Entry :=
! (PC => System.Null_Address,
! PV => System.Null_Address);
!
! function PC_For (TB_Entry : Traceback_Entry) return System.Address;
! function PV_For (TB_Entry : Traceback_Entry) return System.Address;
!
! function TB_Entry_For (PC : System.Address) return Traceback_Entry;
end System.Traceback_Entries;
Index: ada-tree.def
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.def,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 ada-tree.def
*** ada-tree.def 21 Oct 2003 13:41:57 -0000 1.6
--- ada-tree.def 29 Oct 2003 09:27:51 -0000
*************** DEFTREECODE (GNAT_NOP_EXPR, "gnat_nop_ex
*** 77,79 ****
--- 77,87 ----
??? This should be redone at some point. */
DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 0)
+
+ /* Here are the tree codes for the statement types known to Ada. These
+ must be at the end of this file to allow IS_STMT to work.
+
+ We start with an expression statement, whose only operand is an
+ expression, EXPR_STMT_EXPR, Execution of the statement means evaluation of
+ the expression (such as a MODIFY_EXPR) and discarding its result. */
+ DEFTREECODE (EXPR_STMT, "expr_stmt_expr", 's', 1)
Index: ada-tree.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/ada-tree.h,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 ada-tree.h
*** ada-tree.h 24 Apr 2003 17:53:57 -0000 1.8
--- ada-tree.h 29 Oct 2003 09:27:51 -0000
*************** struct lang_type GTY(())
*** 275,277 ****
--- 275,288 ----
node. We need to find some other place to store it! */
#define TREE_LOOP_ID(NODE) \
(((union lang_tree_node *)TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id)
+
+ /* Define fields and macros for statements.
+
+ Start by defining which tree codes are used for statements. */
+ #define IS_STMT(NODE) (TREE_CODE_CLASS (TREE_CODE (NODE)) == 's')
+
+ /* We store the Sloc in statement nodes. */
+ #define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE))
+
+ /* There is just one field in an EXPR_STMT: the expression. */
+ #define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0)
Index: atree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/atree.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 atree.adb
*** atree.adb 21 Oct 2003 13:41:58 -0000 1.7
--- atree.adb 29 Oct 2003 09:27:52 -0000
*************** package body Atree is
*** 838,843 ****
--- 838,844 ----
pragma Warnings (Off, Dummy);
begin
+ Node_Count := 0;
Atree_Private_Part.Nodes.Init;
Orig_Nodes.Init;
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/decl.c,v
retrieving revision 1.18
diff -u -c -3 -p -r1.18 decl.c
*** decl.c 22 Oct 2003 21:34:51 -0000 1.18
--- decl.c 29 Oct 2003 09:27:54 -0000
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 946,952 ****
gnu_expr
= build_component_ref
(gnu_expr, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))));
}
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
--- 946,952 ----
gnu_expr
= build_component_ref
(gnu_expr, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0);
}
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 990,996 ****
(build_binary_op
(MODIFY_EXPR, NULL_TREE,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type)),
gnu_expr));
gnu_type = build_reference_type (gnu_type);
--- 990,996 ----
(build_binary_op
(MODIFY_EXPR, NULL_TREE,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type), 0),
gnu_expr));
gnu_type = build_reference_type (gnu_type);
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 998,1004 ****
= build_unary_op
(ADDR_EXPR, gnu_type,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type)));
gnu_size = 0;
used_by_ref = 1;
--- 998,1004 ----
= build_unary_op
(ADDR_EXPR, gnu_type,
build_component_ref (gnu_new_var, NULL_TREE,
! TYPE_FIELDS (gnu_new_type), 0));
gnu_size = 0;
used_by_ref = 1;
*************** gnat_to_gnu_entity (gnat_entity, gnu_exp
*** 3534,3539 ****
--- 3534,3546 ----
/* ??? For now, don't consider nested functions pure. */
if (! global_bindings_p ())
+ pure_flag = 0;
+
+ /* A subprogram (something that doesn't return anything) shouldn't
+ be considered Pure since there would be no reason for such a
+ subprogram. Note that procedures with Out (or In Out) parameters
+ have already been converted into a function with a return type. */
+ if (TREE_CODE (gnu_return_type) == VOID_TYPE)
pure_flag = 0;
gnu_type
Index: einfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 einfo.adb
*** einfo.adb 21 Oct 2003 13:41:58 -0000 1.9
--- einfo.adb 29 Oct 2003 09:27:55 -0000
*************** package body Einfo is
*** 80,86 ****
-- Hiding_Loop_Variable Node8
-- Mechanism Uint8 (but returns Mechanism_Type)
-- Normalized_First_Bit Uint8
- -- Non_Limited_Views Elist8
-- Class_Wide_Type Node9
-- Current_Value Node9
--- 80,85 ----
*************** package body Einfo is
*** 1798,1814 ****
function Non_Limited_View (Id : E) return E is
begin
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type
! or else Ekind (Id) = E_Package);
return Node17 (Id);
end Non_Limited_View;
- function Non_Limited_Views (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Elist8 (Id);
- end Non_Limited_Views;
-
function Nonzero_Is_True (Id : E) return B is
begin
pragma Assert (Root_Type (Id) = Standard_Boolean);
--- 1797,1806 ----
function Non_Limited_View (Id : E) return E is
begin
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type);
return Node17 (Id);
end Non_Limited_View;
function Nonzero_Is_True (Id : E) return B is
begin
pragma Assert (Root_Type (Id) = Standard_Boolean);
*************** package body Einfo is
*** 2845,2851 ****
begin
pragma Assert
(Is_Type (Id)
! or else Ekind (Id) = E_Package);
Set_Flag159 (Id, V);
end Set_From_With_Type;
--- 2837,2843 ----
begin
pragma Assert
(Is_Type (Id)
! or else Ekind (Id) = E_Package);
Set_Flag159 (Id, V);
end Set_From_With_Type;
*************** package body Einfo is
*** 3741,3757 ****
procedure Set_Non_Limited_View (Id : E; V : E) is
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type
! or else Ekind (Id) = E_Package);
begin
Set_Node17 (Id, V);
end Set_Non_Limited_View;
-
- procedure Set_Non_Limited_Views (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Elist8 (Id, V);
- end Set_Non_Limited_Views;
procedure Set_Nonzero_Is_True (Id : E; V : B := True) is
begin
--- 3733,3742 ----
procedure Set_Non_Limited_View (Id : E; V : E) is
pragma Assert (False
! or else Ekind (Id) = E_Incomplete_Type);
begin
Set_Node17 (Id, V);
end Set_Non_Limited_View;
procedure Set_Nonzero_Is_True (Id : E; V : B := True) is
begin
Index: einfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.ads,v
retrieving revision 1.12
diff -u -c -3 -p -r1.12 einfo.ads
*** einfo.ads 21 Oct 2003 13:41:58 -0000 1.12
--- einfo.ads 29 Oct 2003 09:27:57 -0000
*************** package Einfo is
*** 2381,2388 ****
-- Present in non-generic package entities that are not instances.
-- The elements of this list are the shadow entities created for the
-- types and local packages that are declared in a package that appears
! -- in a limited_with clause. This list and Non_Limited_Views are built
! -- at the same time, and their elements are in one-one correspondence.
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
--- 2381,2387 ----
-- Present in non-generic package entities that are not instances.
-- The elements of this list are the shadow entities created for the
-- types and local packages that are declared in a package that appears
! -- in a limited_with clause.
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
*************** package Einfo is
*** 2551,2564 ****
-- is other than a power of 2.
-- Non_Limited_View (Node17)
! -- Present in incomplete types, and local packages that are the
! -- shadow entities created when analyzing a limited_with_clause.
! -- Points to the definining entity in the original declaration.
!
! -- Non_Limited_Views (Elist8)
! -- Present in non-generic packages that are not instances. The elements
! -- of this list are defining identifiers for types and local packages
! -- declared within a package that appears in a limited_with clause.
-- Nonzero_Is_True (Flag162) [base type only]
-- Present in enumeration types. True if any non-zero value is to be
--- 2550,2558 ----
-- is other than a power of 2.
-- Non_Limited_View (Node17)
! -- Present in incomplete types that are the shadow entities
! -- created when analyzing a limited_with_clause. Points to the
! -- definining entity in the original declaration.
-- Nonzero_Is_True (Flag162) [base type only]
-- Present in enumeration types. True if any non-zero value is to be
*************** package Einfo is
*** 4388,4394 ****
-- E_Package
-- E_Generic_Package
-- Dependent_Instances (Elist8) (for an instance)
- -- Non_Limited_Views (Elist8) (non-generic, not instance)
-- Renaming_Map (Uint9)
-- Handler_Records (List10) (non-generic case only)
-- Generic_Homonym (Node11) (generic case only)
--- 4382,4387 ----
*************** package Einfo is
*** 5152,5158 ****
function No_Return (Id : E) return B;
function Non_Binary_Modulus (Id : E) return B;
function Non_Limited_View (Id : E) return E;
- function Non_Limited_Views (Id : E) return L;
function Nonzero_Is_True (Id : E) return B;
function Normalized_First_Bit (Id : E) return U;
function Normalized_Position (Id : E) return U;
--- 5145,5150 ----
*************** package Einfo is
*** 5624,5630 ****
procedure Set_No_Return (Id : E; V : B := True);
procedure Set_Non_Binary_Modulus (Id : E; V : B := True);
procedure Set_Non_Limited_View (Id : E; V : E);
- procedure Set_Non_Limited_Views (Id : E; V : L);
procedure Set_Nonzero_Is_True (Id : E; V : B := True);
procedure Set_Normalized_First_Bit (Id : E; V : U);
procedure Set_Normalized_Position (Id : E; V : U);
--- 5616,5621 ----
*************** package Einfo is
*** 6150,6156 ****
pragma Inline (No_Return);
pragma Inline (Non_Binary_Modulus);
pragma Inline (Non_Limited_View);
- pragma Inline (Non_Limited_Views);
pragma Inline (Nonzero_Is_True);
pragma Inline (Normalized_First_Bit);
pragma Inline (Normalized_Position);
--- 6141,6146 ----
*************** package Einfo is
*** 6455,6461 ****
pragma Inline (Set_No_Return);
pragma Inline (Set_Non_Binary_Modulus);
pragma Inline (Set_Non_Limited_View);
- pragma Inline (Set_Non_Limited_Views);
pragma Inline (Set_Nonzero_Is_True);
pragma Inline (Set_Normalized_First_Bit);
pragma Inline (Set_Normalized_Position);
--- 6445,6450 ----
Index: exp_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch5.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 exp_ch5.adb
*** exp_ch5.adb 27 Oct 2003 14:27:17 -0000 1.10
--- exp_ch5.adb 29 Oct 2003 09:27:58 -0000
*************** package body Exp_Ch5 is
*** 98,112 ****
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
-- indexed component. The back end can handle such assignments fine
! -- if the object involved is small (64-bits) or if it is aligned on
-- a byte boundary (starts on a byte, and ends on a byte). However,
-- problems arise for large components that are not byte aligned,
! -- since the assignment may clobber other components that share
! -- bit positions in the starting or ending bytes. This function is
! -- used to detect such situations, so that the assignment can be
! -- handled component-wise. A value of False means that either the
! -- object is known to be greater than 64 bits, or that it is known
! -- to be byte aligned. True is returned if the object is known to
-- be greater than 64 bits, and is known to be unaligned. As implied
-- by the name, the result is conservative, in that if the compiler
-- cannot determine these conditions at compile time, True is returned.
--- 98,114 ----
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
-- indexed component. The back end can handle such assignments fine
! -- if the objects involved are small (64-bits) or are both aligned on
-- a byte boundary (starts on a byte, and ends on a byte). However,
-- problems arise for large components that are not byte aligned,
! -- since the assignment may clobber other components that share bit
! -- positions in the starting or ending bytes, and in the case of
! -- components not starting on a byte boundary, the back end cannot
! -- even manage to extract the value. This function is used to detect
! -- such situations, so that the assignment can be handled component-wise.
! -- A value of False means that either the object is known to be greater
! -- than 64 bits, or that it is known to be byte aligned (and occupy an
! -- integral number of bytes. True is returned if the object is known to
-- be greater than 64 bits, and is known to be unaligned. As implied
-- by the name, the result is conservative, in that if the compiler
-- cannot determine these conditions at compile time, True is returned.
*************** package body Exp_Ch5 is
*** 368,373 ****
--- 370,383 ----
R_Type := Get_Actual_Subtype (Act_Rhs);
Loop_Required := True;
+ -- We require a loop if the left side is possibly bit unaligned
+
+ elsif Maybe_Bit_Aligned_Large_Component (Lhs)
+ or else
+ Maybe_Bit_Aligned_Large_Component (Rhs)
+ then
+ Loop_Required := True;
+
-- Arrays with controlled components are expanded into a loop
-- to force calls to adjust at the component level.
*************** package body Exp_Ch5 is
*** 1016,1022 ****
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
! elsif Maybe_Bit_Aligned_Large_Component (Lhs) then
null;
-- If neither condition met, then nothing special to do, the back end
--- 1026,1035 ----
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
! elsif Maybe_Bit_Aligned_Large_Component (Lhs)
! or
! Maybe_Bit_Aligned_Large_Component (Rhs)
! then
null;
-- If neither condition met, then nothing special to do, the back end
Index: exp_disp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_disp.adb,v
retrieving revision 1.6
diff -u -c -3 -p -r1.6 exp_disp.adb
*** exp_disp.adb 24 Oct 2003 13:02:41 -0000 1.6
--- exp_disp.adb 29 Oct 2003 09:27:58 -0000
*************** package body Exp_Disp is
*** 922,931 ****
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
--- 922,932 ----
-- Register_Tag (Dt_Ptr);
! -- Skip this if routine not available, or in No_Run_Time mode
if RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
+ and then not No_Run_Time_Mode
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Index: freeze.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/freeze.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 freeze.adb
*** freeze.adb 21 Oct 2003 13:42:00 -0000 1.7
--- freeze.adb 29 Oct 2003 09:28:00 -0000
*************** package body Freeze is
*** 124,130 ****
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
! -- true if T is not private, or has a full view.
procedure Process_Default_Expressions
(E : Entity_Id;
--- 124,135 ----
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
! -- true if T is not private and has no private components, or has a full
! -- view. Used to determine whether the designated type of an access type
! -- should be frozen when the access type is frozen. This is done when an
! -- allocator is frozen, or an expression that may involve attributes of
! -- the designated type. Otherwise freezing the access type does not freeze
! -- the designated type.
procedure Process_Default_Expressions
(E : Entity_Id;
*************** package body Freeze is
*** 4246,4260 ****
-- Is_Fully_Defined --
-----------------------
- -- Should this be in Sem_Util ???
-
function Is_Fully_Defined (T : Entity_Id) return Boolean is
begin
if Ekind (T) = E_Class_Wide_Type then
return Is_Fully_Defined (Etype (T));
! else
! return not Is_Private_Type (T)
! or else Present (Full_View (Base_Type (T)));
end if;
end Is_Fully_Defined;
--- 4251,4288 ----
-- Is_Fully_Defined --
-----------------------
function Is_Fully_Defined (T : Entity_Id) return Boolean is
begin
if Ekind (T) = E_Class_Wide_Type then
return Is_Fully_Defined (Etype (T));
!
! elsif Is_Array_Type (T) then
! return Is_Fully_Defined (Component_Type (T));
!
! elsif Is_Record_Type (T)
! and not Is_Private_Type (T)
! then
!
! -- Verify that the record type has no components with
! -- private types without completion.
!
! declare
! Comp : Entity_Id;
! begin
! Comp := First_Component (T);
!
! while Present (Comp) loop
! if not Is_Fully_Defined (Etype (Comp)) then
! return False;
! end if;
!
! Next_Component (Comp);
! end loop;
! return True;
! end;
!
! else return not Is_Private_Type (T)
! or else Present (Full_View (Base_Type (T)));
end if;
end Is_Fully_Defined;
Index: gigi.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gigi.h,v
retrieving revision 1.17
diff -u -c -3 -p -r1.17 gigi.h
*** gigi.h 21 Oct 2003 13:42:05 -0000 1.17
--- gigi.h 29 Oct 2003 09:28:00 -0000
*************** extern void gnat_to_code PARAMS ((Node_I
*** 190,195 ****
--- 190,198 ----
code. */
extern tree gnat_to_gnu PARAMS ((Node_Id));
+ /* GNU_STMT is a statement. We generate code for that statement. */
+ extern void gnat_expand_stmt PARAMS ((tree));
+
/* Do the processing for the declaration of a GNAT_ENTITY, a type. If
a separate Freeze node exists, delay the bulk of the processing. Otherwise
make a GCC type for GNAT_ENTITY and set up the correspondance. */
*************** extern void process_type PARAMS ((Entity
*** 201,206 ****
--- 204,212 ----
input_line. If WRITE_NOTE_P is true, emit a line number note. */
extern void set_lineno PARAMS ((Node_Id, int));
+ /* Likewise, but passed a Sloc. */
+ extern void set_lineno_from_sloc PARAMS ((Source_Ptr, int));
+
/* Post an error message. MSG is the error message, properly annotated.
NODE is the node at which to post the error and the node to use for the
"&" substitution. */
*************** extern tree gnat_build_constructor PARAM
*** 699,706 ****
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
! for the field, or both. */
! extern tree build_component_ref PARAMS((tree, tree, tree));
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
--- 705,712 ----
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
! for the field, or both. Don't fold the result if NO_FOLD_P. */
! extern tree build_component_ref PARAMS((tree, tree, tree, int));
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
Index: itypes.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/itypes.adb,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 itypes.adb
*** itypes.adb 21 Oct 2003 13:42:09 -0000 1.5
--- itypes.adb 29 Oct 2003 09:28:00 -0000
***************
*** 26,31 ****
--- 26,32 ----
with Atree; use Atree;
with Einfo; use Einfo;
+ with Opt; use Opt;
with Sem; use Sem;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
*************** package body Itypes is
*** 64,70 ****
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, Related_Nod);
! if In_Deleted_Code then
Set_Is_Frozen (Typ);
end if;
--- 65,73 ----
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, Related_Nod);
! if In_Deleted_Code
! and then not ASIS_Mode
! then
Set_Is_Frozen (Typ);
end if;
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.19
diff -u -c -3 -p -r1.19 make.adb
*** make.adb 27 Oct 2003 14:27:17 -0000 1.19
--- make.adb 29 Oct 2003 09:28:02 -0000
*************** package body Make is
*** 3623,3632 ****
if not At_Least_One_Main then
-- First make sure that the binder and the linker
! -- will not be invoked.
! Do_Bind_Step := False;
! Do_Link_Step := False;
-- Put all the sources in the queue
--- 3623,3634 ----
if not At_Least_One_Main then
-- First make sure that the binder and the linker
! -- will not be invoked if -z is not used.
! if not No_Main_Subprogram then
! Do_Bind_Step := False;
! Do_Link_Step := False;
! end if;
-- Put all the sources in the queue
Index: Makefile.generic
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.generic,v
retrieving revision 1.3
diff -u -c -3 -p -r1.3 Makefile.generic
*** Makefile.generic 27 Oct 2003 14:27:17 -0000 1.3
--- Makefile.generic 29 Oct 2003 09:28:02 -0000
*************** ifndef MAIN
*** 67,76 ****
MAIN=ada
endif
- ifndef CC
- CC=gcc
- endif
-
ifndef ADA_SPEC
ADA_SPEC=.ads
endif
--- 67,72 ----
Index: Makefile.prolog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.prolog,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 Makefile.prolog
*** Makefile.prolog 21 Oct 2003 13:41:53 -0000 1.1
--- Makefile.prolog 29 Oct 2003 09:28:02 -0000
*************** C_EXT:=.c
*** 39,44 ****
--- 39,45 ----
CXX_EXT:=.cc
AR_EXT=.a
OBJ_EXT=.o
+ CC=gcc
# Default target is to build (compile/bind/link)
# Target build is defined in Makefile.generic
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/misc.c,v
retrieving revision 1.66
diff -u -c -3 -p -r1.66 misc.c
*** misc.c 21 Oct 2003 13:42:09 -0000 1.66
--- misc.c 29 Oct 2003 09:28:03 -0000
*************** gnat_expand_expr (tree exp, rtx target,
*** 544,549 ****
--- 544,556 ----
tree new;
rtx result;
+ /* If this is a statement, call the expansion routine for statements. */
+ if (IS_STMT (exp))
+ {
+ gnat_expand_stmt (exp);
+ return const0_rtx;
+ }
+
/* Update EXP to be the new expression to expand. */
switch (TREE_CODE (exp))
{
Index: sem_ch10.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch10.adb,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 sem_ch10.adb
*** sem_ch10.adb 21 Oct 2003 13:42:19 -0000 1.9
--- sem_ch10.adb 29 Oct 2003 09:28:04 -0000
*************** package body Sem_Ch10 is
*** 73,80 ****
-- Analyzes items in the context clause of compilation unit
procedure Build_Limited_Views (N : Node_Id);
! -- Build list of shadow entities for a package mentioned in a
! -- limited_with clause.
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
--- 73,82 ----
-- Analyzes items in the context clause of compilation unit
procedure Build_Limited_Views (N : Node_Id);
! -- Build and decorate the list of shadow entities for a package mentioned
! -- in a limited_with clause. If the package was not previously analyzed
! -- then it also performs a basic decoration of the real entities; this
! -- is required to do not pass non-decorated entities to the back-end.
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
*************** package body Sem_Ch10 is
*** 123,132 ****
-- Subsidiary to previous one. Process only with_ and use_clauses for
-- current unit and its library unit if any.
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
! -- structures for the current compilation. Verify that there is no
! -- regular with_clause in the context.
procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
--- 125,137 ----
-- Subsidiary to previous one. Process only with_ and use_clauses for
-- current unit and its library unit if any.
+ procedure Install_Limited_Context_Clauses (N : Node_Id);
+ -- Subsidiary to Install_Context. Process only limited with_clauses
+ -- for current unit.
+
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
! -- structures for the current compilation.
procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
*************** package body Sem_Ch10 is
*** 782,788 ****
begin
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
! -- b) The second pass add implicit limited_with clauses for the
-- the parents of child units.
-- c) The third pass analyzes limited_with clauses.
--- 787,793 ----
begin
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
! -- b) The second pass add implicit limited_with clauses for
-- the parents of child units.
-- c) The third pass analyzes limited_with clauses.
*************** package body Sem_Ch10 is
*** 792,798 ****
-- For with clause, analyze the with clause, and then update
-- the version, since we are dependent on a unit that we with.
! if Nkind (Item) = N_With_Clause then
-- Skip analyzing with clause if no unit, nothing to do (this
-- happens for a with that references a non-existant unit)
--- 797,805 ----
-- For with clause, analyze the with clause, and then update
-- the version, since we are dependent on a unit that we with.
! if Nkind (Item) = N_With_Clause
! and then not Limited_Present (Item)
! then
-- Skip analyzing with clause if no unit, nothing to do (this
-- happens for a with that references a non-existant unit)
*************** package body Sem_Ch10 is
*** 845,850 ****
--- 852,862 ----
and then Limited_Present (Item)
then
+ if Nkind (Unit (N)) /= N_Package_Declaration then
+ Error_Msg_N ("limited with_clause only allowed in"
+ & " package specification", Item);
+ end if;
+
-- Skip analyzing with clause if no unit, see above.
if Present (Library_Unit (Item)) then
*************** package body Sem_Ch10 is
*** 1239,1244 ****
--- 1251,1257 ----
Num_Scopes : Int := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Enclosing_Child : Entity_Id := Empty;
+ Svg : constant Suppress_Array := Scope_Suppress;
procedure Analyze_Subunit_Context;
-- Capture names in use clauses of the subunit. This must be done
*************** package body Sem_Ch10 is
*** 1482,1487 ****
--- 1495,1504 ----
Re_Install_Use_Clauses;
Install_Context (N);
+ -- Restore state of suppress flags for current body.
+
+ Scope_Suppress := Svg;
+
-- If the subunit is within a child unit, then siblings of any
-- parent unit that appear in the context clause of the subunit
-- must also be made immediately visible.
*************** package body Sem_Ch10 is
*** 2534,2539 ****
--- 2551,2558 ----
Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
end if;
+ Install_Limited_Context_Clauses (N);
+
Check_With_Type_Clauses (N);
end Install_Context;
*************** package body Sem_Ch10 is
*** 2548,2554 ****
Check_Private : Boolean := False;
Decl_Node : Node_Id;
Lib_Parent : Entity_Id;
- Lim_Present : Boolean := False;
begin
-- Loop through context clauses to find the with/use clauses.
--- 2567,2572 ----
*************** package body Sem_Ch10 is
*** 2565,2573 ****
then
if Limited_Present (Item) then
! -- Second pass will be necessary
- Lim_Present := True;
goto Continue;
-- If Name (Item) is not an entity name, something is wrong, and
--- 2583,2590 ----
then
if Limited_Present (Item) then
! -- Limited withed units will be installed later.
goto Continue;
-- If Name (Item) is not an entity name, something is wrong, and
*************** package body Sem_Ch10 is
*** 2703,2709 ****
if Is_Child_Spec (Lib_Unit) then
! -- The unit also has implicit withs on its own parents.
if No (Context_Items (N)) then
Set_Context_Items (N, New_List);
--- 2720,2726 ----
if Is_Child_Spec (Lib_Unit) then
! -- The unit also has implicit withs on its own parents
if No (Context_Items (N)) then
Set_Context_Items (N, New_List);
*************** package body Sem_Ch10 is
*** 2778,2800 ****
if Check_Private then
Check_Private_Child_Unit (N);
end if;
! -- Second pass: install limited_with clauses
! if Lim_Present then
! Item := First (Context_Items (N));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
! and then Limited_Present (Item)
then
! Install_Limited_Withed_Unit (Item);
end if;
Next (Item);
end loop;
! end if;
! end Install_Context_Clauses;
---------------------
-- Install_Parents --
--- 2795,3018 ----
if Check_Private then
Check_Private_Child_Unit (N);
end if;
+ end Install_Context_Clauses;
! -------------------------------------
! -- Install_Limited_Context_Clauses --
! -------------------------------------
! procedure Install_Limited_Context_Clauses (N : Node_Id) is
! Item : Node_Id;
!
! procedure Check_Parent (P : Node_Id; W : Node_Id);
! -- Check that the unlimited view of a given compilation_unit is not
! -- already visible in the parents (neither immediately through the
! -- context clauses, nor indirectly through "use + renamings").
!
! procedure Check_Private_Limited_Withed_Unit (N : Node_Id);
! -- Check that if a limited_with clause of a given compilation_unit
! -- mentions a private child of some library unit, then the given
! -- compilation_unit shall be the declaration of a private descendant
! -- of that library unit.
!
! procedure Check_Withed_Unit (W : Node_Id);
! -- Check that a limited with_clause does not appear in the same
! -- context_clause as a nonlimited with_clause that mentions
! -- the same library.
!
! --------------------
! -- Check_Parent --
! --------------------
!
! procedure Check_Parent (P : Node_Id; W : Node_Id) is
! Item : Node_Id;
! Spec : Node_Id;
! WEnt : Entity_Id;
! Nam : Node_Id;
! E : Entity_Id;
! E2 : Entity_Id;
+ begin
+ pragma Assert (Nkind (W) = N_With_Clause);
+
+ -- Step 1: Check if the unlimited view is installed in the parent
+
+ Item := First (Context_Items (P));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
! and then not Limited_Present (Item)
! and then not Implicit_With (Item)
! and then Library_Unit (Item) = Library_Unit (W)
then
! Error_Msg_N ("unlimited view visible in ancestor", W);
! return;
end if;
Next (Item);
end loop;
!
! -- Step 2: Check "use + renamings"
!
! WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
! Spec := Specification (Unit (P));
!
! -- We tried to traverse the list of entities corresponding to the
! -- defining entity of the package spec. However, first_entity was
! -- found to be 'empty'. Don't know why???
!
! -- Def := Defining_Unit_Name (Spec);
! -- Ent := First_Entity (Def);
!
! -- As a workaround we traverse the list of visible declarations ???
!
! Item := First (Visible_Declarations (Spec));
! while Present (Item) loop
!
! if Nkind (Item) = N_Use_Package_Clause then
!
! -- Traverse the list of packages
!
! Nam := First (Names (Item));
!
! while Present (Nam) loop
! E := Entity (Nam);
!
! pragma Assert (Present (Parent (E)));
!
! if Nkind (Parent (E))
! = N_Package_Renaming_Declaration
! and then Renamed_Entity (E) = WEnt
! then
! Error_Msg_N ("unlimited view visible through "
! & "use_clause + renamings", W);
! return;
!
! elsif Nkind (Parent (E)) = N_Package_Specification then
!
! -- The use clause may refer to a local package.
! -- Check all the enclosing scopes.
!
! E2 := E;
! while E2 /= Standard_Standard
! and then E2 /= WEnt loop
! E2 := Scope (E2);
! end loop;
!
! if E2 = WEnt then
! Error_Msg_N ("unlimited view visible through "
! & "use_clause ", W);
! return;
! end if;
!
! end if;
! Next (Nam);
! end loop;
!
! end if;
!
! Next (Item);
! end loop;
!
! -- Recursive call to check all the ancestors
!
! if Is_Child_Spec (Unit (P)) then
! Check_Parent (P => Parent_Spec (Unit (P)), W => W);
! end if;
! end Check_Parent;
!
! ---------------------------------------
! -- Check_Private_Limited_Withed_Unit --
! ---------------------------------------
!
! procedure Check_Private_Limited_Withed_Unit (N : Node_Id) is
! C : Node_Id;
! P : Node_Id;
! Found : Boolean := False;
!
! begin
! -- If the current compilation unit is not private we don't
! -- need to check anything else.
!
! if not Private_Present (Parent (N)) then
! Found := False;
!
! else
! -- Compilation unit of the parent of the withed library unit
!
! P := Parent_Spec (Unit (Library_Unit (N)));
!
! -- Traverse all the ancestors of the current compilation
! -- unit to check if it is a descendant of named library unit.
!
! C := Parent (N);
! while Present (Parent_Spec (Unit (C))) loop
! C := Parent_Spec (Unit (C));
!
! if C = P then
! Found := True;
! exit;
! end if;
! end loop;
! end if;
!
! if not Found then
! Error_Msg_N ("current unit is not a private descendant"
! & " of the withed unit ('R'M 10.1.2(8)", N);
! end if;
! end Check_Private_Limited_Withed_Unit;
!
! -----------------------
! -- Check_Withed_Unit --
! -----------------------
!
! procedure Check_Withed_Unit (W : Node_Id) is
! Item : Node_Id;
!
! begin
! -- A limited with_clause can not appear in the same context_clause
! -- as a nonlimited with_clause which mentions the same library.
!
! Item := First (Context_Items (N));
! while Present (Item) loop
! if Nkind (Item) = N_With_Clause
! and then not Limited_Present (Item)
! and then not Implicit_With (Item)
! and then Library_Unit (Item) = Library_Unit (W)
! then
! Error_Msg_N ("limited and unlimited view "
! & "not allowed in the same context clauses", W);
! return;
! end if;
!
! Next (Item);
! end loop;
! end Check_Withed_Unit;
!
! -- Start of processing for Install_Limited_Context_Clauses
!
! begin
! Item := First (Context_Items (N));
! while Present (Item) loop
! if Nkind (Item) = N_With_Clause
! and then Limited_Present (Item)
! then
!
! Check_Withed_Unit (Item);
!
! if Private_Present (Library_Unit (Item)) then
! Check_Private_Limited_Withed_Unit (Item);
! end if;
!
! if Is_Child_Spec (Unit (N)) then
! Check_Parent (Parent_Spec (Unit (N)), Item);
! end if;
!
! Install_Limited_Withed_Unit (Item);
! end if;
!
! Next (Item);
! end loop;
! end Install_Limited_Context_Clauses;
---------------------
-- Install_Parents --
*************** package body Sem_Ch10 is
*** 2917,2922 ****
--- 3135,3144 ----
-- the current unit.
-- Shouldn't this be somewhere more general ???
+ -----------------
+ -- Is_Ancestor --
+ -----------------
+
function Is_Ancestor (E : Entity_Id) return Boolean is
Par : Entity_Id;
*************** package body Sem_Ch10 is
*** 3047,3062 ****
P := Defining_Identifier (P);
end if;
if Analyzed (Cunit (Unum))
and then Is_Immediately_Visible (P)
then
- -- disallow naming in a limited with clause a unit (or renaming
- -- thereof) that is mentioned in an enclosing normal with clause.
- Error_Msg_N ("limited_with not allowed on unit already withed", N);
-
return;
end if;
if not Analyzed (Cunit (Unum)) then
Set_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
--- 3269,3305 ----
P := Defining_Identifier (P);
end if;
+ -- A common usage of the limited-with is to have a limited-with
+ -- in the package spec, and a normal with in its package body.
+ -- For example:
+
+ -- limited with X; -- [1]
+ -- package A is ...
+
+ -- with X; -- [2]
+ -- package body A is ...
+
+ -- The compilation of A's body installs the entities of its
+ -- withed packages (the context clauses found at [2]) and
+ -- then the context clauses of its specification (found at [1]).
+
+ -- As a consequence, at point [1] the specification of X has been
+ -- analyzed and it is immediately visible. According to the semantics
+ -- of the limited-with context clauses we don't install the limited
+ -- view because the full view of X supersedes its limited view.
+
if Analyzed (Cunit (Unum))
and then Is_Immediately_Visible (P)
then
return;
end if;
+ if Debug_Flag_I then
+ Write_Str ("install limited view of ");
+ Write_Name (Chars (P));
+ Write_Eol;
+ end if;
+
if not Analyzed (Cunit (Unum)) then
Set_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
*************** package body Sem_Ch10 is
*** 3067,3072 ****
--- 3310,3322 ----
if Current_Entity (P) /= P then
Set_Homonym (P, Current_Entity (P));
Set_Current_Entity (P);
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (P));
+ Write_Eol;
+ end if;
+
end if;
if Is_Child_Package then
*************** package body Sem_Ch10 is
*** 3084,3090 ****
--- 3334,3342 ----
Set_Scope (P, Parent_Id);
end;
end if;
+
else
+
-- If the unit appears in a previous regular with_clause, the
-- regular entities must be unchained before the shadow ones
-- are made accessible.
*************** package body Sem_Ch10 is
*** 3099,3104 ****
--- 3351,3357 ----
Next_Entity (Ent);
end loop;
end;
+
end if;
-- The package must be visible while the with_type clause is active,
*************** package body Sem_Ch10 is
*** 3116,3121 ****
--- 3369,3381 ----
if not In_Chain (Lim_Typ) then
Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
Set_Current_Entity (Lim_Typ);
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (Lim_Typ));
+ Write_Eol;
+ end if;
+
end if;
Next_Elmt (Lim_Elmt);
*************** package body Sem_Ch10 is
*** 3125,3130 ****
--- 3385,3391 ----
-- accordingly, to uninstall it when the context is removed.
Set_Limited_View_Installed (N);
+ Set_From_With_Type (P);
end Install_Limited_Withed_Unit;
-------------------------
*************** package body Sem_Ch10 is
*** 3136,3141 ****
--- 3397,3409 ----
P : constant Entity_Id := Scope (Uname);
begin
+
+ if Debug_Flag_I then
+ Write_Str ("install withed unit ");
+ Write_Name (Chars (Uname));
+ Write_Eol;
+ end if;
+
-- We do not apply the restrictions to an internal unit unless
-- we are compiling the internal unit as a main unit. This check
-- is also skipped for dummy units (for missing packages).
*************** package body Sem_Ch10 is
*** 3308,3313 ****
--- 3576,3588 ----
-- Construct list of shadow entities and attach it to entity of
-- package that is mentioned in a limited_with clause.
+ function New_Internal_Shadow_Entity
+ (Kind : Entity_Kind;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character) return Entity_Id;
+ -- This function is similar to New_Internal_Entity, except that the
+ -- entity is not added to the scope's list of entities.
+
------------------------------
-- Decorate_Incomplete_Type --
------------------------------
*************** package body Sem_Ch10 is
*** 3324,3330 ****
Set_Stored_Constraint (E, No_Elist);
Set_Full_View (E, Empty);
Init_Size_Align (E);
- Set_Has_Unknown_Discriminants (E);
end Decorate_Incomplete_Type;
--------------------------
--- 3599,3604 ----
*************** package body Sem_Ch10 is
*** 3374,3395 ****
Set_Etype (P, Standard_Void_Type);
end Decorate_Package_Specification;
-----------------
-- Build_Chain --
-----------------
procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
! Decl : Node_Id;
begin
Decl := First (Visible_Declarations (Spec));
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration then
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed (Cunit (Unum)) then
! if Tagged_Present (Type_Definition (Decl)) then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
--- 3648,3701 ----
Set_Etype (P, Standard_Void_Type);
end Decorate_Package_Specification;
+ -------------------------
+ -- New_Internal_Entity --
+ -------------------------
+
+ function New_Internal_Shadow_Entity
+ (Kind : Entity_Kind;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character) return Entity_Id
+ is
+ N : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc_Value,
+ Chars => New_Internal_Name (Id_Char));
+
+ begin
+ Set_Ekind (N, Kind);
+ Set_Is_Internal (N, True);
+
+ if Kind in Type_Kind then
+ Init_Size_Align (N);
+ end if;
+
+ return N;
+ end New_Internal_Shadow_Entity;
+
-----------------
-- Build_Chain --
-----------------
+ -- Could use more comments below ???
+
procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
! Decl : Node_Id;
! Analyzed_Unit : Boolean := Analyzed (Cunit (Unum));
! Is_Tagged : Boolean;
begin
Decl := First (Visible_Declarations (Spec));
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration then
+ Is_Tagged :=
+ Nkind (Type_Definition (Decl)) = N_Record_Definition
+ and then Tagged_Present (Type_Definition (Decl));
+
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed_Unit then
! if Is_Tagged then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
*************** package body Sem_Ch10 is
*** 3398,3406 ****
-- Create shadow entity for type
! Lim_Typ := New_Internal_Entity
(Kind => Ekind (Comp_Typ),
- Scope_Id => Scope,
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
--- 3704,3711 ----
-- Create shadow entity for type
! Lim_Typ := New_Internal_Shadow_Entity
(Kind => Ekind (Comp_Typ),
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
*************** package body Sem_Ch10 is
*** 3408,3424 ****
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_From_With_Type (Lim_Typ);
! if Tagged_Present (Type_Definition (Decl)) then
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
else
Decorate_Incomplete_Type (Lim_Typ, Scope);
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
-
- -- Add each entity to the proper list
-
- Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Private_Type_Declaration
--- 3713,3725 ----
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_From_With_Type (Lim_Typ);
! if Is_Tagged then
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
else
Decorate_Incomplete_Type (Lim_Typ, Scope);
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Private_Type_Declaration
*************** package body Sem_Ch10 is
*** 3426,3438 ****
then
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed (Cunit (Unum)) then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Entity
(Kind => Ekind (Comp_Typ),
- Scope_Id => Scope,
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
--- 3727,3738 ----
then
Comp_Typ := Defining_Identifier (Decl);
! if not Analyzed_Unit then
Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Shadow_Entity
(Kind => Ekind (Comp_Typ),
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
*************** package body Sem_Ch10 is
*** 3443,3452 ****
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
-
- -- Add the entities to the proper list
-
- Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Package_Declaration then
--- 3743,3748 ----
*************** package body Sem_Ch10 is
*** 3464,3472 ****
Set_Scope (Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Entity
(Kind => Ekind (Comp_Typ),
- Scope_Id => Scope,
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
--- 3760,3767 ----
Set_Scope (Comp_Typ, Scope);
end if;
! Lim_Typ := New_Internal_Shadow_Entity
(Kind => Ekind (Comp_Typ),
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
*************** package body Sem_Ch10 is
*** 3480,3487 ****
-- Note: The non_limited_view attribute is not used
-- for local packages.
- -- Add the entities to the proper list.
- Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
Append_Elmt (Lim_Typ, To => Limited_Views (P));
Build_Chain (Spec, Scope => Lim_Typ);
--- 3775,3780 ----
*************** package body Sem_Ch10 is
*** 3497,3510 ****
begin
pragma Assert (Limited_Present (N));
! -- Limited withed subprograms are not allowed. Therefore, we
! -- don't need to build the limited-view auxiliary chain.
! if Nkind (Parent (P)) = N_Function_Specification
! or else Nkind (Parent (P)) = N_Procedure_Specification
! then
! return;
! end if;
-- Check if the chain is already built
--- 3790,3830 ----
begin
pragma Assert (Limited_Present (N));
! -- A library_item mentioned in a limited_with_clause shall be
! -- a package_declaration, not a subprogram_declaration,
! -- generic_declaration, generic_instantiation, or
! -- package_renaming_declaration
! case Nkind (Unit (Library_Unit (N))) is
!
! when N_Package_Declaration =>
! null;
!
! when N_Subprogram_Declaration =>
! Error_Msg_N ("subprograms not allowed in "
! & "limited with_clauses", N);
!
! when N_Generic_Package_Declaration |
! N_Generic_Subprogram_Declaration =>
! Error_Msg_N ("generics not allowed in "
! & "limited with_clauses", N);
!
! when N_Package_Instantiation |
! N_Function_Instantiation |
! N_Procedure_Instantiation =>
! Error_Msg_N ("generic instantiations not allowed in "
! & "limited with_clauses", N);
!
! when N_Generic_Package_Renaming_Declaration |
! N_Generic_Procedure_Renaming_Declaration |
! N_Generic_Function_Renaming_Declaration =>
! Error_Msg_N ("generic renamings not allowed in "
! & "limited with_clauses", N);
!
! when others =>
! pragma Assert (False);
! null;
! end case;
-- Check if the chain is already built
*************** package body Sem_Ch10 is
*** 3516,3522 ****
Set_Ekind (P, E_Package);
Set_Limited_Views (P, New_Elmt_List);
- Set_Non_Limited_Views (P, New_Elmt_List);
-- Set_Entity (Name (N), P);
-- Create the auxiliary chain
--- 3836,3841 ----
*************** package body Sem_Ch10 is
*** 3650,3660 ****
Unit_Name : Entity_Id;
begin
! -- Loop through context items and undo with_clauses and use_clauses.
Item := First (Context_Items (N));
while Present (Item) loop
-- We are interested only in with clauses which got installed
--- 3969,4000 ----
Unit_Name : Entity_Id;
begin
+ -- We remove the context clauses in two phases: limited-views first
+ -- and regular-views later (to maintain the stack model).
! -- First Phase: Remove limited_with context clauses
Item := First (Context_Items (N));
+ while Present (Item) loop
+ -- We are interested only in with clauses which got installed
+ -- on entry.
+
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Limited_View_Installed (Item)
+ then
+ Remove_Limited_With_Clause (Item);
+
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- Second Phase: Loop through context items and undo regular
+ -- with_clauses and use_clauses.
+
+ Item := First (Context_Items (N));
while Present (Item) loop
-- We are interested only in with clauses which got installed
*************** package body Sem_Ch10 is
*** 3664,3670 ****
and then Limited_Present (Item)
and then Limited_View_Installed (Item)
then
! Remove_Limited_With_Clause (Item);
elsif Nkind (Item) = N_With_Clause
and then Context_Installed (Item)
--- 4004,4010 ----
and then Limited_Present (Item)
and then Limited_View_Installed (Item)
then
! null;
elsif Nkind (Item) = N_With_Clause
and then Context_Installed (Item)
*************** package body Sem_Ch10 is
*** 3687,3693 ****
Next (Item);
end loop;
-
end Remove_Context_Clauses;
--------------------------------
--- 4027,4032 ----
*************** package body Sem_Ch10 is
*** 3697,3703 ****
procedure Remove_Limited_With_Clause (N : Node_Id) is
P_Unit : Entity_Id := Unit (Library_Unit (N));
P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
-
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
--- 4036,4041 ----
*************** package body Sem_Ch10 is
*** 3709,3714 ****
--- 4047,4059 ----
P := Defining_Identifier (P);
end if;
+ if Debug_Flag_I then
+ Write_Str ("remove limited view of ");
+ Write_Name (Chars (P));
+ Write_Str (" from visibility");
+ Write_Eol;
+ end if;
+
-- Remove all shadow entities from visibility
Lim_Elmt := First_Elmt (Limited_Views (P));
*************** package body Sem_Ch10 is
*** 3720,3725 ****
--- 4065,4075 ----
Next_Elmt (Lim_Elmt);
end loop;
+ -- Indicate that the limited view of the package is not installed
+
+ Set_From_With_Type (P, False);
+ Set_Limited_View_Installed (N, False);
+
-- If the exporting package has previously been analyzed, it
-- has appeared in the closure already and should be left alone.
-- Otherwise, remove package itself from visibility.
*************** package body Sem_Ch10 is
*** 3731,3739 ****
Set_Ekind (P, E_Void);
Set_Scope (P, Empty);
Set_Is_Immediately_Visible (P, False);
- end if;
! Set_Limited_View_Installed (N, False);
end Remove_Limited_With_Clause;
--------------------
--- 4081,4120 ----
Set_Ekind (P, E_Void);
Set_Scope (P, Empty);
Set_Is_Immediately_Visible (P, False);
! else
!
! -- Reinstall visible entities (entities removed from visibility in
! -- Install_Limited_Withed to install the shadow entities).
!
! declare
! Ent : Entity_Id;
!
! begin
! Ent := First_Entity (P);
! while Present (Ent) and then Ent /= First_Private_Entity (P) loop
!
! -- Shadow entities have not been added to the list of
! -- entities associated to the package spec. Therefore we
! -- just have to re-chain all its visible entities.
!
! if not Is_Class_Wide_Type (Ent) then
!
! Set_Homonym (Ent, Current_Entity (Ent));
! Set_Current_Entity (Ent);
!
! if Debug_Flag_I then
! Write_Str (" (homonym) chain ");
! Write_Name (Chars (Ent));
! Write_Eol;
! end if;
!
! end if;
!
! Next_Entity (Ent);
! end loop;
! end;
! end if;
end Remove_Limited_With_Clause;
--------------------
*************** package body Sem_Ch10 is
*** 3819,3824 ****
--- 4200,4207 ----
end if;
end Unchain;
+ -- Start of Remove_With_Type_Clause
+
begin
if Nkind (Name) = N_Selected_Component then
Typ := Entity (Selector_Name (Name));
*************** package body Sem_Ch10 is
*** 3882,3889 ****
begin
if Debug_Flag_I then
! Write_Str ("remove withed unit ");
Write_Name (Chars (Unit_Name));
Write_Eol;
end if;
--- 4265,4273 ----
begin
if Debug_Flag_I then
! Write_Str ("remove unit ");
Write_Name (Chars (Unit_Name));
+ Write_Str (" from visibility");
Write_Eol;
end if;
*************** package body Sem_Ch10 is
*** 3923,3927 ****
--- 4307,4318 ----
Set_Homonym (Prev, Homonym (E));
end if;
end if;
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) unchain ");
+ Write_Name (Chars (E));
+ Write_Eol;
+ end if;
+
end Unchain;
end Sem_Ch10;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.24
diff -u -c -3 -p -r1.24 sem_ch12.adb
*** sem_ch12.adb 27 Oct 2003 14:27:17 -0000 1.24
--- sem_ch12.adb 29 Oct 2003 09:28:08 -0000
*************** package body Sem_Ch12 is
*** 2332,2339 ****
return;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
! Error_Msg_N
! ("expect name of generic package in instantiation", Gen_Id);
Restore_Env;
return;
end if;
--- 2332,2346 ----
return;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
!
! if From_With_Type (Gen_Unit) then
! Error_Msg_N
! ("cannot instantiate a limited withed package", Gen_Id);
! else
! Error_Msg_N
! ("expect name of generic package in instantiation", Gen_Id);
! end if;
!
Restore_Env;
return;
end if;
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.10
diff -u -c -3 -p -r1.10 sem_ch8.adb
*** sem_ch8.adb 27 Oct 2003 14:27:17 -0000 1.10
--- sem_ch8.adb 29 Oct 2003 09:28:10 -0000
*************** package body Sem_Ch8 is
*** 789,796 ****
end if;
if Etype (Old_P) = Any_Type then
! Error_Msg_N
! ("expect package name in renaming", Name (N));
elsif Ekind (Old_P) /= E_Package
and then not (Ekind (Old_P) = E_Generic_Package
--- 789,802 ----
end if;
if Etype (Old_P) = Any_Type then
! Error_Msg_N
! ("expect package name in renaming", Name (N));
!
! elsif Ekind (Old_P) = E_Package
! and then From_With_Type (Old_P)
! then
! Error_Msg_N
! ("limited withed package cannot be renamed", Name (N));
elsif Ekind (Old_P) /= E_Package
and then not (Ekind (Old_P) = E_Generic_Package
*************** package body Sem_Ch8 is
*** 811,821 ****
Set_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
- elsif Ekind (Old_P) = E_Package
- and then From_With_Type (Old_P)
- then
- Error_Msg_N ("imported package cannot be renamed", Name (N));
-
else
-- Entities in the old package are accessible through the
-- renaming entity. The simplest implementation is to have
--- 817,822 ----
*************** package body Sem_Ch8 is
*** 3397,3403 ****
null;
else
Error_Msg_N
! ("imported package can only be used to access imported type",
N);
end if;
end if;
--- 3398,3405 ----
null;
else
Error_Msg_N
! ("limited withed package can only be used to access "
! & " incomplete types",
N);
end if;
end if;
*************** package body Sem_Ch8 is
*** 5285,5291 ****
Set_In_Use (P);
if From_With_Type (P) then
! Error_Msg_N ("imported package cannot appear in use clause", N);
end if;
-- Find enclosing instance, if any.
--- 5287,5293 ----
Set_In_Use (P);
if From_With_Type (P) then
! Error_Msg_N ("limited withed package cannot appear in use clause", N);
end if;
-- Find enclosing instance, if any.
Index: sem_type.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_type.adb,v
retrieving revision 1.8
diff -u -c -3 -p -r1.8 sem_type.adb
*** sem_type.adb 21 Oct 2003 13:42:22 -0000 1.8
--- sem_type.adb 29 Oct 2003 09:28:10 -0000
*************** package body Sem_Type is
*** 2134,2148 ****
if B1 = B2 then
return B1;
! elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
! or else (T1 = Universal_Real and then Is_Real_Type (T2))
! or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
then
return B2;
! elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
! or else (T2 = Universal_Real and then Is_Real_Type (T1))
! or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
then
return B1;
--- 2134,2152 ----
if B1 = B2 then
return B1;
! elsif False
! or else (T1 = Universal_Integer and then Is_Integer_Type (T2))
! or else (T1 = Universal_Real and then Is_Real_Type (T2))
! or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
! or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
then
return B2;
! elsif False
! or else (T2 = Universal_Integer and then Is_Integer_Type (T1))
! or else (T2 = Universal_Real and then Is_Real_Type (T1))
! or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
! or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
then
return B1;
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.11
diff -u -c -3 -p -r1.11 sinfo.ads
*** sinfo.ads 21 Oct 2003 13:42:22 -0000 1.11
--- sinfo.ads 29 Oct 2003 09:28:13 -0000
*************** package Sinfo is
*** 573,579 ****
-- and N_Extension_Aggregate nodes. This field is used during generic
-- processing to relate nodes in the original template to nodes in the
-- generic copy. It overlaps the Entity field, and is used to capture
! -- global references in the analyzed copy and place them in the template.
-- See description in Sem_Ch12 for further details on this usage.
-- At_End_Proc (Node1)
--- 573,579 ----
-- and N_Extension_Aggregate nodes. This field is used during generic
-- processing to relate nodes in the original template to nodes in the
-- generic copy. It overlaps the Entity field, and is used to capture
! -- global references in the analyzed copy and place them in the instance.
-- See description in Sem_Ch12 for further details on this usage.
-- At_End_Proc (Node1)
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.7
diff -u -c -3 -p -r1.7 sprint.adb
*** sprint.adb 21 Oct 2003 13:42:22 -0000 1.7
--- sprint.adb 29 Oct 2003 09:28:14 -0000
***************
*** 6,12 ****
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2002, 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- --
--- 6,12 ----
-- --
-- B o d y --
-- --
! -- Copyright (C) 1992-2003, 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- --
*************** package body Sprint is
*** 2490,2496 ****
else
if First_Name (Node) or else not Dump_Original_Only then
! Write_Indent_Str ("with ");
else
Write_Str (", ");
end if;
--- 2490,2501 ----
else
if First_Name (Node) or else not Dump_Original_Only then
! if Limited_Present (Node) then
! Write_Indent_Str ("limited with ");
! else
! Write_Indent_Str ("with ");
! end if;
!
else
Write_Str (", ");
end if;
Index: switch-c.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/switch-c.adb,v
retrieving revision 1.5
diff -u -c -3 -p -r1.5 switch-c.adb
*** switch-c.adb 21 Oct 2003 13:42:22 -0000 1.5
--- switch-c.adb 29 Oct 2003 09:28:14 -0000
*************** package body Switch.C is
*** 216,221 ****
--- 216,225 ----
Ptr := Ptr + 1;
Operating_Mode := Check_Semantics;
+ if Tree_Output then
+ ASIS_Mode := True;
+ end if;
+
-- Processing for d switch
when 'd' =>
*************** package body Switch.C is
*** 638,644 ****
when 't' =>
Ptr := Ptr + 1;
Tree_Output := True;
! ASIS_Mode := True;
Back_Annotate_Rep_Info := True;
-- Processing for T switch
--- 642,652 ----
when 't' =>
Ptr := Ptr + 1;
Tree_Output := True;
!
! if Operating_Mode = Check_Semantics then
! ASIS_Mode := True;
! end if;
!
Back_Annotate_Rep_Info := True;
-- Processing for T switch
Index: tb-alvms.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/tb-alvms.c,v
retrieving revision 1.1
diff -u -c -3 -p -r1.1 tb-alvms.c
*** tb-alvms.c 21 Oct 2003 13:42:23 -0000 1.1
--- tb-alvms.c 29 Oct 2003 09:28:14 -0000
*************** typedef struct
*** 89,94 ****
--- 89,98 ----
#define RA_UNKNOWN ((REG)~0)
#define RA_STOP ((REG)0)
+ /* Compute Procedure Value from a live Frame Pointer value. */
+ #define PV_FOR(FP) \
+ ((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP);
+
/**********
* unwind *
**********/
*************** unwind (frame_state_t * fs)
*** 127,136 ****
if (fs->fp == 0)
return;
! if ((REG_AT (fs->fp) & 0x7) == 0)
! pv = *(PDSCDEF **)fs->fp;
! else
! pv = (PDSCDEF *) fs->fp;
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
--- 131,137 ----
if (fs->fp == 0)
return;
! pv = PV_FOR (fs->fp);
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
*************** unwind (frame_state_t * fs)
*** 190,207 ****
}
/* Structure representing a traceback entry in the tracebacks array to be
! filled by __gnat_backtrace below. This should match the declaration of
! Traceback_Entry in System.Traceback_Entries.
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
-
typedef struct {
! void * pc; /* Address of the call instruction in the chain. */
! void * sp; /* Stack Pointer value at the point of this call. */
! void * fp; /* Frame Pointer value at the point of this call. */
} tb_entry_t;
/********************
--- 191,205 ----
}
/* Structure representing a traceback entry in the tracebacks array to be
! filled by __gnat_backtrace below.
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
typedef struct {
! void * pc;
! void * pv;
} tb_entry_t;
/********************
*************** __gnat_backtrace (array, size, exclude_m
*** 249,256 ****
|| frame_state.pc > exclude_max)
{
tbe->pc = frame_state.pc;
! tbe->sp = frame_state.sp;
! tbe->fp = frame_state.fp;
cnt ++;
tbe ++;
--- 247,253 ----
|| frame_state.pc > exclude_max)
{
tbe->pc = frame_state.pc;
! tbe->pv = PV_FOR (frame_state.fp);
cnt ++;
tbe ++;
Index: trans.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/trans.c,v
retrieving revision 1.36
diff -u -c -3 -p -r1.36 trans.c
*** trans.c 23 Oct 2003 11:57:52 -0000 1.36
--- trans.c 29 Oct 2003 09:28:17 -0000
*************** gnat_to_code (gnat_node)
*** 243,251 ****
gnu_root = tree_transform (gnat_node);
/* This should just generate code, not return a value. If it returns
a value, something is wrong. */
! if (gnu_root != error_mark_node)
gigi_abort (302);
}
--- 243,255 ----
gnu_root = tree_transform (gnat_node);
+ /* If we return a statement, generate code for it. */
+ if (IS_STMT (gnu_root))
+ expand_expr_stmt (gnu_root);
+
/* This should just generate code, not return a value. If it returns
a value, something is wrong. */
! else if (gnu_root != error_mark_node)
gigi_abort (302);
}
*************** tree_transform (gnat_node)
*** 997,1003 ****
gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
gnu_result
! = build_component_ref (gnu_prefix, NULL_TREE, gnu_field);
}
if (gnu_result == 0)
--- 1001,1009 ----
gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
gnu_result
! = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
! (Nkind (Parent (gnat_node))
! == N_Attribute_Reference));
}
if (gnu_result == 0)
*************** tree_transform (gnat_node)
*** 2058,2065 ****
gnu_rhs
= maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
- set_lineno (gnat_node, 1);
-
/* If range check is needed, emit code to generate it */
if (Do_Range_Check (Expression (gnat_node)))
gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
--- 2064,2069 ----
*************** tree_transform (gnat_node)
*** 2071,2080 ****
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
|| (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
! expand_expr_stmt (build_call_raise (SE_Object_Too_Large));
else
! expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
! gnu_lhs, gnu_rhs));
break;
case N_If_Statement:
--- 2075,2086 ----
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
|| (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
! gnu_result = build_call_raise (SE_Object_Too_Large);
else
! gnu_result
! = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
!
! gnu_result = build_nt (EXPR_STMT, gnu_result);
break;
case N_If_Statement:
*************** tree_transform (gnat_node)
*** 3168,3174 ****
= length == 1 ? gnu_subprog_call
: build_component_ref
(gnu_subprog_call, NULL_TREE,
! TREE_PURPOSE (scalar_return_list));
int unchecked_conversion
= Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
/* If the actual is a conversion, get the inner expression,
--- 3174,3180 ----
= length == 1 ? gnu_subprog_call
: build_component_ref
(gnu_subprog_call, NULL_TREE,
! TREE_PURPOSE (scalar_return_list), 0);
int unchecked_conversion
= Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
/* If the actual is a conversion, get the inner expression,
*************** tree_transform (gnat_node)
*** 3614,3620 ****
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("not_handled_by_others"), NULL_TREE)),
integer_zero_node);
}
--- 3620,3627 ----
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("not_handled_by_others"), NULL_TREE,
! 0)),
integer_zero_node);
}
*************** tree_transform (gnat_node)
*** 3643,3649 ****
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("import_code"), NULL_TREE),
gnu_expr);
else
this_choice
--- 3650,3656 ----
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("import_code"), NULL_TREE, 0),
gnu_expr);
else
this_choice
*************** tree_transform (gnat_node)
*** 3664,3670 ****
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("lang"), NULL_TREE);
this_choice
= build_binary_op
--- 3671,3677 ----
(build_unary_op
(INDIRECT_REF, NULL_TREE,
TREE_VALUE (gnu_except_ptr_stack)),
! get_identifier ("lang"), NULL_TREE, 0);
this_choice
= build_binary_op
*************** tree_transform (gnat_node)
*** 4024,4031 ****
gigi_abort (321);
}
/* If the result is a constant that overflows, raise constraint error. */
! if (TREE_CODE (gnu_result) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_result))
{
post_error ("Constraint_Error will be raised at run-time?", gnat_node);
--- 4031,4047 ----
gigi_abort (321);
}
+ /* If the result is a statement, set needed flags and return it. */
+ if (IS_STMT (gnu_result))
+ {
+ TREE_TYPE (gnu_result) = void_type_node;
+ TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
+ TREE_SLOC (gnu_result) = Sloc (gnat_node);
+ return gnu_result;
+ }
+
/* If the result is a constant that overflows, raise constraint error. */
! else if (TREE_CODE (gnu_result) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_result))
{
post_error ("Constraint_Error will be raised at run-time?", gnat_node);
*************** tree_transform (gnat_node)
*** 4137,4142 ****
--- 4153,4177 ----
return gnu_result;
}
+ /* GNU_STMT is a statement. We generate code for that statement. */
+
+ void
+ gnat_expand_stmt (gnu_stmt)
+ tree gnu_stmt;
+ {
+ set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
+
+ switch (TREE_CODE (gnu_stmt))
+ {
+ case EXPR_STMT:
+ expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
+ break;
+
+ default:
+ abort ();
+ }
+ }
+
/* Force references to each of the entities in packages GNAT_NODE with's
so that the debugging information for all of them are identical
in all clients. Operate recursively on anything it with's, but check
*************** set_lineno (gnat_node, write_note_p)
*** 5407,5412 ****
--- 5442,5457 ----
{
Source_Ptr source_location = Sloc (gnat_node);
+ set_lineno_from_sloc (source_location, write_note_p);
+ }
+
+ /* Likewise, but passed a Sloc. */
+
+ void
+ set_lineno_from_sloc (source_location, write_note_p)
+ Source_Ptr source_location;
+ int write_note_p;
+ {
/* If node not from source code, ignore. */
if (source_location < 0)
return;
Index: utils2.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils2.c,v
retrieving revision 1.17
diff -u -c -3 -p -r1.17 utils2.c
*** utils2.c 21 Oct 2003 13:42:23 -0000 1.17
--- utils2.c 29 Oct 2003 09:28:18 -0000
*************** static tree contains_null_expr PARAMS (
*** 50,56 ****
static tree compare_arrays PARAMS ((tree, tree, tree));
static tree nonbinary_modular_operation PARAMS ((enum tree_code, tree,
tree, tree));
! static tree build_simple_component_ref PARAMS ((tree, tree, tree));
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
--- 50,56 ----
static tree compare_arrays PARAMS ((tree, tree, tree));
static tree nonbinary_modular_operation PARAMS ((enum tree_code, tree,
tree, tree));
! static tree build_simple_component_ref PARAMS ((tree, tree, tree, int));
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
*************** build_binary_op (op_code, result_type, l
*** 955,961 ****
&& integer_zerop (TREE_VALUE (CONSTRUCTOR_ELTS (right_operand))))
{
right_operand = build_component_ref (left_operand, NULL_TREE,
! TYPE_FIELDS (left_base_type));
left_operand = convert (TREE_TYPE (right_operand),
integer_zero_node);
}
--- 955,962 ----
&& integer_zerop (TREE_VALUE (CONSTRUCTOR_ELTS (right_operand))))
{
right_operand = build_component_ref (left_operand, NULL_TREE,
! TYPE_FIELDS (left_base_type),
! 0);
left_operand = convert (TREE_TYPE (right_operand),
integer_zero_node);
}
*************** gnat_build_constructor (type, list)
*** 1609,1624 ****
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
! for the field.
We also handle the fact that we might have been passed a pointer to the
actual record and know how to look for fields in variant parts. */
static tree
! build_simple_component_ref (record_variable, component, field)
tree record_variable;
tree component;
tree field;
{
tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
tree ref;
--- 1610,1626 ----
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
! for the field. Don't fold the result if NO_FOLD_P is nonzero.
We also handle the fact that we might have been passed a pointer to the
actual record and know how to look for fields in variant parts. */
static tree
! build_simple_component_ref (record_variable, component, field, no_fold_p)
tree record_variable;
tree component;
tree field;
+ int no_fold_p;
{
tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
tree ref;
*************** build_simple_component_ref (record_varia
*** 1674,1681 ****
{
tree field_ref
= build_simple_component_ref (record_variable,
! NULL_TREE, new_field);
! ref = build_simple_component_ref (field_ref, NULL_TREE, field);
if (ref != 0)
return ref;
--- 1676,1684 ----
{
tree field_ref
= build_simple_component_ref (record_variable,
! NULL_TREE, new_field, no_fold_p);
! ref = build_simple_component_ref (field_ref, NULL_TREE, field,
! no_fold_p);
if (ref != 0)
return ref;
*************** build_simple_component_ref (record_varia
*** 1697,1715 ****
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
! return fold (ref);
}
/* Like build_simple_component_ref, except that we give an error if the
reference could not be found. */
tree
! build_component_ref (record_variable, component, field)
tree record_variable;
tree component;
tree field;
{
! tree ref = build_simple_component_ref (record_variable, component, field);
if (ref != 0)
return ref;
--- 1700,1720 ----
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
! return no_fold_p ? ref : fold (ref);
}
/* Like build_simple_component_ref, except that we give an error if the
reference could not be found. */
tree
! build_component_ref (record_variable, component, field, no_fold_p)
tree record_variable;
tree component;
tree field;
+ int no_fold_p;
{
! tree ref = build_simple_component_ref (record_variable, component, field,
! no_fold_p);
if (ref != 0)
return ref;
*************** build_allocator (type, init, result_type
*** 1945,1951 ****
build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
! NULL_TREE, TYPE_FIELDS (storage_type)),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
--- 1950,1956 ----
build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
! NULL_TREE, TYPE_FIELDS (storage_type), 0),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
*************** build_allocator (type, init, result_type
*** 1990,1996 ****
result = convert (build_pointer_type (new_type), result);
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
result = build_component_ref (result, NULL_TREE,
! TYPE_FIELDS (new_type));
result = convert (result_type,
build_unary_op (ADDR_EXPR, NULL_TREE, result));
}
--- 1995,2001 ----
result = convert (build_pointer_type (new_type), result);
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
result = build_component_ref (result, NULL_TREE,
! TYPE_FIELDS (new_type), 0);
result = convert (result_type,
build_unary_op (ADDR_EXPR, NULL_TREE, result));
}
Index: utils.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/utils.c,v
retrieving revision 1.34
diff -u -c -3 -p -r1.34 utils.c
*** utils.c 21 Oct 2003 13:42:23 -0000 1.34
--- utils.c 29 Oct 2003 09:28:19 -0000
*************** convert_to_fat_pointer (type, expr)
*** 2825,2834 ****
else
expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
! template = build_component_ref (expr, NULL_TREE, fields);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
! TREE_CHAIN (fields)));
}
else
/* Otherwise, build the constructor for the template. */
--- 2825,2834 ----
else
expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
! template = build_component_ref (expr, NULL_TREE, fields, 0);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
! TREE_CHAIN (fields), 0));
}
else
/* Otherwise, build the constructor for the template. */
*************** convert_to_thin_pointer (type, expr)
*** 2872,2878 ****
/* We get the pointer to the data and use a NOP_EXPR to make it the
proper GCC type. */
! expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)));
expr = build1 (NOP_EXPR, type, expr);
return expr;
--- 2872,2879 ----
/* We get the pointer to the data and use a NOP_EXPR to make it the
proper GCC type. */
! expr
! = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)), 0);
expr = build1 (NOP_EXPR, type, expr);
return expr;
*************** convert (type, expr)
*** 2927,2933 ****
return TREE_VALUE (CONSTRUCTOR_ELTS (expr));
else
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype)));
}
else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
--- 2928,2934 ----
return TREE_VALUE (CONSTRUCTOR_ELTS (expr));
else
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype), 0));
}
else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
*************** convert (type, expr)
*** 2977,2983 ****
if (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)
&& code != UNCONSTRAINED_ARRAY_TYPE)
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype)));
/* If converting to a type that contains a template, convert to the data
type and then build the template. */
--- 2978,2984 ----
if (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)
&& code != UNCONSTRAINED_ARRAY_TYPE)
return convert (type, build_component_ref (expr, NULL_TREE,
! TYPE_FIELDS (etype), 0));
/* If converting to a type that contains a template, convert to the data
type and then build the template. */
*************** convert (type, expr)
*** 3051,3057 ****
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (expr, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE));
etype = TREE_TYPE (expr);
ecode = TREE_CODE (etype);
break;
--- 3052,3058 ----
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (expr, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE, 0));
etype = TREE_TYPE (expr);
ecode = TREE_CODE (etype);
break;
*************** convert (type, expr)
*** 3146,3152 ****
array and then convert it. */
else if (TYPE_FAT_POINTER_P (etype))
expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
! NULL_TREE);
return fold (convert_to_pointer (type, expr));
--- 3147,3153 ----
array and then convert it. */
else if (TYPE_FAT_POINTER_P (etype))
expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
! NULL_TREE, 0);
return fold (convert_to_pointer (type, expr));
*************** maybe_unconstrained_array (exp)
*** 3278,3284 ****
= build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (exp, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE));
TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
return new;
}
--- 3279,3285 ----
= build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (exp, 0),
get_identifier ("P_ARRAY"),
! NULL_TREE, 0));
TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
return new;
}
*************** maybe_unconstrained_array (exp)
*** 3306,3317 ****
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
return
build_component_ref (new, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))));
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return
build_component_ref (exp, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))));
break;
default:
--- 3307,3319 ----
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
return
build_component_ref (new, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
! 0);
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return
build_component_ref (exp, NULL_TREE,
! TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
break;
default:
*************** unchecked_convert (type, expr, notrunc_p
*** 3399,3405 ****
layout_type (rec_type);
expr = unchecked_convert (rec_type, expr, notrunc_p);
! expr = build_component_ref (expr, NULL_TREE, field);
}
/* Similarly for integral input type whose precision is not equal to its
--- 3401,3407 ----
layout_type (rec_type);
expr = unchecked_convert (rec_type, expr, notrunc_p);
! expr = build_component_ref (expr, NULL_TREE, field, 0);
}
/* Similarly for integral input type whose precision is not equal to its
Index: einfo.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/einfo.h,v
retrieving revision 1.9
diff -u -c -3 -p -r1.9 einfo.h
*** einfo.h 21 Oct 2003 13:41:58 -0000 1.9
--- einfo.h 29 Oct 2003 09:42:26 -0000
***************
*** 483,489 ****
INLINE B No_Return (E Id);
INLINE B Non_Binary_Modulus (E Id);
INLINE E Non_Limited_View (E Id);
- INLINE L Non_Limited_Views (E Id);
INLINE B Nonzero_Is_True (E Id);
INLINE U Normalized_First_Bit (E Id);
INLINE U Normalized_Position (E Id);
--- 483,488 ----
***************
*** 1516,1524 ****
INLINE E Non_Limited_View (E Id)
{ return Node17 (Id); }
-
- INLINE L Non_Limited_Views (E Id)
- { return Elist8 (Id); }
INLINE B Nonzero_Is_True (E Id)
{ return Flag162 (Base_Type (Id)); }
--- 1515,1520 ----