Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / exp_aggr.adb < prev next >

Wrap

Text File | 1996-09-28 | 47KB | 1,409 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ A G G R -- -- -- -- B o d y -- -- -- -- $Revision: 1.17 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Exp_Util; use Exp_Util; with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; with Itypes; use Itypes; with Nmake; use Nmake; with Nlists; use Nlists; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch5; use Sem_Ch5; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; with System.Parameters; package body Exp_Aggr is ----------------------------------------------------- -- Subprogram Specs for RECORD AGGREGATE Expansion -- ----------------------------------------------------- procedure Expand_Record_Aggregate (N : Node_Id; Orig_Tag : Node_Id := Empty; Parent_Expr : Node_Id := Empty); -- This is the top level procedure for record aggregate expansion. -- Expansion for record aggregates needs expand aggregates for tagged -- record types. Specifically Expand_Record_Aggregate adds the Tag -- field in front of the Component_Association list that was created -- during resolution by Resolve_Record_Aggregate. -- * N is the record aggregate node. -- * Orig_Tag is the value of the Tag that has to be provided for this -- specific aggregate. It carries the tag corresponding to the type -- of the outermost aggregate during the recursive expansion -- * Parent_Expr is the ancestor part of the original extension -- aggregate procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); -- N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of -- the aggregate. Transodrm the given aggregate into a buch of assignment -- component per component ---------------------------------------------------- -- Subprogram Specs for ARRAY AGGREGATE Expansion -- ---------------------------------------------------- procedure Expand_Array_Aggregate (N : Node_Id); -- This is the top-level routine to perform array aggregate expansion. -- -- N is the N_Aggregate node to be expanded. -- -- Array aggregate expansion proceeds as follows: -- -- 1. If requested we generate code to perform all the array aggregate -- bound checks, specifically -- -- (a) Check that the index range defined by aggregate bounds is -- compatible with corresponding index subtype. -- -- (b) If an others choice is present check that no aggregate -- index is outside the bounds of the index constraint. -- -- (c) For multidimensional arrays make sure that all subaggregates -- corresponding to the same dimension have the same bounds. -- -- 2. Check if the aggregate can be statically processed. If this is the -- case pass it as is to Gigi. Note that a necessary condition for -- static processing is that the aggregate be fully positional. -- -- 3. If in place aggregate expansion is possible (i.e. no need to create -- a temporary) then mark the aggregate as such and return. Otherwise -- create a new temporary and generate the appropriate initialization -- code. function Static_Processing_Possible (N : Node_Id; Index : Node_Id; Max_Size : Pos := System.Parameters.Max_Static_Aggregate_Size) return Boolean; -- This function checks if it possible to build a fully positional array -- aggregate at compile time. If this is possible True is returned. -- -- N is the N_Aggregate node to be checked. -- -- Index is the index node corresponding to the array sub-aggregate that -- we are currently checking. -- -- Max_Size is the maximum size allowed for a static aggregate. -- -- Static processing for the whole array aggregate is possible only if: -- -- 1. N is fully positional and its size is no greater than Max_Size; -- -- 2. No index type in N is an enumeration type with non-standard -- representation. function Is_Empty (Typ : Entity_Id) return Boolean; -- Returns true if constrained array subtype Typ defines an empty array. function In_Place_Copy_Possible (N : Node_Id; Dim : Pos) return Boolean; -- This routine return True if aggregate N can be directly copied into the -- target array. For the time being this is allowed only if all of N's -- components are static expressions, but can (and should) be extended -- for expressions involving names as well, but no function calls or -- arrays. -- -- N is an array aggregate or sub-aggregate to be rewritten. -- -- Dim is the number of sub-aggregate dimension we still need to look at. function Build_Code (N : Node_Id; Index : Node_Id; Into : Entity_Id; Indices : List_Id := No_List) return List_Id; -- This recursive routine returns a list of statements containing the -- loops and assignments that are needed for the expansion of the array -- aggregate N. -- -- N is the (sub-)aggregate node to be expanded into code. -- -- Index is the index node corresponding to the array sub-aggregate N. -- -- Into is the object into which we are copying the aggregate. -- -- Indices is the current list of expressions used to index the -- object we are writing into. -- -- The code that we generate from a one dimensional aggregate is -- -- 1. If the sub-aggregate contains discrete choices we -- (A) Sort the discrete choices -- (B) Otherwise for each discrete choices that specifies a range we -- emit a loop. If a range specifies a single value, or we are -- dealing with an expression we emit an assignment. -- (C) Generate the remaning loops to cover the others choice if any. -- -- 2. If the aggregate contains positional elements we -- (A) translate the positional elements in a series of assignments. -- (B) Generate a final loop to cover the others choice if any. -- Note that this final loop has to be a while loop since the case -- L : Integer := Integer'Last; -- H : Integer := Integer'Last; -- A : array (L .. H) := (1, others =>0); -- cannot be handled by a for loop. Thus for the following -- array (L .. H) := (.. positional elements.., others =>E); -- we always generate something like: -- I : Index_Type := Index_Of_Last_Positional_Element; -- while I < H loop -- I := Index_Base'Succ (I) -- Tmp (I) := E; -- end loop; function Number_Of_Choices (N : Node_Id) return Nat; -- Returns the number of discrete choices (not including the others choice -- if present) contained in (sub-)aggregate N. ------------------------ -- Expand_N_Aggregate -- ------------------------ procedure Expand_N_Aggregate (N : Node_Id) is begin if Is_Record_Type (Etype (N)) then Expand_Record_Aggregate (N); else Expand_Array_Aggregate (N); end if; end Expand_N_Aggregate; ---------------------------- -- Convert_To_Assignments -- ---------------------------- procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is Actions : List_Id := New_List; Comp : Node_Id; Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Instr : Node_Id; begin if Is_Controlled (Typ) then Establish_Transient_Scope (N); elsif Has_Controlled (Typ) then Unimplemented (N, "aggregate with controlled components"); return; end if; -- Create the temporary Instr := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Typ, Loc)); Set_No_Default_Init (Instr); Insert_Action (N, Instr); -- Deal with the ancestor part of extension aggregates if Nkind (N) = N_Extension_Aggregate then declare A : constant Node_Id := Ancestor_Part (N); begin -- if the ancestor part is a subtype mark "T", we generate -- _init_proc (T(tmp)); if Is_Entity_Name (A) and then Is_Type (Entity (A)) then Insert_Actions (N, Build_Initialization_Call (Loc, Id_Ref => Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Entity (A), Loc), Expression => New_Occurrence_Of (Temp, Loc)), Typ => Entity (A), In_Init_Proc => Chars (Current_Scope) = Name_uInit_Proc)); -- if the ancestor part is an expression "E", we generate -- T(tmp) := E; else Instr := Make_Assignment_Statement (Loc, Name => Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (A), Loc), Expression => New_Occurrence_Of (Temp, Loc)), Expression => A); Set_Assignment_OK (Name (Instr)); Insert_Action (N, Instr); end if; end; end if; -- Attach the temporary to the final list when needed if Is_Controlled (Typ) then Insert_Action (N, Make_Attach_Call ( Obj_Ref => New_Occurrence_Of (Temp, Loc), Flist_Ref => Find_Final_List (Current_Scope))); end if; -- Generate the assignments, component per component Comp := First (Component_Associations (N)); while Present (Comp) loop Instr := Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Temp, Loc), Selector_Name => New_Occurrence_Of (Entity (First (Choices (Comp))), Loc)), Expression => Expression (Comp)); Set_Assignment_OK (Name (Instr)); Insert_Action (N, Instr); Comp := Next (Comp); end loop; -- if the type is tagged, the tag needs to be initialized if Is_Tagged_Type (Typ) then Instr := Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Temp, Loc), Selector_Name => New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)), Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Tag), Loc), Expression => New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc))); Set_Assignment_OK (Name (Instr)); Insert_Action (N, Instr); end if; Rewrite_Substitute_Tree (N, New_Occurrence_Of (Temp, Loc)); Analyze (N); Resolve (N, Typ); end Convert_To_Assignments; ---------------------------------- -- Expand_N_Extension_Aggregate -- ---------------------------------- -- If the ancestor part is an expression, add a component association for -- the parent field. If the type of the ancestor part is not the direct -- parent of the expected type, build recursively the needed ancestors. -- If the ancestor part is a subtype_mark, replace aggregate with a decla- -- ration for a temporary of the expected type, followed by individual -- assignments to the given components. procedure Expand_N_Extension_Aggregate (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); A : constant Node_Id := Ancestor_Part (N); Typ : constant Entity_Id := Etype (N); begin -- Gigi doesn't handle properly temporaries of variable size -- so we generate it in the front-end if not Size_Known_At_Compile_Time (Typ) then Convert_To_Assignments (N, Typ); -- temporaries for controlled aggregates need to be attached to a -- final chain in order to be properly finalized, so it has to -- be created in the front-end elsif Is_Controlled (Typ) or else Has_Controlled (Base_Type (Typ)) then Convert_To_Assignments (N, Typ); -- If the ancestor is a subtype mark, an init_proc must be called -- on the resulting object which thus has to be materialized in -- the front-end elsif Is_Entity_Name (A) and then Is_Type (Entity (A)) then Convert_To_Assignments (N, Typ); -- The extension aggregate is transformed into a record aggregate -- of the following form (c1 and c2 are inherited components) -- (Exp with c3 => a, c4 => b) -- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b) else Rewrite_Substitute_Tree (N, Make_Aggregate (Loc, Component_Associations => Component_Associations (N))); Set_Etype (N, Typ); Expand_Record_Aggregate (N, Orig_Tag => New_Occurrence_Of (Access_Disp_Table (Typ), Loc), Parent_Expr => A); end if; end Expand_N_Extension_Aggregate; ----------------------------- -- Expand_Record_Aggregate -- ----------------------------- procedure Expand_Record_Aggregate (N : Node_Id; Orig_Tag : Node_Id := Empty; Parent_Expr : Node_Id := Empty) is Loc : constant Source_Ptr := Sloc (N); Comps : constant List_Id := Component_Associations (N); Typ : Entity_Id := Etype (N); Tag_Value : Node_Id; Comp : Entity_Id; New_Comp : Node_Id; begin -- Gigi doesn't handle properly temporaries of variable size -- so we generate it in the front-end if not Size_Known_At_Compile_Time (Typ) then Convert_To_Assignments (N, Typ); -- Temporaries for controlled aggregates need to be attached to a -- final chain in order to be properly finalized, so it has to -- be created in the front-end elsif Is_Controlled (Typ) or else Has_Controlled (Base_Type (Typ)) then Convert_To_Assignments (N, Typ); -- in all other cases we generate a proper static aggregate that -- can be handled by gigi. In the tagged case, the _parent and -- _tag component need to be created elsif Is_Tagged_Type (Typ) then -- When the current aggregate comes from the expansion of an -- extension aggregate, the parent expr is replaced by an -- aggregate formed by selected components of this expr if Present (Parent_Expr) and then Is_Empty_List (Comps) then Comp := First_Entity (Typ); while Present (Comp) loop -- Skip all entities that are not discriminants or components if Ekind (Comp) not in Object_Kind then null; -- Skip all expander-generated components elsif not Comes_From_Source (Original_Record_Component (Comp)) then null; else New_Comp := Make_Selected_Component (Loc, Prefix => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Typ, Loc), Expression => Duplicate_Subexpr (Parent_Expr, True)), Selector_Name => New_Occurrence_Of (Comp, Loc)); Append_To (Comps, Make_Component_Association (Loc, Choices => New_List (New_Occurrence_Of (Comp, Loc)), Expression => New_Comp)); Analyze (New_Comp); Resolve (New_Comp, Etype (Comp)); end if; Comp := Next_Entity (Comp); end loop; end if; -- Compute the value for the Tag now, if the type is a root it -- will be included in the aggregatge right away, othewise it will -- be propagated to the parent aggregate if Present (Orig_Tag) then Tag_Value := Orig_Tag; else Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc); end if; -- For a derived type, an aggregate for the parent is formed with -- all the inherited components if Is_Derived_Type (Typ) then declare First_Comp : Node_Id; Parent_Comps : List_Id; Parent_Aggr : Node_Id; Parent_Name : Node_Id; begin -- Remove the inherited component association from the -- aggregate and store them in the parent aggregate First_Comp := First (Component_Associations (N)); Parent_Comps := New_List; while Present (First_Comp) and then Scope (Entity (First (Choices (First_Comp)))) /= Typ loop Comp := First_Comp; First_Comp := Next (First_Comp); Remove (Comp); Append (Comp, Parent_Comps); end loop; Parent_Aggr := Make_Aggregate (Loc, Component_Associations => Parent_Comps); Set_Etype (Parent_Aggr, Etype (Base_Type (Typ))); -- Find the _parent component Comp := First_Component (Typ); while Chars (Comp) /= Name_uParent loop Comp := Next_Component (Comp); end loop; Parent_Name := New_Occurrence_Of (Comp, Loc); -- Insert the parent aggregate Prepend_To (Component_Associations (N), Make_Component_Association (Loc, Choices => New_List (Parent_Name), Expression => Parent_Aggr)); -- Expand recursively the parent propagating the right Tag Expand_Record_Aggregate (Parent_Aggr, Tag_Value, Parent_Expr); end; -- For a root type, the tag component is added else declare Tag_Name : constant Node_Id := New_Occurrence_Of (Tag_Component (Typ), Loc); Typ_Tag : constant Entity_Id := RTE (RE_Tag); Conv_Node : constant Node_Id := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Typ_Tag, Loc), Expression => Tag_Value); begin Set_Etype (Conv_Node, Typ_Tag); Prepend_To (Component_Associations (N), Make_Component_Association (Loc, Choices => New_List (Tag_Name), Expression => Conv_Node)); end; end if; end if; end Expand_Record_Aggregate; ---------------------------- -- Expand_Array_Aggregate -- ---------------------------- procedure Expand_Array_Aggregate (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); -- Typ is the correct constrained array subtype of the aggregate. Aggr_Dimension : constant Pos := Number_Dimensions (Typ); -- Number of aggregate index dimensions. Tmp : Entity_Id; -- Holds the temporary aggregate value. Tmp_Decl : Node_Id; -- Holds the declaration of Tmp. New_Aggr : Node_Id; Aggr_Code : List_Id; begin -- If during semantic analysis it has been determined that aggreagte N -- will raise Constraint_Error at run-time, then the aggregate node -- has been replaced with an N_Raise_Constraint_Error node and we -- should never get here. pragma Assert (not Raises_Constraint_Error (N)); -- STEP 1. -- Aggregate consistency checks and bound evaluations should -- be performed here.??? -- STEP 2. -- ??? For now, static processing is never possible for packed array -- ??? aggregates, this must be fixed later on if Static_Processing_Possible (N, First_Index (Typ)) and then not Is_Packed (Typ) then return; end if; -- STEP 3. -- If the aggregate defines an empty array not much to do if Is_Empty (Typ) then null; -- ??? FOR NOW -- then look if in place aggregate expansion is possible elsif In_Place_Copy_Possible (N, Aggr_Dimension) then null; -- ??? FOR NOW end if; -- If we got here then in place aggregate expansion is impossible. -- We need to create a temporary. -- Create the declaration but don't initialize it by default Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Tmp_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Tmp, Object_Definition => New_Occurrence_Of (Typ, Loc), No_Default_Init => True); Insert_Action (N, Tmp_Decl); -- Construct and insert the aggregate code. We can safely suppress -- index checks because this code is guaranteed not to raise CE -- on index checks. However we should *not* suppress all checks. Aggr_Code := Build_Code (N, First_Index (Typ), Into => Tmp); Insert_Actions (N, Aggr_Code, Suppress => All_Checks); Rewrite_Substitute_Tree (N, New_Reference_To (Tmp, Loc)); Analyze (N); Resolve (N, Typ); end Expand_Array_Aggregate; ----------------------- -- Number_Of_Choices -- ----------------------- function Number_Of_Choices (N : Node_Id) return Nat is Assoc : Node_Id; Choice : Node_Id; Nb_Choices : Nat := 0; begin if Present (Expressions (N)) then return 0; end if; Assoc := First (Component_Associations (N)); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) /= N_Others_Choice then Nb_Choices := Nb_Choices + 1; end if; Choice := Next (Choice); end loop; Assoc := Next (Assoc); end loop; return Nb_Choices; end Number_Of_Choices; -------------------------------- -- Static_Processing_Possible -- -------------------------------- function Static_Processing_Possible (N : Node_Id; Index : Node_Id; Max_Size : Pos := System.Parameters.Max_Static_Aggregate_Size) return Boolean is Expr : Node_Id; Size : Pos; Index_Typ : constant Entity_Id := Etype (Index); begin -- No static processing if index subtype is enumeration type with holes -- ??? temporary expedient to get some of these aggregates correct if Is_Enumeration_Type (Index_Typ) and then Present (Enum_Pos_To_Rep (Base_Type (Index_Typ))) then return False; end if; -- If component associations no static processing possible if Present (Component_Associations (N)) then return False; end if; -- Count the number of positional expressions Expr := First (Expressions (N)); while Present (Expr) loop Size := Max_Size - 1; if Size < 0 then return False; elsif Present (Next_Index (Index)) and then not Static_Processing_Possible (Expr, Next_Index (Index), Size) then return False; end if; Expr := Next (Expr); end loop; return True; end Static_Processing_Possible; -------------- -- Is_Empty -- -------------- function Is_Empty (Typ : Entity_Id) return Boolean is begin return False; end Is_Empty; ---------------------------- -- In_Place_Copy_Possible -- ---------------------------- function In_Place_Copy_Possible (N : Node_Id; Dim : Pos) return Boolean is function Static_Expression_Not_Raising_CE (E : Node_Id) return Boolean; -- Returns true if E is a static expression whose evaluation is -- guaranteed not to raise a Constraint_Error. -------------------------------------- -- Static_Expression_Not_Raising_CE -- -------------------------------------- function Static_Expression_Not_Raising_CE (E : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (E); Low : Node_Id; High : Node_Id; begin if not Is_OK_Static_Expression (E) then return False; else Low := Type_Low_Bound (Typ); High := Type_High_Bound (Typ); if not Is_OK_Static_Expression (Low) or else Is_OK_Static_Expression (High) then return False; end if; end if; end Static_Expression_Not_Raising_CE; -- Variables local to In_Place_Copy_Possible Assoc : Node_Id; Expr : Node_Id; -- Begin of In_Place_Copy_Possible begin -- ??? For now just return return False; -- Process positional components if Present (Expressions (N)) then Expr := First (Expressions (N)); while Present (Expr) loop if Dim > 1 and then not In_Place_Copy_Possible (Expr, Dim - 1) then return False; elsif not Static_Expression_Not_Raising_CE (Expr) then return False; end if; Expr := Next (Expr); end loop; end if; -- Process component associations if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop Expr := Expression (Assoc); if Dim > 1 and then not In_Place_Copy_Possible (Expr, Dim - 1) then return False; elsif not Static_Expression_Not_Raising_CE (Expr) then return False; end if; Assoc := Next (Assoc); end loop; end if; return True; end In_Place_Copy_Possible; ---------------- -- Build_Code -- ---------------- function Build_Code (N : Node_Id; Index : Node_Id; Into : Entity_Id; Indices : List_Id := No_List) return List_Id is Loc : constant Source_Ptr := Sloc (N); Index_Base : constant Entity_Id := Base_Type (Etype (Index)); Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); function Add (Val : Int; To : Node_Id) return Node_Id; -- Returns an expression where Val is added to expression To, -- unless To+Val is provably out of To's base type range. -- To must be an already analyzed expression. function Empty_Range (L, H : Node_Id) return Boolean; -- Returns True if the range defined by L .. H is certainly empty. function Equal (L, H : Node_Id) return Boolean; -- Returns True if L = H for sure. function Index_Base_Name return Node_Id; -- Returns a new reference to the index type name. function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id; -- Ind must be a side-effect free expression. -- If the input aggregate N to Build_Loop contains no sub-aggregates, -- This routine returns the assignment statement -- -- Into (Indices, Ind) := Expr; -- -- Otherwise we call Build_Code recursively. function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id; -- Nodes L and H must be side-effect free expressions. -- If the input aggregate N to Build_Loop contains no sub-aggregates, -- This routine returns the for loop statement -- -- for I in Index_Base range L .. H loop -- Into (Indices, I) := Expr; -- end loop; -- -- Otherwise we call Build_Code recursively. function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id; -- Nodes L and H must be side-effect free expressions. -- If the input aggregate N to Build_Loop contains no sub-aggregates, -- This routine returns the while loop statement -- -- I : Index_Base := L; -- while I < H loop -- I := Index_Base'Succ (I); -- Into (Indices, I) := Expr; -- end loop; -- -- Otherwise we call Build_Code recursively. --------- -- Add -- --------- function Add (Val : Int; To : Node_Id) return Node_Id is Expr_Pos : Node_Id; Expr : Node_Id; To_Pos : Node_Id; U_To : Uint; U_Val : Uint := UI_From_Int (Val); begin if Val = 0 then return Duplicate_Subexpr (To); end if; -- First test if we can do constant folding if Is_OK_Static_Expression (To) then U_To := Expr_Value (To) + Val; -- Determine if our constant is outside the range of the index. -- If so return an Empty node. This empty node will be caught -- by Empty_Range below. if Is_OK_Static_Expression (Index_Base_L) and then U_To < Expr_Value (Index_Base_L) then return Empty; elsif Is_OK_Static_Expression (Index_Base_H) and then U_To > Expr_Value (Index_Base_H) then return Empty; end if; Expr_Pos := Make_Integer_Literal (Loc, U_To); if not Is_Enumeration_Type (Index_Base) then Expr := Expr_Pos; -- If we are dealing with enumeration return -- Index_Base'Val (Expr_Pos) else Expr := Make_Attribute_Reference (Loc, Prefix => Index_Base_Name, Attribute_Name => Name_Val, Expressions => New_List (Expr_Pos)); end if; return Expr; end if; -- If we are here no constant folding possible if not Is_Enumeration_Type (Index_Base) then Expr := Make_Op_Add (Loc, Left_Opnd => Duplicate_Subexpr (To), Right_Opnd => Make_Integer_Literal (Loc, U_Val)); -- If we are dealing with enumeration return -- Index_Base'Val (Index_Base'Pos (To) + Val) else To_Pos := Make_Attribute_Reference (Loc, Prefix => Index_Base_Name, Attribute_Name => Name_Pos, Expressions => New_List (Duplicate_Subexpr (To))); Expr_Pos := Make_Op_Add (Loc, Left_Opnd => To_Pos, Right_Opnd => Make_Integer_Literal (Loc, U_Val)); Expr := Make_Attribute_Reference (Loc, Prefix => Index_Base_Name, Attribute_Name => Name_Val, Expressions => New_List (Expr_Pos)); end if; return Expr; end Add; ----------------- -- Empty_Range -- ----------------- function Empty_Range (L, H : Node_Id) return Boolean is Is_Empty : Boolean := False; Low : Node_Id; High : Node_Id; begin -- First check if L or H were already detected as overflowing the -- index base range type by function Add above. If this is so Add -- returns the empty node. if No (L) or else No (H) then return True; end if; for I in 1 .. 3 loop case I is -- L > H range is empty when 1 => Low := L; High := H; -- B_L > H range must be empty when 2 => Low := Index_Base_L; High := H; -- L > B_H range must be empty when 3 => Low := L; High := Index_Base_H; end case; if Is_OK_Static_Expression (Low) and then Is_OK_Static_Expression (High) then Is_Empty := UI_Gt (Expr_Value (Low), Expr_Value (High)); end if; exit when Is_Empty; end loop; return Is_Empty; end Empty_Range; ----------- -- Equal -- ----------- function Equal (L, H : Node_Id) return Boolean is begin if L = H then return True; elsif Is_OK_Static_Expression (L) and then Is_OK_Static_Expression (H) then return UI_Eq (Expr_Value (L), Expr_Value (H)); end if; return False; end Equal; --------------------- -- Index_Base_Name -- --------------------- function Index_Base_Name return Node_Id is begin return New_Reference_To (Index_Base, Sloc (N)); end Index_Base_Name; ---------------- -- Gen_Assign -- ---------------- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is A : Node_Id; L : List_Id; New_Indices : List_Id; Indexed_Comp : Node_Id; begin if No (Indices) then New_Indices := New_List; else New_Indices := New_List_Copy_Tree (Indices); end if; Append_To (New_Indices, Ind); if Present (Next_Index (Index)) then return Build_Code (Expr, Next_Index (Index), Into, New_Indices); end if; -- If we get here then we are at a bottom-level (sub-)aggregate Indexed_Comp := Make_Indexed_Component (Loc, Prefix => New_Reference_To (Into, Loc), Expressions => New_Indices); A := Make_Assignment_Statement (Loc, Name => Indexed_Comp, Expression => New_Copy_Tree (Expr)); L := New_List; Append_To (L, A); return L; end Gen_Assign; -------------- -- Gen_Loop -- -------------- function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is -- The loop built is -- for L_I in Index_Base range L .. H loop -- L_Body; -- end loop; L_I : Node_Id; L_Range : Node_Id; -- L .. H L_Discrete_Subtype_Def : Node_Id; -- Index_Base range L .. H L_Iteration_Scheme : Node_Id; -- L_I in Index_Base range L .. H L_Body : List_Id; -- The statements to execute in the loop S : List_Id := New_List; -- list of statement begin -- If loop bounds define an empty range return the null statement if Empty_Range (L, H) then Append_To (S, Make_Null_Statement (Loc)); return S; end if; -- If loop bounds are the same then generate an assignment if Equal (L, H) then return Gen_Assign (New_Copy_Tree (L), Expr); end if; -- construct the loop index L_I L_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); -- contruct "L .. H" L_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H); -- construct "Index_Base range in L .. H" L_Discrete_Subtype_Def := Make_Subtype_Indication (Loc, Subtype_Mark => Index_Base_Name, Constraint => Make_Range_Constraint (Loc, L_Range)); -- construct "for L_I in Index_Base range in L .. H" L_Iteration_Scheme := Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => L_I, Discrete_Subtype_Definition => L_Discrete_Subtype_Def)); -- Construct the statements to execute in the loop body L_Body := Gen_Assign (New_Reference_To (L_I, Loc), Expr); -- construct the final loop Append_To (S, Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => L_Iteration_Scheme, Statements => L_Body)); return S; end Gen_Loop; --------------- -- Gen_While -- --------------- function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is -- The code built is -- W_I : Index_Base := L; -- while W_I < H loop -- W_I := Index_Base'Succ (W); -- L_Body; -- end loop; W_I : Node_Id; W_Decl : Node_Id; -- W_I : Base_Type := L; W_Iteration_Scheme : Node_Id; -- while W_I < H W_Index_Succ : Node_Id; -- Index_Base'Succ (I) W_Increment : Node_Id; -- W_I := Index_Base'Succ (W) W_Body : List_Id := New_List; -- The statements to execute in the loop S : List_Id := New_List; -- list of statement begin -- If loop bounds define an empty range or are equal return null if Empty_Range (L, H) or else Equal (L, H) then Append_To (S, Make_Null_Statement (Loc)); return S; end if; -- Build the decl of W_I W_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); W_Decl := Make_Object_Declaration (Loc, Defining_Identifier => W_I, Object_Definition => Index_Base_Name, Expression => L); -- Theoretically we should do a New_Copy_Tree (L) here, but we know -- that in this particular case L is a fresh Expr generated by -- Add which we are the only ones to use. Append_To (S, W_Decl); -- construct " while W_I < H" W_Iteration_Scheme := Make_Iteration_Scheme (Loc, Condition => Make_Op_Lt (Loc, Left_Opnd => New_Reference_To (W_I, Loc), Right_Opnd => New_Copy_Tree (H))); -- Construct the statements to execute in the loop body W_Index_Succ := Make_Attribute_Reference (Loc, Prefix => Index_Base_Name, Attribute_Name => Name_Succ, Expressions => New_List (New_Reference_To (W_I, Loc))); W_Increment := Make_Assignment_Statement (Loc, Name => New_Reference_To (W_I, Loc), Expression => W_Index_Succ); Append_To (W_Body, W_Increment); Append_List_To (W_Body, Gen_Assign (New_Reference_To (W_I, Loc), Expr)); -- construct the final loop Append_To (S, Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => W_Iteration_Scheme, Statements => W_Body)); return S; end Gen_While; -- Build_Code Variables Assoc : Node_Id; Choice : Node_Id; Expr : Node_Id; Others_Expr : Node_Id := Empty; Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); -- The aggregate bounds of this specific sub-aggregate. -- Note that if the code generated by Build_Code is executed then these -- bouds are OK. Otherwise a Constraint_Error would have been raised. Aggr_Low : constant Node_Id := Duplicate_Subexpr (Aggr_L); Aggr_High : constant Node_Id := Duplicate_Subexpr (Aggr_H); -- After Duplicate_Subexpr these are side-effect free. Low : Node_Id; High : Node_Id; Nb_Choices : Nat := 0; Table : Case_Table_Type (1 .. Number_Of_Choices (N)); -- Used to sort all the different choice values Nb_Elements : Int; -- Number of elements in the positional aggegate New_Code : List_Id := New_List; -- Build_Code begins here begin -- STEP 1: Process component associations if No (Expressions (N)) then -- STEP 1 (A): Sort the discrete choices Assoc := First (Component_Associations (N)); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then Others_Expr := Expression (Assoc); exit; end if; Get_Index_Bounds (Choice, Low, High); Nb_Choices := Nb_Choices + 1; Table (Nb_Choices) := (Choice_Lo => Low, Choice_Hi => High, Choice_Node => Expression (Assoc)); Choice := Next (Choice); end loop; Assoc := Next (Assoc); end loop; -- If there is more than one set of choices these must be static -- and we can therefore sort them. Remeber that Nb_Choices does not -- account for an others choice. if Nb_Choices > 1 then Sort_Case_Table (Table); end if; -- STEP 1 (B): take care of the whole set of discrete choices. for I in 1 .. Nb_Choices loop Low := Table (I).Choice_Lo; High := Table (I).Choice_Hi; Expr := Table (I).Choice_Node; Append_List (Gen_Loop (Low, High, Expr), To => New_Code); end loop; -- STEP 1 (D): generate the remaning loops to cover others choice if Present (Others_Expr) then for I in 0 .. Nb_Choices loop if I = 0 then Low := Aggr_Low; else Low := Add (1, To => Table (I).Choice_Hi); end if; if I = Nb_Choices then High := Aggr_High; else High := Add (-1, To => Table (I + 1).Choice_Lo); end if; Append_List (Gen_Loop (Low, High, Others_Expr), To => New_Code); end loop; end if; -- STEP 2: Process positional components else -- STEP 2 (A): Generate the assignments for each positional element -- Note that here we have to use Aggr_L rather than Aggr_Low because -- Aggr_L is analyzed and Add wants an analyzed expression. Expr := First (Expressions (N)); Nb_Elements := -1; while Present (Expr) loop Nb_Elements := Nb_Elements + 1; Append_List (Gen_Assign (Add (Nb_Elements, To => Aggr_L), Expr), To => New_Code); Expr := Next (Expr); end loop; -- STEP 2 (B): Generate final loop if an others choice is present -- Here Nb_Elements gives the offset of the last positional element. if Present (Component_Associations (N)) then Assoc := Last (Component_Associations (N)); Expr := Expression (Assoc); Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L), Aggr_High, Expr), To => New_Code); end if; end if; return New_Code; end Build_Code; end Exp_Aggr;