diff options
| -rw-r--r-- | gcc/ada/3vtrasym.adb | 195 | ||||
| -rw-r--r-- | gcc/ada/5vtraent.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/5vtraent.ads | 29 | ||||
| -rw-r--r-- | gcc/ada/ChangeLog | 137 | ||||
| -rw-r--r-- | gcc/ada/Makefile.generic | 4 | ||||
| -rw-r--r-- | gcc/ada/Makefile.prolog | 1 | ||||
| -rw-r--r-- | gcc/ada/ada-tree.def | 8 | ||||
| -rw-r--r-- | gcc/ada/ada-tree.h | 11 | ||||
| -rw-r--r-- | gcc/ada/atree.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/decl.c | 13 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/einfo.h | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 40 | ||||
| -rw-r--r-- | gcc/ada/gigi.h | 10 | ||||
| -rw-r--r-- | gcc/ada/itypes.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/misc.c | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 507 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/tb-alvms.c | 21 | ||||
| -rw-r--r-- | gcc/ada/trans.c | 69 | ||||
| -rw-r--r-- | gcc/ada/utils.c | 24 | ||||
| -rw-r--r-- | gcc/ada/utils2.c | 27 |
31 files changed, 966 insertions, 314 deletions
diff --git a/gcc/ada/3vtrasym.adb b/gcc/ada/3vtrasym.adb index 26382c11130..d11e26b730c 100644 --- a/gcc/ada/3vtrasym.adb +++ b/gcc/ada/3vtrasym.adb @@ -34,7 +34,6 @@ 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; @@ -45,133 +44,147 @@ package body GNAT.Traceback.Symbolic is pragma Warnings (Off); pragma Linker_Options ("--for-linker=sys$library:trace.exe"); - use Interfaces.C.Strings; + use Interfaces.C; 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; + subtype User_Arg_Type is Unsigned_Longword; + subtype Cond_Value_Type is Unsigned_Longword; - 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; + type ASCIC is record + Count : unsigned_char; + Data : char_array (1 .. 255); end record; - for Dscdef1_Type'Size use 64; + pragma Convention (C, ASCIC); - 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; + 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; - 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; + function Fetch_ASCIC is new Fetch_From_Address (ASCIC); - subtype User_Arg_Type is Unsigned_Longword; - subtype Cond_Value_Type is Unsigned_Longword; - - procedure Show_Traceback + procedure Symbolize (Status : out Cond_Value_Type; - Faulting_FP : Address; - Faulting_SP : Address; - Faulting_PC : Address; - Detail_Level : Integer := Integer'Null_Parameter; + 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; - Exceptionn : Unsigned_Longword := Unsigned_Longword'Null_Parameter); + User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter); - pragma Interface (External, Show_Traceback); + pragma Interface (External, Symbolize); 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); - + (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 - Res : String (1 .. 256 * Traceback'Length); - Len : Integer; - Status : Cond_Value_Type; + 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 I in Traceback'Range loop - Image_Len := 0; - Image_Do_Another_Line := True; - Image_Xtra_Msg := False; - Show_Traceback + 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, - FP_For (Traceback (I)), - SP_For (Traceback (I)), - PC_For (Traceback (I)), - 0, - Traceback_Image'Address); + 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 + Image_Len - 1; + Last : Integer := First + 80 - 1; + begin - Res (First .. Last + 1) := Image_Buf & ASCII.LF; - Len := Last + 1; + 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; + System.Soft_Links.Unlock_Task.all; return Res (1 .. Len); + else return ""; end if; diff --git a/gcc/ada/5vtraent.adb b/gcc/ada/5vtraent.adb index bab8daf7f08..532acad6e32 100644 --- a/gcc/ada/5vtraent.adb +++ b/gcc/ada/5vtraent.adb @@ -47,22 +47,13 @@ package body System.Traceback_Entries is end PC_For; ------------ - -- SP_For -- + -- PV_For -- ------------ - function SP_For (TB_Entry : Traceback_Entry) return System.Address is + function PV_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; + return TB_Entry.PV; + end PV_For; ------------------ -- TB_Entry_For -- @@ -70,7 +61,7 @@ package body System.Traceback_Entries is function TB_Entry_For (PC : System.Address) return Traceback_Entry is begin - return (PC => PC, SP => System.Null_Address, FP => System.Null_Address); + return (PC => PC, PV => System.Null_Address); end TB_Entry_For; end System.Traceback_Entries; diff --git a/gcc/ada/5vtraent.ads b/gcc/ada/5vtraent.ads index ed71437ea62..0d27c197fff 100644 --- a/gcc/ada/5vtraent.ads +++ b/gcc/ada/5vtraent.ads @@ -35,34 +35,25 @@ -- -- ------------------------------------------------------------------------------ --- This is the Alpha/OpenVMS version of this package. +-- 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; + PV : 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); + 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; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index adb14dffeda..c6de5e02630 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,140 @@ +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. + 2003-10-27 Arnaud Charlet <charlet@act-europe.fr> * Makefile.generic: Add missing substitution on object_deps handling. diff --git a/gcc/ada/Makefile.generic b/gcc/ada/Makefile.generic index 630f6c5a740..34e0d24af01 100644 --- a/gcc/ada/Makefile.generic +++ b/gcc/ada/Makefile.generic @@ -67,10 +67,6 @@ ifndef MAIN MAIN=ada endif -ifndef CC - CC=gcc -endif - ifndef ADA_SPEC ADA_SPEC=.ads endif diff --git a/gcc/ada/Makefile.prolog b/gcc/ada/Makefile.prolog index 5766fa98ae1..1aaff294617 100644 --- a/gcc/ada/Makefile.prolog +++ b/gcc/ada/Makefile.prolog @@ -39,6 +39,7 @@ C_EXT:=.c 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 diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def index 9b3b1cdf9bd..24cfa59fa8e 100644 --- a/gcc/ada/ada-tree.def +++ b/gcc/ada/ada-tree.def @@ -77,3 +77,11 @@ DEFTREECODE (GNAT_NOP_EXPR, "gnat_nop_expr", '1', 1) ??? 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) diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h index 9f1675a2c23..13487ffb068 100644 --- a/gcc/ada/ada-tree.h +++ b/gcc/ada/ada-tree.h @@ -275,3 +275,14 @@ struct lang_type GTY(()) 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) diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index e27a63fa445..50647da5eeb 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -838,6 +838,7 @@ package body Atree is pragma Warnings (Off, Dummy); begin + Node_Count := 0; Atree_Private_Part.Nodes.Init; Orig_Nodes.Init; diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index bbad5b50e46..d01074e9b0a 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -946,7 +946,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) gnu_expr = build_component_ref (gnu_expr, NULL_TREE, - TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr)))); + TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0); } if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST @@ -990,7 +990,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) (build_binary_op (MODIFY_EXPR, NULL_TREE, build_component_ref (gnu_new_var, NULL_TREE, - TYPE_FIELDS (gnu_new_type)), + TYPE_FIELDS (gnu_new_type), 0), gnu_expr)); gnu_type = build_reference_type (gnu_type); @@ -998,7 +998,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) = build_unary_op (ADDR_EXPR, gnu_type, build_component_ref (gnu_new_var, NULL_TREE, - TYPE_FIELDS (gnu_new_type))); + TYPE_FIELDS (gnu_new_type), 0)); gnu_size = 0; used_by_ref = 1; @@ -3536,6 +3536,13 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) 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 = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6eac0d78359..6b0c1a132aa 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -80,7 +80,6 @@ package body Einfo is -- 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 @@ -1798,17 +1797,10 @@ package body Einfo is 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); + or else Ekind (Id) = E_Incomplete_Type); 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); @@ -2845,7 +2837,7 @@ package body Einfo is begin pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Package); + or else Ekind (Id) = E_Package); Set_Flag159 (Id, V); end Set_From_With_Type; @@ -3741,18 +3733,11 @@ package body Einfo is 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); + or else Ekind (Id) = E_Incomplete_Type); 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 pragma Assert diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3f8b227fd6d..a16063d27be 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2381,8 +2381,7 @@ package Einfo is -- 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. +-- in a limited_with clause. -- Lit_Indexes (Node15) -- Present in enumeration types and subtypes. Non-empty only for the @@ -2551,14 +2550,9 @@ package Einfo is -- 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. +-- 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 @@ -4388,7 +4382,6 @@ package Einfo is -- 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) @@ -5152,7 +5145,6 @@ package Einfo is 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; @@ -5624,7 +5616,6 @@ package Einfo is 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); @@ -6150,7 +6141,6 @@ package Einfo is 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); @@ -6455,7 +6445,6 @@ package Einfo is 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); diff --git a/gcc/ada/einfo.h b/gcc/ada/einfo.h index f9b0a8a41fa..05db041ddc6 100644 --- a/gcc/ada/einfo.h +++ b/gcc/ada/einfo.h @@ -483,7 +483,6 @@ 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); @@ -1517,9 +1516,6 @@ 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)); } diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4287b752ce1..8105de381d2 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -98,15 +98,17 @@ package body Exp_Ch5 is 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 + -- 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. 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 + -- 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. @@ -368,6 +370,14 @@ package body Exp_Ch5 is 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. @@ -1016,7 +1026,10 @@ package body Exp_Ch5 is -- 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 + 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 diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index c9ba3be354f..0d203b6d289 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -922,10 +922,11 @@ package body Exp_Disp is -- Register_Tag (Dt_Ptr); - -- Skip this if routine not available + -- 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, diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 18f77f04283..0ac32c3dd9e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -124,7 +124,12 @@ package body Freeze is -- 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. + -- 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; @@ -4246,15 +4251,38 @@ package body Freeze is -- 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))); + + 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; diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h index 573d934b4ab..f820e3a0a41 100644 --- a/gcc/ada/gigi.h +++ b/gcc/ada/gigi.h @@ -190,6 +190,9 @@ extern void gnat_to_code PARAMS ((Node_Id)); 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. */ @@ -201,6 +204,9 @@ extern void process_type PARAMS ((Entity_Id)); 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. */ @@ -699,8 +705,8 @@ extern tree gnat_build_constructor PARAMS((tree, tree)); /* 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)); + 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, diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb index 12864b84be2..dd5f98a5132 100644 --- a/gcc/ada/itypes.adb +++ b/gcc/ada/itypes.adb @@ -26,6 +26,7 @@ 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; @@ -64,7 +65,9 @@ package body Itypes is Set_Is_Itype (Typ); Set_Associated_Node_For_Itype (Typ, Related_Nod); - if In_Deleted_Code then + if In_Deleted_Code + and then not ASIS_Mode + then Set_Is_Frozen (Typ); end if; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index a82c99aff7f..e0f5998f21f 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -3623,10 +3623,12 @@ package body Make is if not At_Least_One_Main then -- First make sure that the binder and the linker - -- will not be invoked. + -- will not be invoked if -z is not used. - Do_Bind_Step := False; - Do_Link_Step := False; + if not No_Main_Subprogram then + Do_Bind_Step := False; + Do_Link_Step := False; + end if; -- Put all the sources in the queue diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c index 83907b94903..8d541e4d0b9 100644 --- a/gcc/ada/misc.c +++ b/gcc/ada/misc.c @@ -544,6 +544,13 @@ gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode, int modifier) 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)) { diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 743e943ff7a..c7803048681 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -73,8 +73,10 @@ package body Sem_Ch10 is -- 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. + -- 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 @@ -123,10 +125,13 @@ package body Sem_Ch10 is -- 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. Verify that there is no - -- regular with_clause in the context. + -- 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. @@ -782,7 +787,7 @@ package body Sem_Ch10 is 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 + -- b) The second pass add implicit limited_with clauses for -- the parents of child units. -- c) The third pass analyzes limited_with clauses. @@ -792,7 +797,9 @@ package body Sem_Ch10 is -- 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 + 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) @@ -845,6 +852,11 @@ package body Sem_Ch10 is 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 @@ -1239,6 +1251,7 @@ package body Sem_Ch10 is 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 @@ -1482,6 +1495,10 @@ package body Sem_Ch10 is 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. @@ -2534,6 +2551,8 @@ package body Sem_Ch10 is Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit))); end if; + Install_Limited_Context_Clauses (N); + Check_With_Type_Clauses (N); end Install_Context; @@ -2548,7 +2567,6 @@ package body Sem_Ch10 is 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. @@ -2565,9 +2583,8 @@ package body Sem_Ch10 is then if Limited_Present (Item) then - -- Second pass will be necessary + -- Limited withed units will be installed later. - Lim_Present := True; goto Continue; -- If Name (Item) is not an entity name, something is wrong, and @@ -2703,7 +2720,7 @@ package body Sem_Ch10 is if Is_Child_Spec (Lib_Unit) then - -- The unit also has implicit withs on its own parents. + -- The unit also has implicit withs on its own parents if No (Context_Items (N)) then Set_Context_Items (N, New_List); @@ -2778,23 +2795,224 @@ package body Sem_Ch10 is if Check_Private then Check_Private_Child_Unit (N); end if; + end Install_Context_Clauses; - -- Second pass: install limited_with clauses + ------------------------------------- + -- Install_Limited_Context_Clauses -- + ------------------------------------- - if Lim_Present then - Item := First (Context_Items (N)); + 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 Limited_Present (Item) + and then not Limited_Present (Item) + and then not Implicit_With (Item) + and then Library_Unit (Item) = Library_Unit (W) then - Install_Limited_Withed_Unit (Item); + Error_Msg_N ("unlimited view visible in ancestor", W); + return; end if; Next (Item); end loop; - end if; - end Install_Context_Clauses; + + -- 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 -- @@ -2917,6 +3135,10 @@ package body Sem_Ch10 is -- the current unit. -- Shouldn't this be somewhere more general ??? + ----------------- + -- Is_Ancestor -- + ----------------- + function Is_Ancestor (E : Entity_Id) return Boolean is Par : Entity_Id; @@ -3047,16 +3269,37 @@ package body Sem_Ch10 is 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 - -- 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 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); @@ -3067,6 +3310,13 @@ package body Sem_Ch10 is 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 @@ -3084,7 +3334,9 @@ package body Sem_Ch10 is 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. @@ -3099,6 +3351,7 @@ package body Sem_Ch10 is Next_Entity (Ent); end loop; end; + end if; -- The package must be visible while the with_type clause is active, @@ -3116,6 +3369,13 @@ package body Sem_Ch10 is 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); @@ -3125,6 +3385,7 @@ package body Sem_Ch10 is -- accordingly, to uninstall it when the context is removed. Set_Limited_View_Installed (N); + Set_From_With_Type (P); end Install_Limited_Withed_Unit; ------------------------- @@ -3136,6 +3397,13 @@ package body Sem_Ch10 is 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). @@ -3308,6 +3576,13 @@ package body Sem_Ch10 is -- 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 -- ------------------------------ @@ -3324,7 +3599,6 @@ package body Sem_Ch10 is Set_Stored_Constraint (E, No_Elist); Set_Full_View (E, Empty); Init_Size_Align (E); - Set_Has_Unknown_Discriminants (E); end Decorate_Incomplete_Type; -------------------------- @@ -3374,22 +3648,54 @@ package body Sem_Ch10 is 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; + 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 (Cunit (Unum)) then - if Tagged_Present (Type_Definition (Decl)) then + if not Analyzed_Unit then + if Is_Tagged then Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); else Decorate_Incomplete_Type (Comp_Typ, Scope); @@ -3398,9 +3704,8 @@ package body Sem_Ch10 is -- Create shadow entity for type - Lim_Typ := New_Internal_Entity + Lim_Typ := New_Internal_Shadow_Entity (Kind => Ekind (Comp_Typ), - Scope_Id => Scope, Sloc_Value => Sloc (Comp_Typ), Id_Char => 'Z'); @@ -3408,17 +3713,13 @@ package body Sem_Ch10 is Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_From_With_Type (Lim_Typ); - if Tagged_Present (Type_Definition (Decl)) then + 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); - - -- 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 @@ -3426,13 +3727,12 @@ package body Sem_Ch10 is then Comp_Typ := Defining_Identifier (Decl); - if not Analyzed (Cunit (Unum)) then + if not Analyzed_Unit then Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope); end if; - Lim_Typ := New_Internal_Entity + Lim_Typ := New_Internal_Shadow_Entity (Kind => Ekind (Comp_Typ), - Scope_Id => Scope, Sloc_Value => Sloc (Comp_Typ), Id_Char => 'Z'); @@ -3443,10 +3743,6 @@ package body Sem_Ch10 is 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 @@ -3464,9 +3760,8 @@ package body Sem_Ch10 is Set_Scope (Comp_Typ, Scope); end if; - Lim_Typ := New_Internal_Entity + Lim_Typ := New_Internal_Shadow_Entity (Kind => Ekind (Comp_Typ), - Scope_Id => Scope, Sloc_Value => Sloc (Comp_Typ), Id_Char => 'Z'); @@ -3480,8 +3775,6 @@ package body Sem_Ch10 is -- 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); @@ -3497,14 +3790,41 @@ package body Sem_Ch10 is begin pragma Assert (Limited_Present (N)); - -- Limited withed subprograms are not allowed. Therefore, we - -- don't need to build the limited-view auxiliary chain. + -- 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 - if Nkind (Parent (P)) = N_Function_Specification - or else Nkind (Parent (P)) = N_Procedure_Specification - then - return; - end if; + 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 @@ -3516,7 +3836,6 @@ package body Sem_Ch10 is 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 @@ -3650,11 +3969,32 @@ package body Sem_Ch10 is 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). - -- Loop through context items and undo with_clauses and use_clauses. + -- 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 @@ -3664,7 +4004,7 @@ package body Sem_Ch10 is and then Limited_Present (Item) and then Limited_View_Installed (Item) then - Remove_Limited_With_Clause (Item); + null; elsif Nkind (Item) = N_With_Clause and then Context_Installed (Item) @@ -3687,7 +4027,6 @@ package body Sem_Ch10 is Next (Item); end loop; - end Remove_Context_Clauses; -------------------------------- @@ -3697,7 +4036,6 @@ package body Sem_Ch10 is 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; @@ -3709,6 +4047,13 @@ package body Sem_Ch10 is 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)); @@ -3720,6 +4065,11 @@ package body Sem_Ch10 is 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. @@ -3731,9 +4081,40 @@ package body Sem_Ch10 is Set_Ekind (P, E_Void); Set_Scope (P, Empty); Set_Is_Immediately_Visible (P, False); - end if; - Set_Limited_View_Installed (N, 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; -------------------- @@ -3819,6 +4200,8 @@ package body Sem_Ch10 is end if; end Unchain; + -- Start of Remove_With_Type_Clause + begin if Nkind (Name) = N_Selected_Component then Typ := Entity (Selector_Name (Name)); @@ -3882,8 +4265,9 @@ package body Sem_Ch10 is begin if Debug_Flag_I then - Write_Str ("remove withed unit "); + Write_Str ("remove unit "); Write_Name (Chars (Unit_Name)); + Write_Str (" from visibility"); Write_Eol; end if; @@ -3923,5 +4307,12 @@ package body Sem_Ch10 is 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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index f8ca61ea52e..09e9717f18b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2332,8 +2332,15 @@ package body Sem_Ch12 is return; elsif Ekind (Gen_Unit) /= E_Generic_Package then - Error_Msg_N - ("expect name of generic package in instantiation", Gen_Id); + + 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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index c4ad473fe84..3f249c5428f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -789,8 +789,14 @@ package body Sem_Ch8 is end if; if Etype (Old_P) = Any_Type then - Error_Msg_N - ("expect package name in renaming", Name (N)); + 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 @@ -811,11 +817,6 @@ package body Sem_Ch8 is 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 @@ -3397,7 +3398,8 @@ package body Sem_Ch8 is null; else Error_Msg_N - ("imported package can only be used to access imported type", + ("limited withed package can only be used to access " + & " incomplete types", N); end if; end if; @@ -5285,7 +5287,7 @@ package body Sem_Ch8 is Set_In_Use (P); if From_With_Type (P) then - Error_Msg_N ("imported package cannot appear in use clause", N); + Error_Msg_N ("limited withed package cannot appear in use clause", N); end if; -- Find enclosing instance, if any. diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 105dc53bc55..dda7d1d785e 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2134,15 +2134,19 @@ package body Sem_Type is 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)) + 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 (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)) + 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; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 014228b5a9c..fe94742e6e3 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -573,7 +573,7 @@ package Sinfo is -- 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. + -- 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) diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 0cb991802e4..6ae6542c9b2 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- 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- -- @@ -2490,7 +2490,12 @@ package body Sprint is else if First_Name (Node) or else not Dump_Original_Only then - Write_Indent_Str ("with "); + if Limited_Present (Node) then + Write_Indent_Str ("limited with "); + else + Write_Indent_Str ("with "); + end if; + else Write_Str (", "); end if; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index c76c4a1af55..e5e95368392 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -216,6 +216,10 @@ package body Switch.C is Ptr := Ptr + 1; Operating_Mode := Check_Semantics; + if Tree_Output then + ASIS_Mode := True; + end if; + -- Processing for d switch when 'd' => @@ -638,7 +642,11 @@ package body Switch.C is when 't' => Ptr := Ptr + 1; Tree_Output := True; - ASIS_Mode := True; + + if Operating_Mode = Check_Semantics then + ASIS_Mode := True; + end if; + Back_Annotate_Rep_Info := True; -- Processing for T switch diff --git a/gcc/ada/tb-alvms.c b/gcc/ada/tb-alvms.c index fecedd396f0..ff222603a8f 100644 --- a/gcc/ada/tb-alvms.c +++ b/gcc/ada/tb-alvms.c @@ -89,6 +89,10 @@ typedef struct #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 * **********/ @@ -127,10 +131,7 @@ unwind (frame_state_t * fs) if (fs->fp == 0) return; - if ((REG_AT (fs->fp) & 0x7) == 0) - pv = *(PDSCDEF **)fs->fp; - else - pv = (PDSCDEF *) fs->fp; + pv = PV_FOR (fs->fp); if (pv == 0 || pv->pdsc$w_flags & PDSC$M_BASE_FRAME) @@ -190,18 +191,15 @@ unwind (frame_state_t * fs) } /* 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. + 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; /* 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. */ + void * pc; + void * pv; } tb_entry_t; /******************** @@ -249,8 +247,7 @@ __gnat_backtrace (array, size, exclude_min, exclude_max, skip_frames) || frame_state.pc > exclude_max) { tbe->pc = frame_state.pc; - tbe->sp = frame_state.sp; - tbe->fp = frame_state.fp; + tbe->pv = PV_FOR (frame_state.fp); cnt ++; tbe ++; diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index d28ded8f305..0d4539f9746 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -243,9 +243,13 @@ gnat_to_code (gnat_node) 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. */ - if (gnu_root != error_mark_node) + else if (gnu_root != error_mark_node) gigi_abort (302); } @@ -997,7 +1001,9 @@ tree_transform (gnat_node) gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0); gnu_result - = build_component_ref (gnu_prefix, NULL_TREE, gnu_field); + = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, + (Nkind (Parent (gnat_node)) + == N_Attribute_Reference)); } if (gnu_result == 0) @@ -2058,8 +2064,6 @@ tree_transform (gnat_node) 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))); @@ -2071,10 +2075,12 @@ tree_transform (gnat_node) && 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)); + gnu_result = build_call_raise (SE_Object_Too_Large); else - expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_lhs, gnu_rhs)); + 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: @@ -3168,7 +3174,7 @@ tree_transform (gnat_node) = length == 1 ? gnu_subprog_call : build_component_ref (gnu_subprog_call, NULL_TREE, - TREE_PURPOSE (scalar_return_list)); + 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, @@ -3614,7 +3620,8 @@ tree_transform (gnat_node) (build_unary_op (INDIRECT_REF, NULL_TREE, TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("not_handled_by_others"), NULL_TREE)), + get_identifier ("not_handled_by_others"), NULL_TREE, + 0)), integer_zero_node); } @@ -3643,7 +3650,7 @@ tree_transform (gnat_node) (build_unary_op (INDIRECT_REF, NULL_TREE, TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("import_code"), NULL_TREE), + get_identifier ("import_code"), NULL_TREE, 0), gnu_expr); else this_choice @@ -3664,7 +3671,7 @@ tree_transform (gnat_node) (build_unary_op (INDIRECT_REF, NULL_TREE, TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("lang"), NULL_TREE); + get_identifier ("lang"), NULL_TREE, 0); this_choice = build_binary_op @@ -4024,8 +4031,17 @@ tree_transform (gnat_node) 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. */ - if (TREE_CODE (gnu_result) == INTEGER_CST + 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); @@ -4137,6 +4153,25 @@ tree_transform (gnat_node) 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 @@ -5407,6 +5442,16 @@ set_lineno (gnat_node, write_note_p) { 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; diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index c1c5ccf4ce4..a474870922f 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -2825,10 +2825,10 @@ convert_to_fat_pointer (type, expr) else expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr); - template = build_component_ref (expr, NULL_TREE, fields); + 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))); + TREE_CHAIN (fields), 0)); } else /* Otherwise, build the constructor for the template. */ @@ -2872,7 +2872,8 @@ convert_to_thin_pointer (type, expr) /* 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 + = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)), 0); expr = build1 (NOP_EXPR, type, expr); return expr; @@ -2927,7 +2928,7 @@ convert (type, expr) return TREE_VALUE (CONSTRUCTOR_ELTS (expr)); else return convert (type, build_component_ref (expr, NULL_TREE, - TYPE_FIELDS (etype))); + TYPE_FIELDS (etype), 0)); } else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type)) { @@ -2977,7 +2978,7 @@ convert (type, expr) 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))); + TYPE_FIELDS (etype), 0)); /* If converting to a type that contains a template, convert to the data type and then build the template. */ @@ -3051,7 +3052,7 @@ convert (type, expr) expr = build_unary_op (INDIRECT_REF, NULL_TREE, build_component_ref (TREE_OPERAND (expr, 0), get_identifier ("P_ARRAY"), - NULL_TREE)); + NULL_TREE, 0)); etype = TREE_TYPE (expr); ecode = TREE_CODE (etype); break; @@ -3146,7 +3147,7 @@ convert (type, expr) array and then convert it. */ else if (TYPE_FAT_POINTER_P (etype)) expr = build_component_ref (expr, get_identifier ("P_ARRAY"), - NULL_TREE); + NULL_TREE, 0); return fold (convert_to_pointer (type, expr)); @@ -3278,7 +3279,7 @@ maybe_unconstrained_array (exp) = build_unary_op (INDIRECT_REF, NULL_TREE, build_component_ref (TREE_OPERAND (exp, 0), get_identifier ("P_ARRAY"), - NULL_TREE)); + NULL_TREE, 0)); TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp); return new; } @@ -3306,12 +3307,13 @@ maybe_unconstrained_array (exp) && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new))) return build_component_ref (new, NULL_TREE, - TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new)))); + 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)))); + TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0); break; default: @@ -3399,7 +3401,7 @@ unchecked_convert (type, expr, notrunc_p) layout_type (rec_type); expr = unchecked_convert (rec_type, expr, notrunc_p); - expr = build_component_ref (expr, NULL_TREE, field); + expr = build_component_ref (expr, NULL_TREE, field, 0); } /* Similarly for integral input type whose precision is not equal to its diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index c2ffdfbc153..3e90487d711 100644 --- a/gcc/ada/utils2.c +++ b/gcc/ada/utils2.c @@ -50,7 +50,7 @@ static tree contains_null_expr PARAMS ((tree)); 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)); +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. @@ -955,7 +955,8 @@ build_binary_op (op_code, result_type, left_operand, right_operand) && integer_zerop (TREE_VALUE (CONSTRUCTOR_ELTS (right_operand)))) { right_operand = build_component_ref (left_operand, NULL_TREE, - TYPE_FIELDS (left_base_type)); + TYPE_FIELDS (left_base_type), + 0); left_operand = convert (TREE_TYPE (right_operand), integer_zero_node); } @@ -1609,16 +1610,17 @@ gnat_build_constructor (type, list) /* 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. + 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) +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; @@ -1674,8 +1676,9 @@ build_simple_component_ref (record_variable, component, field) { tree field_ref = build_simple_component_ref (record_variable, - NULL_TREE, new_field); - ref = build_simple_component_ref (field_ref, NULL_TREE, field); + 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; @@ -1697,19 +1700,21 @@ build_simple_component_ref (record_variable, component, field) || TYPE_VOLATILE (record_type)) TREE_THIS_VOLATILE (ref) = 1; - return fold (ref); + 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) +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); + tree ref = build_simple_component_ref (record_variable, component, field, + no_fold_p); if (ref != 0) return ref; @@ -1945,7 +1950,7 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool, gnat_node) build_component_ref (build_unary_op (INDIRECT_REF, NULL_TREE, convert (storage_ptr_type, storage)), - NULL_TREE, TYPE_FIELDS (storage_type)), + NULL_TREE, TYPE_FIELDS (storage_type), 0), build_template (template_type, type, NULL_TREE)), convert (result_type, convert (storage_ptr_type, storage))); } @@ -1990,7 +1995,7 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool, gnat_node) 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)); + TYPE_FIELDS (new_type), 0); result = convert (result_type, build_unary_op (ADDR_EXPR, NULL_TREE, result)); } |