+ -- Name_File - expand string name of source file
+ -- Name_Line - expand integer line number
+ -- Name_Source_Location - expand string of form file:line
+ -- Name_Enclosing_Entity - expand string name of enclosing entity
+ -- Name_Compilation_Date - expand string with compilation date
+ -- Name_Compilation_Time - expand string with compilation time
+
+ procedure Write_Entity_Name (E : Entity_Id);
+ -- Recursive procedure to construct string for qualified name of enclosing
+ -- program unit. The qualification stops at an enclosing scope has no
+ -- source name (block or loop). If entity is a subprogram instance, skip
+ -- enclosing wrapper package. The name is appended to the current contents
+ -- of Name_Buffer, incrementing Name_Len.
+
+ ---------------------
+ -- Add_Source_Info --
+ ---------------------
+
+ procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id) is
+ Ent : Entity_Id;
+
+ Save_NB : constant String := Name_Buffer (1 .. Name_Len);
+ Save_NL : constant Natural := Name_Len;
+ -- Save current Name_Buffer contents
+
+ begin
+ Name_Len := 0;
+
+ -- Line
+
+ case Nam is
+
+ when Name_Line =>
+ Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Loc)));
+
+ when Name_File =>
+ Get_Decoded_Name_String
+ (Reference_Name (Get_Source_File_Index (Loc)));
+
+ when Name_Source_Location =>
+ Build_Location_String (Loc);
+
+ when Name_Enclosing_Entity =>
+
+ -- Skip enclosing blocks to reach enclosing unit
+
+ Ent := Current_Scope;
+ while Present (Ent) loop
+ exit when Ekind (Ent) /= E_Block
+ and then Ekind (Ent) /= E_Loop;
+ Ent := Scope (Ent);
+ end loop;
+
+ -- Ent now points to the relevant defining entity
+
+ Write_Entity_Name (Ent);
+
+ when Name_Compilation_Date =>
+ declare
+ subtype S13 is String (1 .. 3);
+ Months : constant array (1 .. 12) of S13 :=
+ ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
+
+ M1 : constant Character := Opt.Compilation_Time (6);
+ M2 : constant Character := Opt.Compilation_Time (7);
+
+ MM : constant Natural range 1 .. 12 :=
+ (Character'Pos (M1) - Character'Pos ('0')) * 10 +
+ (Character'Pos (M2) - Character'Pos ('0'));
+
+ begin
+ -- Reformat ISO date into MMM DD YYYY (__DATE__) format
+
+ Name_Buffer (1 .. 3) := Months (MM);
+ Name_Buffer (4) := ' ';
+ Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10);
+ Name_Buffer (7) := ' ';
+ Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4);
+ Name_Len := 11;
+ end;
+
+ when Name_Compilation_Time =>
+ Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19);
+ Name_Len := 8;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Prepend original Name_Buffer contents
+
+ Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+ Name_Buffer (1 .. Save_NL) := Save_NB;
+ end Add_Source_Info;
+
+ ---------------------------------
+ -- Expand_Binary_Operator_Call --
+ ---------------------------------
+
+ procedure Expand_Binary_Operator_Call (N : Node_Id) is
+ T1 : constant Entity_Id := Underlying_Type (Etype (Left_Opnd (N)));
+ T2 : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N)));
+ TR : constant Entity_Id := Etype (N);
+ T3 : Entity_Id;
+ Res : Node_Id;
+
+ Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2));
+ -- Maximum of operand sizes
+
+ begin
+ -- Nothing to do if the operands have the same modular type
+
+ if Base_Type (T1) = Base_Type (T2)
+ and then Is_Modular_Integer_Type (T1)
+ then
+ return;
+ end if;
+
+ -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64
+
+ if Siz > 32 then
+ T3 := RTE (RE_Unsigned_64);
+ else
+ T3 := RTE (RE_Unsigned_32);
+ end if;
+
+ -- Copy operator node, and reset type and entity fields, for
+ -- subsequent reanalysis.
+
+ Res := New_Copy (N);
+ Set_Etype (Res, T3);
+
+ case Nkind (N) is
+ when N_Op_And =>
+ Set_Entity (Res, Standard_Op_And);
+ when N_Op_Or =>
+ Set_Entity (Res, Standard_Op_Or);
+ when N_Op_Xor =>
+ Set_Entity (Res, Standard_Op_Xor);
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Convert operands to large enough intermediate type
+
+ Set_Left_Opnd (Res,
+ Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N))));
+ Set_Right_Opnd (Res,
+ Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N))));
+
+ -- Analyze and resolve result formed by conversion to target type
+
+ Rewrite (N, Unchecked_Convert_To (TR, Res));
+ Analyze_And_Resolve (N, TR);
+ end Expand_Binary_Operator_Call;