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_ch3.adb < prev next >

Wrap

Text File | 1996-09-28 | 110KB | 3,070 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.243 $ -- -- -- -- 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 Elists; use Elists; with Exp_Ch4; use Exp_Ch4; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; with Exp_Disp; use Exp_Disp; with Exp_Pakd; use Exp_Pakd; with Exp_TSS; use Exp_TSS; with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Snames; use Snames; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; with Urealp; use Urealp; package body Exp_Ch3 is ------------------------ -- Local Subprograms -- ------------------------ procedure Build_Array_Init_Proc (A_Type : Entity_Id); -- Build initialization procedure for given array type function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id; -- This function uses the discriminants of a type to build a list of -- formal parameters, used in the following function. If the flag Use_D1 -- is set, the list is built using the already defined discriminals -- of the type. Otherwise new identifiers are created, with the source -- names of the discriminants. procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); -- If the designated type of an access type is a task type or contains -- tasks, we make sure that a _Master variable is declared in the current -- scope, and then declare a renaming for it: -- -- atypeM : Master_Id renames _Master; -- -- where atyp is the name of the access type. This declaration is -- used when an allocator for the access type is expanded. procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); -- Build record initialization procedure. params ??? procedure Build_Variant_Record_Equality (Typ : Entity_Id); -- Create An Equality function for the non-tagged variant record 'Typ' -- and attach it to the TSS list procedure Expand_Tagged_Root (T : Entity_Id); -- Add a field _Tag at the beginning of the record. This field carries -- the value of the access to the Dispatch table. This procedure is only -- called on root (non CPP_Class) types, the _Tag field being inherited -- by the descendants. procedure Expand_Record_Controller (T : Entity_Id); -- T must be a record type that Has_Controlled. Add a field _C of type -- Record_Controller or Limited_Record_Controller in the record T. procedure Freeze_Array_Type (N : Node_Id); -- Freeze an array type. Deals with building the initialization procedure, -- creating the packed array type for a packed array and also with the -- creation of the controlling procedures for the controlled case. procedure Freeze_Enumeration_Type (N : Node_Id); -- Freeze enumeration type with non-standard representation. Builds the -- array and function needed to convert between enumeration pos and -- enumeration representation values. N is the N_Freeze_Entity node. procedure Freeze_Fixed_Point_Type (N : Node_Id); -- Freeze fixed point type. N is the N_Freeze_Entity node. function Init_Formals (Typ : Entity_Id) return List_Id; -- This function builds the list of formals for an initialization routine. -- The first formal is always _Init with the given type. For task value -- record types and types containing tasks, two additional formals are -- added: -- -- _Master : Master_Id -- _Chain : in out Activation_Chain -- -- The caller must append additional entries for discriminants if required. function In_Runtime (E : Entity_Id) return Boolean; -- Check if E is defined in the RTL (in a child of Ada or System). -- Used to avoid to bring in the overhead of _Input, _Output for tagged -- types function Make_Eq_Case (Loc : Source_Ptr; CL : Node_Id) return List_Id; -- Building block for variant record equality. Defined to share the -- code between the tagged and non-tagged case. Given a Component_List -- node CL, it generates a 'if' followed by a 'case' statement that -- compares all components of 'X' and 'Y' (that are supposed to be -- formals at some upper level) function Make_Eq_If (Loc : Source_Ptr; L : List_Id) return Node_Id; -- Building block for variant record equality. Defined to share the -- code between the tagged and non-tagged case. Given the list of -- components (or discriminants) L, it generates a 'if' statement that -- compares all components of 'X' and 'Y' (that are supposed to be -- formals at some upper level) function Predef_Spec (Loc : Source_Ptr; Tag_Typ : Entity_Id; Name : Name_Id; Profile : List_Id; Ret_Type : Entity_Id := Empty; For_Body : Boolean := False) return Node_Id; -- Shortcut function that generate the appropriate expansion for a -- predefined primitive specified by its name, profile and return -- type (Empty means this is a procedure). For_Body controls if -- a specification for a declaration or a body is generated. function Predef_Stream_IO_Spec (Loc : Source_Ptr; Tag_Typ : Entity_Id; Name : Name_Id; For_Body : Boolean := False) return Node_Id; -- Specialized version of Predef_Spec that apply to _read, _write, -- _input and _output which have the same kind of spec function Predef_Deep_Spec (Loc : Source_Ptr; Tag_Typ : Entity_Id; Name : Name_Id; For_Body : Boolean := False) return Node_Id; -- Specialized version of Predef_Spec that apply to _deep_adjust and -- _deep_finalize function Predefined_Primitive_Bodies (Tag_Typ : Entity_Id) return List_Id; -- Create the bodies of the predefined primitives that are described in -- Predefined_Primitive_Specs function Predefined_Primitive_Specs (Tag_Typ : Entity_Id) return List_Id; -- Create a list with the specs of the predefined primitive operations. -- This list contains _Size, _Read, _Write, _Input and _Output for -- every tagged types, plus _equality, _assign, _deep_finalize and -- _deep_adjust for non limited tagged types. _Size, _Read, _Write, -- _Input and _Output implement the corresponding attributes that need -- to be dispatching when their arguments are classwide. _equality and -- _assign, implement equality and assignment that also must be -- dispatching. _Deep_Finalize and _Deep_Adjust are empty procedures -- unless the type contains some controlled components that require -- finalization actions ---------------------------- -- Build_Array_Init_Proc -- ---------------------------- procedure Build_Array_Init_Proc (A_Type : Entity_Id) is Comp_Type : constant Entity_Id := Component_Type (A_Type); Loc : constant Source_Ptr := Sloc (A_Type); Index_List : List_Id; Proc_Id : Entity_Id; Proc_Body : Node_Id; function Init_Component return List_Id; -- Create one statement to initialize one array component, designated -- by a full set of indices. function Init_One_Dimension (N : Int) return List_Id; -- Create loop to initialize one dimension of the array. The single -- statement in the body of the loop initializes the inner dimensions if -- any,or else a single component. -------------------- -- Init_Component -- -------------------- function Init_Component return List_Id is Comp : Node_Id; begin Comp := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Expressions => Index_List); if Is_Access_Type (Comp_Type) then return New_List ( Make_Assignment_Statement (Loc, Name => Comp, Expression => Make_Null (Loc))); elsif Is_Private_Type (Comp_Type) and then Is_Access_Type (Underlying_Type (Comp_Type)) then return New_List ( Make_Assignment_Statement (Loc, Name => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To ( Underlying_Type (Comp_Type), Loc), Expression => Comp), Expression => Make_Null (Loc))); else return Build_Initialization_Call (Loc, Comp, Comp_Type, True); end if; end Init_Component; ------------------------ -- Init_One_Dimension -- ------------------------ function Init_One_Dimension (N : Int) return List_Id is Index : Entity_Id; begin if N > Number_Dimensions (A_Type) then return Init_Component; else Index := Make_Defining_Identifier (Loc, New_External_Name ('X', N)); Append (New_Reference_To (Index, Loc), Index_List); return New_List ( Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => Index, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, UI_From_Int (N)))))), Statements => Init_One_Dimension (N + 1))); end if; end Init_One_Dimension; -- Start of processing for Build_Array_Init_Proc begin Index_List := New_List; if Present (Base_Init_Proc (Comp_Type)) or else Is_Access_Type (Comp_Type) or else (Is_Private_Type (Comp_Type) and then Is_Access_Type (Underlying_Type (Comp_Type))) or else Has_Tasks (Comp_Type) then Proc_Id := Make_Defining_Identifier (Loc, Name_uInit_Proc); Proc_Body := Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc_Id, Parameter_Specifications => Init_Formals (A_Type)), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Init_One_Dimension (1))); Set_Init_Proc (A_Type, Proc_Id); Set_Ekind (Proc_Id, E_Procedure); Set_Is_Public (Proc_Id, Is_Public (A_Type)); Set_Is_Inlined (Proc_Id); Set_Is_Internal (Proc_Id); Set_Has_Completion (Proc_Id); end if; end Build_Array_Init_Proc; ------------------------------------ -- Build_Variant_Record_Equality -- ------------------------------------ -- Generates: -- -- function _Equality (X, Y : T) return Boolean is -- begin -- -- -- Compare discriminants -- -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then -- return False; -- end if; -- -- -- Compare components -- -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then -- return False; -- end if; -- -- -- Compare variant part -- -- case X.D1 is -- when V1 => -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then -- return False; -- end if; -- ... -- when Vn => -- if False or else X.Cn /= Y.Cn then -- return False; -- end if; -- end case; -- return True; -- end _Equality; procedure Build_Variant_Record_Equality (Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (Typ); F : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uEquality); X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X); Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y); Def : constant Node_Id := Parent (Typ); Comps : constant Node_Id := Component_List (Type_Definition (Def)); Function_Body : Node_Id; Stmts : List_Id := New_List; begin Function_Body := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => F, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => X, Parameter_Type => New_Reference_To (Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Y, Parameter_Type => New_Reference_To (Typ, Loc))), Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); Append_To (Stmts, Make_Eq_If (Loc, Discriminant_Specifications (Def))); Append_List_To (Stmts, Make_Eq_Case (Loc, Comps)); Append_To (Stmts, Make_Return_Statement (Loc, New_Reference_To (Standard_True, Loc))); Set_TSS (Typ, F); end Build_Variant_Record_Equality; ------------------ -- Make_Eq_Case -- ------------------ -- <Make_Eq_if shared components> -- case X.D1 is -- when V1 => <Make_Eq_Case> on subcomponents -- ... -- when Vn => <Make_Eq_Case> on subcomponents -- end case; function Make_Eq_Case (Loc : Source_Ptr; CL : Node_Id) return List_Id is Variant : Node_Id; Alt_List : List_Id; Result : List_Id := New_List; begin Append_To (Result, Make_Eq_If (Loc, Component_Items (CL))); if No (Variant_Part (CL)) then return Result; end if; Variant := First (Variants (Variant_Part (CL))); if No (Variant) then return Result; end if; Alt_List := New_List; while Present (Variant) loop Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List_Copy (Discrete_Choices (Variant)), Statements => Make_Eq_Case (Loc, Component_List (Variant)))); Variant := Next (Variant); end loop; Append_To (Result, Make_Case_Statement (Loc, Expression => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_X), Selector_Name => New_Copy (Name (Variant_Part (CL)))), Alternatives => Alt_List)); return Result; end Make_Eq_Case; ---------------- -- Make_Eq_If -- ---------------- -- if False -- or else X.C1 /= Y.C1 -- or else X.C2 /= Y.C2 -- ... -- then -- return False; -- end if; function Make_Eq_If (Loc : Source_Ptr; L : List_Id) return Node_Id is C : Node_Id; Field : Entity_Id; Expr : Node_Id; begin if No (L) then return Make_Null_Statement (Loc); else C := First (L); if No (C) then return Make_Null_Statement (Loc); end if; end if; Expr := New_Reference_To (Standard_False, Loc); while Present (C) loop if Nkind (C) /= N_Pragma then Field := Defining_Identifier (C); -- Note that in the following, we use Make_Identifier for the -- component names. Use of New_Reference_To to identify the -- components would be incorrect because the wrong entities -- for discriminants could be picked up in the private type case. Expr := Make_Or_Else (Loc, Left_Opnd => Expr, Right_Opnd => Make_Op_Ne (Loc, Left_Opnd => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_X), Selector_Name => Make_Identifier (Loc, Chars (Field))), Right_Opnd => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Y), Selector_Name => Make_Identifier (Loc, Chars (Field))))); end if; C := Next (C); end loop; return Make_If_Statement (Loc, Condition => Expr, Then_Statements => New_List ( Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_False, Loc)))); end Make_Eq_If; -------------------------------- -- Build_Discriminant_Formals -- -------------------------------- function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id is D : Entity_Id; Formal : Entity_Id; Loc : constant Source_Ptr := Sloc (Rec_Id); Param_Spec_Node : Node_Id; Parameter_List : List_Id := New_List; begin if Has_Discriminants (Rec_Id) then D := First_Discriminant (Rec_Id); while Present (D) loop if Use_Dl then Formal := Discriminal (D); else Formal := Make_Defining_Identifier (Loc, Chars (D)); end if; Param_Spec_Node := Make_Parameter_Specification (Loc, Defining_Identifier => Formal, Parameter_Type => New_Reference_To (Etype (D), Loc)); Append (Param_Spec_Node, Parameter_List); D := Next_Discriminant (D); end loop; end if; return Parameter_List; end Build_Discriminant_Formals; -------------------------------- -- Build_Discr_Checking_Funcs -- -------------------------------- procedure Build_Discr_Checking_Funcs (N : Node_Id) is Rec_Id : Entity_Id; Loc : Source_Ptr; Enclosing_Func_Id : Entity_Id; Insertion_Node : Node_Id := N; Sequence : Nat := 1; Type_Def : Node_Id; V : Node_Id; function Build_Case_Statement (Case_Id : Entity_Id; Variant : Node_Id) return Node_Id; -- TBSL need documentation for this spec function Build_Function (Case_Id : Entity_Id; Variant : Node_Id) return Entity_Id; -- Build the discriminant checking function for a given variant procedure Build_Functions (Variant_Part_Node : Node_Id); -- Builds the discriminant checking function for each variant of the -- given variant part of the record type. function Build_Case_Statement (Case_Id : Entity_Id; Variant : Node_Id) return Node_Id is Actuals_List : List_Id; Alt_List : List_Id := New_List; Case_Node : Node_Id; Case_Alt_Node : Node_Id; Choice : Node_Id; Choice_List : List_Id; D : Entity_Id; Return_Node : Node_Id; begin -- Build a case statement containing only two alternatives. The -- first alternative corresponds exactly to the discrete choices -- given on the variant with contains the components that we are -- generating the checks for. If the discriminant is one of these -- return False. The other alternative consists of the choice -- "Others" and will return True indicating the discriminant did -- not match. Case_Node := New_Node (N_Case_Statement, Loc); -- Replace the discriminant which controls the variant, with the -- name of the formal of the checking function. Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id))); Choice := First (Discrete_Choices (Variant)); if Nkind (Choice) = N_Others_Choice then Choice_List := New_List_Copy (Others_Discrete_Choices (Choice)); else Choice_List := New_List_Copy (Discrete_Choices (Variant)); end if; if not Is_Empty_List (Choice_List) then Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); Set_Discrete_Choices (Case_Alt_Node, Choice_List); -- In case this is a nested variant, we need to return the result -- of the discriminant checking function for the immediately -- enclosing variant. if Present (Enclosing_Func_Id) then Actuals_List := New_List; D := First_Discriminant (Rec_Id); while Present (D) loop Append (Make_Identifier (Loc, Chars (D)), Actuals_List); D := Next_Discriminant (D); end loop; Return_Node := Make_Return_Statement (Loc, Expression => Make_Function_Call (Loc, Name => New_Reference_To (Enclosing_Func_Id, Loc), Parameter_Associations => Actuals_List)); else Return_Node := Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_False, Loc)); end if; Set_Statements (Case_Alt_Node, New_List (Return_Node)); Append (Case_Alt_Node, Alt_List); end if; Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); Choice_List := New_List (New_Node (N_Others_Choice, Loc)); Set_Discrete_Choices (Case_Alt_Node, Choice_List); Return_Node := Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc)); Set_Statements (Case_Alt_Node, New_List (Return_Node)); Append (Case_Alt_Node, Alt_List); Set_Alternatives (Case_Node, Alt_List); return Case_Node; end Build_Case_Statement; function Build_Function (Case_Id : Entity_Id; Variant : Node_Id) return Entity_Id is Body_Node : Node_Id; Func_Id : Entity_Id; Parameter_List : List_Id; Spec_Node : Node_Id; begin Body_Node := New_Node (N_Subprogram_Body, Loc); Sequence := Sequence + 1; Func_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); Spec_Node := New_Node (N_Function_Specification, Loc); Set_Defining_Unit_Name (Spec_Node, Func_Id); Parameter_List := Build_Discriminant_Formals (Rec_Id, False); Set_Parameter_Specifications (Spec_Node, Parameter_List); Set_Subtype_Mark (Spec_Node, New_Reference_To (Standard_Boolean, Loc)); Set_Specification (Body_Node, Spec_Node); Set_Declarations (Body_Node, New_List); Set_Handled_Statement_Sequence (Body_Node, Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Build_Case_Statement (Case_Id, Variant)))); Set_Ekind (Func_Id, E_Function); Set_Is_Inlined (Func_Id); Set_Is_Pure (Func_Id); Set_Is_Public (Func_Id, Is_Public (Rec_Id)); Set_Is_Internal (Func_Id); Insert_After (Insertion_Node, Body_Node); Insertion_Node := Body_Node; Analyze (Body_Node); return Func_Id; end Build_Function; procedure Build_Functions (Variant_Part_Node : Node_Id) is Component_List_Node : Node_Id; Decl : Entity_Id; Discr_Name : Entity_Id; Func_Id : Entity_Id; Variant : Node_Id; Saved_Enclosing_Func_Id : Entity_Id; begin -- Build the discriminant checking function for each variant, label -- all components of that variant with the function's name. Discr_Name := Entity (Name (Variant_Part_Node)); Variant := First (Variants (Variant_Part_Node)); while Present (Variant) loop Func_Id := Build_Function (Discr_Name, Variant); Component_List_Node := Component_List (Variant); if not Null_Present (Component_List_Node) then Decl := First (Component_Items (Component_List_Node)); while Present (Decl) loop if Nkind (Decl) /= N_Pragma then Set_Discriminant_Checking_Func (Defining_Identifier (Decl), Func_Id); end if; Decl := Next (Decl); end loop; if Present (Variant_Part (Component_List_Node)) then Saved_Enclosing_Func_Id := Enclosing_Func_Id; Enclosing_Func_Id := Func_Id; Build_Functions (Variant_Part (Component_List_Node)); Enclosing_Func_Id := Saved_Enclosing_Func_Id; end if; end if; Variant := Next (Variant); end loop; end Build_Functions; -- Start of processing for Build_Discr_Checking_Funcs begin Type_Def := Type_Definition (N); pragma Assert (Nkind (Type_Def) = N_Record_Definition or else Nkind (Type_Def) = N_Derived_Type_Definition); if Nkind (Type_Def) = N_Record_Definition then if No (Component_List (Type_Def)) then -- null record. return; else V := Variant_Part (Component_List (Type_Def)); end if; else -- Nkind (Type_Def) = N_Derived_Type_Definition if No (Component_List (Record_Extension_Part (Type_Def))) then return; else V := Variant_Part (Component_List (Record_Extension_Part (Type_Def))); end if; end if; if Present (V) then Loc := Sloc (N); Enclosing_Func_Id := Empty; Rec_Id := Defining_Identifier (N); Build_Functions (V); end if; end Build_Discr_Checking_Funcs; ---------------------------- -- Build_Record_Init_Proc -- ---------------------------- procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Proc_Id : Entity_Id; Rec_Type : Entity_Id; -------------------------------------------------- -- Local Subprograms for Build_Record_Init_Proc -- -------------------------------------------------- function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; -- Build a assignment statement node which assigns to record -- component its default expression if defined. The left hand side -- of the assignment is marked Assignment_OK so that initialization -- of limited private records works correctly, Return also the -- adjustment call for controlled objects procedure Build_Discriminant_Assignments (Statement_List : List_Id); -- If the record has discriminants, adds assignment statements to -- statement list to initialize the discriminant values from the -- arguments of the initialization procedure. function Build_Init_Statements (Comp_List : Node_Id) return List_Id; -- Build a list representing a sequence of statements which initialize -- components of the given component list. This may involve building -- case statements for the variant parts. procedure Build_Init_Procedure; -- Build the tree corresponding to the procedure specification and body -- of the initialization procedure (by calling all the preceding -- auxillary routines), and install it as the _init TSS. function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; -- Determines whether a record initialization procedure needs to be -- generated for the given record type. ---------------------- -- Build_Assignment -- ---------------------- function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is Lhs : Node_Id; Typ : constant Entity_Id := Underlying_Type (Etype (Id)); Res : List_Id; begin Lhs := Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => New_Occurrence_Of (Id, Loc)); Set_Assignment_OK (Lhs); Res := New_List ( Make_Assignment_Statement (Loc, Name => Lhs, Expression => N)); -- Adjust the tag if tagged if Is_Tagged_Type (Typ) then Append_To (Res, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => New_Copy_Tree (Lhs), Selector_Name => New_Reference_To (Tag_Component (Typ), Loc)), Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Tag), Loc), Expression => New_Reference_To (Access_Disp_Table (Typ), Loc)))); end if; -- Adjust the component if controlled if Controlled_Type (Typ) then Append_List_To (Res, Make_Adjust_Call ( Ref => New_Copy_Tree (Lhs), Typ => Typ, Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (Lhs)), With_Attach => New_Reference_To (Standard_True, Loc))); end if; return Res; end Build_Assignment; --------------------------- -- Build_Init_Statements -- --------------------------- function Build_Init_Statements (Comp_List : Node_Id) return List_Id is Alt_List : List_Id; Statement_List : List_Id; Stmts : List_Id; Decl : Node_Id; Variant : Node_Id; Id : Entity_Id; Typ : Entity_Id; begin if Null_Present (Comp_List) then return New_List (Make_Null_Statement (Loc)); end if; Statement_List := New_List; -- Loop through components, skipping pragmas Decl := First (Component_Items (Comp_List)); while Present (Decl) loop if Nkind (Decl) /= N_Pragma then Id := Defining_Identifier (Decl); Typ := Etype (Id); if Present (Expression (Decl)) then Stmts := Build_Assignment (Id, Expression (Decl)); elsif Is_Access_Type (Typ) then Stmts := Build_Assignment (Id, Make_Null (Loc)); elsif Present (Base_Init_Proc (Typ)) then Stmts := Build_Initialization_Call (Loc, Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => New_Occurrence_Of (Id, Loc)), Typ, True); -- If the type is private and has no Base_Init_Proc, its full -- declaration can be an access type which must be initialized -- unless they are Tags or Vtable_Ptr in which case they are -- initialized by other means elsif Is_Private_Type (Typ) and then Is_Access_Type (Underlying_Type (Typ)) and then Typ /= RTE (RE_Tag) and then Typ /= RTE (RE_Vtable_Ptr) then Stmts := New_List ( Make_Assignment_Statement (Loc, Name => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To ( Underlying_Type (Typ), Loc), Expression => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => New_Occurrence_Of (Id, Loc))), Expression => Make_Null (Loc))); Set_Assignment_OK (Name (First (Stmts))); else Stmts := No_List; end if; -- Some fields have to be initialized early. The record -- Controller is one example. if Present (Stmts) then if Chars (Id) = Name_uController then Append_List_To (Stmts, Statement_List); Statement_List := Stmts; else Append_List_To (Statement_List, Stmts); end if; end if; end if; Decl := Next (Decl); end loop; -- Process the variant part if Present (Variant_Part (Comp_List)) then Alt_List := New_List; Variant := First (Variants (Variant_Part (Comp_List))); while Present (Variant) loop Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List_Copy (Discrete_Choices (Variant)), Statements => Build_Init_Statements (Component_List (Variant)))); Variant := Next (Variant); end loop; -- The expression of the case statement which is a reference -- to one of the discriminants is replaced by the appropriate -- formal parameter of the initialization procedure. Append_To (Statement_List, Make_Case_Statement (Loc, Expression => New_Reference_To (Discriminal ( Entity (Name (Variant_Part (Comp_List)))), Loc), Alternatives => Alt_List)); end if; -- For a task record type, add the task create call and calls -- to bind any interrupt (signal) entries. if Is_Task_Record_Type (Rec_Type) then Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); declare Task_Type : constant Entity_Id := Corresponding_Concurrent_Type (Rec_Type); Task_Decl : constant Node_Id := Parent (Task_Type); Task_Def : constant Node_Id := Task_Definition (Task_Decl); Vis_Decl : Node_Id; Ent : Entity_Id; begin if Present (Task_Def) then Vis_Decl := First (Visible_Declarations (Task_Def)); while Present (Vis_Decl) loop if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then if Get_Attribute_Id (Chars (Vis_Decl)) = Attribute_Address then Ent := Entity (Name (Vis_Decl)); if Ekind (Ent) = E_Entry then Append_To (Statement_List, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To ( RTE (RE_Bind_Signal_To_Entry), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Entry_Index_Expression ( Loc, Ent, Empty, Task_Type), Expression (Vis_Decl)))); end if; end if; end if; Vis_Decl := Next (Vis_Decl); end loop; end if; end; end if; -- For a protected type, add a call to Initialize_Protection. if Is_Protected_Record_Type (Rec_Type) then Append_To (Statement_List, Make_Initialize_Protection_Call (Rec_Type)); end if; -- If no initializations when generated for component declarations -- corresponding to this Statement_List, append a null statement -- to the Statement_List to make it a valid Ada tree. if Is_Empty_List (Statement_List) then Append (New_Node (N_Null_Statement, Loc), Statement_List); end if; return Statement_List; end Build_Init_Statements; -------------------------- -- Build_Init_Procedure -- -------------------------- procedure Build_Init_Procedure is Body_Node : Node_Id; Handled_Stmt_Node : Node_Id; Parameters : List_Id; Proc_Spec_Node : Node_Id; Statement_List : List_Id; Record_Extension_Node : Node_Id; begin Statement_List := New_List; Body_Node := New_Node (N_Subprogram_Body, Loc); Proc_Id := Make_Defining_Identifier (Loc, Name_uInit_Proc); Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); Build_Discriminant_Assignments (Statement_List); Parameters := Init_Formals (Rec_Type); Append_List_To (Parameters, Build_Discriminant_Formals (Rec_Type, True)); Set_Parameter_Specifications (Proc_Spec_Node, Parameters); Set_Specification (Body_Node, Proc_Spec_Node); Set_Declarations (Body_Node, New_List); if Nkind (Type_Definition (N)) = N_Record_Definition then if not Null_Present (Type_Definition (N)) then Append_List_To (Statement_List, Build_Init_Statements ( Component_List (Type_Definition (N)))); end if; else -- N is a Derived_Type_Definition with a possible non-empty -- extension. The initialization of a type extension consists -- in the initialization of the components in the extension. Record_Extension_Node := Record_Extension_Part (Type_Definition (N)); if not Null_Present (Record_Extension_Node) then declare Stmts : List_Id := Build_Init_Statements ( Component_List (Record_Extension_Node)); begin -- The parent field must be initialized first because -- the offset of the new discriminants may depend on it Prepend_To (Statement_List, Remove_Head (Stmts)); Append_List_To (Statement_List, Stmts); end; end if; end if; -- Add here the assignment to instantiate the Tag -- This instantiation is done at the end because the instantiation -- of the _parent field calls the Record_Init_Proc for the parent -- Parent which instantiate the Tag with a wrong value. -- The assignement corresponds to the code: -- _Init._Tag := Typ'Tag; if Is_Tagged_Type (Rec_Type) and then not Is_CPP_Class (Rec_Type) then Append_To (Statement_List, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => New_Reference_To (Tag_Component (Rec_Type), Loc)), Expression => New_Reference_To (Access_Disp_Table (Rec_Type), Loc))); end if; Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); Set_Statements (Handled_Stmt_Node, Statement_List); Set_Exception_Handlers (Handled_Stmt_Node, No_List); Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); Set_Init_Proc (Rec_Type, Proc_Id); end Build_Init_Procedure; ------------------------------------ -- Build_Discriminant_Assignments -- ------------------------------------ procedure Build_Discriminant_Assignments (Statement_List : List_Id) is D : Entity_Id; begin if Has_Discriminants (Rec_Type) then D := First_Discriminant (Rec_Type); while Present (D) loop Append_List_To (Statement_List, Build_Assignment (D, New_Reference_To (Discriminal (D), Loc))); D := Next_Discriminant (D); end loop; end if; end Build_Discriminant_Assignments; ------------------------ -- Requires_Init_Proc -- ------------------------ function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is Comp_Decl : Node_Id; Id : Entity_Id; begin -- An initialization procedure needs to be generated only if at -- least one of the following applies: -- 1. Discriminants are present, since they need to be initialized -- with the appropriate discriminant constraint expressions. -- 2. The type is a tagged type, since the implicit Tag component -- needs to be initialized with a pointer to the dispatch table. -- 3. The type contains tasks -- 4. One or more components has an initial value -- 5. One or more components is for a type which itself requires -- an initialization procedure. -- 6. One or more components is an access type or a private type -- whose full declaration is an access type (which needs to be -- initialized to null). -- 7. The type is the record type built for a task type (since at -- the very least, Create_Task must be called) -- 8. The type is the record type built for a protected type (since -- Initialize_Protection must be called) if Is_CPP_Class (Rec_Id) then return False; elsif Has_Discriminants (Rec_Id) or else Is_Tagged_Type (Rec_Id) or else Is_Concurrent_Record_Type (Rec_Id) or else Has_Tasks (Rec_Id) then return True; end if; Id := First_Component (Rec_Id); while Present (Id) loop Comp_Decl := Parent (Id); if Present (Expression (Comp_Decl)) or else Present (Base_Init_Proc (Etype (Id))) or else Is_Access_Type (Etype (Id)) or else (Is_Private_Type (Etype (Id)) and then Is_Access_Type (Underlying_Type (Etype (Id)))) then return True; end if; Id := Next_Component (Id); end loop; return False; end Requires_Init_Proc; -- Start of processing for Build_Record_Init_Proc begin Rec_Type := Defining_Identifier (N); -- This may be full declaration of a private type, in which case -- the visible entity is a record, and the private entity has been -- exchanged with it in the private part of the current package. -- The initialization procedure is built for the record type, which -- is retrievable from the private entity. if Is_Incomplete_Or_Private_Type (Rec_Type) then Rec_Type := Underlying_Type (Rec_Type); end if; -- Derived types that have no type extension can use the initialization -- procedure of their parent and do not need a procedure of their own. -- This is only correct if there are no representation clauses for the -- type or its parent, and if the parent has in fact been frozen so -- that its initialization procedure exists. if Is_Derived_Type (Rec_Type) and then not Is_Tagged_Type (Rec_Type) and then not Has_Non_Standard_Rep (Rec_Type) and then not Has_Non_Standard_Rep (Root_Type (Rec_Type)) and then Present (Base_Init_Proc (Root_Type (Rec_Type))) then Copy_TSS (Base_Init_Proc (Root_Type (Rec_Type)), Rec_Type); -- Otherwise if we need an initialization procedure, then build one, -- mark it as public and inlinable and as having a completion. elsif Requires_Init_Proc (Rec_Type) then Build_Init_Procedure; Set_Ekind (Proc_Id, E_Procedure); Set_Is_Public (Proc_Id, Is_Public (Pe)); Set_Is_Inlined (Proc_Id); Set_Is_Internal (Proc_Id); Set_Has_Completion (Proc_Id); end if; end Build_Record_Init_Proc; --------------------------- -- Expand_Derived_Record -- --------------------------- -- Add a field _parent at the beginning of the record extension. This is -- used to implement inheritance. Here are some examples of expansion: -- 1. no discriminants -- type T2 is new T1 with null record; -- gives -- type T2 is new T1 with record -- _Parent : T1; -- end record; -- 2. renamed discriminants -- type T2 (B, C : Int) is new T1 (A => B) with record -- _Parent : T1 (A => B); -- D : Int; -- end; -- 3. inherited discriminants -- type T2 is new T1 with record -- discriminant A inherited -- _Parent : T1 (A); -- D : Int; -- end; procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is Indic : constant Node_Id := Subtype_Indication (Def); Loc : constant Source_Ptr := Sloc (Def); Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); Comp_List : Node_Id; Comp_Decl : Node_Id; Parent_N : Node_Id; D : Entity_Id; List_Constr : constant List_Id := New_List; New_Indic : Node_Id; begin -- Expand_Tagged_Extension is called directly from the semantics, so -- we must check to see whether expansion is active before proceeding if not Expander_Active then return; end if; Comp_List := Component_List (Rec_Ext_Part); Parent_N := Make_Defining_Identifier (Loc, Name_uParent); -- If the derived type inherits its discriminants the type of the -- _parent field must be constrained by the inherited discriminants if Has_Discriminants (T) and then Nkind (Indic) /= N_Subtype_Indication and then not Is_Constrained (Entity (Indic)) then D := First_Discriminant (T); while (Present (D)) loop Append_To (List_Constr, New_Occurrence_Of (D, Loc)); D := Next_Discriminant (D); end loop; New_Indic := Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Entity (Indic), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => List_Constr)); -- Otherwise the the original subtype_indication is just what is needed else New_Indic := New_Copy (Indic); end if; Comp_Decl := Make_Component_Declaration (Loc, Defining_Identifier => Parent_N, Subtype_Indication => New_Indic); if Null_Present (Rec_Ext_Part) then Set_Component_List (Rec_Ext_Part, Make_Component_List (Loc, Component_Items => New_List (Comp_Decl), Variant_Part => Empty, Null_Present => False)); Set_Null_Present (Rec_Ext_Part, False); elsif Null_Present (Comp_List) or else Is_Empty_List (Component_Items (Comp_List)) then Set_Component_Items (Comp_List, New_List (Comp_Decl)); Set_Null_Present (Comp_List, False); else Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); end if; end Expand_Derived_Record; ------------------------ -- Expand_Tagged_Root -- ------------------------ procedure Expand_Tagged_Root (T : Entity_Id) is Def : constant Node_Id := Type_Definition (Parent (T)); Comp_List : Node_Id; Comp_Decl : Node_Id; Sloc_N : Source_Ptr; begin if Null_Present (Def) then Set_Component_List (Def, Make_Component_List (Sloc (Def), Component_Items => Empty_List, Variant_Part => Empty, Null_Present => True)); end if; Comp_List := Component_List (Def); if Null_Present (Comp_List) or else Is_Empty_List (Component_Items (Comp_List)) then Sloc_N := Sloc (Comp_List); else Sloc_N := Sloc (First (Component_Items (Comp_List))); end if; Comp_Decl := Make_Component_Declaration (Sloc_N, Defining_Identifier => Tag_Component (T), Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N)); if Null_Present (Comp_List) or else Is_Empty_List (Component_Items (Comp_List)) then Set_Component_Items (Comp_List, New_List (Comp_Decl)); Set_Null_Present (Comp_List, False); else Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); end if; -- We don't Analyze the whole expansion because the tag component has -- already been analyzed previously. Here we just insure that the -- tree is coherent with the semantic decoration Find_Type (Subtype_Indication (Comp_Decl)); end Expand_Tagged_Root; ------------------------------ -- Expand_Record_Controller -- ------------------------------ procedure Expand_Record_Controller (T : Entity_Id) is Def : Node_Id := Type_Definition (Parent (T)); Comp_List : Node_Id; Comp_Decl : Node_Id; Loc : Source_Ptr; First_Comp : Node_Id; Controller_Type : Entity_Id; begin if Nkind (Def) = N_Derived_Type_Definition then Def := Record_Extension_Part (Def); end if; if Null_Present (Def) then Set_Component_List (Def, Make_Component_List (Sloc (Def), Component_Items => Empty_List, Variant_Part => Empty, Null_Present => True)); end if; Comp_List := Component_List (Def); if Null_Present (Comp_List) or else Is_Empty_List (Component_Items (Comp_List)) then Loc := Sloc (Comp_List); else Loc := Sloc (First (Component_Items (Comp_List))); end if; if Is_Limited_Type (T) then Controller_Type := RTE (RE_Limited_Record_Controller); else Controller_Type := RTE (RE_Record_Controller); end if; Comp_Decl := Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uController), Subtype_Indication => New_Reference_To (Controller_Type, Loc)); if Null_Present (Comp_List) or else Is_Empty_List (Component_Items (Comp_List)) then Set_Component_Items (Comp_List, New_List (Comp_Decl)); Set_Null_Present (Comp_List, False); else -- The controller cannot be placed before the _Parent field First_Comp := First (Component_Items (Comp_List)); if Chars (Defining_Identifier (First_Comp)) /= Name_uParent and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag then Insert_Before (First_Comp, Comp_Decl); else Insert_After (First_Comp, Comp_Decl); end if; end if; New_Scope (T); Analyze (Comp_Decl); Set_Ekind (Defining_Identifier (Comp_Decl), E_Component); End_Scope; end Expand_Record_Controller; ----------------------- -- Freeze_Array_Type -- ----------------------- procedure Freeze_Array_Type (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Entity (N); Base : constant Entity_Id := Base_Type (Typ); PAT : Entity_Id; Decl : Node_Id; begin Set_Is_Packed (Typ, Is_Packed (Base)); -- Non-packed case if not Is_Packed (Typ) then if No (Init_Proc (Base)) then Build_Array_Init_Proc (Base); end if; if Typ = Base and then Has_Controlled (Base) then Build_Controlling_Procs (Base); end if; -- Case of packed array, i.e. constrained one dimensional array type -- or subtype for which a pragma Pack is given, and whose component -- type is a scalar type whose size is in the range 1 .. 4. The checks -- on dimensionality and the component type are made in the pragma Pack -- processing in Sem_Prag. -- The processing below constructs an appropriate substitute type that -- is used to represent the packed array, and places the declaration of -- this type as a freeze action for the original array type or subtype. elsif Is_Constrained (Typ) then Expand_Packed_Array_Type (Typ, PAT, Decl); Set_Packed_Array_Type (Typ, PAT); Insert_Before_And_Analyze (N, Decl); -- A size may have been given for the original type, and here is -- where we deal with this. The size belongs to the corresponding -- packed array. Note that for the static case, the size was -- validated when the original size clause was encountered. For -- the dynamic case, Gigi will validate it in the usual manner. if Esize (Typ) /= Uint_0 then Set_Esize (PAT, Esize (Typ)); Set_Esize (Typ, Uint_0); end if; -- Finally make sure packed array type gets frozen first Insert_List_Before_And_Analyze (N, Freeze_Entity (PAT, Loc)); end if; end Freeze_Array_Type; ----------------------------- -- Freeze_Enumeration_Type -- ----------------------------- procedure Freeze_Enumeration_Type (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Entity (N); Ent : Entity_Id; Lst : List_Id; Num : Nat; Arr : Entity_Id; Fent : Entity_Id; Func : Entity_Id; begin -- Build list of literal references Lst := New_List; Num := 0; Ent := First_Literal (Typ); while Present (Ent) loop Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); Num := Num + 1; Ent := Next_Literal (Ent); end loop; -- Now build an array declaration -- typA : array (Natural range 0 .. num - 1) of etype := -- (v, v, v, v, v, ....) -- where ctype is the corresponding integer type Arr := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), 'A')); Append_Freeze_Action (Typ, Make_Object_Declaration (Loc, Defining_Identifier => Arr, Constant_Present => True, Object_Definition => Make_Constrained_Array_Definition (Loc, Discrete_Subtype_Definitions => New_List ( Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Standard_Natural, Loc), Constraint => Make_Range_Constraint (Loc, Range_Expression => Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, Intval => Uint_0), High_Bound => Make_Integer_Literal (Loc, Intval => UI_From_Int (Num - 1)))))), Subtype_Indication => New_Reference_To (Typ, Loc)), Expression => Make_Aggregate (Loc, Expressions => Lst))); Set_Enum_Pos_To_Rep (Typ, Arr); -- Now we build the function that converts representation values to -- position values. This function has the form: -- function _Rep_To_Pos (A : etype) return Integer is -- begin -- case A is -- when enum-lit => return posval; -- when enum-lit => return posval; -- ... -- when others => return -1; -- end case; -- end; -- First build list of cases Lst := New_List; Ent := First_Literal (Typ); while Present (Ent) loop Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (New_Reference_To (Ent, Loc)), Statements => New_List ( Make_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, Enumeration_Pos (Ent)))))); Ent := Next_Literal (Ent); end loop; Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( Make_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, Uint_Minus_1))))); -- Now we can build the function body Fent := Make_Defining_Identifier (Loc, Name_uRep_To_Pos); Func := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Fent, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA), Parameter_Type => New_Reference_To (Typ, Loc))), Subtype_Mark => New_Reference_To (Standard_Integer, Loc)), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Case_Statement (Loc, Expression => Make_Identifier (Loc, Name_uA), Alternatives => Lst)))); Set_TSS (Typ, Fent); end Freeze_Enumeration_Type; ----------------------------- -- Freeze_Fixed_Point_Type -- ----------------------------- -- Now that we know the small value, we can set the small values on the -- bounds of the range. We delay this till the freeze-point since we do -- not know the final small value to be used till then. procedure Freeze_Fixed_Point_Type (N : Node_Id) is Typ : constant Entity_Id := Entity (N); Rng : constant Node_Id := Scalar_Range (Typ); Lo : constant Node_Id := Low_Bound (Rng); Hi : constant Node_Id := High_Bound (Rng); Loval : constant Ureal := Realval (Lo); Hival : constant Ureal := Realval (Hi); Btyp : constant Entity_Id := Base_Type (Typ); Small : constant Ureal := Small_Value (Typ); begin -- See if we can unfudge the bounds without increasing the size -- but be sure to respect the bounds of the base type when we -- do this in the case of a fixed point subtype. if Ekind (Typ) /= E_Ordinary_Fixed_Point_Subtype or else Loval > Realval (Low_Bound (Scalar_Range (Btyp))) then Set_Realval (Lo, Loval - Small); if Minimum_Size (Typ) > Esize (Typ) then Set_Realval (Lo, Loval); end if; end if; if Ekind (Typ) /= E_Ordinary_Fixed_Point_Subtype or else Hival < Realval (High_Bound (Scalar_Range (Btyp))) then Set_Realval (Hi, Hival + Small); if Minimum_Size (Typ) > Esize (Typ) then Set_Realval (Hi, Hival); end if; end if; -- Deal with low bound if not already set if No (Etype (Lo)) then Analyze (Lo); -- Resolve with universal fixed if the base type, and the base -- type if it is a subtype. Note we can't resolve the base type -- with itself, that would be a reference before definition. if Typ = Btyp then Resolve (Lo, Universal_Fixed); else Resolve (Lo, Btyp); end if; -- Set corresponding integer value for bound Set_Corresponding_Integer_Value (Lo, UR_To_Uint (Realval (Lo) / Small)); end if; -- Similar processing for high bound if No (Etype (Hi)) then Analyze (Hi); if Typ = Btyp then Resolve (Hi, Universal_Fixed); else Resolve (Hi, Btyp); end if; Set_Corresponding_Integer_Value (Hi, UR_To_Uint (Realval (Hi) / Small)); end if; end Freeze_Fixed_Point_Type; ----------------- -- Freeze_Type -- ----------------- -- Full type declarations are expanded at the point at which the type -- is frozen. The formal N is the Freeze_Node for the type. Any statements -- or declarations generated by the freezing (e.g. the procedure generated -- for initialization) are chained in the Acions field list of the freeze -- node using Append_Freeze_Actions. procedure Freeze_Type (N : Node_Id) is Def_Id : constant Entity_Id := Entity (N); Type_Decl : Node_Id := Parent (Def_Id); begin -- Freeze processing for record type declaration if Ekind (Def_Id) = E_Record_Type and then not Is_Itype (Def_Id) -- why this exception??? then -- Creation of the Dispatch Table. Note that a Dispatch Table is -- created for regular tagged types as well as for Ada types -- deriving from a C++ Class, but not for tagged types directly -- corresponding to the C++ classes. In the later case we assume -- that the Vtable is created in the C++ side and we just use it. if Is_Tagged_Type (Def_Id) then if Is_CPP_Class (Def_Id) then Set_All_DT_Position (Def_Id); Set_Default_Constructor (Def_Id); else if Underlying_Type (Etype (Def_Id)) = Def_Id then Expand_Tagged_Root (Def_Id); end if; -- Unfreeze momentarily the type to add the predefined -- primitives operations Set_Is_Frozen (Def_Id, False); Insert_List_Before_And_Analyze (N, Predefined_Primitive_Specs (Def_Id)); Set_Is_Frozen (Def_Id, True); Set_All_DT_Position (Def_Id); Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); -- Make sure that the primitives Initialize, Adjust and -- Finalize are Frozen before other TSS subprograms. We -- don't want them Frozen inside. if Is_Controlled (Def_Id) then if not Is_Limited_Type (Def_Id) then Append_Freeze_Actions (Def_Id, Freeze_Entity (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); end if; Append_Freeze_Actions (Def_Id, Freeze_Entity (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); Append_Freeze_Actions (Def_Id, Freeze_Entity (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); end if; Append_Freeze_Actions (Def_Id, Predefined_Primitive_Bodies (Def_Id)); end if; -- In the non-tagged case, an equality function is provided only -- for variant records elsif Has_Discriminants (Def_Id) and then not Is_Limited_Type (Def_Id) then declare Comps : constant Node_Id := Component_List (Type_Definition (Type_Decl)); begin if Present (Comps) and then Present (Variant_Part (Comps)) then Build_Variant_Record_Equality (Def_Id); end if; end; end if; -- Before building the record initialization procedure, if we are -- dealing with a concurrent record value type, then we must go -- through the discriminants, exchanging discriminals between the -- concurrent type and the concurrent record value type. See the -- section "Handling of Discriminants" in the Einfo spec for details. if Is_Concurrent_Record_Type (Def_Id) and then Has_Discriminants (Def_Id) then declare Ctyp : constant Entity_Id := Corresponding_Concurrent_Type (Def_Id); Conc_Discr : Entity_Id; Rec_Discr : Entity_Id; Temp : Entity_Id; begin Conc_Discr := First_Discriminant (Ctyp); Rec_Discr := First_Discriminant (Def_Id); while Present (Conc_Discr) loop Temp := Discriminal (Conc_Discr); Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); Set_Discriminal (Rec_Discr, Temp); Conc_Discr := Next_Discriminant (Conc_Discr); Rec_Discr := Next_Discriminant (Rec_Discr); end loop; end; end if; if Has_Controlled (Def_Id) then if No (Controller_Component (Def_Id)) then Expand_Record_Controller (Def_Id); end if; Build_Controlling_Procs (Def_Id); end if; Build_Record_Init_Proc (Type_Decl, Def_Id); -- Build discriminant checking functions if not a derived type (for -- derived types that are not tagged types, we always use the -- discriminant checking functions of the base type). if not Is_Derived_Type (Def_Id) and then not Is_Tagged_Type (Def_Id) and then not Has_Non_Standard_Rep (Def_Id) and then not Has_Non_Standard_Rep (Root_Type (Def_Id)) then Build_Discr_Checking_Funcs (Type_Decl); end if; -- Freeze processing for array type declaration elsif Is_Array_Type (Def_Id) then Freeze_Array_Type (N); -- Freeze processing for access type declaration -- For pool-specific access types, find out the pool object used for -- this type, needs actual expansion of it in some cases. Here are the -- different cases : -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" -- ---> Storage Pool is 'Empty_Pool_Object' -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. -- Expand: -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" -- ---> Storage Pool is the specified one -- See GNAT Pool packages in the Run-Time for more details elsif Ekind (Def_Id) = E_Access_Type or else Ekind (Def_Id) = E_General_Access_Type then declare Loc : constant Source_Ptr := Sloc (N); Desig_Type : constant Entity_Id := Designated_Type (Def_Id); Pool_Object : Entity_Id; Siz_Exp : Node_Id; begin if Has_Storage_Size_Clause (Def_Id) then Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); else Siz_Exp := Empty; end if; -- case 1 if Has_Storage_Size_Clause (Def_Id) and then Is_OK_Static_Expression (Siz_Exp) and then Expr_Value (Siz_Exp) = 0 then Set_Associated_Storage_Pool (Def_Id, RTE (RE_Empty_Pool_Object)); -- case 2 elsif Has_Storage_Size_Clause (Def_Id) then declare DT_Size : Node_Id; DT_Align : Node_Id; begin -- Note: for now ??? we replace DT'Size by the arbitrary -- value 4096 if DT is unconstrained. This obviously must -- be fixed later (we need another storage pool type). -- Similarly, we use Maximum_Alignment for the alignment. if Is_Array_Type (Desig_Type) and then not Is_Constrained (Desig_Type) then DT_Size := Make_Integer_Literal (Loc, Intval => UI_From_Int (4096)); DT_Align := Make_Integer_Literal (Loc, Intval => UI_From_Int (Maximum_Alignment)); else DT_Size := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Desig_Type, Loc), Attribute_Name => Name_Size); DT_Align := Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Desig_Type, Loc), Attribute_Name => Name_Alignment); end if; Pool_Object := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Def_Id), 'P')); Append_Freeze_Action (Def_Id, Make_Object_Declaration (Loc, Defining_Identifier => Pool_Object, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Stack_Bounded_Pool), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( -- First discriminant is the Pool Size New_Reference_To ( Storage_Size_Variable (Def_Id), Loc), -- Second discriminant is the element size DT_Size, -- Third discriminant is the alignment DT_Align))))); end; Set_Associated_Storage_Pool (Def_Id, Pool_Object); -- case 3 elsif Present (Associated_Storage_Pool (Def_Id)) then -- Nothing to do the associated storage pool has been attached -- when analyzing the rep. clause null; end if; -- For access to controlled types (including class-wide types -- and taft amendment types which potentially have controlled -- components), expand the list controller object that will -- store the dynamically allocated objects. Do not do this -- transformation for expander generated access types. if not Comes_From_Source (Def_Id) then null; elsif Controlled_Type (Desig_Type) or else (Is_Incomplete_Or_Private_Type (Desig_Type) and then No (Full_View (Desig_Type)) -- An exception is made for types defined in the run-time -- because Ada.Tags.Tag itself is such a type and cannot -- afford this unnecessary overhead that would generates a -- loop in the expansion scheme... and then not In_Runtime (Def_Id)) then Set_Associated_Final_Chain (Def_Id, Make_Defining_Identifier (Loc, New_External_Name (Chars (Def_Id), 'L'))); Append_Freeze_Action (Def_Id, Make_Object_Declaration (Loc, Defining_Identifier => Associated_Final_Chain (Def_Id), Object_Definition => New_Reference_To (RTE (RE_List_Controller), Loc))); end if; end; -- Freezing for enumeration types elsif Ekind (Def_Id) = E_Enumeration_Type then -- Always ignore types derived from standard character or standard -- wide character, these types do not permit enum rep clauses. -- Also ignore types derived from standard boolean. if Root_Type (Def_Id) = Standard_Character or else Root_Type (Def_Id) = Standard_Wide_Character or else Root_Type (Def_Id) = Standard_Boolean then return; end if; -- We only have something to do if we have a non-standard -- representation (i.e. at least one literal whose pos value -- is not the same as its representation) declare E : Entity_Id; begin E := First_Literal (Def_Id); while Present (E) loop if Enumeration_Rep (E) /= Enumeration_Pos (E) then Freeze_Enumeration_Type (N); return; end if; E := Next_Literal (E); end loop; end; -- Freezing for fixed-point types elsif Is_Fixed_Point_Type (Def_Id) then Freeze_Fixed_Point_Type (N); -- All other types require no expander action. There are such -- cases (e.g. task types and protected types). In such cases, -- the freeze nodes are there for use by Gigi. end if; end Freeze_Type; ------------------------------------ -- Expand_N_Full_Type_Declaration -- ------------------------------------ procedure Expand_N_Full_Type_Declaration (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); begin if Is_Access_Type (Def_Id) then if Has_Tasks (Designated_Type (Def_Id)) then Build_Master_Entity (Def_Id); Build_Master_Renaming (N, Def_Id); end if; elsif Has_Tasks (Def_Id) then Expand_Previous_Access_Type (N, Def_Id); end if; end Expand_N_Full_Type_Declaration; --------------------------- -- Build_Master_Renaming -- --------------------------- procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); M_Id : Entity_Id; Decl : Node_Id; begin M_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'M')); Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => M_Id, Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), Name => Make_Identifier (Loc, Name_uMaster)); Insert_After (N, Decl); Analyze (Decl); Set_Master_Id (T, M_Id); end Build_Master_Renaming; --------------------------------- -- Expand_Previous_Access_Type -- --------------------------------- procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id) is T : Entity_Id := First_Entity (Current_Scope); begin while Present (T) and then T /= Def_Id loop if Is_Access_Type (T) and then Designated_Type (T) = Def_Id then Build_Master_Entity (Def_Id); Build_Master_Renaming (N, T); end if; T := Next_Entity (T); end loop; end Expand_Previous_Access_Type; --------------------------------- -- Expand_N_Object_Declaration -- --------------------------------- -- First we do special processing for objects of a tagged type where this -- is the point at which the type is frozen. The creation of the dispatch -- table and the initialization procedure have to be deffered to this -- point, since we reference previously declared primitive subprograms. -- For all types, we call an initialization procedure if there is one procedure Expand_N_Object_Declaration (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); Typ : constant Entity_Id := Etype (Def_Id); Loc : constant Source_Ptr := Sloc (N); Expr : Node_Id := Expression (N); New_Ref : Node_Id; begin -- Don't do anything for deferred constants. All proper actions will -- be expanded during the redeclaration. if No (Expr) and Constant_Present (N) then return; end if; -- If tasks being declared, make sure we have an activation chain -- defined for the tasks (has no effect if we already have one), and -- also that a Master variable is established and that the appropriate -- enclosing construct is established as a task master. if Has_Tasks (Typ) then Build_Activation_Chain_Entity (N); Build_Master_Entity (Def_Id); end if; if No_Default_Init (N) then null; elsif No (Expr) then -- Expand Initialize call for controlled objects. One may wonder why -- the Initialize Call is not done in the regular Init procedure -- attached to the record type. That's because the init procedure is -- recursively called on each component, including _Parent, thus the -- Init call for a controlled object would generate not only one -- Initialize call as it is required but one for each ancestor of -- its type. if Controlled_Type (Typ) then Insert_List_After (N, Make_Init_Call ( Ref => New_Reference_To (Def_Id, Loc), Typ => Typ, Flist_Ref => Find_Final_List (Def_Id))); end if; -- Call type initialization procedure if there is one. We build the -- call and put it immediately after the object declaration, so that -- it will be expanded in the usual manner. Note that this will -- result in proper handling of defaulted discriminants. if Present (Base_Init_Proc (Typ)) then Insert_List_After (N, Build_Initialization_Call (Loc, New_Reference_To (Def_Id, Loc), Typ)); elsif Is_Access_Type (Typ) then -- For access types we don't call an init procedure, we directly -- assign a null value in order to leave the code preelaborable -- No_Location is used to mark the null in order to ease its -- removal in case the variable happend to be pragma imported. -- What is this all about ???? (Robert) Set_Expression (N, Make_Null (No_Location)); Analyze (Expression (N)); Resolve (Expression (N), Typ); end if; else -- if the type is controlled we attach the object to the final list -- and adjust the target after the copy. if Controlled_Type (Typ) then Insert_List_After (N, Make_Adjust_Call ( Ref => New_Reference_To (Def_Id, Loc), Typ => Typ, Flist_Ref => Find_Final_List (Def_Id), With_Attach => New_Reference_To (Standard_True, Loc))); end if; -- For tagged types, when an init value is given, the tag has to be -- re-initialized separately in order to avoid the propagation of a -- wrong tag coming from a view conversion unless the type is class -- wide (in this case the tag comes from the init value). if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then -- The re-assignment of the tag has to be done even if -- the object is a constant New_Ref := Make_Selected_Component (Loc, Prefix => New_Reference_To (Def_Id, Loc), Selector_Name => New_Reference_To (Tag_Component (Typ), Loc)); Set_Assignment_OK (New_Ref); Insert_After (N, Make_Assignment_Statement (Loc, Name => New_Ref, Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Tag), Loc), Expression => New_Reference_To (Access_Disp_Table (Typ), Loc)))); end if; end if; end Expand_N_Object_Declaration; ------------------------------- -- Build_Initialization_Call -- ------------------------------- -- References to a discriminant inside the record type declaration -- can appear either in the subtype_indication to constrain a -- record or an array, or as part of a larger expression given for -- the initial value of a component. In both of these cases N appears -- in the record initialization procedure and needs to be replaced by -- the formal parameter of the initialization procedure which -- corresponds to that discriminant. -- In the example below, references to discriminants D1 and D2 in proc_1 -- are replaced by references to formals with the same name -- (discriminals) -- A similar replacement is done for calls to any record -- initialization procedure for any components that are themselves -- of a record type. -- type R (D1, D2 : Integer) is record -- X : Integer := F * D1; -- Y : Integer := F * D2; -- end record; -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is -- begin -- Out_2.D1 := D1; -- Out_2.D2 := D2; -- Out_2.X := F * D1; -- Out_2.Y := F * D2; -- end; function Build_Initialization_Call (Loc : Source_Ptr; Id_Ref : Node_Id; Typ : Entity_Id; In_Init_Proc : Boolean := False) return List_Id is First_Arg : Node_Id; Args : List_Id; Discr : Elmt_Id; Arg : Node_Id; Proc : constant Entity_Id := Base_Init_Proc (Typ); Res : List_Id; Full_Type : Entity_Id := Typ; begin if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then Full_Type := Full_View (Typ); end if; -- First argument (_Init) is the object to be initialized. if Is_CPP_Class (Typ) then First_Arg := Make_Attribute_Reference (Loc, Prefix => Id_Ref, Attribute_Name => Name_Unrestricted_Access); -- If Typ is derived, the procedure is the initialization procedure for -- the root type. Wrap the argument in an conversion to make it type -- honest. Actually it isn't quite type honest, because there can be -- conflicts of views in the private type case. That is why we set -- Conversion_OK in the conversion node. -- it type-honest. elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ)) and then Etype (First_Formal (Proc)) /= Typ then declare Ftyp : constant Entity_Id := Etype (First_Formal (Proc)); begin First_Arg := Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (Ftyp), Loc), Expression => Id_Ref); Set_Etype (First_Arg, Ftyp); Set_Conversion_OK (First_Arg); end; else First_Arg := Id_Ref; end if; Args := New_List (Convert_Concurrent (First_Arg, Typ)); -- In the tasks case, add _Master as the value of the _Master parameter -- and _Chain as the value of the _Chain parameter. At the outer level, -- these will be variables holding the corresponding values obtained -- from GNARL. At inner levels, they will be the parameters passed down -- through the outer routines. if Has_Tasks (Full_Type) then Append_To (Args, Make_Identifier (Loc, Name_uMaster)); Append_To (Args, Make_Identifier (Loc, Name_uChain)); end if; -- Add discriminant values if discriminants are present if Has_Discriminants (Full_Type) then Discr := First_Elmt (Discriminant_Constraint (Full_Type)); if In_Init_Proc then -- Replace any possible references to the discriminant in the -- call to the record initialization procedure with references -- to the appropriate formal parameter. while Present (Discr) loop Arg := Node (Discr); if Nkind (Arg) = N_Identifier and then Ekind (Entity (Arg)) = E_Discriminant then Append_To (Args, New_Reference_To (Discriminal (Entity (Arg)), Loc)); -- Case of access discriminants. We replace the reference -- to the type by a reference to the actual object elsif Nkind (Arg) = N_Attribute_Reference and then Is_Entity_Name (Prefix (Arg)) and then Is_Type (Entity (Prefix (Arg))) then Append_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Copy (Prefix (Id_Ref)), Attribute_Name => Name_Unrestricted_Access)); else Append_To (Args, New_Copy (Arg)); end if; Discr := Next_Elmt (Discr); end loop; else while Present (Discr) loop if Is_Constrained (Full_Type) then Append_To (Args, Duplicate_Subexpr (Node (Discr))); else -- The constraints come from the discriminant default -- exps, they must be reevaluated, that is why New_Copy -- is used here Append_To (Args, New_Copy (Node (Discr))); end if; Discr := Next_Elmt (Discr); end loop; end if; end if; Res := New_List ( Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => Args)); if Controlled_Type (Typ) and then Nkind (Id_Ref) = N_Selected_Component and then Chars (Selector_Name (Id_Ref)) /= Name_uParent then Append_List_To (Res, Make_Init_Call ( Ref => New_Copy_Tree (First_Arg), Typ => Typ, Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)))); end if; return Res; end Build_Initialization_Call; ---------------- -- In_Runtime -- ---------------- function In_Runtime (E : Entity_Id) return Boolean is S1 : Entity_Id := Scope (E); begin while Scope (S1) /= Standard_Standard loop S1 := Scope (S1); end loop; return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; end In_Runtime; ----------------- -- Predef_Spec -- ----------------- function Predef_Spec (Loc : Source_Ptr; Tag_Typ : Entity_Id; Name : Name_Id; Profile : List_Id; Ret_Type : Entity_Id := Empty; For_Body : Boolean := False) return Node_Id is Id : Entity_Id := Make_Defining_Identifier (Loc, Name); Spec : Node_Id; begin Set_Is_Public (Id, Is_Public (Tag_Typ)); -- The internal flag is set to mark these declarations because -- they have specific properties. First they are primitives even -- if they are not defined in the type scope (the freezing point -- is not necessarily in the same scope), furthermore the -- predefined equality can be overridden by a user-defined -- equality, no body will be generated in this case. Set_Is_Internal (Id); if No (Ret_Type) then Spec := Make_Procedure_Specification (Loc, Defining_Unit_Name => Id, Parameter_Specifications => Profile); else Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Id, Parameter_Specifications => Profile, Subtype_Mark => New_Reference_To (Ret_Type, Loc)); end if; if For_Body then return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); else return Make_Subprogram_Declaration (Loc, Spec); end if; end Predef_Spec; --------------------------- -- Predef_Stream_IO_Spec -- --------------------------- function Predef_Stream_IO_Spec (Loc : Source_Ptr; Tag_Typ : Entity_Id; Name : Name_Id; For_Body : Boolean := False) return Node_Id is begin return Predef_Spec (Loc, Name => Name, Tag_Typ => Tag_Typ, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), Parameter_Type => Make_Access_Definition (Loc, Subtype_Mark => New_Reference_To ( Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), Out_Present => True, Parameter_Type => New_Reference_To (Tag_Typ, Loc))), For_Body => For_Body); end Predef_Stream_IO_Spec; ---------------------- -- Predef_Deep_Spec -- ---------------------- function Predef_Deep_Spec (Loc : Source_Ptr; Tag_Typ : Entity_Id; Name : Name_Id; For_Body : Boolean := False) return Node_Id is begin return Predef_Spec (Loc, Name => Name, Tag_Typ => Tag_Typ, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (Tag_Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), For_Body => For_Body); end Predef_Deep_Spec; -------------------------------- -- Predefined_Primitive_Specs -- -------------------------------- function Predefined_Primitive_Specs (Tag_Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Tag_Typ); Res : List_Id := New_List; Prim : Elmt_Id; Eq_Needed : Boolean; begin -- Spec of _Size Append_To (Res, Predef_Spec (Loc, Tag_Typ => Tag_Typ, Name => Name_uSize, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Ret_Type => Standard_Long_Long_Integer)); -- Specs for Dispatching stream IO if not In_Runtime (Tag_Typ) then Append_To (Res, Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uRead)); Append_To (Res, Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uWrite)); Append_To (Res, Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uInput)); Append_To (Res, Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uOutput)); end if; if not Is_Limited_Type (Tag_Typ) then -- Spec of "=" if expanded if the type is not limited and if a -- user defined "=" was not already declared for the non-full -- view of a private extension Eq_Needed := True; Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Present (Prim) loop if Chars (Node (Prim)) = Name_Op_Eq and then No (Alias (Node (Prim))) then Eq_Needed := False; exit; end if; Prim := Next_Elmt (Prim); end loop; if Eq_Needed then Append_To (Res, Predef_Spec (Loc, Tag_Typ => Tag_Typ, Name => Name_Op_Eq, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), Parameter_Type => New_Reference_To (Tag_Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Ret_Type => Standard_Boolean)); end if; -- Spec for dispatching assignment Append_To (Res, Predef_Spec (Loc, Tag_Typ => Tag_Typ, Name => Name_uAssign, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), Out_Present => True, Parameter_Type => New_Reference_To (Tag_Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); end if; -- Specs for finalization actions that may be required in case a -- future extension contain a controlled element. We generate those -- only for root tagged types where they will get dummy bodies or -- when the type has controlled components and their body must be -- generated. It is also impossible to provide those for tagged -- types defined within s-finimp since it would involve circularity -- problems if In_Finalization_Implementation (Tag_Typ) then null; elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then if not Is_Limited_Type (Tag_Typ) then Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust)); end if; Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize)); end if; return Res; end Predefined_Primitive_Specs; --------------------------------- -- Predefined_Primitive_Bodies -- --------------------------------- function Predefined_Primitive_Bodies (Tag_Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Tag_Typ); Decl : Node_Id; Res : List_Id := New_List; Prim : Elmt_Id; Eq_Needed : Boolean := False; begin -- Make sure that predefined primitives operations are frozen -- before their bodies since their body will not freeze anything Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Present (Prim) loop if Is_Internal (Node (Prim)) then Append_List_To (Res, Freeze_Entity (Node (Prim), Loc)); if Chars (Node (Prim)) = Name_Op_Eq then Eq_Needed := True; end if; end if; Prim := Next_Elmt (Prim); end loop; -- Body of _Size Decl := Predef_Spec (Loc, Tag_Typ => Tag_Typ, Name => Name_uSize, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Ret_Type => Standard_Long_Long_Integer, For_Body => True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Return_Statement (Loc, Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_X), Attribute_Name => Name_Size))))); Append_To (Res, Decl); -- Bodies for Dispatching stream IO routines if not In_Runtime (Tag_Typ) then Decl := Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uRead, True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Null_Statement (Loc)))); Append_To (Res, Decl); Decl := Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uWrite, True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Null_Statement (Loc)))); Append_To (Res, Decl); Decl := Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uInput, True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Null_Statement (Loc)))); Append_To (Res, Decl); Decl := Predef_Stream_IO_Spec (Loc, Tag_Typ, Name_uOutput, True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Null_Statement (Loc)))); Append_To (Res, Decl); end if; if not Is_Limited_Type (Tag_Typ) then -- Body for equality if Eq_Needed then Decl := Predef_Spec (Loc, Tag_Typ => Tag_Typ, Name => Name_Op_Eq, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), Parameter_Type => New_Reference_To (Tag_Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Ret_Type => Standard_Boolean, For_Body => True); declare Def : constant Node_Id := Parent (Tag_Typ); Variant_Case : Boolean := Has_Discriminants (Tag_Typ); Comps : Node_Id := Empty; Typ_Def : Node_Id := Type_Definition (Def); Stmts : List_Id := New_List; begin if Variant_Case then if Nkind (Typ_Def) = N_Derived_Type_Definition then Typ_Def := Record_Extension_Part (Typ_Def); end if; if Present (Typ_Def) then Comps := Component_List (Typ_Def); end if; Variant_Case := Present (Comps) and then Present (Variant_Part (Comps)); end if; if Variant_Case then Append_To (Stmts, Make_Eq_If (Loc, Discriminant_Specifications (Def))); Append_List_To (Stmts, Make_Eq_Case (Loc, Comps)); Append_To (Stmts, Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc))); else Append_To (Stmts, Make_Return_Statement (Loc, Expression => Expand_Record_Equality (Loc, Typ => Tag_Typ, Lhs => Make_Identifier (Loc, Name_X), Rhs => Make_Identifier (Loc, Name_Y)))); end if; Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end; Append_To (Res, Decl); end if; -- Body for dispatching assignment Decl := Predef_Spec (Loc, Tag_Typ => Tag_Typ, Name => Name_uAssign, Profile => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), Out_Present => True, Parameter_Type => New_Reference_To (Tag_Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), Parameter_Type => New_Reference_To (Tag_Typ, Loc))), For_Body => True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_X), Expression => Make_Identifier (Loc, Name_Y))))); Append_To (Res, Decl); end if; -- Generate dummy bodies for finalization actions of types that have -- no controlled components if In_Finalization_Implementation (Tag_Typ) then null; elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ)) and then not Has_Controlled (Tag_Typ) then if not Is_Limited_Type (Tag_Typ) then Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust, True); if Is_Controlled (Tag_Typ) then Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, Make_Adjust_Call ( Ref => Make_Identifier (Loc, Name_V), Typ => Tag_Typ, Flist_Ref => Make_Identifier (Loc, Name_L), With_Attach => Make_Identifier (Loc, Name_B)))); else Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Null_Statement (Loc)))); end if; Append_To (Res, Decl); end if; Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize, True); if Is_Controlled (Tag_Typ) then Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, Make_Final_Call ( Ref => Make_Identifier (Loc, Name_V), Typ => Tag_Typ, Flist_Ref => Make_Identifier (Loc, Name_L), With_Detach => Make_Identifier (Loc, Name_B)))); else Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Null_Statement (Loc)))); end if; Append_To (Res, Decl); end if; return Res; end Predefined_Primitive_Bodies; --------------------------- -- Expand_N_Variant_Part -- --------------------------- -- If the last variant does not contain the Others choice, replace -- it with an N_Others_Choice node since Gigi always wants an Others. -- Note that we do not bother to call Analyze on the modified variant -- part, since it's only effect would be to compute the contents of -- the Others_Discrete_Choices node laboriously, and of course we -- already know the list of choices that corresponds to the others -- choice (it's the list we are replacing!) procedure Expand_N_Variant_Part (N : Node_Id) is Last_Var : constant Node_Id := Last (Variants (N)); Others_Node : Node_Id; begin if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then Others_Node := Make_Others_Choice (Sloc (Last_Var)); Set_Others_Discrete_Choices (Others_Node, Discrete_Choices (Last_Var)); Set_Discrete_Choices (Last_Var, New_List (Others_Node)); end if; end Expand_N_Variant_Part; ------------------ -- Init_Formals -- ------------------ function Init_Formals (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Formals : List_Id; begin -- First parameter is always _Init : in out typ. Note that we need -- this to be in/out because in the case of the task record value, -- there are default record fields (_Priority and _Size) that may be -- referenced in the generated initialization routine. Formals := New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (Typ, Loc))); -- For task record value, or type that contains tasks, add two more -- formals, _Master : Master_Id and _Chain : in out Activation_Chain -- We also add these parameters for the task record type case. if Has_Tasks (Typ) or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) then Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uMaster), Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uChain), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (RTE (RE_Activation_Chain), Loc))); end if; return Formals; end Init_Formals; end Exp_Ch3;