diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/a-tags.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/cstand.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch2.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch8.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 138 | ||||
| -rw-r--r-- | gcc/ada/exp_pakd.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/g-socket.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 520 | ||||
| -rw-r--r-- | gcc/ada/interfac.ads | 62 | ||||
| -rw-r--r-- | gcc/ada/s-poosiz.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/s-poosiz.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 50 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 559 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/vms_data.ads | 40 |
20 files changed, 994 insertions, 529 deletions
diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index d687570..5dc3d1e 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -60,11 +60,11 @@ private --------------------------------------------------------------- -- GNAT's Dispatch Table format is customizable in order to match the - -- format used in another langauge. GNAT supports programs that use - -- two different dispatch table format at the same time: the native + -- format used in another language. GNAT supports programs that use + -- two different dispatch table formats at the same time: the native -- format that supports Ada 95 tagged types and which is described in - -- Ada.Tags and a foreign format for types that are imported from some - -- other language (typically C++) which is described in interfaces.cpp. + -- Ada.Tags, and a foreign format for types that are imported from some + -- other language (typically C++) which is described in Interfaces.CPP. -- The runtime information kept for each tagged type is separated into -- two objects: the Dispatch Table and the Type Specific Data record. -- These two objects are allocated statically using the constants: diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 191e223..3962655 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1045,7 +1045,7 @@ package body CStand is Delta_Val := UR_From_Components (UI_From_Int (20), Uint_3, 10); -- In standard 64-bit mode, the size is 64-bits and the delta and - -- amll values are set to nanoseconds (1.0**(10.0**(-9)) + -- small values are set to nanoseconds (1.0**(10.0**(-9)) else Dlo := Intval (Type_Low_Bound (Standard_Integer_64)); diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 130d74d..e68e9a6 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -661,7 +661,7 @@ package body Exp_Ch2 is Set_Etype (N, Etype (Prival (E))); Scop := Current_Scope; - -- Find entity for protected operation, which must be on scope stack. + -- Find entity for protected operation, which must be on scope stack while not Is_Protected_Type (Scope (Scop)) loop Scop := Scope (Scop); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0d3d72d..27173ef 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -640,7 +640,7 @@ package body Exp_Ch3 is P : Node_Id; begin - -- Nothing to do if there is no task hierarchy. + -- Nothing to do if there is no task hierarchy if Restriction_Active (No_Task_Hierarchy) then return; @@ -686,7 +686,7 @@ package body Exp_Ch3 is end loop; end if; - -- Now define the renaming of the master_id. + -- Now define the renaming of the master_id M_Id := Make_Defining_Identifier (Loc, @@ -1310,7 +1310,7 @@ package body Exp_Ch3 is Decl : Node_Id; begin - -- Nothing to do if there is no task hierarchy. + -- Nothing to do if there is no task hierarchy if Restriction_Active (No_Task_Hierarchy) then return; @@ -2663,7 +2663,7 @@ package body Exp_Ch3 is Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), End_Label => Empty); - -- Build exit condition. + -- Build exit condition declare F_Ass : constant List_Id := New_List; @@ -3970,7 +3970,7 @@ package body Exp_Ch3 is end loop; end if; - -- Now build an array declaration. + -- Now build an array declaration -- typA : array (Natural range 0 .. num - 1) of ctype := -- (v, v, v, v, v, ....) @@ -4081,7 +4081,7 @@ package body Exp_Ch3 is if Enumeration_Rep (Ent) = Last_Repval then - -- Another special case: for a single literal, Pos is zero. + -- Another special case: for a single literal, Pos is zero Pos_Expr := Make_Integer_Literal (Loc, Uint_0); @@ -4542,7 +4542,7 @@ package body Exp_Ch3 is if RACW_Seen then - -- If there are RACWs designating this type, make stubs now. + -- If there are RACWs designating this type, make stubs now Remote_Types_Tagged_Full_View_Encountered (Def_Id); end if; @@ -4574,7 +4574,7 @@ package body Exp_Ch3 is begin if Scope (Old_C) = Base_Type (Def_Id) then - -- The entity is the one in the parent. Create new one. + -- The entity is the one in the parent. Create new one New_C := New_Copy (Old_C); Set_Parent (New_C, Parent (Old_C)); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 198d216..819b576 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -387,7 +387,7 @@ package body Exp_Ch5 is -- File.Storage := Contents; -- end Write_All; - -- We expand to a loop in either of these two cases. + -- We expand to a loop in either of these two cases -- Question for future thought. Another potentially more efficient -- approach would be to create the actual subtype, and then do an @@ -1459,7 +1459,7 @@ package body Exp_Ch5 is end if; end loop; - -- Now we can insert and analyze the pre-assignment. + -- Now we can insert and analyze the pre-assignment -- If the right-hand side requires a transient scope, it has -- already been placed on the stack. However, the declaration is @@ -2480,7 +2480,7 @@ package body Exp_Ch5 is Enumeration_Rep (First_Literal (Btype))), Right_Opnd => New_Reference_To (New_Id, Loc))); else - -- Use the constructed array Enum_Pos_To_Rep. + -- Use the constructed array Enum_Pos_To_Rep Expr := Make_Indexed_Component (Loc, @@ -2667,7 +2667,7 @@ package body Exp_Ch5 is if No (Exp) then Kind := Ekind (Scope_Id); - -- If it is a return from procedures do no extra steps. + -- If it is a return from procedures do no extra steps if Kind = E_Procedure or else Kind = E_Generic_Procedure then return; diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 9459885..730d464 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -182,7 +182,7 @@ package body Exp_Ch8 is elsif K = N_Type_Conversion then Evaluate_Name (Expression (Fname)); - -- For a function call, we evaluate the call. + -- For a function call, we evaluate the call elsif K = N_Function_Call then Force_Evaluation (Fname); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ac1e213..dbd692d 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -294,7 +294,7 @@ package body Exp_Ch9 is S : Node_Id; function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; - -- Compute difference between bounds of entry family. + -- Compute difference between bounds of entry family -------------------------- -- Actual_Family_Offset -- @@ -358,7 +358,7 @@ package body Exp_Ch9 is -- designated one, to which is added the index expression, if this -- expression denotes a member of a family. - -- The following is a place holder for the count of simple entries. + -- The following is a place holder for the count of simple entries Num := Make_Integer_Literal (Sloc, 1); @@ -384,7 +384,7 @@ package body Exp_Ch9 is Expr := Num; end if; - -- Now add lengths of preceding entries and entry families. + -- Now add lengths of preceding entries and entry families Prev := First_Entity (Ttyp); @@ -411,7 +411,7 @@ package body Exp_Ch9 is Right_Opnd => Make_Integer_Literal (Sloc, 1))); - -- Other components are anonymous types to be ignored. + -- Other components are anonymous types to be ignored else null; @@ -990,7 +990,7 @@ package body Exp_Ch9 is Siz : Node_Id := Empty; procedure Add_If_Clause (Expr : Node_Id); - -- Add test for range of current entry. + -- Add test for range of current entry function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; -- If a bound of an entry is given by a discriminant, retrieve the @@ -1008,11 +1008,11 @@ package body Exp_Ch9 is Expression => Make_Integer_Literal (Loc, Index + 1))); begin - -- Index for current entry body. + -- Index for current entry body Index := Index + 1; - -- Compute total length of entry queues so far. + -- Compute total length of entry queues so far if No (Siz) then Siz := Expr; @@ -1720,7 +1720,7 @@ package body Exp_Ch9 is Parameter_Associations => Uactuals); end if; - -- Wrap call in block that will be covered by an at_end handler. + -- Wrap call in block that will be covered by an at_end handler if not Exc_Safe then Unprot_Call := Make_Block_Statement (Loc, @@ -2029,7 +2029,7 @@ package body Exp_Ch9 is Conctyp := Designated_Type (Conctyp); end if; - -- Special case for protected subprogram calls. + -- Special case for protected subprogram calls if Is_Protected_Type (Conctyp) and then Is_Subprogram (Entity (Ename)) @@ -2678,10 +2678,8 @@ package body Exp_Ch9 is -- objectV!(name)._Object - -- for a protected object. - - -- For the case of an access to a concurrent object, - -- there is an extra explicit dereference: + -- for a protected object. For the case of an access to a concurrent + -- object, there is an extra explicit dereference: -- taskV!(name.all)._Task_Id -- objectV!(name.all)._Object @@ -2872,7 +2870,7 @@ package body Exp_Ch9 is -- designated one, to which is added the index expression, if this -- expression denotes a member of a family. - -- The following is a place holder for the count of simple entries. + -- The following is a place holder for the count of simple entries Num := Make_Integer_Literal (Sloc, 1); @@ -2916,7 +2914,7 @@ package body Exp_Ch9 is Expr := Num; end if; - -- Now add lengths of preceding entries and entry families. + -- Now add lengths of preceding entries and entry families Prev := First_Entity (Ttyp); @@ -2938,7 +2936,7 @@ package body Exp_Ch9 is Left_Opnd => Expr, Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp)); - -- Other components are anonymous types to be ignored. + -- Other components are anonymous types to be ignored else null; @@ -3117,7 +3115,7 @@ package body Exp_Ch9 is pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); - -- ??? Consider a single label for select statements. + -- ??? Consider a single label for select statements if Present (Handled_Statement_Sequence (N)) then Prepend (Ldecl2, @@ -3262,7 +3260,7 @@ package body Exp_Ch9 is Def1 : Node_Id; begin - -- Create access to protected subprogram with full signature. + -- Create access to protected subprogram with full signature if Nkind (Type_Definition (N)) = N_Access_Function_Definition then Def1 := @@ -3739,19 +3737,19 @@ package body Exp_Ch9 is -- Expand_N_Asynchronous_Select -- ---------------------------------- - -- This procedure assumes that the trigger statement is an entry - -- call. A delay alternative should already have been expanded - -- into an entry call to the appropriate delay object Wait entry. + -- This procedure assumes that the trigger statement is an entry call. A + -- delay alternative should already have been expanded into an entry call + -- to the appropriate delay object Wait entry. - -- If the trigger is a task entry call, the select is implemented - -- with Task_Entry_Call: + -- If the trigger is a task entry call, the select is implemented with + -- a Task_Entry_Call: -- declare -- B : Boolean; -- C : Boolean; -- P : parms := (parm, parm, parm); - -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions. + -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions -- procedure _clean is -- begin @@ -3867,16 +3865,16 @@ package body Exp_Ch9 is -- ... -- end; - -- The job is to convert this to the asynchronous form. + -- The job is to convert this to the asynchronous form - -- If the trigger is a delay statement, it will have been expanded - -- into a call to one of the GNARL delay procedures. This routine - -- will convert this into a protected entry call on a delay object - -- and then continue processing as for a protected entry call trigger. - -- This requires declaring a Delay_Block object and adding a pointer - -- to this object to the parameter list of the delay procedure to form - -- the parameter list of the entry call. This object is used by - -- the runtime to queue the delay request. + -- If the trigger is a delay statement, it will have been expanded into a + -- call to one of the GNARL delay procedures. This routine will convert + -- this into a protected entry call on a delay object and then continue + -- processing as for a protected entry call trigger. This requires + -- declaring a Delay_Block object and adding a pointer to this object to + -- the parameter list of the delay procedure to form the parameter list of + -- the entry call. This object is used by the runtime to queue the delay + -- request. -- For a description of the use of P and the assignments after the -- call, see Expand_N_Entry_Call_Statement. @@ -3961,7 +3959,7 @@ package body Exp_Ch9 is Prefix => New_Reference_To (Dblock_Ent, Loc), Attribute_Name => Name_Unchecked_Access)); - -- Create the inner block to protect the abortable part. + -- Create the inner block to protect the abortable part Hdle := New_List ( Make_Exception_Handler (Loc, @@ -4191,7 +4189,7 @@ package body Exp_Ch9 is Defining_Identifier => Cancel_Param, Object_Definition => New_Reference_To (Standard_Boolean, Loc))); - -- Remove and save the call to Call_Simple. + -- Remove and save the call to Call_Simple Stmt := First (Stmts); @@ -4205,7 +4203,7 @@ package body Exp_Ch9 is Call := Stmt; - -- Create the inner block to protect the abortable part. + -- Create the inner block to protect the abortable part Hdle := New_List ( Make_Exception_Handler (Loc, @@ -4556,7 +4554,7 @@ package body Exp_Ch9 is Index_Decl : List_Id; begin - -- Add the renamings for private declarations and discriminants. + -- Add the renamings for private declarations and discriminants Add_Discriminal_Declarations (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); @@ -4882,7 +4880,7 @@ package body Exp_Ch9 is when N_Subprogram_Body => - -- Exclude functions created to analyze defaults. + -- Exclude functions created to analyze defaults if not Is_Eliminated (Defining_Entity (Op_Body)) and then not Is_Eliminated (Corresponding_Spec (Op_Body)) @@ -5663,7 +5661,7 @@ package body Exp_Ch9 is -- <some more of the statement sequence for entry> - -- -- Requeue from an entry body to a task entry. + -- -- Requeue from an entry body to a task entry -- Requeue_Protected_To_Task_Entry ( -- New._task_id, @@ -5681,7 +5679,7 @@ package body Exp_Ch9 is -- end; -- end entE; - -- Requeue of a task entry call to a task entry. + -- Requeue of a task entry call to a task entry -- Accept_Call (E, Ann); -- <start of statement sequence for accept statement> @@ -5695,7 +5693,7 @@ package body Exp_Ch9 is -- when all others => -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); - -- Requeue of a task entry call to a protected entry. + -- Requeue of a task entry call to a protected entry -- Accept_Call (E, Ann); -- <start of statement sequence for accept statement> @@ -5933,7 +5931,7 @@ package body Exp_Ch9 is -- statements of an accept or delay alternative. function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; - -- Build call to Selective_Wait runtime routine. + -- Build call to Selective_Wait runtime routine procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); -- Add code to compare value of delay with previous values, and @@ -6176,7 +6174,7 @@ package body Exp_Ch9 is if No (Alt_Stats) then - -- Accept with no body, followed by trailing statements. + -- Accept with no body, followed by trailing statements Choices := New_List ( Make_Integer_Literal (Loc, Index)); @@ -6225,7 +6223,8 @@ package body Exp_Ch9 is Adjust_Condition (Condition (Alt)); - -- Determine the smallest specified delay. + -- Determine the smallest specified delay + -- for each delay alternative generate: -- if guard-expression then @@ -6237,7 +6236,7 @@ package body Exp_Ch9 is -- end if; -- end if; - -- The enclosing if-statement is omitted if there is no guard. + -- The enclosing if-statement is omitted if there is no guard if Delay_Count = 1 or else First_Delay @@ -6402,7 +6401,7 @@ package body Exp_Ch9 is if No (Condition (Alt)) then - -- This guard will always be open. + -- This guard will always be open Check_Guard := False; end if; @@ -6467,7 +6466,7 @@ package body Exp_Ch9 is Append (X, Decls); - -- After this follow procedure declarations for each accept body. + -- After this follow procedure declarations for each accept body -- procedure Pnn is -- begin @@ -6490,7 +6489,7 @@ package body Exp_Ch9 is -- build them unconditionally, and not significantly inefficient, -- since if they are short they will be inlined anyway. - -- The procedure declarations have been assembled in Body_List. + -- The procedure declarations have been assembled in Body_List -- If delays are present, we must compute the required delay. -- We first generate the declarations: @@ -6500,10 +6499,11 @@ package body Exp_Ch9 is -- Delay_Val : Some_Time_Type.Time; -- Delay_Index will be set to the index of the minimum delay, i.e. the - -- active delay that is actually chosen as the basis for the possible - -- delay if an immediate rendez-vous is not possible. - -- In the most common case there is a single delay statement, and this - -- is handled specially. + -- active delay that is actually chosen as the basis for the possible + -- delay if an immediate rendez-vous is not possible. + + -- In the most common case there is a single delay statement, and this + -- is handled specially. if Delay_Count > 0 then @@ -6655,17 +6655,17 @@ package body Exp_Ch9 is -- ... -- Exit: - -- Generate label for common exit. + -- Generate label for common exit End_Lab := Make_And_Declare_Label (Num_Alts + 1); - -- First entry is the default case, when no rendezvous is possible. + -- First entry is the default case, when no rendezvous is possible Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc)); if Else_Present then - -- If no rendezvous is possible, the else part is executed. + -- If no rendezvous is possible, the else part is executed Lab := Make_And_Declare_Label (0); Alt_Stats := New_List ( @@ -6831,7 +6831,7 @@ package body Exp_Ch9 is Insert_After (Parm, New_Reference_To (M, Loc)); Insert_After (Parm, New_Reference_To (D, Loc)); - -- Create a call to RTS. + -- Create a call to RTS Rewrite (Select_Call, Make_Procedure_Call_Statement (Loc, @@ -7216,7 +7216,7 @@ package body Exp_Ch9 is -- This is done last, since the corresponding record initialization -- procedure will reference the previously created entities. - -- Fill in the component declarations. First the _Task_Id field. + -- Fill in the component declarations -- first the _Task_Id field Append_To (Cdecls, Make_Component_Declaration (Loc, @@ -7590,7 +7590,7 @@ package body Exp_Ch9 is B := Make_Defining_Identifier (Loc, Name_uB); - -- Create a boolean object used for a return parameter. + -- Create a boolean object used for a return parameter Prepend_To (Decls, Make_Object_Declaration (Loc, @@ -7635,20 +7635,20 @@ package body Exp_Ch9 is Dummy := Remove_Next (Next (Parm)); - -- In case some garbage is following the Cancel_Param, remove. + -- Remove garbage is following the Cancel_Param if present Dummy := Next (Parm); - -- Remove the mode of the Protected_Entry_Call call, the - -- Communication_Block of the Protected_Entry_Call call, and add a - -- Duration and a Delay_Mode parameter + -- Remove the mode of the Protected_Entry_Call call, then remove the + -- Communication_Block of the Protected_Entry_Call call, and finally + -- add Duration and a Delay_Mode parameter pragma Assert (Present (Parm)); Rewrite (Parm, New_Reference_To (D, Loc)); Rewrite (Dummy, New_Reference_To (M, Loc)); - -- Add a Boolean flag for successful entry call. + -- Add a Boolean flag for successful entry call Append_To (Parms, New_Reference_To (B, Loc)); @@ -8258,7 +8258,7 @@ package body Exp_Ch9 is or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Ptyp) > 1 then - -- Find index mapping function (clumsy but ok for now). + -- Find index mapping function (clumsy but ok for now) while Ekind (P_Arr) /= E_Function loop Next_Entity (P_Arr); @@ -8366,10 +8366,12 @@ package body Exp_Ch9 is Next_Rep_Item (Ritem); end loop; - -- Appends the table argument we just built. + -- Append the table argument we just built + Append_To (Args, Make_Aggregate (Loc, Table)); - -- Appends the Install_Handler call to the statements. + -- Append the Install_Handler call to the statements + Append_To (L, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), @@ -8807,7 +8809,9 @@ package body Exp_Ch9 is return Skip; elsif Nkind (N) = N_String_Literal then - -- array type, but bounds are constant. + + -- Array type, but bounds are constant + return OK; elsif Nkind (N) = N_Object_Declaration diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index d6f47dd..ca0ce83 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -1347,7 +1347,7 @@ package body Exp_Pakd is -- the "or ..." is omitted if rhs is constant and all 0 bits - -- rhs is converted to the appropriate type. + -- rhs is converted to the appropriate type -- The result is converted back to the array type, since -- otherwise we lose knowledge of the packed nature. @@ -1545,7 +1545,7 @@ package body Exp_Pakd is -- Set_nn (Arr'address, Subscr, Bits_nn!(Rhs)) - -- where Subscr is the computed linear subscript. + -- where Subscr is the computed linear subscript declare Bits_nn : constant Entity_Id := RTE (Bits_Id (Csiz)); @@ -1556,7 +1556,7 @@ package body Exp_Pakd is begin if No (Bits_nn) then - -- Error, most likely High_Integrity_Mode restriction. + -- Error, most likely High_Integrity_Mode restriction return; end if; @@ -1774,7 +1774,7 @@ package body Exp_Pakd is -- convert to the base type, since this would be unconstrained, and -- hence not have a corresponding packed array type set. - -- Note that both operands must be modular for this code to be used. + -- Note that both operands must be modular for this code to be used if Is_Modular_Integer_Type (PAT) and then @@ -1916,7 +1916,7 @@ package body Exp_Pakd is return; end if; - -- Remaining processing is for the bit-packed case. + -- Remaining processing is for the bit-packed case Obj := Relocate_Node (Prefix (N)); Convert_To_Actual_Subtype (Obj); @@ -1967,7 +1967,7 @@ package body Exp_Pakd is -- Component_Type!(Get_nn (Arr'address, Subscr)) - -- where Subscr is the computed linear subscript. + -- where Subscr is the computed linear subscript declare Get_nn : Entity_Id; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index c2c4479..f56b4cc 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -502,12 +502,16 @@ package GNAT.Sockets is function Get_Host_By_Address (Address : Inet_Addr_Type; Family : Family_Type := Family_Inet) return Host_Entry_Type; - -- Return host entry structure for the given inet address + -- Return host entry structure for the given Inet address. + -- Note that no result will be returned if there is no mapping of this + -- IP address to a host name in the system tables (host database, + -- DNS or otherwise). function Get_Host_By_Name (Name : String) return Host_Entry_Type; -- Return host entry structure for the given host name. Here name - -- is either a host name, or an IP address. + -- is either a host name, or an IP address. If Name is an IP address, + -- this is equivalent to Get_Host_By_Address (Inet_Addr (Name)). function Host_Name return String; -- Return the name of the current host diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 765a1b9..989a25f 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -176,6 +176,7 @@ Ada Core Technologies, Inc.@* * GNAT Project Manager:: * The Cross-Referencing Tools gnatxref and gnatfind:: * The GNAT Pretty-Printer gnatpp:: +* The GNAT Metric Tool gnatmetric:: * File Name Krunching Using gnatkr:: * Preprocessing Using gnatprep:: @ifset vms @@ -395,6 +396,10 @@ The GNAT Pretty-Printer gnatpp * Switches for gnatpp:: * Formatting Rules:: +The GNAT Metrics Tool gnatmetric + +* Switches for gnatmetric:: + File Name Krunching Using gnatkr * About gnatkr:: @@ -724,6 +729,11 @@ version of an Ada source file with control over casing, indentation, comment placement, and other elements of program presentation style. @item +@ref{The GNAT Metric Tool gnatmetric}, shows how to compute various +metrics for an Ada source file, such as the number of types and subprograms, +and assorted complexity measures. + +@item @ref{File Name Krunching Using gnatkr}, describes the @code{gnatkr} file name krunching utility, used to handle shortened file names on operating systems with a limit on the length of names. @@ -11185,11 +11195,17 @@ case insensitive. The following package names are legal: @item @code{Eliminate} @item +@code{Pretty_Printer} +@item +@code{Metrics} +@item @code{gnatls} @item @code{gnatstub} @item @code{IDE} +@item +@code{Language_Processing} @end itemize @noindent @@ -13205,6 +13221,8 @@ are project-aware: @command{^gnatls^gnatls^}, @command{^gnatelim^gnatelim^}, @command{^gnatpp^gnatpp^}, +@command{^gnatmetric^gnatmetric^}, +@command{^gnatstub^gnatstub^}, and @command{^gnatxref^gnatxref^}. However, none of these tools can be invoked directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). They must be invoked through the @command{gnat} driver. @@ -13245,6 +13263,8 @@ PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} @item PP or PRETTY to invoke @command{^gnatpp^gnatpp^} @item +METRIC to invoke @command{^gnatmetric^gnatmetric^} +@item STUB to invoke @command{^gnatstub^gnatstub^} @item XREF to invoke @command{^gnatxref^gnatxref^} @@ -13286,8 +13306,8 @@ files may be specified with their path name preceded by '@@'. @end smallexample @noindent -In addition, for command BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, -PP or PRETTY and XREF, the project file related switches +In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, +METRIC, PP or PRETTY, STUB and XREF, the project file related switches (@option{^-P^/PROJECT_FILE^}, @option{^-X^/EXTERNAL_REFERENCE^} and @option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to @@ -13299,8 +13319,15 @@ specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all the immediate sources of the specified project file. @noindent -For each of these commands, there is optionally a corresponding package -in the main project. +When GNAT METRIC is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} +with all the immediate sources of the specified project file and with +@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory +of the project. + +@noindent +For each of the following commands, there is optionally a corresponding +package in the main project. @itemize @bullet @item @@ -13323,10 +13350,18 @@ package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) @item +package @code{Metrics} for command METRIC +(invoking @code{^gnatmetric^gnatmetric^}) + +@item package @code{Pretty_Printer} for command PP or PRETTY (invoking @code{^gnatpp^gnatpp^}) @item +package @code{Gnatstub} for command STUB +(invoking @code{^gnatstub^gnatstub^}) + +@item package @code{Cross_Reference} for command XREF (invoking @code{^gnatxref^gnatxref^}) @@ -15395,6 +15430,474 @@ end Test; @end cartouche @end smallexample +@c ********************************* +@node The GNAT Metric Tool gnatmetric +@chapter The GNAT Metric Tool @command{gnatmetric} +@findex gnatmetric +@cindex Metric tool + +@noindent +^The @command{gnatmetric} tool^GNAT METRIC^ is an ASIS-based utility +for computing various program metrics. +It takes an Ada source file as input and generates a file containing the +metrics data as output. Various switches control which +metrics are computed and output. + +@command{gnatmetric} generates and uses the ASIS +tree for the input source and thus requires the input to be syntactically and +semantically legal. +If this condition is not met, @command{gnatmetric} will generate +an error message; no metric information for this file will be +computed and reported. + +If the compilation unit contained in the input source depends semantically +upon units located outside the current directory, you have to provide the +source search path when invoking @command{gnatmetric}. +If these units are contained in files +with names that do not follow the GNAT file naming rules, you have to provide +the configuration file describing the corresponding naming scheme; see the +description of the @command{gnatmetric} switches below. Another possibility +is to use a project file and to +call @command{gnatmetric} through the @command{gnat} driver + +The @command{gnatmetric} command has the form + +@smallexample +$ gnatmetric [@var{switches}] @var{filename} [@var{-cargs gcc_switches}] +@end smallexample + +@noindent +where +@itemize @bullet +@item +@var{switches} is an optional sequence of switches specifying +the set of metrics to compute and defining the destination for the +output information + +@item +@var{filename} is the name (including the extension) of the source file to +process; ``wildcards'' or several file names on the same @command{gnatmetric} +command are allowed. The file name may contain path information; in this case +it does not have to follow the GNAT file naming rules + +@item +@option{-cargs gcc_switches} is a list of switches that are valid switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatmetric} to generate the ASIS trees. Here you can provide +@option{-I} switches to form the source search path, +and use the @var{-gnatec} switch to set the configuration file. +@end itemize + +@menu +* Switches for gnatmetric:: +@end menu + +@node Switches for gnatmetric +@section Switches for @command{gnatmetric} + +@noindent +The following subsections describe the various switches accepted by +@command{gnatmetric}, organized by category. + +@menu +* Output Files Control:: +* Disable Metrics For Local Units:: +* Line Metrics Control:: +* Syntax Metrics Control:: +* Complexity Metrics Control:: +* Other gnatmetric Switches:: +@end menu + +@node Output Files Control +@subsection Output File Control +@cindex Output file control in @command{gnatmetric} + +@noindent +@command{gnatmetric} has two output formats. It can generate the output in +textual (human-readable) form, and also as XML. By default only textual +output is generated. + +When generating the output in textual form, @command{gnatmetric} creates +for each Ada source file a corresponding text file +containing the computed metrics. By default, this file +is placed in the same directory as where the source file is located, and +its name is obtained +by appending the ^@file{.metrix}^@file{$METRIX}^ suffix to the name of the +input file. + +All the output information generated in XML format is placed in a single +file. By default this file is placed in the current directory and has the +name ^@file{metrix.xml}^@file{METRIX$XML}^. + +Some of the computed metrics are summed over the units passed to +@command{gnatmetric}; for example, the total number of lines of code. +By default this information is sent to @file{stdout}, but a file +can be specified with the @option{-og} switch. + +The following switches may be used to control the @command{gnatmetric} output: + +@table @option +@cindex @option{^-x^/XML^} (@command{gnatmetric}) +@item ^-x^/XML^ +Generate the XML output + +@cindex @option{^-nt^/NO_TEXT^} (@command{gnatmetric}) +@item ^-nt^/NO_TEXT^ +Do not generate the output in text form (implies @option{^-x^/XML^}) + +@cindex @option{^-d^/DIRECTORY^} (@command{gnatmetric}) +@item ^-d @var{output_dir}^/DIRECTORY=@var{output_dir}^ +Put textual files with detailed metrics into @var{output_dir} + +@cindex @option{^-o^/SUFFIX_DETAILS^} (@command{gnatmetric}) +@item ^-o @var{file_suffix}^/SUFFIX_DETAILS=@var{file_suffix}^ +Use @var{file_suffix} to form the name of the file for the detailed metrics. + +@cindex @option{^-og^/GLOBAL_OUTPUT^} (@command{gnatmetric}) +@item ^-og @var{file_name}^/GLOBAL_OUTPUT=@var{file_name}^ +Put global metrics info into @var{file_name} + +@cindex @option{^-ox^/XML_OUTPUT^} (@command{gnatmetric}) +@item ^-ox @var{file_name}^/XML_OUTPUT=@var{file_name}^ +Put the XML output into @var{file_name} (also implies @option{^-x^/XML^}) + +@cindex @option{^-sfn^/SHORT_SOURCE_FILE_NAME^} (@command{gnatmetric}) +@item ^-sfn^/SHORT_SOURCE_FILE_NAME^ +Use short source file names in the output + +@end table + +@node Disable Metrics For Local Units +@subsection Disable Metrics For Local Units +@cindex Disable Metrics For Local Units in @command{gnatmetric} + +@noindent +@command{gnatmetric} relies on the GNAT compilation model @minus{} +one compilation +unit per one source file. It computes some metrics for the whole source +file (mostly ``number of lines'' metrics) and it always computes metrics for +the top program unit of the corresponding compilation unit. + +@command{gnatmetric} considers the following constructs as program units to +compute metrics for: + +@itemize @bullet +@item +a library item or a subunit into a compilation unit; + +@item +all kinds of bodies; + +@item +declarations of tasks and protected types and objects, package and generic + +@item +package declarations; + +@end itemize + +@noindent +That is, a subprogram declaration, a generic instantiation or a renaming is +considered as a program unit only if it is a library item of a compilation +unit. + +@table @option +@cindex @option{^-n@var{x}^/SUPPRESS^} (@command{gnatmetric}) +@item ^-nolocal^/SUPPRESS=LOCAL_DETAILS^ +Do not compute detailed metrics for local program units + +@end table + +@node Line Metrics Control +@subsection Line Metrics Control +@cindex Line metrics control in @command{gnatmetric} + +@noindent +For any source file containing a legal compilation unit, and for any program +unit, @command{gnatmetric} computes the following metrics: + +@itemize @bullet +@item +the total number of lines in the file; + +@item +the total number of code lines (i.e., non-blank lines that are not comments) + +@item +the number of comment lines + +@item +the number of code lines containing end-of-line comments; + +@item +the number of empty lines and lines containing only space characters and/or +format effectors (blank lines) + +@end itemize + +If @command{gnatmetric} is invoked on more than one source file, it sums the +values of the line metrics for all the files being processed and then prints +out the cumulative results. + +By default, all the line metrics are computed and reported. You can use the +following switches to select the specific line metrics to be computed and +reported (if any of these parameters is set, only explicitly specified line +metrics are computed) + +@table @option +@cindex @option{^-la^/LINES_ALL^} (@command{gnatmetric}) +@item ^-la^/LINES_ALL^ +Compute and print out the number of all lines + +@cindex @option{^-lcode^/CODE_LINES^} (@command{gnatmetric}) +@item ^-lcode^/CODE_LINES^ +Compute and print out the number of code lines + +@cindex @option{^-lcomm^/COMENT_LINES^} (@command{gnatmetric}) +@item ^-lcomm^/COMENT_LINES^ +Compute and print out the number of comment lines + +@cindex @option{^-leol^/MIXED_CODE_COMMENTS^} (@command{gnatmetric}) +@item ^-leol^/MIXED_CODE_COMMENTS^ +Compute and print out the number of code lines containing +end-of-line comments + +@cindex @option{^-lb^/BLANK_LINES^} (@command{gnatmetric}) +@item ^-lb^/BLANK_LINES^ + Compute and print out the number of blank lines + +@end table + +@node Syntax Metrics Control +@subsection Syntax Metrics Control +@cindex Syntax metrics control in @command{gnatmetric} + +@noindent +For any program unit, @command{gnatmetri}c computes the total number of +declarations and the total number of statements. The sum of all the statements +and all the declarations is considered as @emph{LSLOC} (Logical Source +Lines Of Code) +and is reported as a separate metric. + +For any body and any task, protected, package and generic package declaration a +maximal nesting level of nested program units is computed. According to +@cite{Ada 95 Language Reference Manual}, 10.1(1), ``A program unit is either a +package, a task unit, a protected unit, a +protected entry, a generic unit, or an explicitly declared subprogram other +than an enumeration literal.'' + +For any program unit @command{gnatmetric} computes the maximal nesting level of +composite syntactic constructs. This corresponds to the notion of the +maximum nesting level in the GNAT built-in style checks +(see @ref{Style Checking}) + +For any library-level program unit @command{gnatmetric} additionally computes +the following metrics: + +@table @emph +@item Public subprograms +This metric is computed for non-private compilation units only. It is a number +of the subprograms and generic subprograms declared in the given compilation +unit that can be called +or instantiated outside the unit. Formal generic subprograms and generic +instantiations are not counted. Protected subprograms are counted in the same +way as non-protected ones. + +@item All subprograms +This metric is computed for all the library level bodies and subunits. The +metric is equal to a total number of subprogram bodies in the compilation unit. +Neither generic instantiations nor renamings-as-a-body nor body stubs +are counted. Any subprogram body is counted, independently of its nesting +level and enclosing constructs. Generic bodies and bodies of protected +subprograms are counted in the same way as ``usual'' subprogram bodies. + +@item Public types +This metric is computed only for non-private package declarations and +generic package declarations. It is the total number of types +that can be referenced from outside this compilation unit, plus the +number of types from all the visible parts of all the visible generic packages. +Generic formal types are not counted. + +@noindent +Along with counting the total number of public types, the following +types are counted and reported separately: + +@itemize @bullet +@item +abstract types; + +@item +tagged types (abstract, non-abstract, private, non-private). Type +extensions are @emph{not} counted as tagged types; the idea is to count +possible roots for classes of extendable types; + +@item +private types (including private extensions); + +@item +task types; + +@item +protected types. + +@end itemize + +@item All types +This metric is computed for any compilation unit. It is equal to the total +number of the declarations of different types given in the compilation unit. +The private and the corresponding full type declaration are counted as one +type declaration. Incomplete type declarations and generic formal types +are not counted. +No distinction is made among different kinds of types (abstract, +private etc.); the total number of types is computed and reported. + +@end table + +@noindent +By default, all the syntax metrics are computed and reported. You can use the +following switches to select specific syntax metrics; +if any of these is set, only the explicitly specified metrics are computed. + +@table @option +@cindex @option{^-ed^/DECLARATION_TOTAL^} (@command{gnatmetric}) +@item ^-ed^/DECLARATION_TOTAL^ +Compute and print out the total number of declarations + +@cindex @option{^-es^/STATEMENT_TOTAL^} (@command{gnatmetric}) +@item ^-es^/STATEMENT_TOTAL^ +Compute and print out the total number of statements + +@cindex @option{^-eps^/^} (@command{gnatmetric}) +@item ^-eps^/INT_SUBPROGRAMS^ +Compute and print out the number of public subprograms in a +compilation unit + +@cindex @option{^-eas^/SUBPROGRAMS_ALL^} (@command{gnatmetric}) +@item ^-eas^/SUBPROGRAMS_ALL^ +Compute and print out the number of all the subprograms in a +compilation unit + +@cindex @option{^-ept^/INT_TYPES^} (@command{gnatmetric}) +@item ^-ept^/INT_TYPES^ +Compute and print out the number of public types in a compilation +unit + +@cindex @option{^-eat^/TYPES_ALL^} (@command{gnatmetric}) +@item ^-eat^/TYPES_ALL^ +Compute and print out the number of all the types in a compilation +unit + +@cindex @option{^-enu^/PROGRAM_NESTING_MAX^} (@command{gnatmetric}) +@item ^-enu^/PROGRAM_NESTING_MAX^ +Compute and print out the maximal program unit nesting level + +@cindex @option{^-ec^/CONSTRUCT_NESTING_MAX^} (@command{gnatmetric}) +@item ^-ec^/CONSTRUCT_NESTING_MAX^ +Compute and print out the maximal construct nesting level + +@end table + +@node Complexity Metrics Control +@subsection Complexity Metrics Control +@cindex Complexity metrics control in @command{gnatmetric} + +@noindent +For a program unit that is an executable body (a subprogram body (including +generic bodies), task body, entry body or a package body containing +its own statement sequence ) @command{gnatmetric} computes the following +complexity metrics: + +@itemize @bullet +@item +McCabe cyclomatic complexity; + +@item +McCabe essential complexity; + +@item +maximal loop nesting level + +@end itemize + +@noindent +The McCabe complexity metrics are defined +in @url{www.mccabe.com/pdf/nist235r.pdf} + +According to McCabe, both control statements and short-circuit control forms +should be taken into account when computing cyclomatic complexity. For each +body, we compute three metric values: + +@itemize @bullet +@item +the complexity introduced by control +statements only, without taking into account short-circuit forms, + +@item +the complexity introduced by short-circuit control forms only, and + +@item +the total +cyclomatic complexity, which is the sum of these two values. +@end itemize + +@noindent +When computing cyclomatic and essential complexity, @command{gnatmetric} skips +the code in the exception handlers and in all the nested program units + +By default, all the complexity metrics are computed and reported. +For more finely-grained control you can use +the following switches: + +@table @option +@cindex @option{^-n@var{x}^/SUPPRESS^} (@command{gnatmetric}) + +@item ^-nocc^/SUPPRESS=CYCLOMATIC_COMPLEXITY^ +Do not compute the McCabe Cyclomatic Complexity + +@item ^noec-^/SUPPRESS=ESSENTIAL_COMPLEXITY^ +Do not compute the Essential Complexity + +@item ^-nonl^/SUPPRESS=MAXIMAL_LOOP_NESTING^ +Do not compute maximal loop nesting level + +@item ^-ne^/SUPPRESS=EXITS_AS_GOTOS^ +Do not consider @code{exit} statements as @code{goto}s when +computing Essential Complexity + +@end table + +@node Other gnatmetric Switches +@subsection Other @code{gnatmetric} Switches + +@noindent +Additional @command{gnatmetric} switches are as follows: + +@table @option +@item ^-files @var{filename}^/FILES=@var{filename}^ +@cindex @option{^-files^/FILES^} (@code{gnatmetric}) +Take the argument source files from the specified file. This file should be an +ordinary textual file containing file names separated by spaces or +line breaks. You can use this switch more then once in the same call to +@command{gnatmetric}. You also can combine this switch with explicit list of +files. + +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatmetric}) +Verbose mode; +@command{gnatmetric} generates version information and then +a trace of sources being procesed. + +@item ^-dv^/DEBUG_OUTPUT^ +@cindex @option{^-dv^/DEBUG_OUTPUT^} (@code{gnatmetric}) +Debug mode; +@command{gnatmetric} generates various messages useful to understand what +happens during the metrics computation + +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@code{gnatmetric}) +Quiet mode. +@end table + @c *********************************** @node File Name Krunching Using gnatkr @chapter File Name Krunching Using @code{gnatkr} @@ -16084,7 +16587,7 @@ equivalent @code{gnatmake} flag (see @ref{Switches for gnatmake}). @item ^-v^/OUTPUT=VERBOSE^ @cindex @option{^-v^/OUTPUT=VERBOSE^} (@code{gnatls}) -Verbose mode. Output the complete source and object paths. Do not use +Verbose mode. Output the complete source, object and project paths. Do not use the default column layout but instead use long format giving as much as information possible on each requested units, including special characteristics such as: @@ -16130,7 +16633,8 @@ object paths are affected by the -I switch. @smallexample $ gnatls -v -I.. demo1.o -GNATLS 3.10w (970212) Copyright 1999 Free Software Foundation, Inc. +GNATLS 5.03w (20041123-34) +Copyright 1997-2004 Free Software Foundation, Inc. Source Search Path: <Current_Directory> @@ -16142,6 +16646,10 @@ Object Search Path: ../ /home/comar/local/lib/gcc-lib/mips-sni-sysv4/2.7.2/adalib/ +Project Search Path: + <Current_Directory> + /home/comar/local/lib/gnat/ + ./demo1.o Unit => Name => demo1 diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads index dab89ec..a02ef82 100644 --- a/gcc/ada/interfac.ads +++ b/gcc/ada/interfac.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -69,103 +69,83 @@ pragma Pure (Interfaces); function Shift_Left (Value : Unsigned_8; - Amount : Natural) - return Unsigned_8; + Amount : Natural) return Unsigned_8; function Shift_Right (Value : Unsigned_8; - Amount : Natural) - return Unsigned_8; + Amount : Natural) return Unsigned_8; function Shift_Right_Arithmetic (Value : Unsigned_8; - Amount : Natural) - return Unsigned_8; + Amount : Natural) return Unsigned_8; function Rotate_Left (Value : Unsigned_8; - Amount : Natural) - return Unsigned_8; + Amount : Natural) return Unsigned_8; function Rotate_Right (Value : Unsigned_8; - Amount : Natural) - return Unsigned_8; + Amount : Natural) return Unsigned_8; function Shift_Left (Value : Unsigned_16; - Amount : Natural) - return Unsigned_16; + Amount : Natural) return Unsigned_16; function Shift_Right (Value : Unsigned_16; - Amount : Natural) - return Unsigned_16; + Amount : Natural) return Unsigned_16; function Shift_Right_Arithmetic (Value : Unsigned_16; - Amount : Natural) - return Unsigned_16; + Amount : Natural) return Unsigned_16; function Rotate_Left (Value : Unsigned_16; - Amount : Natural) - return Unsigned_16; + Amount : Natural) return Unsigned_16; function Rotate_Right (Value : Unsigned_16; - Amount : Natural) - return Unsigned_16; + Amount : Natural) return Unsigned_16; function Shift_Left (Value : Unsigned_32; - Amount : Natural) - return Unsigned_32; + Amount : Natural) return Unsigned_32; function Shift_Right (Value : Unsigned_32; - Amount : Natural) - return Unsigned_32; + Amount : Natural) return Unsigned_32; function Shift_Right_Arithmetic (Value : Unsigned_32; - Amount : Natural) - return Unsigned_32; + Amount : Natural) return Unsigned_32; function Rotate_Left (Value : Unsigned_32; - Amount : Natural) - return Unsigned_32; + Amount : Natural) return Unsigned_32; function Rotate_Right (Value : Unsigned_32; - Amount : Natural) - return Unsigned_32; + Amount : Natural) return Unsigned_32; function Shift_Left (Value : Unsigned_64; - Amount : Natural) - return Unsigned_64; + Amount : Natural) return Unsigned_64; function Shift_Right (Value : Unsigned_64; - Amount : Natural) - return Unsigned_64; + Amount : Natural) return Unsigned_64; function Shift_Right_Arithmetic (Value : Unsigned_64; - Amount : Natural) - return Unsigned_64; + Amount : Natural) return Unsigned_64; function Rotate_Left (Value : Unsigned_64; - Amount : Natural) - return Unsigned_64; + Amount : Natural) return Unsigned_64; function Rotate_Right (Value : Unsigned_64; - Amount : Natural) - return Unsigned_64; + Amount : Natural) return Unsigned_64; pragma Import (Intrinsic, Shift_Left); pragma Import (Intrinsic, Shift_Right); diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb index 37878cf..1daeca6 100644 --- a/gcc/ada/s-poosiz.adb +++ b/gcc/ada/s-poosiz.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -153,8 +153,15 @@ package body System.Pool_Size is ---------------- procedure Initialize (Pool : in out Stack_Bounded_Pool) is + + -- Define the appropriate alignment for allocations. This is the + -- maximum of the requested alignment, and the alignment required + -- for Storage_Count values. The latter test is to ensure that we + -- can properly reference the linked list pointers for free lists. + Align : constant SSE.Storage_Count := - SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, Pool.Alignment); + SSE.Storage_Count'Max + (SSE.Storage_Count'Alignment, Pool.Alignment); begin if Pool.Elmt_Size = 0 then @@ -165,7 +172,7 @@ package body System.Pool_Size is Pool.First_Empty := 1; -- Compute the size to allocate given the size of the element and - -- the possible Alignment clause + -- the possible alignment requirement as defined above. Pool.Aligned_Elmt_Size := SSE.Storage_Count'Max (SC_Size, @@ -178,8 +185,7 @@ package body System.Pool_Size is ------------------ function Storage_Size - (Pool : Stack_Bounded_Pool) - return SSE.Storage_Count + (Pool : Stack_Bounded_Pool) return SSE.Storage_Count is begin return Pool.Pool_Size; @@ -205,20 +211,17 @@ package body System.Pool_Size is function Size (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) - return SSE.Storage_Count; + Chunk : SSE.Storage_Count) return SSE.Storage_Count; -- Fetch the field 'size' of a chunk of available storage function Next (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) - return SSE.Storage_Count; + Chunk : SSE.Storage_Count) return SSE.Storage_Count; -- Fetch the field 'next' of a chunk of available storage function Chunk_Of (Pool : Stack_Bounded_Pool; - Addr : System.Address) - return SSE.Storage_Count; + Addr : System.Address) return SSE.Storage_Count; -- Give the chunk number in the pool from its Address -------------- @@ -284,8 +287,7 @@ package body System.Pool_Size is function Chunk_Of (Pool : Stack_Bounded_Pool; - Addr : System.Address) - return SSE.Storage_Count + Addr : System.Address) return SSE.Storage_Count is begin return 1 + abs (Addr - Pool.The_Pool (1)'Address); @@ -339,8 +341,7 @@ package body System.Pool_Size is function Next (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) - return SSE.Storage_Count + Chunk : SSE.Storage_Count) return SSE.Storage_Count is begin pragma Warnings (Off); @@ -397,8 +398,7 @@ package body System.Pool_Size is function Size (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) - return SSE.Storage_Count + Chunk : SSE.Storage_Count) return SSE.Storage_Count is begin pragma Warnings (Off); diff --git a/gcc/ada/s-poosiz.ads b/gcc/ada/s-poosiz.ads index 508d7ea..ea70200 100644 --- a/gcc/ada/s-poosiz.ads +++ b/gcc/ada/s-poosiz.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -66,8 +66,7 @@ pragma Elaborate_Body; end record; function Storage_Size - (Pool : Stack_Bounded_Pool) - return System.Storage_Elements.Storage_Count; + (Pool : Stack_Bounded_Pool) return System.Storage_Elements.Storage_Count; procedure Allocate (Pool : in out Stack_Bounded_Pool; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index b790a93..346cbf3 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -178,7 +178,7 @@ package body Sem_Ch10 is -- analysis (should it appear otherwise in the context). procedure Remove_Context_Clauses (N : Node_Id); - -- Subsidiary of previous one. Remove use_ and with_clauses. + -- Subsidiary of previous one. Remove use_ and with_clauses procedure Remove_Limited_With_Clause (N : Node_Id); -- Remove from visibility the shadow entities introduced for a package @@ -337,7 +337,7 @@ package body Sem_Ch10 is Semantics (Lib_Unit); Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); - -- Verify that the library unit is a package declaration. + -- Verify that the library unit is a package declaration if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration and then @@ -476,7 +476,7 @@ package body Sem_Ch10 is if Is_Child_Spec (Unit_Node) then - -- Set the entities of all parents in the program_unit_name. + -- Set the entities of all parents in the program_unit_name Generate_Parent_References ( Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node)))); @@ -864,7 +864,7 @@ package body Sem_Ch10 is Next (Item); end loop; - -- Third pass: examine all limited_with clauses. + -- Third pass: examine all limited_with clauses Item := First (Context_Items (N)); @@ -878,7 +878,7 @@ package body Sem_Ch10 is & " package specification", Item); end if; - -- Skip analyzing with clause if no unit, see above. + -- Skip analyzing with clause if no unit, see above if Present (Library_Unit (Item)) then Analyze (Item); @@ -905,7 +905,7 @@ package body Sem_Ch10 is Nam : Entity_Id; begin - -- The package declaration must be in the current declarative part. + -- The package declaration must be in the current declarative part Check_Stub_Level (N); Nam := Current_Entity_In_Scope (Id); @@ -1197,7 +1197,7 @@ package body Sem_Ch10 is begin Check_Stub_Level (N); - -- First occurence of name may have been as an incomplete type. + -- First occurence of name may have been as an incomplete type if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); @@ -1484,7 +1484,7 @@ package body Sem_Ch10 is begin if not Is_Empty_List (Context_Items (N)) then - -- Save current use clauses. + -- Save current use clauses Remove_Scope; Remove_Context (Lib_Unit); @@ -1539,7 +1539,7 @@ package body Sem_Ch10 is Re_Install_Use_Clauses; Install_Context (N); - -- Restore state of suppress flags for current body. + -- Restore state of suppress flags for current body Scope_Suppress := Svg; @@ -1568,7 +1568,7 @@ package body Sem_Ch10 is begin Check_Stub_Level (N); - -- First occurence of name may have been as an incomplete type. + -- First occurence of name may have been as an incomplete type if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then Nam := Full_View (Nam); @@ -1831,7 +1831,7 @@ package body Sem_Ch10 is and then Present (System_Extend_Unit) and then Present_System_Aux (N) then - -- If the extension is not present, an error will have been emitted. + -- If the extension is not present, an error will have been emitted null; end if; @@ -1859,7 +1859,7 @@ package body Sem_Ch10 is Sel : Node_Id; procedure Decorate_Tagged_Type (T : Entity_Id); - -- Set basic attributes of type, including its class_wide type. + -- Set basic attributes of type, including its class_wide type function In_Chain (E : Entity_Id) return Boolean; -- Check that the imported type is not already in the homonym chain, @@ -1884,7 +1884,7 @@ package body Sem_Ch10 is Set_Current_Entity (T); end if; - -- Build bogus class_wide type, if not previously done. + -- Build bogus class_wide type, if not previously done if No (Class_Wide_Type (T)) then CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); @@ -1999,7 +1999,7 @@ package body Sem_Ch10 is if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then - -- Make parent packages visible. + -- Make parent packages visible declare Parent_Comp : Node_Id; @@ -2149,7 +2149,7 @@ package body Sem_Ch10 is Lib_Unit : constant Node_Id := Unit (N); procedure Check_Parent_Context (U : Node_Id); - -- Examine context items of parent unit to locate with_type clauses. + -- Examine context items of parent unit to locate with_type clauses -------------------------- -- Check_Parent_Context -- @@ -2532,7 +2532,7 @@ package body Sem_Ch10 is Withn : Node_Id; function Build_Ancestor_Name (P : Node_Id) return Node_Id; - -- Build prefix of child unit name. Recurse if needed. + -- Build prefix of child unit name. Recurse if needed function Build_Unit_Name return Node_Id; -- If the unit is a child unit, build qualified name with all @@ -2657,7 +2657,7 @@ package body Sem_Ch10 is then if Limited_Present (Item) then - -- Limited withed units will be installed later. + -- Limited withed units will be installed later goto Continue; @@ -4167,7 +4167,7 @@ package body Sem_Ch10 is Lib_Unit : constant Node_Id := Unit (N); begin - -- If this is a child unit, first remove the parent units. + -- If this is a child unit, first remove the parent units if Is_Child_Spec (Lib_Unit) then Remove_Parents (Lib_Unit); @@ -4394,7 +4394,11 @@ package body Sem_Ch10 is P : Entity_Id; procedure Unchain (E : Entity_Id); - -- Remove entity from visibility list. + -- Remove entity from visibility list + + ------------- + -- Unchain -- + ------------- procedure Unchain (E : Entity_Id) is Prev : Entity_Id; @@ -4424,13 +4428,15 @@ package body Sem_Ch10 is end if; end Unchain; - -- Start of Remove_With_Type_Clause + -- Start of processing for Remove_With_Type_Clause begin if Nkind (Name) = N_Selected_Component then Typ := Entity (Selector_Name (Name)); - if No (Typ) then -- error in declaration. + -- If no Typ, then error in declaration, ignore + + if No (Typ) then return; end if; else @@ -4456,7 +4462,7 @@ package body Sem_Ch10 is Set_From_With_Type (P, False); - -- If P is a child unit, remove parents as well. + -- If P is a child unit, remove parents as well P := Scope (P); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3ece550..117dde2 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -83,7 +83,7 @@ package body Sem_Ch13 is -- operational attributes. function Address_Aliased_Entity (N : Node_Id) return Entity_Id; - -- If expression N is of the form E'Address, return E. + -- If expression N is of the form E'Address, return E procedure Mark_Aliased_Address_As_Volatile (N : Node_Id); -- This is used for processing of an address representation clause. If @@ -2131,7 +2131,7 @@ package body Sem_Ch13 is ("component clause previously given#", CC); else - -- Update Fbit and Lbit to the actual bit number. + -- Update Fbit and Lbit to the actual bit number Fbit := Fbit + UI_From_Int (SSU) * Posit; Lbit := Lbit + UI_From_Int (SSU) * Posit; @@ -2647,7 +2647,7 @@ package body Sem_Ch13 is return; end if; - -- Otherwise look at the identifier and see if it is OK. + -- Otherwise look at the identifier and see if it is OK if Ekind (Ent) = E_Named_Integer or else @@ -3206,7 +3206,7 @@ package body Sem_Ch13 is raise Program_Error; end if; - -- Fall through with Hi and Lo set. Deal with biased case. + -- Fall through with Hi and Lo set. Deal with biased case if (Biased and then not Is_Fixed_Point_Type (T)) or else Has_Biased_Representation (T) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 78d714e..a80ec96 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -401,11 +401,11 @@ package body Sem_Ch3 is -- SI is the N_Subtype_Indication node containing the constraint and -- the unconstrained type to constrain. -- - -- Def_Id is the entity for the resulting constrained subtype. A - -- value of Empty for Def_Id indicates that an implicit type must be - -- created, but creation is delayed (and must be done by this procedure) - -- because other subsidiary implicit types must be created first (which - -- is why Def_Id is an in/out parameter). + -- Def_Id is the entity for the resulting constrained subtype. A value + -- of Empty for Def_Id indicates that an implicit type must be created, + -- but creation is delayed (and must be done by this procedure) because + -- other subsidiary implicit types must be created first (which is why + -- Def_Id is an in/out parameter). -- -- Related_Nod gives the place where this type has to be inserted -- in the tree @@ -452,9 +452,9 @@ package body Sem_Ch3 is Related_Id : Entity_Id; Suffix : Character; Suffix_Index : Nat); - -- Process an index constraint in a constrained array declaration. - -- The constraint can be a subtype name, or a range with or without - -- an explicit subtype mark. The index is the corresponding index of the + -- Process an index constraint in a constrained array declaration. The + -- constraint can be a subtype name, or a range with or without an + -- explicit subtype mark. The index is the corresponding index of the -- unconstrained array. The Related_Id and Suffix parameters are used to -- build the associated Implicit type name. @@ -732,12 +732,12 @@ package body Sem_Ch3 is Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); -- The context is either a subprogram declaration or an access - -- discriminant, in a private or a full type declaration. In - -- the case of a subprogram, If the designated type is incomplete, - -- the operation will be a primitive operation of the full type, to - -- be updated subsequently. If the type is imported through a limited - -- with clause, it is not a primitive operation of the type (which - -- is declared elsewhere in some other scope). + -- discriminant, in a private or a full type declaration. In the case + -- of a subprogram, If the designated type is incomplete, the operation + -- will be a primitive operation of the full type, to be updated + -- subsequently. If the type is imported through a limited with clause, + -- it is not a primitive operation of the type (which is declared + -- elsewhere in some other scope). if Ekind (Desig_Type) = E_Incomplete_Type and then not From_With_Type (Desig_Type) @@ -783,10 +783,10 @@ package body Sem_Ch3 is Process_Formals (Formals, Parent (T_Def)); -- A bit of a kludge here, End_Scope requires that the parent - -- pointer be set to something reasonable, but Itypes don't - -- have parent pointers. So we set it and then unset it ??? - -- If and when Itypes have proper parent pointers to their - -- declarations, this kludge can be removed. + -- pointer be set to something reasonable, but Itypes don't have + -- parent pointers. So we set it and then unset it ??? If and when + -- Itypes have proper parent pointers to their declarations, this + -- kludge can be removed. Set_Parent (Desig_Type, T_Name); End_Scope; @@ -1098,8 +1098,8 @@ package body Sem_Ch3 is Set_Etype (Id, T); Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N))); - -- The component declaration may have a per-object constraint, set the - -- appropriate flag in the defining identifier of the subtype. + -- The component declaration may have a per-object constraint, set + -- the appropriate flag in the defining identifier of the subtype. if Present (Subtype_Indication (Component_Definition (N))) then declare @@ -1226,14 +1226,14 @@ package body Sem_Ch3 is end if; -- At the end of a declarative part, freeze remaining entities - -- declared in it. The end of the visible declarations of a - -- package specification is not the end of a declarative part - -- if private declarations are present. The end of a package - -- declaration is a freezing point only if it a library package. - -- A task definition or protected type definition is not a freeze - -- point either. Finally, we do not freeze entities in generic - -- scopes, because there is no code generated for them and freeze - -- nodes will be generated for the instance. + -- declared in it. The end of the visible declarations of package + -- specification is not the end of a declarative part if private + -- declarations are present. The end of a package declaration is a + -- freezing point only if it a library package. A task definition or + -- protected type definition is not a freeze point either. Finally, + -- we do not freeze entities in generic scopes, because there is no + -- code generated for them and freeze nodes will be generated for + -- the instance. -- The end of a package instantiation is not a freeze point, but -- for now we make it one, because the generic body is inserted @@ -1330,9 +1330,9 @@ package body Sem_Ch3 is End_Scope; - -- If the type has discriminants, non-trivial subtypes may be - -- be declared before the full view of the type. The full views - -- of those subtypes will be built after the full view of the type. + -- If the type has discriminants, non-trivial subtypes may be be + -- declared before the full view of the type. The full views of those + -- subtypes will be built after the full view of the type. Set_Private_Dependents (T, New_Elmt_List); Set_Is_Pure (T, F); @@ -1511,12 +1511,12 @@ package body Sem_Ch3 is -- worthile building the corresponding subtype. function Count_Tasks (T : Entity_Id) return Uint; - -- This function is called when a library level object of type T - -- is declared. It's function is to count the static number of - -- tasks declared within the type (it is only called if Has_Tasks - -- is set for T). As a side effect, if an array of tasks with - -- non-static bounds or a variant record type is encountered, - -- Check_Restrictions is called indicating the count is unknown. + -- This function is called when a library level object of type is + -- declared. It's function is to count the static number of tasks + -- declared within the type (it is only called if Has_Tasks is set for + -- T). As a side effect, if an array of tasks with non-static bounds or + -- a variant record type is encountered, Check_Restrictions is called + -- indicating the count is unknown. --------------------------- -- Build_Default_Subtype -- @@ -2346,17 +2346,17 @@ package body Sem_Ch3 is -- where the defining identifier has already been entered into the -- scope but the declaration as a whole needs to be analyzed. - -- This case in particular happens for derived enumeration types. - -- The derived enumeration type is processed as an inserted enumeration + -- This case in particular happens for derived enumeration types. The + -- derived enumeration type is processed as an inserted enumeration -- type declaration followed by a rewritten subtype declaration. The -- defining identifier, however, is entered into the name scope very -- early in the processing of the original type declaration and -- therefore needs to be avoided here, when the created subtype -- declaration is analyzed. (See Build_Derived_Types) - -- This also happens when the full view of a private type is a - -- derived type with constraints. In this case the entity has been - -- introduced in the private declaration. + -- This also happens when the full view of a private type is derived + -- type with constraints. In this case the entity has been introduced + -- in the private declaration. if Present (Etype (Id)) and then (Is_Private_Type (Etype (Id)) @@ -2882,9 +2882,9 @@ package body Sem_Ch3 is begin -- In the case where the base type is different from the first - -- subtype, we pre-allocate a freeze node, and set the proper - -- link to the first subtype. Freeze_Entity will use this - -- preallocated freeze node when it freezes the entity. + -- subtype, we pre-allocate a freeze node, and set the proper link + -- to the first subtype. Freeze_Entity will use this preallocated + -- freeze node when it freezes the entity. if B /= T then Ensure_Freeze_Node (B); @@ -3805,10 +3805,9 @@ package body Sem_Ch3 is Insert_Before (N, Type_Decl); Analyze (Type_Decl); - -- After the implicit base is analyzed its Etype needs to be - -- changed to reflect the fact that it is derived from the - -- parent type which was ignored during analysis. We also set - -- the size at this point. + -- After the implicit base is analyzed its Etype needs to be changed + -- to reflect the fact that it is derived from the parent type which + -- was ignored during analysis. We also set the size at this point. Set_Etype (Implicit_Base, Parent_Type); @@ -3839,8 +3838,8 @@ package body Sem_Ch3 is else -- Constraint is a Range attribute. Replace with the - -- explicit mention of the bounds of the prefix, which - -- must be a subtype. + -- explicit mention of the bounds of the prefix, which must + -- be a subtype. Analyze (Prefix (R)); Hi := @@ -3897,17 +3896,16 @@ package body Sem_Ch3 is Analyze (N); - -- If pragma Discard_Names applies on the first subtype - -- of the parent type, then it must be applied on this - -- subtype as well. + -- If pragma Discard_Names applies on the first subtype of the + -- parent type, then it must be applied on this subtype as well. if Einfo.Discard_Names (First_Subtype (Parent_Type)) then Set_Discard_Names (Derived_Type); end if; - -- Apply a range check. Since this range expression doesn't - -- have an Etype, we have to specifically pass the Source_Typ - -- parameter. Is this right??? + -- Apply a range check. Since this range expression doesn't have an + -- Etype, we have to specifically pass the Source_Typ parameter. Is + -- this right??? if Nkind (Indic) = N_Subtype_Indication then Apply_Range_Check (Range_Expression (Constraint (Indic)), @@ -3943,9 +3941,9 @@ package body Sem_Ch3 is Discard_Node (Process_Subtype (Indic, N)); - -- Introduce an implicit base type for the derived type even if - -- there is no constraint attached to it, since this seems closer - -- to the Ada semantics. + -- Introduce an implicit base type for the derived type even if there + -- is no constraint attached to it, since this seems closer to the Ada + -- semantics. Implicit_Base := Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); @@ -3975,9 +3973,9 @@ package body Sem_Ch3 is Set_Includes_Infinities (Scalar_Range (Implicit_Base)); end if; - -- The Derived_Type, which is the entity of the declaration, is - -- a subtype of the implicit base. Its Ekind is a subtype, even - -- in the absence of an explicit constraint. + -- The Derived_Type, which is the entity of the declaration, is a + -- subtype of the implicit base. Its Ekind is a subtype, even in the + -- absence of an explicit constraint. Set_Etype (Derived_Type, Implicit_Base); @@ -3988,9 +3986,9 @@ package body Sem_Ch3 is Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); end if; - -- If we did not have a range constraint, then set the range - -- from the parent type. Otherwise, the call to Process_Subtype - -- has set the bounds. + -- If we did not have a range constraint, then set the range from the + -- parent type. Otherwise, the call to Process_Subtype has set the + -- bounds. if No_Constraint or else not Has_Range_Constraint (Indic) @@ -4029,11 +4027,11 @@ package body Sem_Ch3 is elsif Is_Fixed_Point_Type (Parent_Type) then - -- Small of base type and derived type are always copied from - -- the parent base type, since smalls never change. The delta - -- of the base type is also copied from the parent base type. - -- However the delta of the derived type will have been set - -- already if a constraint was present. + -- Small of base type and derived type are always copied from the + -- parent base type, since smalls never change. The delta of the + -- base type is also copied from the parent base type. However the + -- delta of the derived type will have been set already if a + -- constraint was present. Set_Small_Value (Derived_Type, Small_Value (Parent_Base)); Set_Small_Value (Implicit_Base, Small_Value (Parent_Base)); @@ -4075,8 +4073,8 @@ package body Sem_Ch3 is Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); -- The implicit_base should be frozen when the derived type is frozen, - -- but note that it is used in the conversions of the bounds. For - -- fixed types we delay the determination of the bounds until the proper + -- but note that it is used in the conversions of the bounds. For fixed + -- types we delay the determination of the bounds until the proper -- freezing point. For other numeric types this is rejected by GCC, for -- reasons that are currently unclear (???), so we choose to freeze the -- implicit base now. In the case of integers and floating point types @@ -4152,10 +4150,9 @@ package body Sem_Ch3 is if Present (Full_View (Parent_Type)) then if not Is_Completion then - -- Copy declaration for subsequent analysis, to - -- provide a completion for what is a private - -- declaration. Indicate that the full type is - -- internally generated. + -- Copy declaration for subsequent analysis, to provide a + -- completion for what is a private declaration. Indicate that + -- the full type is internally generated. Full_Decl := New_Copy_Tree (N); Full_Der := New_Copy (Derived_Type); @@ -4210,10 +4207,9 @@ package body Sem_Ch3 is Swapped := True; end if; - -- Build full view of derived type from full view of - -- parent which is now installed. - -- Subprograms have been derived on the partial view, - -- the completion does not derive them anew. + -- Build full view of derived type from full view of parent which + -- is now installed. Subprograms have been derived on the partial + -- view, the completion does not derive them anew. if not Is_Tagged_Type (Parent_Type) then Build_Derived_Record_Type @@ -4241,15 +4237,14 @@ package body Sem_Ch3 is Set_Full_View (Derived_Type, Full_Der); Set_Full_View (Der_Base, Base_Type (Full_Der)); - -- Copy the discriminant list from full view to - -- the partial views (base type and its subtype). - -- Gigi requires that the partial and full views - -- have the same discriminants. - -- ??? Note that since the partial view is pointing - -- to discriminants in the full view, their scope - -- will be that of the full view. This might - -- cause some front end problems and need - -- adjustment? + -- Copy the discriminant list from full view to the partial views + -- (base type and its subtype). Gigi requires that the partial + -- and full views have the same discriminants. + + -- Note that since the partial view is pointing to discriminants + -- in the full view, their scope will be that of the full view. + -- This might cause some front end problems and need + -- adjustment??? Discr := First_Discriminant (Base_Type (Full_Der)); Set_First_Entity (Der_Base, Discr); @@ -4361,9 +4356,9 @@ package body Sem_Ch3 is (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); end if; - -- Construct the implicit full view by deriving from full - -- view of the parent type. In order to get proper visibility, - -- we install the parent scope and its declarations. + -- Construct the implicit full view by deriving from full view of + -- the parent type. In order to get proper visibility, we install + -- the parent scope and its declarations. -- ??? if the parent is untagged private and its completion is -- tagged, this mechanism will not work because we cannot derive @@ -4389,10 +4384,10 @@ package body Sem_Ch3 is Copy_And_Build; Uninstall_Declarations (Par_Scope); - -- If parent scope is open and in another unit, and - -- parent has a completion, then the derivation is taking - -- place in the visible part of a child unit. In that - -- case retrieve the full view of the parent momentarily. + -- If parent scope is open and in another unit, and parent has a + -- completion, then the derivation is taking place in the visible + -- part of a child unit. In that case retrieve the full view of + -- the parent momentarily. elsif not In_Same_Source_Unit (N, Parent_Type) then Full_P := Full_View (Parent_Type); @@ -4500,8 +4495,8 @@ package body Sem_Ch3 is -- in R and T have the same position in objects of type R and T. -- This has two implications. The first is that the entire tree for R's - -- declaration needs to be copied for T in the untagged case, so that - -- T can be viewed as a record type of its own with its own representation + -- declaration needs to be copied for T in the untagged case, so that T + -- can be viewed as a record type of its own with its own representation -- clauses. The second implication is the way we handle discriminants. -- Specifically, in the untagged case we need a way to communicate to Gigi -- what are the real discriminants in the record, while for the semantics @@ -4531,10 +4526,10 @@ package body Sem_Ch3 is -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if -- there is one; - -- o Otherwise, each discriminant of the parent type (implicitly - -- declared in the same order with the same specifications). In this - -- case, the discriminants are said to be "inherited", or if unknown in - -- the parent are also unknown in the derived type. + -- o Otherwise, each discriminant of the parent type (implicitly declared + -- in the same order with the same specifications). In this case, the + -- discriminants are said to be "inherited", or if unknown in the parent + -- are also unknown in the derived type. -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: @@ -4756,6 +4751,7 @@ package body Sem_Ch3 is -- components are inherited in the derived type from the parent type. In -- the absence of discriminants component, inheritance is straightforward -- as components can simply be copied from the parent. + -- If the parent has discriminants, inheriting components constrained with -- these discriminants requires caution. Consider the following example: @@ -4850,19 +4846,18 @@ package body Sem_Ch3 is -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS -- The full view of a private extension is handled exactly as described - -- above. The model chose for the private view of a private extension - -- is the same for what concerns discriminants (ie they receive the same + -- above. The model chose for the private view of a private extension is + -- the same for what concerns discriminants (ie they receive the same -- treatment as in the tagged case). However, the private view of the -- private extension always inherits the components of the parent base, - -- without replacing any discriminant reference. Strictly speaking this - -- is incorrect. However, Gigi never uses this view to generate code so - -- this is a purely semantic issue. In theory, a set of transformations - -- similar to those given in 5. and 6. above could be applied to private - -- views of private extensions to have the same model of component - -- inheritance as for non private extensions. However, this is not done - -- because it would further complicate private type processing. - -- Semantically speaking, this leaves us in an uncomfortable - -- situation. As an example consider: + -- without replacing any discriminant reference. Strictly speaking this is + -- incorrect. However, Gigi never uses this view to generate code so this + -- is a purely semantic issue. In theory, a set of transformations similar + -- to those given in 5. and 6. above could be applied to private views of + -- private extensions to have the same model of component inheritance as + -- for non private extensions. However, this is not done because it would + -- further complicate private type processing. Semantically speaking, this + -- leaves us in an uncomfortable situation. As an example consider: -- package Pack is -- type R (D : integer) is tagged record @@ -4901,6 +4896,7 @@ package body Sem_Ch3 is -- a private extension such as T, we first mark T as unconstrained, we -- process it, we perform program derivation and just before returning from -- Build_Derived_Record_Type we mark T as constrained. + -- ??? Are there are other uncomfortable cases that we will have to -- deal with. @@ -5100,9 +5096,9 @@ package body Sem_Ch3 is Mark_Rewrite_Insertion (New_Decl); Insert_Before (N, New_Decl); - -- Note that this call passes False for the Derive_Subps - -- parameter because subprogram derivation is deferred until - -- after creating the subtype (see below). + -- Note that this call passes False for the Derive_Subps parameter + -- because subprogram derivation is deferred until after creating + -- the subtype (see below). Build_Derived_Type (New_Decl, Parent_Base, New_Base, @@ -5323,9 +5319,9 @@ package body Sem_Ch3 is exit; end if; - -- If a new discriminant is used in the constraint, - -- then its subtype must be statically compatible - -- with the parent discriminant's subtype (3.7(15)). + -- If a new discriminant is used in the constraint, then its + -- subtype must be statically compatible with the parent + -- discriminant's subtype (3.7(15)). if Present (Corresponding_Discriminant (Discrim)) and then @@ -5756,9 +5752,9 @@ package body Sem_Ch3 is return; end if; - -- Set delayed freeze and then derive subprograms, we need to do - -- this in this order so that derived subprograms inherit the - -- derived freeze if necessary. + -- Set delayed freeze and then derive subprograms, we need to do this + -- in this order so that derived subprograms inherit the derived freeze + -- if necessary. Set_Has_Delayed_Freeze (Derived_Type); if Derive_Subps then @@ -6400,8 +6396,8 @@ package body Sem_Ch3 is while Present (Elmt) loop Subp := Node (Elmt); - -- Special exception, do not complain about failure to - -- override _Input and _Output, since we always provide + -- Special exception, do not complain about failure to override the + -- stream routines _Input and _Output, since we always provide -- automatic overridings for these subprograms. if Is_Abstract (Subp) @@ -6471,9 +6467,8 @@ package body Sem_Ch3 is C : Entity_Id; begin - -- ??? Also need to check components of record extensions, - -- but not components of protected types (which are always - -- limited). + -- ??? Also need to check components of record extensions, but not + -- components of protected types (which are always limited). if not Is_Limited_Type (T) then if Ekind (T) = E_Record_Type then @@ -6551,9 +6546,9 @@ package body Sem_Ch3 is end if; -- If a generated entity has no completion, then either previous - -- semantic errors have disabled the expansion phase, or else - -- we had missing subunits, or else we are compiling without expan- - -- sion, or else something is very wrong. + -- semantic errors have disabled the expansion phase, or else we had + -- missing subunits, or else we are compiling without expan- sion, + -- or else something is very wrong. if not Comes_From_Source (E) then pragma Assert @@ -6636,7 +6631,7 @@ package body Sem_Ch3 is -- parent: -- procedure Parent.Child (...); - -- + -- with Parent.Child; -- package body Parent is @@ -6690,10 +6685,9 @@ package body Sem_Ch3 is then Post_Error; - -- A single task declared in the current scope is - -- a constant, verify that the body of its anonymous - -- type is in the same scope. If the task is defined - -- elsewhere, this may be a renaming declaration for + -- A single task declared in the current scope is a constant, verify + -- that the body of its anonymous type is in the same scope. If the + -- task is defined elsewhere, this may be a renaming declaration for -- which no completion is needed. elsif Ekind (E) = E_Constant @@ -6976,10 +6970,10 @@ package body Sem_Ch3 is Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); Set_Depends_On_Private (Full, Has_Private_Component (Full)); - -- Freeze the private subtype entity if its parent is delayed, - -- and not already frozen. We skip this processing if the type - -- is an anonymous subtype of a record component, or is the - -- corresponding record of a protected type, since ??? + -- Freeze the private subtype entity if its parent is delayed, and not + -- already frozen. We skip this processing if the type is an anonymous + -- subtype of a record component, or is the corresponding record of a + -- protected type, since ??? if not Is_Type (Scope (Full)) then Set_Has_Delayed_Freeze (Full, @@ -7038,10 +7032,10 @@ package body Sem_Ch3 is Set_Cloned_Subtype (Full, Full_Base); end if; - -- It is unsafe to share to bounds of a scalar type, because the - -- Itype is elaborated on demand, and if a bound is non-static - -- then different orders of elaboration in different units will - -- lead to different external symbols. + -- It is unsafe to share to bounds of a scalar type, because the Itype + -- is elaborated on demand, and if a bound is non-static then different + -- orders of elaboration in different units will lead to different + -- external symbols. if Is_Scalar_Type (Full_Base) then Set_Scalar_Range (Full, @@ -7061,9 +7055,9 @@ package body Sem_Ch3 is end if; end if; - -- ??? It seems that a lot of fields are missing that should be - -- copied from Full_Base to Full. Here are some that are introduced - -- in a non-disruptive way but a cleanup is necessary. + -- ??? It seems that a lot of fields are missing that should be copied + -- from Full_Base to Full. Here are some that are introduced in a + -- non-disruptive way but a cleanup is necessary. if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); @@ -7505,9 +7499,9 @@ package body Sem_Ch3 is function Build_Constrained_Array_Type (Old_Type : Entity_Id) return Entity_Id; - -- If Old_Type is an array type, one of whose indices is - -- constrained by a discriminant, build an Itype whose constraint - -- replaces the discriminant with its value in the constraint. + -- If Old_Type is an array type, one of whose indices is constrained + -- by a discriminant, build an Itype whose constraint replaces the + -- discriminant with its value in the constraint. function Build_Constrained_Discriminated_Type (Old_Type : Entity_Id) return Entity_Id; @@ -7734,8 +7728,8 @@ package body Sem_Ch3 is Btyp : Entity_Id := Base_Type (T); begin - -- The Related_Node better be here or else we won't be able - -- to attach new itypes to a node in the tree. + -- The Related_Node better be here or else we won't be able to + -- attach new itypes to a node in the tree. pragma Assert (Present (Related_Node)); @@ -7800,9 +7794,9 @@ package body Sem_Ch3 is -- The corresponding_Discriminant mechanism is incomplete, because -- the correspondence between new and old discriminants is not one - -- to one: one new discriminant can constrain several old ones. - -- In that case, scan sequentially the stored_constraint, the list - -- of discriminants of the parents, and the constraints. + -- to one: one new discriminant can constrain several old ones. In + -- that case, scan sequentially the stored_constraint, the list of + -- discriminants of the parents, and the constraints. if Is_Derived_Type (Typ) and then Present (Stored_Constraint (Typ)) @@ -8567,9 +8561,9 @@ package body Sem_Ch3 is Set_First_Entity (Full, First_Entity (Priv)); Set_Last_Entity (Full, Last_Entity (Priv)); - -- If access types have been recorded for later handling, keep them - -- in the full view so that they get handled when the full view - -- freeze node is expanded. + -- If access types have been recorded for later handling, keep them in + -- the full view so that they get handled when the full view freeze + -- node is expanded. if Present (Freeze_Node (Priv)) and then Present (Access_Types_To_Process (Freeze_Node (Priv))) @@ -8670,8 +8664,8 @@ package body Sem_Ch3 is procedure Collect_Fixed_Components (Typ : Entity_Id) is begin - -- Build association list for discriminants, and find components of - -- the variant part selected by the values of the discriminants. + -- Build association list for discriminants, and find components of the + -- variant part selected by the values of the discriminants. Old_C := First_Discriminant (Typ); Discr_Val := First_Elmt (Constraints); @@ -9086,9 +9080,9 @@ package body Sem_Ch3 is Prev : Entity_Id; begin - -- The visible operation that is overriden is a homonym of - -- the parent subprogram. We scan the homonym chain to find - -- the one whose alias is the subprogram we are deriving. + -- The visible operation that is overriden is a homonym of the + -- parent subprogram. We scan the homonym chain to find the one + -- whose alias is the subprogram we are deriving. Prev := Homonym (Parent_Subp); while Present (Prev) loop @@ -9265,15 +9259,14 @@ package body Sem_Ch3 is -- or if we are in the private part of an instance. This test -- should still be refined ??? - -- The test for In_Instance_Not_Visible avoids inheriting the - -- derived operation as a non-visible operation in cases where - -- the parent subprogram might not be visible now, but was - -- visible within the original generic, so it would be wrong - -- to make the inherited subprogram non-visible now. (Not - -- clear if this test is fully correct; are there any cases - -- where we should declare the inherited operation as not - -- visible to avoid it being overridden, e.g., when the - -- parent type is a generic actual with private primitives ???) + -- The test for In_Instance_Not_Visible avoids inheriting the derived + -- operation as a non-visible operation in cases where the parent + -- subprogram might not be visible now, but was visible within the + -- original generic, so it would be wrong to make the inherited + -- subprogram non-visible now. (Not clear if this test is fully + -- correct; are there any cases where we should declare the inherited + -- operation as not visible to avoid it being overridden, e.g., when + -- the parent type is a generic actual with private primitives ???) -- (they should be treated the same as other private inherited -- subprograms, but it's not clear how to do this cleanly). ??? @@ -9301,9 +9294,9 @@ package body Sem_Ch3 is New_Formal := New_Copy (Formal); -- Normally we do not go copying parents, but in the case of - -- formals, we need to link up to the declaration (which is - -- the parameter specification), and it is fine to link up to - -- the original formal's parameter specification in this case. + -- formals, we need to link up to the declaration (which is the + -- parameter specification), and it is fine to link up to the + -- original formal's parameter specification in this case. Set_Parent (New_Formal, Parent (Formal)); @@ -9356,11 +9349,11 @@ package body Sem_Ch3 is (New_Subp, Is_Valued_Procedure (Parent_Subp)); end if; - -- A derived function with a controlling result is abstract. - -- If the Derived_Type is a nonabstract formal generic derived - -- type, then inherited operations are not abstract: check is - -- done at instantiation time. If the derivation is for a generic - -- actual, the function is not abstract unless the actual is. + -- A derived function with a controlling result is abstract. If the + -- Derived_Type is a nonabstract formal generic derived type, then + -- inherited operations are not abstract: the required check is done at + -- instantiation time. If the derivation is for a generic actual, the + -- function is not abstract unless the actual is. if Is_Generic_Type (Derived_Type) and then not Is_Abstract (Derived_Type) @@ -9394,12 +9387,11 @@ package body Sem_Ch3 is New_Overloaded_Entity (New_Subp, Derived_Type); - -- Check for case of a derived subprogram for the instantiation - -- of a formal derived tagged type, if so mark the subprogram as - -- dispatching and inherit the dispatching attributes of the - -- parent subprogram. The derived subprogram is effectively a - -- renaming of the actual subprogram, so it needs to have the - -- same attributes as the actual. + -- Check for case of a derived subprogram for the instantiation of a + -- formal derived tagged type, if so mark the subprogram as dispatching + -- and inherit the dispatching attributes of the parent subprogram. The + -- derived subprogram is effectively renaming of the actual subprogram, + -- so it needs to have the same attributes as the actual. if Present (Actual_Subp) and then Is_Dispatching_Operation (Parent_Subp) @@ -9411,8 +9403,8 @@ package body Sem_Ch3 is end if; end if; - -- Indicate that a derived subprogram does not require a body - -- and that it does not require processing of default expressions. + -- Indicate that a derived subprogram does not require a body and that + -- it does not require processing of default expressions. Set_Has_Completion (New_Subp); Set_Default_Expressions_Processed (New_Subp); @@ -9457,8 +9449,8 @@ package body Sem_Ch3 is Act_Elmt := No_Elmt; end if; - -- Literals are derived earlier in the process of building the - -- derived type, and are skipped here. + -- Literals are derived earlier in the process of building the derived + -- type, and are skipped here. Elmt := First_Elmt (Op_List); while Present (Elmt) loop @@ -9578,9 +9570,9 @@ package body Sem_Ch3 is or else (Is_Class_Wide_Type (Parent_Type) and then Etype (Parent_Type) = T) then - -- If Parent_Type is undefined or illegal, make new type into - -- a subtype of Any_Type, and set a few attributes to prevent - -- cascaded errors. If this is a self-definition, emit error now. + -- If Parent_Type is undefined or illegal, make new type into a + -- subtype of Any_Type, and set a few attributes to prevent cascaded + -- errors. If this is a self-definition, emit error now. if T = Parent_Type or else T = Etype (Parent_Type) @@ -9718,11 +9710,11 @@ package body Sem_Ch3 is elsif No (Extension) and then Taggd then - -- If this is within a private part (or body) of a generic - -- instantiation then the derivation is allowed (the parent - -- type can only appear tagged in this case if it's a generic - -- actual type, since it would otherwise have been rejected - -- in the analysis of the generic template). + -- If this declaration is within a private part (or body) of a + -- generic instantiation then the derivation is allowed (the parent + -- type can only appear tagged in this case if it's a generic actual + -- type, since it would otherwise have been rejected in the analysis + -- of the generic template). if not Is_Generic_Actual_Type (Parent_Type) or else In_Visible_Part (Scope (Parent_Type)) @@ -9940,8 +9932,8 @@ package body Sem_Ch3 is elsif Ekind (Prev) = E_Incomplete_Type then - -- Indicate that the incomplete declaration has a matching - -- full declaration. The defining occurrence of the incomplete + -- Indicate that the incomplete declaration has a matching full + -- declaration. The defining occurrence of the incomplete -- declaration remains the visible one, and the procedure -- Get_Full_View dereferences it whenever the type is used. @@ -10140,10 +10132,10 @@ package body Sem_Ch3 is Subtype_Indication => Relocate_Node (Obj_Def))); -- This subtype may need freezing, and this will not be done - -- automatically if the object declaration is not in a - -- declarative part. Since this is an object declaration, the - -- type cannot always be frozen here. Deferred constants do not - -- freeze their type (which often enough will be private). + -- automatically if the object declaration is not in declarative + -- part. Since this is an object declaration, the type cannot always + -- be frozen here. Deferred constants do not freeze their type + -- (which often enough will be private). if Nkind (P) = N_Object_Declaration and then Constant_Present (P) @@ -10354,9 +10346,8 @@ package body Sem_Ch3 is -- type T0 (Dx, Dy, Dz...) - -- There are zero or more levels of derivation, with each - -- derivation either purely inheriting the discriminants, or - -- defining its own. + -- There are zero or more levels of derivation, with each derivation + -- either purely inheriting the discriminants, or defining its own. -- type Ti is new Ti-1 -- or @@ -10364,9 +10355,8 @@ package body Sem_Ch3 is -- or -- subtype Ti is ... - -- The subtype issue is avoided by the use of - -- Original_Record_Component, and the fact that derived subtypes - -- also derive the constraints. + -- The subtype issue is avoided by the use of Original_Record_Component, + -- and the fact that derived subtypes also derive the constraints. -- This chain leads back from @@ -10630,10 +10620,10 @@ package body Sem_Ch3 is (Old_C : Entity_Id; Plain_Discrim : Boolean := False; Stored_Discrim : Boolean := False); - -- Inherits component Old_C from Parent_Base to the Derived_Base. - -- If Plain_Discrim is True, Old_C is a discriminant. - -- If Stored_Discrim is True, Old_C is a stored discriminant. - -- If they are both false then Old_C is a regular component. + -- Inherits component Old_C from Parent_Base to the Derived_Base. If + -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is + -- True, Old_C is a stored discriminant. If they are both false then + -- Old_C is a regular component. ----------------------- -- Inherit_Component -- @@ -10786,12 +10776,12 @@ package body Sem_Ch3 is -- See if we can apply the second transformation for derived types, as -- explained in point 6. in the comments above Build_Derived_Record_Type - -- This is achieved by appending Derived_Base discriminants into - -- Discs, which has the side effect of returning a non empty Discs - -- list to the caller of Inherit_Components, which is what we want. - -- This must be done for private derived types if there are explicit - -- stored discriminants, to ensure that we can retrieve the values of - -- the constraints provided in the ancestors. + -- This is achieved by appending Derived_Base discriminants into Discs, + -- which has the side effect of returning a non empty Discs list to the + -- caller of Inherit_Components, which is what we want. This must be + -- done for private derived types if there are explicit stored + -- discriminants, to ensure that we can retrieve the values of the + -- constraints provided in the ancestors. if Inherit_Discr and then Is_Empty_Elmt_List (Discs) @@ -10915,9 +10905,9 @@ package body Sem_Ch3 is Type_Scope : Entity_Id; function Is_Local_Type (Typ : Entity_Id) return Boolean; - -- Check whether parent type of inherited component is declared - -- locally, possibly within a nested package or instance. The - -- current scope is the derived record itself. + -- Check whether parent type of inherited component is declared locally, + -- possibly within a nested package or instance. The current scope is + -- the derived record itself. ------------------- -- Is_Local_Type -- @@ -10970,9 +10960,9 @@ package body Sem_Ch3 is elsif not Comes_From_Source (Original_Comp) then return True; - -- If we are in the body of an instantiation, the component is - -- visible even when the parent type (possibly defined in an - -- enclosing unit or in a parent unit) might not. + -- If we are in the body of an instantiation, the component is visible + -- even when the parent type (possibly defined in an enclosing unit or + -- in a parent unit) might not. elsif In_Instance_Body then return True; @@ -11035,8 +11025,8 @@ package body Sem_Ch3 is -- private -- type T is new A2 with null record; - -- In this case, the full view of T inherits F1 and F2 but the - -- private view inherits only F1 + -- In this case, the full view of T inherits F1 and F2 but the private + -- view inherits only F1 else declare @@ -11226,8 +11216,8 @@ package body Sem_Ch3 is and then Is_Type (Entity (Prefix (Low_Bound (I)))) and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I)))) then - -- The type of the index will be the type of the prefix, - -- as long as the upper bound is 'Last of the same type. + -- The type of the index will be the type of the prefix, as long + -- as the upper bound is 'Last of the same type. Def_Id := Entity (Prefix (Low_Bound (I))); @@ -11349,18 +11339,17 @@ package body Sem_Ch3 is return; end if; - -- We will now create the appropriate Itype to describe the - -- range, but first a check. If we originally had a subtype, - -- then we just label the range with this subtype. Not only - -- is there no need to construct a new subtype, but it is wrong - -- to do so for two reasons: + -- We will now create the appropriate Itype to describe the range, but + -- first a check. If we originally had a subtype, then we just label + -- the range with this subtype. Not only is there no need to construct + -- a new subtype, but it is wrong to do so for two reasons: - -- 1. A legality concern, if we have a subtype, it must not - -- freeze, and the Itype would cause freezing incorrectly + -- 1. A legality concern, if we have a subtype, it must not freeze, + -- and the Itype would cause freezing incorrectly - -- 2. An efficiency concern, if we created an Itype, it would - -- not be recognized as the same type for the purposes of - -- eliminating checks in some circumstances. + -- 2. An efficiency concern, if we created an Itype, it would not be + -- recognized as the same type for the purposes of eliminating + -- checks in some circumstances. -- We signal this case by setting the subtype entity in Def_Id @@ -11604,8 +11593,8 @@ package body Sem_Ch3 is Set_Delta_Value (Implicit_Base, Delta_Val); - -- Compute default small from given delta, which is the largest - -- power of two that does not exceed the given delta value. + -- Compute default small from given delta, which is the largest power + -- of two that does not exceed the given delta value. declare Tmp : Ureal := Ureal_1; @@ -11661,11 +11650,11 @@ package body Sem_Ch3 is end; end if; - -- The range for both the implicit base and the declared first - -- subtype cannot be set yet, so we use the special routine - -- Set_Fixed_Range to set a temporary range in place. Note that - -- the bounds of the base type will be widened to be symmetrical - -- and to fill the available bits when the type is frozen. + -- The range for both the implicit base and the declared first subtype + -- cannot be set yet, so we use the special routine Set_Fixed_Range to + -- set a temporary range in place. Note that the bounds of the base + -- type will be widened to be symmetrical and to fill the available + -- bits when the type is frozen. -- We could do this with all discrete types, and probably should, but -- we absolutely have to do it for fixed-point, since the end-points @@ -11704,9 +11693,10 @@ package body Sem_Ch3 is begin if Present (Full_B) then - -- The Base_Type is already completed, we can complete the - -- subtype now. We have to create a new entity with the same name, - -- Thus we can't use Create_Itype. + -- The Base_Type is already completed, we can complete the subtype + -- now. We have to create a new entity with the same name, Thus we + -- can't use Create_Itype. + -- This is messy, should be fixed ??? Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); @@ -12110,11 +12100,10 @@ package body Sem_Ch3 is end if; -- Create a full declaration for all its subtypes recorded in - -- Private_Dependents and swap them similarly to the base type. - -- These are subtypes that have been define before the full - -- declaration of the private type. We also swap the entry in - -- Private_Dependents list so we can properly restore the - -- private view on exit from the scope. + -- Private_Dependents and swap them similarly to the base type. These + -- are subtypes that have been define before the full declaration of + -- the private type. We also swap the entry in Private_Dependents list + -- so we can properly restore the private view on exit from the scope. declare Priv_Elmt : Elmt_Id; @@ -12191,15 +12180,15 @@ package body Sem_Ch3 is else -- In this case the partial view is untagged, so here we -- locate all of the earlier primitives that need to be - -- treated as dispatching (those that appear between the - -- two views). Note that these additional operations must - -- all be new operations (any earlier operations that - -- override inherited operations of the full view will - -- already have been inserted in the primitives list and - -- marked as dispatching by Check_Operation_From_Private_View. - -- Note that implicit "/=" operators are excluded from being - -- added to the primitives list since they shouldn't be - -- treated as dispatching (tagged "/=" is handled specially). + -- treated as dispatching (those that appear between the two + -- views). Note that these additional operations must all be + -- new operations (any earlier operations that override + -- inherited operations of the full view will already have + -- been inserted in the primitives list and marked as + -- dispatching by Check_Operation_From_Private_View. Note that + -- implicit "/=" operators are excluded from being added to + -- the primitives list since they shouldn't be treated as + -- dispatching (tagged "/=" is handled specially). Prim := Next_Entity (Full_T); while Present (Prim) and then Prim /= Priv_T loop @@ -12406,12 +12395,11 @@ package body Sem_Ch3 is Set_Etype (Hi, T); end if; - -- If the bounds of the range have been mistakenly given as - -- string literals (perhaps in place of character literals), - -- then an error has already been reported, but we rewrite - -- the string literal as a bound of the range's type to - -- avoid blowups in later processing that looks at static - -- values. + -- If the bounds of the range have been mistakenly given as string + -- literals (perhaps in place of character literals), then an error + -- has already been reported, but we rewrite the string literal as a + -- bound of the range's type to avoid blowups in later processing + -- that looks at static values. if Nkind (Lo) = N_String_Literal then Rewrite (Lo, @@ -12443,8 +12431,10 @@ package body Sem_Ch3 is -- not be raised. -- ??? The following code should be cleaned up as follows + -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it -- is done in the call to Range_Check (R, T); below + -- 2. The use of R_Check_Off should be investigated and possibly -- removed, this would clean up things a bit. @@ -12680,11 +12670,11 @@ package body Sem_Ch3 is Def_Id := Defining_Identifier (Parent (P)); -- Implicit case, the Def_Id must be created as an implicit type. - -- The one exception arises in the case of concurrent types, - -- array and access types, where other subsidiary implicit types - -- may be created and must appear before the main implicit type. - -- In these cases we leave Def_Id set to Empty as a signal that - -- Create_Itype has not yet been called to create Def_Id. + -- The one exception arises in the case of concurrent types, array + -- and access types, where other subsidiary implicit types may be + -- created and must appear before the main implicit type. In these + -- cases we leave Def_Id set to Empty as a signal that Create_Itype + -- has not yet been called to create Def_Id. else if Is_Array_Type (Subtype_Mark_Id) @@ -13064,18 +13054,17 @@ package body Sem_Ch3 is -- A small clause may affect the values of the end-points -- We try to include the end-points if it does not affect the size - -- This means that the actual end-points must be established at the - -- point when the type is frozen. Meanwhile, we first narrow the range - -- as permitted (so that it will fit if necessary in a small specified - -- size), and then build a range subtree with these narrowed bounds. + -- This means that the actual end-points must be established at the point + -- when the type is frozen. Meanwhile, we first narrow the range as + -- permitted (so that it will fit if necessary in a small specified size), + -- and then build a range subtree with these narrowed bounds. - -- Set_Fixed_Range constructs the range from real literal values, and - -- sets the range as the Scalar_Range of the given fixed-point type - -- entity. + -- Set_Fixed_Range constructs the range from real literal values, and sets + -- the range as the Scalar_Range of the given fixed-point type entity. - -- The parent of this range is set to point to the entity so that it - -- is properly hooked into the tree (unlike normal Scalar_Range entries - -- for other scalar types, which are just pointers to the range in the + -- The parent of this range is set to point to the entity so that it is + -- properly hooked into the tree (unlike normal Scalar_Range entries for + -- other scalar types, which are just pointers to the range in the -- original tree, this would otherwise be an orphan). -- The tree is left unanalyzed. When the type is frozen, the processing diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 58d7e53..bc069fa 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -129,15 +129,6 @@ package body Sem_Ch6 is -- N is the N_Subprogram_Body node for a subprogram. This routine applies -- the alpha ordering rule for N if this ordering requirement applicable. - function Is_Non_Overriding_Operation - (Prev_E : Entity_Id; - New_E : Entity_Id) return Boolean; - -- Enforce the rule given in 12.3(18): a private operation in an instance - -- overrides an inherited operation only if the corresponding operation - -- was overriding in the generic. This can happen for primitive operations - -- of types derived (in the generic unit) from formal private or formal - -- derived types. - procedure Check_Returns (HSS : Node_Id; Mode : Character; @@ -172,6 +163,15 @@ package body Sem_Ch6 is -- sufficient: the formals must become the current entities for -- their names. + function Is_Non_Overriding_Operation + (Prev_E : Entity_Id; + New_E : Entity_Id) return Boolean; + -- Enforce the rule given in 12.3(18): a private operation in an instance + -- overrides an inherited operation only if the corresponding operation + -- was overriding in the generic. This can happen for primitive operations + -- of types derived (in the generic unit) from formal private or formal + -- derived types. + procedure Make_Inequality_Operator (S : Entity_Id); -- Create the declaration for an inequality operator that is implicitly -- created by a user-defined equality operator that yields a boolean. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 91d3067..5ffa863 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -92,7 +92,7 @@ package body Sem_Ch7 is -- is an inner package. function Is_Private_Base_Type (E : Entity_Id) return Boolean; - -- True for a private type that is not a subtype. + -- True for a private type that is not a subtype function Is_Visible_Dependent (Dep : Entity_Id) return Boolean; -- If the private dependent is a private type whose full view is @@ -288,7 +288,7 @@ package body Sem_Ch7 is Append_Entity (Body_Id, Scope (Spec_Id)); end if; - -- Indicate that we are currently compiling the body of the package. + -- Indicate that we are currently compiling the body of the package Set_In_Package_Body (Spec_Id); Set_Has_Completion (Spec_Id); @@ -377,7 +377,7 @@ package body Sem_Ch7 is End_Package_Scope (Spec_Id); - -- All entities declared in body are not visible. + -- All entities declared in body are not visible declare E : Entity_Id; @@ -877,7 +877,7 @@ package body Sem_Ch7 is Analyze_Declarations (Vis_Decls); end if; - -- Verify that incomplete types have received full declarations. + -- Verify that incomplete types have received full declarations E := First_Entity (Id); while Present (E) loop @@ -1485,7 +1485,7 @@ package body Sem_Ch7 is Next_Entity (Id); end loop; - -- Next make other declarations in the private part visible as well. + -- Next make other declarations in the private part visible as well Id := First_Private_Entity (P); @@ -1669,7 +1669,7 @@ package body Sem_Ch7 is -- that need to be available for the partial view also. function Type_In_Use (T : Entity_Id) return Boolean; - -- Check whether type or base type appear in an active use_type clause. + -- Check whether type or base type appear in an active use_type clause ------------------------------ -- Preserve_Full_Attributes -- @@ -1767,7 +1767,7 @@ package body Sem_Ch7 is In_Use (P) and not Is_Hidden (Id)); end if; - -- Local entities are not immediately visible outside of the package. + -- Local entities are not immediately visible outside of the package Set_Is_Immediately_Visible (Id, False); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 1c2bc65..60a22be 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2159,7 +2159,7 @@ package Sinfo is -- INTEGER_TYPE_DEFINITION ::= -- SIGNED_INTEGER_TYPE_DEFINITION - -- MODULAR_TYPE_DEFINITION + -- | MODULAR_TYPE_DEFINITION ------------------------------------------- -- 3.5.4 Signed Integer Type Definition -- @@ -2168,17 +2168,17 @@ package Sinfo is -- SIGNED_INTEGER_TYPE_DEFINITION ::= -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION - -- Note: the Low_Bound and High_Bound fields are set to Empty for - -- integer types defined in package Standard. + -- Note: the Low_Bound and High_Bound fields are set to Empty + -- for integer types defined in package Standard. -- N_Signed_Integer_Type_Definition -- Sloc points to RANGE -- Low_Bound (Node1) -- High_Bound (Node2) - ----------------------------------------- - -- 3.5.4 Unsigned Range Specification -- - ----------------------------------------- + ------------------------------------ + -- 3.5.4 Modular Type Definition -- + ------------------------------------ -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION @@ -2236,9 +2236,6 @@ package Sinfo is -- Note: In Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION - -- Note: the Delta_Expression and Real_Range_Specification fields - -- are set to Empty for fixed point types declared in Standard. - -- N_Ordinary_Fixed_Point_Definition -- Sloc points to DELTA -- Delta_Expression (Node3) diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 12b6734..0dbd0f1 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -4051,22 +4051,6 @@ package VMS_Data is -- Switches for GNAT METRIC -- ------------------------------ - S_Metric_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & - "-gnatec>"; - -- /CONFIGURATION_PRAGMAS_FILE=file - -- - -- Specify a configuration pragmas file that need to be taken into account - - S_Metric_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- - -- Look for files in the directory where GNAT METRIC was invoked - -- - -- /NOCURRENT_DIRECTORY - -- - -- Do not look for files in the directory where GNAT METRIC was invoked - S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " & "-dv"; -- /DEBUG_OUTPUT @@ -4082,8 +4066,9 @@ package VMS_Data is S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" & "ALL " & - "!-ed,!-es,!-enl,!-eis," & - "!-eas,!-eit,!-eat,!-enu " & + "!-ed,!-es,!-enl,!-eps," & + "!-eas,!-ept,!-eat,!-enu," & + "!-ec " & "DECLARATION_TOTAL " & "-ed " & "STATEMENT_TOTAL " & @@ -4091,15 +4076,17 @@ package VMS_Data is "LOOP_NESTING_MAX " & "-enl " & "INT_SUBPROGRAMS " & - "-eis " & + "-eps " & "SUBPROGRAMS_ALL " & "-eas " & "INT_TYPES " & - "-eit " & + "-ept " & "TYPES_ALL " & "-eat " & "PROGRAM_NESTING_MAX " & - "-enu"; + "-enu " & + "CONSTRUCT_NESTING_MAX " & + "-ec"; -- /ELEMENT_METRICS=(option, option ...) -- -- Specifies the element metrics to be computed (if not set, all the @@ -4232,12 +4219,6 @@ package VMS_Data is -- the number of program units left to be processed. This option turns -- this trace off. - S_Metric_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory, ...) - -- - -- When looking for source files also look in the specified directories. - S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' & "-o" & '"'; -- /SUFFIX_DETAILS=suffix @@ -4290,9 +4271,7 @@ package VMS_Data is -- Place the XML output into the specified file Metric_Switches : aliased constant Switches := - (S_Metric_Config 'Access, - S_Metric_Current 'Access, - S_Metric_Debug 'Access, + (S_Metric_Debug 'Access, S_Metric_Direct 'Access, S_Metric_Element 'Access, S_Metric_Ext 'Access, @@ -4303,7 +4282,6 @@ package VMS_Data is S_Metric_Mess 'Access, S_Metric_Project 'Access, S_Metric_Quiet 'Access, - S_Metric_Search 'Access, S_Metric_Suffix 'Access, S_Metric_Suppress 'Access, S_Metric_Verbose 'Access, |