From 9bebf0e989ac6a6be39d1f14693fd011c2ce624b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 22 Jun 2010 19:29:41 +0200 Subject: [PATCH] [multiple changes] 2010-06-22 Robert Dewar * errout.adb (Finalize): Set Prev pointers. (Finalize): Delete continuations for deletion by warnings off(str). * erroutc.ads: Add Prev pointer to error message structure. 2010-06-22 Ed Schonberg * sem.adb (Do_Unit_And_Dependents): If the spec of the main unit is a child unit, examine context of parent units to locate instantiated generics whose bodies may be needed. * sem_ch12.adb: (Mark_Context): if the enclosing unit does not have a with_clause for the instantiated generic, examine the context of its parents, to set Withed_Body flag, so that it can be visited earlier. * exp_ch4.adb (Expand_N_Op_Not): If this is a VMS operator applied to an unsigned type, use a type of the proper size for the intermediate value, to prevent alignment problems on unchecked conversion. 2010-06-22 Geert Bosch * s-rannum.ads Change Generator type to be self-referential to allow Random to update its argument. Use "in" mode for the generator in the Reset procedures to allow them to be called from the Ada.Numerics packages without tricks. * s-rannum.adb: Use the self-referencing argument to get write access to the internal state of the random generator. * a-nudira.ads: Make Generator a derived type of System.Random_Numbers.Generator. * a-nudira.adb: Remove use of 'Unrestricted_Access. Put subprograms in alpha order and add headers. * g-mbdira.ads: Change Generator type to be self-referential. * g-mbdira.adb: Remove use of 'Unrestricted_Access. From-SVN: r161215 --- gcc/ada/ChangeLog | 33 ++++++++++++ gcc/ada/a-nudira.adb | 118 +++++++++++++++++++------------------------ gcc/ada/a-nudira.ads | 4 +- gcc/ada/a-nuflra.adb | 70 +++++++++---------------- gcc/ada/a-nuflra.ads | 4 +- gcc/ada/errout.adb | 32 +++++++++++- gcc/ada/erroutc.ads | 7 ++- gcc/ada/exp_ch4.adb | 33 ++++++++++-- gcc/ada/g-mbdira.adb | 42 +++++---------- gcc/ada/g-mbdira.ads | 5 ++ gcc/ada/s-rannum.adb | 86 ++++++++++++++----------------- gcc/ada/s-rannum.ads | 28 +++++----- gcc/ada/sem.adb | 18 ++++++- gcc/ada/sem_ch12.adb | 24 ++++++++- 14 files changed, 287 insertions(+), 217 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 12a741a4b97..a16bc19fbf5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2010-06-22 Robert Dewar + + * errout.adb (Finalize): Set Prev pointers. + (Finalize): Delete continuations for deletion by warnings off(str). + * erroutc.ads: Add Prev pointer to error message structure. + +2010-06-22 Ed Schonberg + + * sem.adb (Do_Unit_And_Dependents): If the spec of the main unit is a + child unit, examine context of parent units to locate instantiated + generics whose bodies may be needed. + * sem_ch12.adb: (Mark_Context): if the enclosing unit does not have a + with_clause for the instantiated generic, examine the context of its + parents, to set Withed_Body flag, so that it can be visited earlier. + * exp_ch4.adb (Expand_N_Op_Not): If this is a VMS operator applied to + an unsigned type, use a type of the proper size for the intermediate + value, to prevent alignment problems on unchecked conversion. + +2010-06-22 Geert Bosch + + * s-rannum.ads Change Generator type to be self-referential to allow + Random to update its argument. Use "in" mode for the generator in the + Reset procedures to allow them to be called from the Ada.Numerics + packages without tricks. + * s-rannum.adb: Use the self-referencing argument to get write access + to the internal state of the random generator. + * a-nudira.ads: Make Generator a derived type of + System.Random_Numbers.Generator. + * a-nudira.adb: Remove use of 'Unrestricted_Access. + Put subprograms in alpha order and add headers. + * g-mbdira.ads: Change Generator type to be self-referential. + * g-mbdira.adb: Remove use of 'Unrestricted_Access. + 2010-06-22 Robert Dewar * freeze.adb: Minor reformatting diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb index d352418efcc..ca81ba51895 100644 --- a/gcc/ada/a-nudira.adb +++ b/gcc/ada/a-nudira.adb @@ -29,80 +29,66 @@ -- -- ------------------------------------------------------------------------------ -with System.Random_Numbers; use System.Random_Numbers; - package body Ada.Numerics.Discrete_Random is - ------------------------- - -- Implementation Note -- - ------------------------- + package SRN renames System.Random_Numbers; + use SRN; - -- The design of this spec is a bit awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution would be to add a self-referential component to the generator - -- allowing access to the generator object from inside the function. This - -- would work because the generator is limited, which prevents any copy. + ----------- + -- Image -- + ----------- - -- This is a bit heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - subtype Rep_Generator is System.Random_Numbers.Generator; - subtype Rep_State is System.Random_Numbers.State; - - function Rep_Random is - new Random_Discrete (Result_Subtype, Result_Subtype'First); - - function Random (Gen : Generator) return Result_Subtype is + function Image (Of_State : State) return String is begin - return Rep_Random (Gen.Rep); - end Random; - - procedure Reset - (Gen : Generator; - Initiator : Integer) - is - G : Rep_Generator renames Gen.Rep'Unrestricted_Access.all; - begin - Reset (G, Initiator); - end Reset; - - procedure Reset (Gen : Generator) is - G : Rep_Generator renames Gen.Rep'Unrestricted_Access.all; - begin - Reset (G); - end Reset; - - procedure Save - (Gen : Generator; - To_State : out State) - is - begin - Save (Gen.Rep, State (To_State)); - end Save; - - procedure Reset - (Gen : Generator; - From_State : State) - is - G : Rep_Generator renames Gen.Rep'Unrestricted_Access.all; - begin - Reset (G, From_State); - end Reset; - - function Image (Of_State : State) return String is - begin - return Image (Rep_State (Of_State)); + return Image (SRN.State (Of_State)); end Image; - function Value (Coded_State : String) return State is - G : Generator; - S : Rep_State; + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Result_Subtype is + function Random is + new SRN.Random_Discrete (Result_Subtype, Result_Subtype'First); begin - Reset (G.Rep, Coded_State); - System.Random_Numbers.Save (G.Rep, S); - return State (S); + return Random (SRN.Generator (Gen)); + end Random; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator) is + begin + Reset (SRN.Generator (Gen)); + end Reset; + + procedure Reset (Gen : Generator; Initiator : Integer) is + begin + Reset (SRN.Generator (Gen), Initiator); + end Reset; + + procedure Reset (Gen : Generator; From_State : State) is + begin + Reset (SRN.Generator (Gen), SRN.State (From_State)); + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + Save (SRN.Generator (Gen), SRN.State (To_State)); + end Save; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + begin + return State (SRN.State'(Value (Coded_State))); end Value; end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads index 03ce48b38b4..385f33619f3 100644 --- a/gcc/ada/a-nudira.ads +++ b/gcc/ada/a-nudira.ads @@ -66,9 +66,7 @@ package Ada.Numerics.Discrete_Random is private - type Generator is limited record - Rep : System.Random_Numbers.Generator; - end record; + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb index 0c62f0fea4b..2c6fbc47f6d 100644 --- a/gcc/ada/a-nuflra.adb +++ b/gcc/ada/a-nuflra.adb @@ -29,29 +29,19 @@ -- -- ------------------------------------------------------------------------------ -with Interfaces; use Interfaces; - -with System.Random_Numbers; use System.Random_Numbers; - package body Ada.Numerics.Float_Random is - ------------------------- - -- Implementation Note -- - ------------------------- + package SRN renames System.Random_Numbers; + use SRN; - -- The design of this spec is a bit awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution would be to add a self-referential component to the generator - -- allowing access to the generator object from inside the function. This - -- would work because the generator is limited, which prevents any copy. + ----------- + -- Image -- + ----------- - -- This is a bit heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - subtype Rep_Generator is System.Random_Numbers.Generator; - subtype Rep_State is System.Random_Numbers.State; + function Image (Of_State : State) return String is + begin + return Image (SRN.State (Of_State)); + end Image; ------------ -- Random -- @@ -59,35 +49,32 @@ package body Ada.Numerics.Float_Random is function Random (Gen : Generator) return Uniformly_Distributed is begin - return Random (Gen.Rep); + return Random (SRN.Generator (Gen)); end Random; ----------- -- Reset -- ----------- - -- Version that works from given initiator value - - procedure Reset (Gen : Generator; Initiator : Integer) is - G : Rep_Generator renames Gen.Rep'Unrestricted_Access.all; - begin - Reset (G, Integer_32 (Initiator)); - end Reset; - -- Version that works from calendar procedure Reset (Gen : Generator) is - G : Rep_Generator renames Gen.Rep'Unrestricted_Access.all; begin - Reset (G); + Reset (SRN.Generator (Gen)); + end Reset; + + -- Version that works from given initiator value + + procedure Reset (Gen : Generator; Initiator : Integer) is + begin + Reset (SRN.Generator (Gen), Initiator); end Reset; -- Version that works from specific saved state procedure Reset (Gen : Generator; From_State : State) is - G : Rep_Generator renames Gen.Rep'Unrestricted_Access.all; begin - Reset (G, From_State); + Reset (SRN.Generator (Gen), From_State); end Reset; ---------- @@ -96,28 +83,19 @@ package body Ada.Numerics.Float_Random is procedure Save (Gen : Generator; To_State : out State) is begin - Save (Gen.Rep, State (To_State)); + Save (SRN.Generator (Gen), To_State); end Save; - ----------- - -- Image -- - ----------- - - function Image (Of_State : State) return String is - begin - return Image (Rep_State (Of_State)); - end Image; - ----------- -- Value -- ----------- function Value (Coded_State : String) return State is - G : Generator; - S : Rep_State; + G : SRN.Generator; + S : SRN.State; begin - Reset (G.Rep, Coded_State); - System.Random_Numbers.Save (G.Rep, S); + Reset (G, Coded_State); + Save (G, S); return State (S); end Value; diff --git a/gcc/ada/a-nuflra.ads b/gcc/ada/a-nuflra.ads index 9f8308121bb..5a448a7811e 100644 --- a/gcc/ada/a-nuflra.ads +++ b/gcc/ada/a-nuflra.ads @@ -65,9 +65,7 @@ package Ada.Numerics.Float_Random is private - type Generator is limited record - Rep : System.Random_Numbers.Generator; - end record; + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index bb25564f084..935bc5857d1 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -881,6 +881,7 @@ package body Errout is Errors.Append ((Text => new String'(Msg_Buffer (1 .. Msglen)), Next => No_Error_Msg, + Prev => No_Error_Msg, Sptr => Sptr, Optr => Optr, Sfile => Get_Source_File_Index (Sptr), @@ -1215,6 +1216,16 @@ package body Errout is F : Error_Msg_Id; begin + -- Set Prev pointers + + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + exit when Nxt = No_Error_Msg; + Errors.Table (Nxt).Prev := Cur; + Cur := Nxt; + end loop; + -- Eliminate any duplicated error messages from the list. This is -- done after the fact to avoid problems with Change_Error_Text. @@ -1239,11 +1250,28 @@ package body Errout is while Cur /= No_Error_Msg loop if not Errors.Table (Cur).Deleted and then Warning_Specifically_Suppressed - (Errors.Table (Cur).Sptr, - Errors.Table (Cur).Text) + (Errors.Table (Cur).Sptr, Errors.Table (Cur).Text) then Errors.Table (Cur).Deleted := True; Warnings_Detected := Warnings_Detected - 1; + + -- If this is a continuation, delete previous messages + + F := Cur; + while Errors.Table (F).Msg_Cont loop + F := Errors.Table (F).Prev; + Errors.Table (F).Deleted := True; + end loop; + + -- Delete any following continuations + + F := Cur; + loop + F := Errors.Table (F).Next; + exit when F = No_Error_Msg; + exit when not Errors.Table (F).Msg_Cont; + Errors.Table (F).Deleted := True; + end loop; end if; Cur := Errors.Table (Cur).Next; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index f2127deaa39..d7628ed01ca 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -147,6 +147,11 @@ package Erroutc is -- Pointer to next message in error chain. A value of No_Error_Msg -- indicates the end of the chain. + Prev : Error_Msg_Id; + -- Pointer to previous message in error chain. Only set during the + -- Finalize procedure. A value of No_Error_Msg indicates the first + -- message in the chain. + Sfile : Source_File_Index; -- Source table index of source file. In the case of an error that -- refers to a template, always references the original template diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d90b787b70f..4112254bd30 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6905,12 +6905,39 @@ package body Exp_Ch4 is if Is_VMS_Operator (Entity (N)) then declare - LI : constant Entity_Id := RTE (RE_Unsigned_64); + Rtyp : Entity_Id; + Utyp : Entity_Id; + begin + -- If this is a derived type, retrieve original VMS type so that + -- the proper sized type is used for intermediate values. + + if Is_Derived_Type (Typ) then + Rtyp := First_Subtype (Etype (Typ)); + else + Rtyp := Typ; + end if; + + -- The proper unsigned type must have a size compatible with + -- the operand, to prevent misalignment.. + + if RM_Size (Rtyp) <= 8 then + Utyp := RTE (RE_Unsigned_8); + + elsif RM_Size (Rtyp) <= 16 then + Utyp := RTE (RE_Unsigned_16); + + elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then + Utyp := Typ; + + else + Utyp := RTE (RE_Long_Long_Unsigned); + end if; + Rewrite (N, Unchecked_Convert_To (Typ, - (Make_Op_Not (Loc, - Right_Opnd => Unchecked_Convert_To (LI, Right_Opnd (N)))))); + Make_Op_Not (Loc, + Unchecked_Convert_To (Utyp, Right_Opnd (N))))); Analyze_And_Resolve (N, Typ); return; end; diff --git a/gcc/ada/g-mbdira.adb b/gcc/ada/g-mbdira.adb index e7e1c470d67..f5fd4dce60d 100644 --- a/gcc/ada/g-mbdira.adb +++ b/gcc/ada/g-mbdira.adb @@ -35,25 +35,8 @@ with Interfaces; use Interfaces; package body GNAT.MBBS_Discrete_Random is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is a bit awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution would be to add a self-referential component to the generator - -- allowing access to the generator object from inside the function. This - -- would work because the generator is limited, which prevents any copy. - - -- This is a bit heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - package Calendar renames Ada.Calendar; - type Pointer is access all State; - Fits_In_32_Bits : constant Boolean := Rst'Size < 31 or else (Rst'Size = 31 @@ -109,7 +92,7 @@ package body GNAT.MBBS_Discrete_Random is ------------ function Random (Gen : Generator) return Rst is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + S : State renames Gen.Writable.Self.Gen_State; Temp : Int; TF : Flt; @@ -124,21 +107,21 @@ package body GNAT.MBBS_Discrete_Random is -- Continue with computation if non-flat range - Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); - Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); - Temp := Genp.X2 - Genp.X1; + S.X1 := Square_Mod_N (S.X1, S.P); + S.X2 := Square_Mod_N (S.X2, S.Q); + Temp := S.X2 - S.X1; -- Following duplication is not an error, it is a loop unwinding! if Temp < 0 then - Temp := Temp + Genp.Q; + Temp := Temp + S.Q; end if; if Temp < 0 then - Temp := Temp + Genp.Q; + Temp := Temp + S.Q; end if; - TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl; + TF := Offs + (Flt (Temp) * Flt (S.P) + Flt (S.X1)) * S.Scl; -- Pathological, but there do exist cases where the rounding implicit -- in calculating the scale factor will cause rounding to 'Last + 1. @@ -160,7 +143,7 @@ package body GNAT.MBBS_Discrete_Random is ----------- procedure Reset (Gen : Generator; Initiator : Integer) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + S : State renames Gen.Writable.Self.Gen_State; X1, X2 : Int; begin @@ -174,7 +157,7 @@ package body GNAT.MBBS_Discrete_Random is -- Eliminate effects of small Initiators - Genp.all := + S := (X1 => X1, X2 => X2, P => K1, @@ -188,7 +171,7 @@ package body GNAT.MBBS_Discrete_Random is ----------- procedure Reset (Gen : Generator) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + S : State renames Gen.Writable.Self.Gen_State; Now : constant Calendar.Time := Calendar.Clock; X1 : Int; X2 : Int; @@ -210,7 +193,7 @@ package body GNAT.MBBS_Discrete_Random is X2 := Square_Mod_N (X2, K2); end loop; - Genp.all := + S := (X1 => X1, X2 => X2, P => K1, @@ -225,9 +208,8 @@ package body GNAT.MBBS_Discrete_Random is ----------- procedure Reset (Gen : Generator; From_State : State) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; begin - Genp.all := From_State; + Gen.Writable.Self.Gen_State := From_State; end Reset; ---------- diff --git a/gcc/ada/g-mbdira.ads b/gcc/ada/g-mbdira.ads index c29667e1a0b..c415a24cfcf 100644 --- a/gcc/ada/g-mbdira.ads +++ b/gcc/ada/g-mbdira.ads @@ -111,7 +111,12 @@ private Scl : Flt := Scal; end record; + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments Gen_State : State; end record; diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index 87408c30804..5065910eb39 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -95,21 +95,6 @@ use Ada; package body System.Random_Numbers is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is a bit awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution would be to add a self-referential component to the generator - -- allowing access to the generator object from inside the function. This - -- would work because the generator is limited, which prevents any copy. - - -- This is a bit heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - Y2K : constant Calendar.Time := Calendar.Time_Of (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); @@ -168,7 +153,7 @@ package body System.Random_Numbers is -- Local Subprograms -- ----------------------- - procedure Init (Gen : out Generator; Initiator : Unsigned_32); + procedure Init (Gen : Generator; Initiator : Unsigned_32); -- Perform a default initialization of the state of Gen. The resulting -- state is identical for identical values of Initiator. @@ -192,7 +177,7 @@ package body System.Random_Numbers is ------------ function Random (Gen : Generator) return Unsigned_32 is - G : Generator renames Gen'Unrestricted_Access.all; + G : Generator renames Gen.Writable.Self.all; Y : State_Val; I : Integer; -- should avoid use of identifier I ??? @@ -498,23 +483,23 @@ package body System.Random_Numbers is -- Reset -- ----------- - procedure Reset (Gen : out Generator) is + procedure Reset (Gen : Generator) is X : constant Unsigned_32 := Unsigned_32 ((Calendar.Clock - Y2K) * 64.0); begin Init (Gen, X); end Reset; - procedure Reset (Gen : out Generator; Initiator : Integer_32) is + procedure Reset (Gen : Generator; Initiator : Integer_32) is begin Init (Gen, To_Unsigned (Initiator)); end Reset; - procedure Reset (Gen : out Generator; Initiator : Unsigned_32) is + procedure Reset (Gen : Generator; Initiator : Unsigned_32) is begin Init (Gen, Initiator); end Reset; - procedure Reset (Gen : out Generator; Initiator : Integer) is + procedure Reset (Gen : Generator; Initiator : Integer) is begin pragma Warnings (Off, "condition is always *"); -- This is probably an unnecessary precaution against future change, but @@ -539,27 +524,27 @@ package body System.Random_Numbers is pragma Warnings (On, "condition is always *"); end Reset; - procedure Reset (Gen : out Generator; Initiator : Initialization_Vector) is + procedure Reset (Gen : Generator; Initiator : Initialization_Vector) is + G : Generator renames Gen.Writable.Self.all; I, J : Integer; begin - Init (Gen, Seed1); + Init (G, Seed1); I := 1; J := 0; if Initiator'Length > 0 then for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop - Gen.S (I) := - (Gen.S (I) - xor ((Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) - * Mult1)) + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult1)) + Initiator (J + Initiator'First) + Unsigned_32 (J); I := I + 1; J := J + 1; if I >= N then - Gen.S (0) := Gen.S (N - 1); + G.S (0) := G.S (N - 1); I := 1; end if; @@ -570,39 +555,42 @@ package body System.Random_Numbers is end if; for K in reverse 1 .. N - 1 loop - Gen.S (I) := - (Gen.S (I) xor ((Gen.S (I - 1) - xor Shift_Right (Gen.S (I - 1), 30)) * Mult2)) + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult2)) - Unsigned_32 (I); I := I + 1; if I >= N then - Gen.S (0) := Gen.S (N - 1); + G.S (0) := G.S (N - 1); I := 1; end if; end loop; - Gen.S (0) := Upper_Mask; + G.S (0) := Upper_Mask; end Reset; - procedure Reset (Gen : out Generator; From_State : Generator) is + procedure Reset (Gen : Generator; From_State : Generator) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.S := From_State.S; - Gen.I := From_State.I; + G.S := From_State.S; + G.I := From_State.I; end Reset; - procedure Reset (Gen : out Generator; From_State : State) is + procedure Reset (Gen : Generator; From_State : State) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.I := 0; - Gen.S := From_State; + G.I := 0; + G.S := From_State; end Reset; - procedure Reset (Gen : out Generator; From_Image : String) is + procedure Reset (Gen : Generator; From_Image : String) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.I := 0; + G.I := 0; for J in 0 .. N - 1 loop - Gen.S (J) := Extract_Value (From_Image, J); + G.S (J) := Extract_Value (From_Image, J); end loop; end Reset; @@ -670,17 +658,18 @@ package body System.Random_Numbers is -- Init -- ---------- - procedure Init (Gen : out Generator; Initiator : Unsigned_32) is + procedure Init (Gen : Generator; Initiator : Unsigned_32) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.S (0) := Initiator; + G.S (0) := Initiator; for I in 1 .. N - 1 loop - Gen.S (I) := - Mult0 * (Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) + - Unsigned_32 (I); + G.S (I) := + (G.S (I - 1) xor Shift_Right (G.S (I - 1), 30)) * Mult0 + + Unsigned_32 (I); end loop; - Gen.I := 0; + G.I := 0; end Init; ------------------ @@ -706,5 +695,4 @@ package body System.Random_Numbers is begin return State_Val'Value (S (Start .. Start + Image_Numeral_Length - 1)); end Extract_Value; - end System.Random_Numbers; diff --git a/gcc/ada/s-rannum.ads b/gcc/ada/s-rannum.ads index c61d86b94c6..b7031d47c6f 100644 --- a/gcc/ada/s-rannum.ads +++ b/gcc/ada/s-rannum.ads @@ -88,27 +88,27 @@ package System.Random_Numbers is -- in Reset). In general, there is little point in providing more than -- a certain number of values (currently 624). - procedure Reset (Gen : out Generator); + procedure Reset (Gen : Generator); -- Re-initialize the state of Gen from the time of day - procedure Reset (Gen : out Generator; Initiator : Initialization_Vector); - procedure Reset (Gen : out Generator; Initiator : Interfaces.Integer_32); - procedure Reset (Gen : out Generator; Initiator : Interfaces.Unsigned_32); - procedure Reset (Gen : out Generator; Initiator : Integer); + procedure Reset (Gen : Generator; Initiator : Initialization_Vector); + procedure Reset (Gen : Generator; Initiator : Interfaces.Integer_32); + procedure Reset (Gen : Generator; Initiator : Interfaces.Unsigned_32); + procedure Reset (Gen : Generator; Initiator : Integer); -- Re-initialize Gen based on the Initiator in various ways. Identical -- values of Initiator cause identical sequences of values. - procedure Reset (Gen : out Generator; From_State : Generator); + procedure Reset (Gen : Generator; From_State : Generator); -- Causes the state of Gen to be identical to that of From_State; Gen -- and From_State will produce identical sequences of values subsequently. - procedure Reset (Gen : out Generator; From_State : State); + procedure Reset (Gen : Generator; From_State : State); procedure Save (Gen : Generator; To_State : out State); -- The sequence -- Save (Gen2, S); Reset (Gen1, S) -- has the same effect as Reset (Gen2, Gen1). - procedure Reset (Gen : out Generator; From_Image : String); + procedure Reset (Gen : Generator; From_Image : String); function Image (Gen : Generator) return String; -- The call -- Reset (Gen2, Image (Gen1)) @@ -135,11 +135,15 @@ private subtype State_Val is Interfaces.Unsigned_32; type State is array (0 .. N - 1) of State_Val; - type Generator is limited record - S : State := (others => 0); - -- The shift register, a circular buffer + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type - I : Integer := N; + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + S : State := (others => 0); + -- The shift register, a circular buffer + I : Integer := N; -- Current starting position in shift register S (N means uninitialized) end record; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 8a9628e6c08..71989ada4d2 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1728,7 +1728,9 @@ package body Sem is procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is Unit_Num : constant Unit_Number_Type := - Get_Cunit_Unit_Number (CU); + Get_Cunit_Unit_Number (CU); + Child : Node_Id; + Parent_CU : Node_Id; procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); @@ -1758,6 +1760,20 @@ package body Sem is if CU = Library_Unit (Main_CU) then Process_Bodies_In_Context (CU); + + -- If main is a child unit, examine context of parent + -- units to see if they include instantiated units. + + if Is_Child_Unit (Cunit_Entity (Main_Unit)) then + Child := Cunit_Entity (Main_Unit); + while Is_Child_Unit (Child) loop + Parent_CU := + Cunit + (Get_Cunit_Entity_Unit_Number (Scope (Child))); + Process_Bodies_In_Context (Parent_CU); + Child := Scope (Child); + end loop; + end if; end if; Do_Action (CU, Item); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index cfb08c8f0ef..1f28f9d544f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2598,7 +2598,7 @@ package body Sem_Ch12 is then Error_Msg_N ("premature usage of incomplete type", Def); - elsif Is_Internal (Designated_Type (T)) then + elsif not Is_Entity_Name (Subtype_Indication (Def)) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; @@ -10396,6 +10396,7 @@ package body Sem_Ch12 is procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id) is Inst_CU : constant Unit_Number_Type := Get_Code_Unit (Inst_Decl); Gen_CU : constant Unit_Number_Type := Get_Source_Unit (Gen_Decl); + Inst : Entity_Id := Cunit_Entity (Inst_CU); Clause : Node_Id; begin @@ -10410,10 +10411,31 @@ package body Sem_Ch12 is and then Library_Unit (Clause) = Cunit (Gen_CU) then Set_Withed_Body (Clause, Cunit (Gen_CU)); + return; end if; Next (Clause); end loop; + + -- If the with-clause for the generic unit was not found, it must + -- appear in some ancestor of the current unit. + + while Is_Child_Unit (Inst) loop + Inst := Scope (Inst); + Clause := + First (Context_Items (Parent (Unit_Declaration_Node (Inst)))); + + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then Library_Unit (Clause) = Cunit (Gen_CU) + then + Set_Withed_Body (Clause, Cunit (Gen_CU)); + return; + end if; + + Next (Clause); + end loop; + end loop; end Mark_Context; ---------------------