+2001-12-17 Joel Brobecker <brobecke@gnat.com>
+
+ * gnat_rm.texi: Fix minor typos. Found while reading the section
+ regarding "Bit_Order Clauses" that was sent to a customer.
+ Very interesting documentation!
+
+2001-12-17 Robert Dewar <dewar@gnat.com>
+
+ * sem_case.adb (Choice_Image): Avoid creating improper character
+ literal names by using the routine Set_Character_Literal_Name. This
+ fixes bombs in certain error message cases.
+
+2001-12-17 Arnaud Charlet <charlet@gnat.com>
+
+ * a-reatim.adb: Minor reformatting.
+
+2001-12-17 Ed Schonberg <schonber@gnat.com>
+
+ * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the
+ case where the formal is an extension of another formal in the current
+ unit or in a parent generic unit.
+
+2001-12-17 Arnaud Charlet <charlet@gnat.com>
+
+ * s-tposen.adb: Update comments. Minor reformatting.
+ Minor code clean up.
+
+ * s-tarest.adb: Update comments. Minor code reorganization.
+
+2001-12-17 Gary Dismukes <dismukes@gnat.com>
+
+ * exp_attr.adb (Attribute_Tag): Suppress expansion of <type_name>'Tag
+ when Java_VM.
+
+2001-12-17 Robert Dewar <dewar@gnat.com>
+
+ * exp_attr.adb: Minor reformatting
+
+2001-12-17 Ed Schonberg <schonber@gnat.com>
+
+ * sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle
+ derivations nested within a child unit: verify that the parent
+ type is declared in an outer scope.
+
+2001-12-17 Robert Dewar <dewar@gnat.com>
+
+ * sem_ch12.adb: Minor reformatting
+
+2001-12-17 Ed Schonberg <schonber@gnat.com>
+
+ * sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post
+ warning if current unit is a predefined one, from which bodies may
+ have been deleted.
+
+2001-12-17 Robert Dewar <dewar@gnat.com>
+
+ * eval_fat.ads: Add comment that Round_Even is referenced in Ada code
+ Fix header format. Add 2001 to copyright date.
+
+ * exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference,
+ which caused CE during compilation if checks were enabled.
+
2001-12-17 Vincent Celier <celier@gnat.com>
* make.adb:
-- Extract the integer part of T, truncating towards zero.
if T_Val < 0.5 then
- SC := 0;
-
+ SC := 0;
else
SC := Seconds_Count (Time_Span' (T_Val - 0.5));
end if;
-- --
-- S p e c --
-- --
--- $Revision: 1.4 $ --
+-- $Revision$
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2001 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- --
-- The compile time representation of the floating-point root type
type Rounding_Mode is (Floor, Ceiling, Round, Round_Even);
+ for Rounding_Mode use (0, 1, 2, 3);
-- Used to indicate rounding mode for Machine attribute
+ -- Note that C code in gigi knows that Round_Even is 3
Rounding_Was_Biased : Boolean;
-- Set if last use of Machine rounded a halfway case away from zero
-- --
-- B o d y --
-- --
--- $Revision: 1.304 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
Ttyp := Underlying_Type (Ttyp);
if Prefix_Is_Type then
- Rewrite (N,
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
+
+ -- For JGNAT we leave the type attribute unexpanded because
+ -- there's not a dispatching table to reference.
+
+ if not Java_VM then
+ Rewrite (N,
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
+ Analyze_And_Resolve (N, RTE (RE_Tag));
+ end if;
else
Rewrite (N,
Prefix => Relocate_Node (Pref),
Selector_Name =>
New_Reference_To (Tag_Component (Ttyp), Loc)));
+ Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
-
- Analyze_And_Resolve (N, RTE (RE_Tag));
end Tag;
----------------
-- --
-- B o d y --
-- --
--- $Revision: 1.56 $
+-- $Revision$
-- --
-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
-- --
-- Or if this is a dummy type for a renaming
- or else Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR"
- or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
- or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"
+ or else (Name_Len >= 3 and then
+ Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
+
+ or else (Name_Len >= 4 and then
+ (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
+ or else
+ Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
-- For all these cases, just return the name unchanged
@c o
@c G N A T _ RM o
@c o
-@c $Revision: 1.1 $
+@c $Revision$
@c o
@c Copyright (C) 1992-2001 Ada Core Technologies, Inc. o
@c o
@title GNAT Reference Manual
@subtitle GNAT, The GNU Ada 95 Compiler
@subtitle Version 3.15w
-@subtitle Document revision level $Revision: 1.1 $
-@subtitle Date: $Date: 2001/10/26 13:55:51 $
+@subtitle Document revision level $Revision$
+@subtitle Date: $Date$
@author Ada Core Technologies, Inc.
@page
Version 3.14a
-Date: $Date: 2001/10/26 13:55:51 $
+Date: $Date$
Ada Core Technologies, Inc.
Since the misconception that Bit_Order automatically deals with all
endian-related incompatibilities is a common one, the specification of
a component field that is an integral number of bytes will always
-generate a warning This warning may be suppressed using
+generate a warning. This warning may be suppressed using
@code{pragma Suppress} if desired. The following section contains additional
details regarding the issue of byte ordering.
@cindex ordering, of bytes
@noindent
-In this section we will review the effec of the @code{Bit_Order} attribute
+In this section we will review the effect of the @code{Bit_Order} attribute
definition clause on byte ordering. Briefly, it has no effect at all, but
a detailed example will be helpful. Before giving this
example, let us review the precise
-- --
-- B o d y --
-- --
--- $Revision: 1.13 $
+-- $Revision$
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies --
-- --
Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
Terminate_Task (Self_ID);
- exception -- not needed in no exc mode
- when others => -- not needed in no exc mode
- Terminate_Task (Self_ID); -- not needed in no exc mode
+ exception
+ when others =>
+ Terminate_Task (Self_ID);
end;
end Task_Wrapper;
procedure Activate_Restricted_Tasks
(Chain_Access : Activation_Chain_Access)
is
- Self_ID : constant Task_ID := STPO.Self;
- C : Task_ID;
- Activate_Prio : System.Any_Priority;
- Success : Boolean;
+ Self_ID : constant Task_ID := STPO.Self;
+ C : Task_ID;
+ Activate_Prio : System.Any_Priority;
+ Success : Boolean;
begin
pragma Assert (Self_ID = Environment_Task);
SSL.Lock_Task := Task_Lock'Access;
SSL.Unlock_Task := Task_Unlock'Access;
+
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
- SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
- SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access;
- SSL.Timed_Delay := Timed_Delay_T'Access;
- SSL.Adafinal := Finalize_Global_Tasks'Access;
+ SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
+ SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+
+ SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
+ SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
-- No need to create a new Secondary Stack, since we will use the
-- default one created in s-secsta.adb
- SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
- SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
- SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+ Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
+
+ SSL.Timed_Delay := Timed_Delay_T'Access;
+ SSL.Adafinal := Finalize_Global_Tasks'Access;
end Init_RTS;
begin
-- --
-- B o d y --
-- --
--- $Revision: 1.14 $
+-- $Revision$
-- --
-- Copyright (C) 1998-2001 Ada Core Technologies --
-- --
(Self_Id : Task_ID;
Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link);
+ -- This procedure executes or queues an entry call, depending
+ -- on the status of the corresponding barrier. It assumes that the
+ -- specified object is locked.
---------------------
-- Check_Exception --
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link)
is
- use type Ada.Exceptions.Exception_Id;
-
procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
+ use type Ada.Exceptions.Exception_Id;
+
E : constant Ada.Exceptions.Exception_Id :=
Entry_Call.Exception_To_Raise;
procedure Wait_For_Completion
(Self_ID : Task_ID;
- Entry_Call : Entry_Call_Link)
- is
+ Entry_Call : Entry_Call_Link) is
begin
pragma Assert (Self_ID = Entry_Call.Self);
Self_ID.Common.State := Entry_Caller_Sleep;
STPO.Unlock (Entry_Call.Self);
end if;
- exception -- not needed in no exc mode
- when others => -- not needed in no exc mode
- Send_Program_Error -- not needed in no exc mode
- (Self_Id, Entry_Call); -- not needed in no exc mode
+ exception
+ when others =>
+ Send_Program_Error
+ (Self_Id, Entry_Call);
end PO_Do_Or_Queue;
----------------------------
-- Protected_Single_Count --
----------------------------
- function Protected_Count_Entry
- (Object : Protection_Entry) return Natural is
+ function Protected_Count_Entry (Object : Protection_Entry) return Natural is
begin
if Object.Call_In_Progress /= null then
return 1;
pragma Assert (Entry_Call.State /= Cancelled);
- if Entry_Call.State = Done then
- Check_Exception (Self_Id, Entry_Call'Access);
- return;
+ if Entry_Call.State /= Done then
+ STPO.Write_Lock (Self_Id);
+ Wait_For_Completion (Self_Id, Entry_Call'Access);
+ STPO.Unlock (Self_Id);
end if;
- STPO.Write_Lock (Self_Id);
- Wait_For_Completion (Self_Id, Entry_Call'Access);
- STPO.Unlock (Self_Id);
Check_Exception (Self_Id, Entry_Call'Access);
end Protected_Single_Entry_Call;
procedure Service_Entry (Object : Protection_Entry_Access) is
Self_Id : constant Task_ID := STPO.Self;
- Entry_Call : Entry_Call_Link;
+ Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
Caller : Task_ID;
Barrier_Value : Boolean;
begin
- Entry_Call := Object.Entry_Queue;
-
if Entry_Call /= null then
- Barrier_Value :=
- Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
+ Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
if Barrier_Value then
if Object.Call_In_Progress /= null then
-
-- This violates the No_Entry_Queue restriction, send
-- Program_Error to the caller.
end if;
end if;
- exception -- not needed in no exc mode
- when others => -- not needed in no exc mode
- Send_Program_Error -- not needed in no exc mode
- (Self_Id, Entry_Call); -- not needed in no exc mode
+ exception
+ when others =>
+ Send_Program_Error (Self_Id, Entry_Call);
end Service_Entry;
---------------------------------------
-- --
-- B o d y --
-- --
--- $Revision: 1.13 $
+-- $Revision$
-- --
-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
-- --
C := UI_To_Int (Value);
if C in 16#20# .. 16#7E# then
- Name_Buffer (1) := ''';
- Name_Buffer (2) := Character'Val (C);
- Name_Buffer (3) := ''';
- Name_Len := 3;
+ Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
return Name_Find;
end if;
-- --
-- B o d y --
-- --
--- $Revision: 1.14 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
Ancestor :=
Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
- elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) then
+ -- The type may be a local derivation, or a type extension of
+ -- a previous formal, or of a formal of a parent package.
+
+ elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
+ or else
+ Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
+ then
Ancestor :=
Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
if Is_Child_Unit (Scope (Current_Scope))
and then Is_Completion
and then In_Private_Part (Current_Scope)
+ and then Scope (Parent_Type) /= Current_Scope
then
-- This is the unusual case where a type completed by a private
-- derivation occurs within a package nested in a child unit,
if Unit = Spec_Unit then
Set_Unreferenced_In_Spec (Item);
+ -- In No_Run_Time_Mode, we remove the bodies of non-
+ -- inlined subprograms, which may lead to spurious
+ -- warnings, clearly undesirable.
+
+ elsif No_Run_Time
+ and then Is_Predefined_File_Name (Unit_File_Name (Unit))
+ then
+ null;
+
-- Otherwise simple unreferenced message
else
projects / gcc.git / commitdiff