Warning, /frameworks/syntax-highlighting/autotests/folding/test.adb.fold is written in an unsupported language. File is not indexed.
0001 with Ada.Containers.Vectors;
0002 with Ada.Strings; use Ada.Strings;
0003 with Put_Title;
0004
0005 procedure LAL_DDA is
0006 Collection : Repinfo_Collection;
0007
0008 A_Basic_Record : Basic_Record := Basic_Record'(A => 42);
0009 Another_Basic_Record : Basic_Record := (A => 42);
0010 Nix : constant Null_Record := (null record);
0011
0012 procedure Process_Type_Decl (Decl : Base_Type_Decl);
0013 -- Display all representation information that is available in
0014 -- ``Collection`` for this type declaration.
0015
0016 procedure Process_Variants
0017 (Variants : Variant_Representation_Array; Prefix : String);
0018 -- Display all representation information for the given record variants.
0019 -- ``Prefix`` is used as a prefix for all printed lines.
0020
0021 package Expr_Vectors is new Ada.Containers.Vectors (Positive, Expr);
0022 use type Expr_Vectors.Vector;
0023 package Expr_Vector_Vectors is new Ada.Containers.Vectors
0024 (Positive, Expr_Vectors.Vector);
0025
0026 function Test_Discriminants
0027 (Decl : Base_Type_Decl) return Expr_Vector_Vectors.Vector;
0028 -- Fetch the vector of discriminants to use for testing from nearby Test
0029 -- pragmas.
0030
0031 procedure Error (Node : Ada_Node'Class; Message : String) with No_Return;
0032 -- Abort the App with the given error ``Message``, contextualized using
0033 -- ``Node`` 's source location.
0034
0035 package App is new Libadalang.Helpers.App
0036 (Name => "lal_dda",
0037 Description =>
0038 "Exercize Libadalang's Data_Decomposition API on type declarations",
0039 App_Setup => App_Setup,
0040 Process_Unit => Process_Unit);
0041
0042 package Args is
0043 use GNATCOLL.Opt_Parse;
0044
0045 package Rep_Info_Files is new Parse_Option_List
0046 (App.Args.Parser, "-i", "--rep-info-file",
0047 Arg_Type => Unbounded_String,
0048 Accumulate => True,
0049 Help => "Output for the compiler's -gnatR4j option");
0050
0051 <endfold id='1'>end</endfold id='1'> Args;
0052
0053 ---------------
0054 -- App_Setup --
0055 ---------------
0056
0057 procedure App_Setup (Context : App_Context; Jobs : App_Job_Context_Array) is
0058 pragma Unreferenced (Context, Jobs);
0059 <beginfold id='1'>begin</beginfold id='1'>
0060 Collection := Load (Filename_Array (Args.Rep_Info_Files.Get));
0061 exception
0062 when Exc : Loading_Error =>
0063 Put_Line
0064 ("Loading_Error raised while loading representation information:");
0065 Put_Line (Exception_Message (Exc));
0066 New_Line;
0067 <endfold id='1'>end</endfold id='1'> App_Setup;
0068
0069 ------------------
0070 -- Process_Unit --
0071 ------------------
0072
0073 procedure Process_Unit (Context : App_Job_Context; Unit : Analysis_Unit) is
0074 pragma Unreferenced (Context);
0075
0076 function Process (Node : Ada_Node'Class) return Visit_Status;
0077
0078 function Process (Node : Ada_Node'Class) return Visit_Status is
0079 <beginfold id='1'>begin</beginfold id='1'>
0080 <beginfold id='2'>case</beginfold id='2'> Node.Kind is
0081 when Ada_Base_Type_Decl =>
0082 Process_Type_Decl (Node.As_Base_Type_Decl);
0083
0084 when Ada_Pragma_Node =>
0085 declare
0086 PN : constant Pragma_Node := Node.As_Pragma_Node;
0087 Name : constant Text_Type := To_Lower (PN.F_Id.Text);
0088 Decl : Ada_Node;
0089 <beginfold id='1'>begin</beginfold id='1'>
0090 <beginfold id='3'>if</beginfold id='3'> Name = "test_object_type" then
0091 Decl := PN.Previous_Sibling;
0092 <beginfold id='3'>if</beginfold id='3'> Decl.Kind /= Ada_Object_Decl then
0093 Error
0094 (Node,
0095 "previous declaration must be an object"
0096 & " declaration");
0097 <endfold id='3'>end if</endfold id='3'>;
0098 Process_Type_Decl
0099 (Decl.As_Object_Decl
0100 .F_Type_Expr
0101 .P_Designated_Type_Decl);
0102 <endfold id='3'>end if</endfold id='3'>;
0103 <beginfold id='3'>if</beginfold id='3'> I > 1 then
0104 Put (", ");
0105 <endfold id='3'>end if</endfold id='3'>;
0106 <endfold id='1'>end</endfold id='1'>;
0107
0108 when others =>
0109 null;
0110 <endfold id='2'>end case</endfold id='2'>;
0111 return Into;
0112 <endfold id='1'>end</endfold id='1'> Process;
0113
0114 <beginfold id='1'>begin</beginfold id='1'>
0115 Put_Title
0116 ('#', "Analyzing " & Ada.Directories.Simple_Name (Unit.Get_Filename));
0117 <beginfold id='3'>if</beginfold id='3'> Unit.Has_Diagnostics then
0118 for D of Unit.Diagnostics <beginfold id='4'>loop</beginfold id='4'>
0119 Put_Line (Unit.Format_GNU_Diagnostic (D));
0120 <endfold id='4'>end loop</endfold id='4'>;
0121 New_Line;
0122 return;
0123
0124 elsif not Unit.Root.Is_Null then
0125 Unit.Root.Traverse (Process'Access);
0126 <endfold id='3'>end if</endfold id='3'>;
0127 <endfold id='1'>end</endfold id='1'> Process_Unit;
0128 <endfold id='1'>end</endfold id='1'> LAL_DDA;
0129
0130 type Car is <beginfold id='5'>record</beginfold id='5'>
0131 Identity : Long_Long_Integer;
0132 Number_Wheels : Positive range 1 .. 16#FF#E1;
0133 Number_Wheels : Positive range 16#F.FF#E+2 .. 2#1111_1111#;
0134 Paint : Color;
0135 Horse_Power_kW : Float range 0.0 .. 2_000.0;
0136 Consumption : Float range 0.0 .. 100.0;
0137 <endfold id='5'>end record</endfold id='5'>;
0138
0139 type Null_Record is null record;
0140
0141 type Traffic_Light_Access is access Mutable_Variant_Record;
0142 Any_Traffic_Light : Traffic_Light_Access :=
0143 new Mutable_Variant_Record;
0144 Aliased_Traffic_Light : aliased Mutable_Variant_Record;
0145
0146 pragma Unchecked_Union (Union);
0147 pragma Convention (C, Union); -- optional
0148
0149 type Programmer is new Person
0150 and Printable
0151 with
0152 <beginfold id='5'>record</beginfold id='5'>
0153 Skilled_In : Language_List;
0154 <endfold id='5'>end record</endfold id='5'>;
0155
0156 3#12.112#e3
0157 3#12.11 use
0158 -- ^ invalid
0159 3#12.23#e3
0160 -- ^ invalid
0161 3#12.11ds#
0162 -- ^ invalid
0163 1211ds
0164 -- ^ invalid