Warning, /frameworks/syntax-highlighting/autotests/input/test.adb 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 end 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 begin 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 end 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 begin 0080 case 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 begin 0090 if Name = "test_object_type" then 0091 Decl := PN.Previous_Sibling; 0092 if Decl.Kind /= Ada_Object_Decl then 0093 Error 0094 (Node, 0095 "previous declaration must be an object" 0096 & " declaration"); 0097 end if; 0098 Process_Type_Decl 0099 (Decl.As_Object_Decl 0100 .F_Type_Expr 0101 .P_Designated_Type_Decl); 0102 end if; 0103 if I > 1 then 0104 Put (", "); 0105 end if; 0106 end; 0107 0108 when others => 0109 null; 0110 end case; 0111 return Into; 0112 end Process; 0113 0114 begin 0115 Put_Title 0116 ('#', "Analyzing " & Ada.Directories.Simple_Name (Unit.Get_Filename)); 0117 if Unit.Has_Diagnostics then 0118 for D of Unit.Diagnostics loop 0119 Put_Line (Unit.Format_GNU_Diagnostic (D)); 0120 end loop; 0121 New_Line; 0122 return; 0123 0124 elsif not Unit.Root.Is_Null then 0125 Unit.Root.Traverse (Process'Access); 0126 end if; 0127 end Process_Unit; 0128 end LAL_DDA; 0129 0130 type Car is record 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 end record; 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 record 0153 Skilled_In : Language_List; 0154 end record; 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