test.adb

    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