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;
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;
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 --
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;
-- --
------------------------------------------------------------------------------
--- 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;
+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.
MAIN=ada
endif
-ifndef CC
- CC=gcc
-endif
-
ifndef ADA_SPEC
ADA_SPEC=.ads
endif
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
??? 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)
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)
pragma Warnings (Off, Dummy);
begin
+ Node_Count := 0;
Atree_Private_Part.Nodes.Init;
Orig_Nodes.Init;
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
(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);
= 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;
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)
-- 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
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);
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;
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
-- 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
-- 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
-- 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)
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;
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);
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);
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);
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);
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)); }
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.
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.
-- 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
-- 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,
-- 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;
-- 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;
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. */
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. */
/* 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,
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;
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;
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
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))
{
-- 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
-- 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.
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.
-- 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)
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
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
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.
Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
end if;
+ Install_Limited_Context_Clauses (N);
+
Check_With_Type_Clauses (N);
end Install_Context;
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.
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
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);
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 --
-- the current unit.
-- Shouldn't this be somewhere more general ???
+ -----------------
+ -- Is_Ancestor --
+ -----------------
+
function Is_Ancestor (E : Entity_Id) return Boolean is
Par : Entity_Id;
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);
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
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.
Next_Entity (Ent);
end loop;
end;
+
end if;
-- The package must be visible while the with_type clause is active,
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);
-- accordingly, to uninstall it when the context is removed.
Set_Limited_View_Installed (N);
+ Set_From_With_Type (P);
end Install_Limited_Withed_Unit;
-------------------------
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).
-- 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 --
------------------------------
Set_Stored_Constraint (E, No_Elist);
Set_Full_View (E, Empty);
Init_Size_Align (E);
- Set_Has_Unknown_Discriminants (E);
end Decorate_Incomplete_Type;
--------------------------
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);
-- 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');
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
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');
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
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');
-- 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);
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
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
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
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)
Next (Item);
end loop;
-
end Remove_Context_Clauses;
--------------------------------
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;
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));
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.
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;
--------------------
end if;
end Unchain;
+ -- Start of Remove_With_Type_Clause
+
begin
if Nkind (Name) = N_Selected_Component then
Typ := Entity (Selector_Name (Name));
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;
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;
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;
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
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
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;
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.
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;
-- 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)
-- --
-- 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- --
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;
Ptr := Ptr + 1;
Operating_Mode := Check_Semantics;
+ if Tree_Output then
+ ASIS_Mode := True;
+ end if;
+
-- Processing for d switch
when 'd' =>
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
#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 *
**********/
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)
}
/* 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;
/********************
|| 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 ++;
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);
}
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)
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)));
&& 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:
= 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,
(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);
}
(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
(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
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);
return gnu_result;
}
\f
+/* 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 ();
+ }
+}
+\f
/* 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
{
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;
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. */
/* 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;
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))
{
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. */
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;
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));
= 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;
}
&& 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:
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
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));
\f
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
&& 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);
}
\f
/* 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;
{
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;
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
- return fold (ref);
+ return no_fold_p ? ref : fold (ref);
}
\f
/* 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;
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)));
}
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));
}
projects / gcc.git / commitdiff