165 lines
6.2 KiB
Plaintext
165 lines
6.2 KiB
Plaintext
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");
|
|
|
|
<endfold id='1'>end</endfold id='1'> Args;
|
|
|
|
---------------
|
|
-- App_Setup --
|
|
---------------
|
|
|
|
procedure App_Setup (Context : App_Context; Jobs : App_Job_Context_Array) is
|
|
pragma Unreferenced (Context, Jobs);
|
|
<beginfold id='1'>begin</beginfold id='1'>
|
|
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;
|
|
<endfold id='1'>end</endfold id='1'> 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
|
|
<beginfold id='1'>begin</beginfold id='1'>
|
|
<beginfold id='2'>case</beginfold id='2'> 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;
|
|
<beginfold id='1'>begin</beginfold id='1'>
|
|
<beginfold id='3'>if</beginfold id='3'> Name = "test_object_type" then
|
|
Decl := PN.Previous_Sibling;
|
|
<beginfold id='3'>if</beginfold id='3'> Decl.Kind /= Ada_Object_Decl then
|
|
Error
|
|
(Node,
|
|
"previous declaration must be an object"
|
|
& " declaration");
|
|
<endfold id='3'>end if</endfold id='3'>;
|
|
Process_Type_Decl
|
|
(Decl.As_Object_Decl
|
|
.F_Type_Expr
|
|
.P_Designated_Type_Decl);
|
|
<endfold id='3'>end if</endfold id='3'>;
|
|
<beginfold id='3'>if</beginfold id='3'> I > 1 then
|
|
Put (", ");
|
|
<endfold id='3'>end if</endfold id='3'>;
|
|
<endfold id='1'>end</endfold id='1'>;
|
|
|
|
when others =>
|
|
null;
|
|
<endfold id='2'>end case</endfold id='2'>;
|
|
return Into;
|
|
<endfold id='1'>end</endfold id='1'> Process;
|
|
|
|
<beginfold id='1'>begin</beginfold id='1'>
|
|
Put_Title
|
|
('#', "Analyzing " & Ada.Directories.Simple_Name (Unit.Get_Filename));
|
|
<beginfold id='3'>if</beginfold id='3'> Unit.Has_Diagnostics then
|
|
for D of Unit.Diagnostics <beginfold id='4'>loop</beginfold id='4'>
|
|
Put_Line (Unit.Format_GNU_Diagnostic (D));
|
|
<endfold id='4'>end loop</endfold id='4'>;
|
|
New_Line;
|
|
return;
|
|
|
|
elsif not Unit.Root.Is_Null then
|
|
Unit.Root.Traverse (Process'Access);
|
|
<endfold id='3'>end if</endfold id='3'>;
|
|
<endfold id='1'>end</endfold id='1'> Process_Unit;
|
|
<endfold id='1'>end</endfold id='1'> LAL_DDA;
|
|
|
|
type Car is <beginfold id='5'>record</beginfold id='5'>
|
|
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;
|
|
<endfold id='5'>end record</endfold id='5'>;
|
|
|
|
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
|
|
<beginfold id='5'>record</beginfold id='5'>
|
|
Skilled_In : Language_List;
|
|
<endfold id='5'>end record</endfold id='5'>;
|
|
|
|
3#12.112#e3
|
|
3#12.11 use
|
|
-- ^ invalid
|
|
3#12.23#e3
|
|
-- ^ invalid
|
|
3#12.11ds#
|
|
-- ^ invalid
|
|
1211ds
|
|
-- ^ invalid
|