Skip to content

Commit

Permalink
Merge branch 'sync/leo/139-fqn_bug' into 'master'
Browse files Browse the repository at this point in the history
TGen: Always use fully qualified names in support library

See merge request eng/ide/libadalang-tools!182
leocreuse committed Feb 13, 2024
2 parents 5317575 + 83548ef commit be0d0a6
Showing 3 changed files with 38 additions and 25 deletions.
21 changes: 13 additions & 8 deletions share/tgen/templates/marshalling_templates/variant_size_max.tmplt
Original file line number Diff line number Diff line change
@@ -9,6 +9,7 @@
@@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type.
@@-- @_TY_NAME_@ Name of the current type.
@@-- @_DISCR_NAME_@ Names of the discriminants of the current type.
@@-- @_DISCR_TYP_@ Types of the discriminants of the current type.
@@-- @_CHOICES_@ Vector of choices for the variant part.
@@-- @_COMPONENT_SIZE_MAX_@ Vector of calls to Size_Max for all the
@@-- components of the current type.
@@ -25,21 +26,25 @@
@@IF@@ (@_COMPONENT_SIZE_MAX_@ = "") and (@_VARIANT_PART_@ = "")
@_SPACING_@ null;
@@ELSE@@
@_SPACING_@ if @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Max /= @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Min
@_SPACING_@ or else @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Min in @_CHOICES_@
@_SPACING_@ then
@_SPACING_@ @_GLOBAL_PREFIX_@_Nb_Bits := @_GLOBAL_PREFIX_@_Init;
@_SPACING_@ declare
@_SPACING_@ use type @_DISCR_TYP_@;
@_SPACING_@ begin
@_SPACING_@ if @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Max /= @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Min
@_SPACING_@ or else @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Min in @_CHOICES_@
@_SPACING_@ then
@_SPACING_@ @_GLOBAL_PREFIX_@_Nb_Bits := @_GLOBAL_PREFIX_@_Init;
@@TABLE'TERSE@@
@_SPACING_@ @_GLOBAL_PREFIX_@_Nb_Bits := @_GLOBAL_PREFIX_@_Nb_Bits +
@_SPACING_@ @_GLOBAL_PREFIX_@_Nb_Bits := @_GLOBAL_PREFIX_@_Nb_Bits +
@_COMPONENT_SIZE_MAX_@
@@END_TABLE@@
@@IF@@ @_VARIANT_PART_@ /= ""
@_VARIANT_PART_@
@@END_IF@@
@_SPACING_@ if @_GLOBAL_PREFIX_@_Nb_Bits > @_GLOBAL_PREFIX_@_Upper then
@_SPACING_@ @_GLOBAL_PREFIX_@_Upper := @_GLOBAL_PREFIX_@_Nb_Bits;
@_SPACING_@ if @_GLOBAL_PREFIX_@_Nb_Bits > @_GLOBAL_PREFIX_@_Upper then
@_SPACING_@ @_GLOBAL_PREFIX_@_Upper := @_GLOBAL_PREFIX_@_Nb_Bits;
@_SPACING_@ end if;
@_SPACING_@ end if;
@_SPACING_@ end if;
@_SPACING_@ end;
@@END_IF@@
@@END_TABLE@@
@_SPACING_@end;
14 changes: 9 additions & 5 deletions src/tgen/tgen-marshalling.adb
Original file line number Diff line number Diff line change
@@ -591,9 +591,10 @@ package body TGen.Marshalling is
Spacing : Natural;
Object_Name : String)
is
Discr_Name : constant String := +V.Discr_Name;
Discr_Typ : constant TGen.Types.Typ'Class :=
Discr_Name : constant String := +V.Discr_Name;
Discr_Typ : constant TGen.Types.Typ'Class :=
Discriminants (V.Discr_Name).Get;
Discr_Typ_FQN : constant String := Discr_Typ.Fully_Qualified_Name;

Choices_Tag : Matrix_Tag;
Comp_Read_Tag : Matrix_Tag;
@@ -668,7 +669,8 @@ package body TGen.Marshalling is
Common_Assocs
& [1 => Assoc ("OBJECT_NAME", Object_Name),
2 => Assoc ("DISCR_NAME", Discr_Name),
3 => Assoc ("CHOICES", Choices_Tag)];
3 => Assoc ("DISCR_TYP", Discr_Typ_FQN),
4 => Assoc ("CHOICES", Choices_Tag)];

begin
Read_Tag := +Variant_Read_Write
@@ -829,7 +831,8 @@ package body TGen.Marshalling is
2 => Assoc ("COMPONENT_WRITE", Component_Write),
3 => Assoc ("COMPONENT_SIZE", Component_Size),
4 => Assoc ("COMPONENT_SIZE_MAX", Component_Size_Max),
5 => Assoc ("COMP_TYP", Named_Comp_Ty.Type_Name),
5 => Assoc
("COMP_TYP", Named_Comp_Ty.Fully_Qualified_Name),
6 => Assoc ("ADA_DIM", Ada_Dim_Tag),
7 => Assoc ("FIRST_NAME", First_Name_Tag),
8 => Assoc ("LAST_NAME", Last_Name_Tag),
@@ -1061,7 +1064,8 @@ package body TGen.Marshalling is
is
begin
if Typ in Enum_Typ'Class then
return Lit_Image (Enum_Typ'Class (Typ), V);
return To_Ada (Typ.Package_Name) & "."
& Lit_Image (Enum_Typ'Class (Typ), V);
else
return Trim (To_String (V), Left);
end if;
28 changes: 16 additions & 12 deletions src/tgen/tgen-types-translation.adb
Original file line number Diff line number Diff line change
@@ -656,18 +656,6 @@ package body TGen.Types.Translation is
others => <>));
end if;
return Res;
exception
when Exc : Translation_Error =>
if Verbose_Diag then
Put_Line
("Warning: could not determine static properties of" & " type" &
Decl.Image & " : " & Ada.Exceptions.Exception_Message (Exc));
end if;
Res.Res.Set
(Float_Typ'(Is_Static => False,
Has_Range => False,
others => <>));
return Res;
end Translate_Float_Decl;

-----------------------------------
@@ -1090,6 +1078,11 @@ package body TGen.Types.Translation is
(Num => Min_Eval.Real_Result.Numerator.Image,
Den => Min_Eval.Real_Result.Denominator.Image);
Min_Static := True;
exception
when Exc : Storage_Error =>
raise Translation_Error with
"Technical limitation: "
& Ada.Exceptions.Exception_Message (Exc);
end;
else
Min_Text := +Node.F_Range.As_Bin_Op.F_Left.Text;
@@ -1108,6 +1101,11 @@ package body TGen.Types.Translation is
(Num => Max_Eval.Real_Result.Numerator.Image,
Den => Max_Eval.Real_Result.Denominator.Image);
Max_Static := True;
exception
when Exc : Storage_Error =>
raise Translation_Error with
"Technical limitation: "
& Ada.Exceptions.Exception_Message (Exc);
end;
else
Max_Text := +Node.F_Range.As_Bin_Op.F_Right.Text;
@@ -3085,6 +3083,12 @@ package body TGen.Types.Translation is
& Ada.Exceptions.Exception_Message (Exc));
end if;
return Translate_Internal (N, Verbose_Diag, True);
when Exc : Translation_Error =>
return
(Success => False,
Diagnostics =>
+(Image (Type_Name.Text) & ": "
& Ada.Exceptions.Exception_Message (Exc)));
end Translate_Internal;

function Translate_Globals

0 comments on commit be0d0a6

Please sign in to comment.