3vtrasym.adb, [...]: Minor reformatting
* 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 * 3vtrasym.adb: * 5vtraent.adb: * 5vtraent.ads: * tb-alvms.c: Support for TBK$SYMBOLIZE-based symbolic traceback. * 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. * 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. * Makefile.generic: Remove duplicated setting of CC. * Makefile.prolog: Set CC to gcc by default, to override make's default (cc). * einfo.h: Regenerated. * 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. * 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. * 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. * 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). * 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. From-SVN: r73032
This commit is contained in:
Arnaud Charlet
parent
e9da8a5af7
commit
657a9dd94d
|
|
@ -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;
|
||||
|
||||
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);
|
||||
type ASCIC is record
|
||||
Count : unsigned_char;
|
||||
Data : char_array (1 .. 255);
|
||||
end record;
|
||||
pragma Convention (C, ASCIC);
|
||||
|
||||
pragma Interface (External, Show_Traceback);
|
||||
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
|
||||
(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
|
||||
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,
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -67,10 +67,6 @@ ifndef MAIN
|
|||
MAIN=ada
|
||||
endif
|
||||
|
||||
ifndef CC
|
||||
CC=gcc
|
||||
endif
|
||||
|
||||
ifndef ADA_SPEC
|
||||
ADA_SPEC=.ads
|
||||
endif
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -838,6 +838,7 @@ package body Atree is
|
|||
pragma Warnings (Off, Dummy);
|
||||
|
||||
begin
|
||||
Node_Count := 0;
|
||||
Atree_Private_Part.Nodes.Init;
|
||||
Orig_Nodes.Init;
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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)); }
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ++;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue