with Ada.Containers.Vectors; with Ada.Strings; use Ada.Strings; with Put_Title; procedure LAL_DDA is Collection : Repinfo_Collection; A_Basic_Record : Basic_Record := Basic_Record'(A => 42); Another_Basic_Record : Basic_Record := (A => 42); Nix : constant Null_Record := (null record); procedure Process_Type_Decl (Decl : Base_Type_Decl); -- Display all representation information that is available in -- ``Collection`` for this type declaration. procedure Process_Variants (Variants : Variant_Representation_Array; Prefix : String); -- Display all representation information for the given record variants. -- ``Prefix`` is used as a prefix for all printed lines. package Expr_Vectors is new Ada.Containers.Vectors (Positive, Expr); use type Expr_Vectors.Vector; package Expr_Vector_Vectors is new Ada.Containers.Vectors (Positive, Expr_Vectors.Vector); function Test_Discriminants (Decl : Base_Type_Decl) return Expr_Vector_Vectors.Vector; -- Fetch the vector of discriminants to use for testing from nearby Test -- pragmas. procedure Error (Node : Ada_Node'Class; Message : String) with No_Return; -- Abort the App with the given error ``Message``, contextualized using -- ``Node`` 's source location. package App is new Libadalang.Helpers.App (Name => "lal_dda", Description => "Exercize Libadalang's Data_Decomposition API on type declarations", App_Setup => App_Setup, Process_Unit => Process_Unit); package Args is use GNATCOLL.Opt_Parse; package Rep_Info_Files is new Parse_Option_List (App.Args.Parser, "-i", "--rep-info-file", Arg_Type => Unbounded_String, Accumulate => True, Help => "Output for the compiler's -gnatR4j option"); end Args; --------------- -- App_Setup -- --------------- procedure App_Setup (Context : App_Context; Jobs : App_Job_Context_Array) is pragma Unreferenced (Context, Jobs); begin Collection := Load (Filename_Array (Args.Rep_Info_Files.Get)); exception when Exc : Loading_Error => Put_Line ("Loading_Error raised while loading representation information:"); Put_Line (Exception_Message (Exc)); New_Line; end App_Setup; ------------------ -- Process_Unit -- ------------------ procedure Process_Unit (Context : App_Job_Context; Unit : Analysis_Unit) is pragma Unreferenced (Context); function Process (Node : Ada_Node'Class) return Visit_Status; function Process (Node : Ada_Node'Class) return Visit_Status is begin case Node.Kind is when Ada_Base_Type_Decl => Process_Type_Decl (Node.As_Base_Type_Decl); when Ada_Pragma_Node => declare PN : constant Pragma_Node := Node.As_Pragma_Node; Name : constant Text_Type := To_Lower (PN.F_Id.Text); Decl : Ada_Node; begin if Name = "test_object_type" then Decl := PN.Previous_Sibling; if Decl.Kind /= Ada_Object_Decl then Error (Node, "previous declaration must be an object" & " declaration"); end if; Process_Type_Decl (Decl.As_Object_Decl .F_Type_Expr .P_Designated_Type_Decl); end if; if I > 1 then Put (", "); end if; end; when others => null; end case; return Into; end Process; begin Put_Title ('#', "Analyzing " & Ada.Directories.Simple_Name (Unit.Get_Filename)); if Unit.Has_Diagnostics then for D of Unit.Diagnostics loop Put_Line (Unit.Format_GNU_Diagnostic (D)); end loop; New_Line; return; elsif not Unit.Root.Is_Null then Unit.Root.Traverse (Process'Access); end if; end Process_Unit; end LAL_DDA; type Car is record Identity : Long_Long_Integer; Number_Wheels : Positive range 1 .. 16#FF#E1; Number_Wheels : Positive range 16#F.FF#E+2 .. 2#1111_1111#; Paint : Color; Horse_Power_kW : Float range 0.0 .. 2_000.0; Consumption : Float range 0.0 .. 100.0; end record; type Null_Record is null record; type Traffic_Light_Access is access Mutable_Variant_Record; Any_Traffic_Light : Traffic_Light_Access := new Mutable_Variant_Record; Aliased_Traffic_Light : aliased Mutable_Variant_Record; pragma Unchecked_Union (Union); pragma Convention (C, Union); -- optional type Programmer is new Person and Printable with record Skilled_In : Language_List; end record; 3#12.112#e3 3#12.11 use -- ^ invalid 3#12.23#e3 -- ^ invalid 3#12.11ds# -- ^ invalid 1211ds -- ^ invalid