From 36953446da89bbd35129d77c38e74a71209fda16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20Creuse?= Date: Wed, 7 Feb 2024 09:49:59 +0100 Subject: [PATCH 1/2] TGen: Always use fully qualified names in support library Some parts of the support library did not use fully qualified names when referencing types (enumeration values in discrete choices and discriminant type names). This rendered the code illegal if those types were not use-visible --- .../variant_size_max.tmplt | 21 ++++++++++++------- src/tgen/tgen-marshalling.adb | 14 ++++++++----- 2 files changed, 22 insertions(+), 13 deletions(-) diff --git a/share/tgen/templates/marshalling_templates/variant_size_max.tmplt b/share/tgen/templates/marshalling_templates/variant_size_max.tmplt index 6c327608..8ade37ad 100644 --- a/share/tgen/templates/marshalling_templates/variant_size_max.tmplt +++ b/share/tgen/templates/marshalling_templates/variant_size_max.tmplt @@ -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; diff --git a/src/tgen/tgen-marshalling.adb b/src/tgen/tgen-marshalling.adb index 20b8a164..9181f35f 100644 --- a/src/tgen/tgen-marshalling.adb +++ b/src/tgen/tgen-marshalling.adb @@ -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; From 83548efb09d88710cfde34d85ac2effc0d977052 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20Creuse?= Date: Wed, 7 Feb 2024 09:52:34 +0100 Subject: [PATCH 2/2] Properly reject floating point types that are too large The Big_Integer library in the Ada runtime cannot represent the upper bound of some floating point types, such as Long_Long_Float. Reject those types and emit a technical limitation diagnostic in such cases. --- src/tgen/tgen-types-translation.adb | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/src/tgen/tgen-types-translation.adb b/src/tgen/tgen-types-translation.adb index dff61f23..d6058d2b 100644 --- a/src/tgen/tgen-types-translation.adb +++ b/src/tgen/tgen-types-translation.adb @@ -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