gcc/ada/sa_messages.adb

   1 ------------------------------------------------------------------------------
   2 --                       C O D E P E E R / S P A R K                        --
   3 --                                                                          --
   4 --                     Copyright (C) 2015-2018, AdaCore                     --
   5 --                                                                          --
   6 -- This is free software;  you can redistribute it  and/or modify it  under --
   7 -- terms of the  GNU General Public License as published  by the Free Soft- --
   8 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
   9 -- sion.  This software is distributed in the hope  that it will be useful, --
  10 -- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
  11 -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
  12 -- License for  more details.  You should have  received  a copy of the GNU --
  13 -- General  Public  License  distributed  with  this  software;   see  file --
  14 -- COPYING3.  If not, go to http://www.gnu.org/licenses for a complete copy --
  15 -- of the license.                                                          --
  16 --                                                                          --
  17 ------------------------------------------------------------------------------
  18
  19 pragma Ada_2012;
  20
  21 with Ada.Directories; use Ada.Directories;
  22 with Ada.Strings.Unbounded.Hash;
  23
  24 with Ada.Text_IO;     use Ada.Text_IO;
  25 with GNATCOLL.JSON;   use GNATCOLL.JSON;
  26
  27 package body SA_Messages is
  28
  29    -----------------------
  30    -- Local subprograms --
  31    -----------------------
  32
  33    function "<" (Left, Right : SA_Message) return Boolean is
  34      (if Left.Kind /= Right.Kind then
  35          Left.Kind < Right.Kind
  36       else
  37          Left.Kind in Check_Kind
  38            and then Left.Check_Result < Right.Check_Result);
  39
  40    function "<" (Left, Right : Simple_Source_Location) return Boolean is
  41       (if Left.File_Name /= Right.File_Name then
  42           Left.File_Name < Right.File_Name
  43        elsif Left.Line /= Right.Line then
  44           Left.Line < Right.Line
  45        else
  46           Left.Column < Right.Column);
  47
  48    function "<" (Left, Right : Source_Locations) return Boolean is
  49      (if Left'Length /= Right'Length then
  50          Left'Length < Right'Length
  51       elsif Left'Length = 0 then
  52          False
  53       elsif Left (Left'Last) /= Right (Right'Last) then
  54          Left (Left'Last) < Right (Right'Last)
  55       else
  56          Left (Left'First .. Left'Last - 1) <
  57            Right (Right'First .. Right'Last - 1));
  58
  59    function "<" (Left, Right : Source_Location) return Boolean is
  60      (Left.Locations < Right.Locations);
  61
  62    function Base_Location
  63      (Location : Source_Location) return Simple_Source_Location is
  64      (Location.Locations (1));
  65
  66    function Hash (Key : SA_Message) return Hash_Type;
  67    function Hash (Key : Source_Location) return Hash_Type;
  68
  69    ---------
  70    -- "<" --
  71    ---------
  72
  73    function "<" (Left, Right : Message_And_Location) return Boolean is
  74      (if Left.Message = Right.Message
  75       then Left.Location < Right.Location
  76       else Left.Message < Right.Message);
  77
  78    ------------
  79    -- Column --
  80    ------------
  81
  82    function Column (Location : Source_Location) return Column_Number is
  83      (Base_Location (Location).Column);
  84
  85    ---------------
  86    -- File_Name --
  87    ---------------
  88
  89    function File_Name (Location : Source_Location) return String is
  90      (To_String (Base_Location (Location).File_Name));
  91
  92    function File_Name (Location : Source_Location) return Unbounded_String is
  93      (Base_Location (Location).File_Name);
  94
  95    ------------------------
  96    -- Enclosing_Instance --
  97    ------------------------
  98
  99    function Enclosing_Instance
 100      (Location : Source_Location) return Source_Location_Or_Null is
 101      (Count     => Location.Count - 1,
 102       Locations => Location.Locations (2 .. Location.Count));
 103
 104    ----------
 105    -- Hash --
 106    ----------
 107
 108    function Hash (Key : Message_And_Location) return Hash_Type is
 109      (Hash (Key.Message) + Hash (Key.Location));
 110
 111    function Hash (Key : SA_Message) return Hash_Type is
 112    begin
 113       return Result : Hash_Type :=
 114                         Hash_Type'Mod (Message_Kind'Pos (Key.Kind))
 115       do
 116          if Key.Kind in Check_Kind then
 117             Result := Result +
 118               Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result));
 119          end if;
 120       end return;
 121    end Hash;
 122
 123    function Hash (Key : Source_Location) return Hash_Type is
 124    begin
 125       return Result : Hash_Type := Hash_Type'Mod (Key.Count) do
 126          for Loc of Key.Locations loop
 127             Result := Result + Hash (Loc.File_Name);
 128             Result := Result + Hash_Type'Mod (Loc.Line);
 129             Result := Result + Hash_Type'Mod (Loc.Column);
 130          end loop;
 131       end return;
 132    end Hash;
 133
 134    ---------------
 135    -- Iteration --
 136    ---------------
 137
 138    function Iteration (Location : Source_Location) return Iteration_Id is
 139      (Base_Location (Location).Iteration);
 140
 141    ----------
 142    -- Line --
 143    ----------
 144
 145    function Line (Location : Source_Location) return Line_Number is
 146      (Base_Location (Location).Line);
 147
 148    --------------
 149    -- Location --
 150    --------------
 151
 152    function Location
 153      (Item : Message_And_Location) return Source_Location is
 154      (Item.Location);
 155
 156    ----------
 157    -- Make --
 158    ----------
 159
 160    function Make
 161      (File_Name          : String;
 162       Line               : Line_Number;
 163       Column             : Column_Number;
 164       Iteration          : Iteration_Id;
 165       Enclosing_Instance : Source_Location_Or_Null) return Source_Location
 166    is
 167    begin
 168       return Result : Source_Location
 169                         (Count => Enclosing_Instance.Count + 1)
 170       do
 171          Result.Locations (1) :=
 172            (File_Name => To_Unbounded_String (File_Name),
 173             Line      => Line,
 174             Column    => Column,
 175             Iteration => Iteration);
 176
 177          Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations;
 178       end return;
 179    end Make;
 180
 181    ------------------
 182    -- Make_Msg_Loc --
 183    ------------------
 184
 185    function Make_Msg_Loc
 186      (Msg : SA_Message;
 187       Loc : Source_Location) return Message_And_Location
 188    is
 189    begin
 190       return Message_And_Location'(Count    => Loc.Count,
 191                                    Message  => Msg,
 192                                    Location => Loc);
 193    end Make_Msg_Loc;
 194
 195    -------------
 196    -- Message --
 197    -------------
 198
 199    function Message (Item : Message_And_Location) return SA_Message is
 200      (Item.Message);
 201
 202    package Field_Names is
 203
 204       --  A Source_Location value is represented in JSON as a two or three
 205       --  field value having fields Message_Kind (a string) and Locations (an
 206       --  array); if the Message_Kind indicates a check kind, then a third
 207       --  field is present: Check_Result (a string). The element type of the
 208       --  Locations array is a value having at least 4 fields:
 209       --  File_Name (a string), Line (an integer), Column (an integer),
 210       --  and Iteration_Kind (an integer); if the Iteration_Kind field
 211       --  has the value corresponding to the enumeration literal Numbered,
 212       --  then two additional integer fields are present, Iteration_Number
 213       --  and Iteration_Of_Total.
 214
 215       Check_Result       : constant String := "Check_Result";
 216       Column             : constant String := "Column";
 217       File_Name          : constant String := "File_Name";
 218       Iteration_Kind     : constant String := "Iteration_Kind";
 219       Iteration_Number   : constant String := "Iteration_Number";
 220       Iteration_Of_Total : constant String := "Iteration_Total";
 221       Line               : constant String := "Line";
 222       Locations          : constant String := "Locations";
 223       Message_Kind       : constant String := "Message_Kind";
 224       Messages           : constant String := "Messages";
 225    end Field_Names;
 226
 227    package body Writing is
 228       File : File_Type;
 229       --  The file to which output will be written (in Close, not in Write)
 230
 231       Messages : JSON_Array;
 232       --  Successive calls to Write append messages to this list
 233
 234       -----------------------
 235       -- Local subprograms --
 236       -----------------------
 237
 238       function To_JSON_Array
 239         (Locations : Source_Locations) return JSON_Array;
 240       --  Represent a Source_Locations array as a JSON_Array
 241
 242       function To_JSON_Value
 243         (Location : Simple_Source_Location) return JSON_Value;
 244       --  Represent a Simple_Source_Location as a JSON_Value
 245
 246       -----------
 247       -- Close --
 248       -----------
 249
 250       procedure Close is
 251          Value : constant JSON_Value := Create_Object;
 252
 253       begin
 254          --  only one field for now
 255          Set_Field (Value, Field_Names.Messages, Messages);
 256          Put_Line (File, Write (Item => Value, Compact => False));
 257          Clear (Messages);
 258          Close (File => File);
 259       end Close;
 260
 261       -------------
 262       -- Is_Open --
 263       -------------
 264
 265       function Is_Open return Boolean is (Is_Open (File));
 266
 267       ----------
 268       -- Open --
 269       ----------
 270
 271       procedure Open (File_Name : String) is
 272       begin
 273          Create (File => File, Mode => Out_File, Name => File_Name);
 274          Clear (Messages);
 275       end Open;
 276
 277       -------------------
 278       -- To_JSON_Array --
 279       -------------------
 280
 281       function To_JSON_Array
 282         (Locations : Source_Locations) return JSON_Array
 283       is
 284       begin
 285          return Result : JSON_Array := Empty_Array do
 286             for Location of Locations loop
 287                Append (Result, To_JSON_Value (Location));
 288             end loop;
 289          end return;
 290       end To_JSON_Array;
 291
 292       -------------------
 293       -- To_JSON_Value --
 294       -------------------
 295
 296       function To_JSON_Value
 297         (Location : Simple_Source_Location) return JSON_Value
 298       is
 299       begin
 300          return Result : constant JSON_Value := Create_Object do
 301             Set_Field (Result, Field_Names.File_Name, Location.File_Name);
 302             Set_Field (Result, Field_Names.Line, Integer (Location.Line));
 303             Set_Field (Result, Field_Names.Column, Integer (Location.Column));
 304             Set_Field (Result, Field_Names.Iteration_Kind, Integer'(
 305                        Iteration_Kind'Pos (Location.Iteration.Kind)));
 306
 307             if Location.Iteration.Kind = Numbered then
 308                Set_Field (Result, Field_Names.Iteration_Number,
 309                           Location.Iteration.Number);
 310                Set_Field (Result, Field_Names.Iteration_Of_Total,
 311                           Location.Iteration.Of_Total);
 312             end if;
 313          end return;
 314       end To_JSON_Value;
 315
 316       -----------
 317       -- Write --
 318       -----------
 319
 320       procedure Write (Message : SA_Message; Location : Source_Location) is
 321          Value : constant JSON_Value := Create_Object;
 322
 323       begin
 324          Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img);
 325
 326          if Message.Kind in Check_Kind then
 327             Set_Field
 328               (Value, Field_Names.Check_Result, Message.Check_Result'Img);
 329          end if;
 330
 331          Set_Field
 332            (Value, Field_Names.Locations, To_JSON_Array (Location.Locations));
 333          Append (Messages, Value);
 334       end Write;
 335    end Writing;
 336
 337    package body Reading is
 338       File       : File_Type;
 339       --  The file from which messages are read (in Open, not in Read)
 340
 341       Messages   : JSON_Array;
 342       --  The list of messages that were read in from File
 343
 344       Next_Index : Positive;
 345       --  The index of the message in Messages which will be returned by the
 346       --  next call to Get.
 347
 348       Parse_Full_Path : Boolean := True;
 349       --  if the full path or only the base name of the file should be parsed
 350
 351       -----------
 352       -- Close --
 353       -----------
 354
 355       procedure Close is
 356       begin
 357          Clear (Messages);
 358          Close (File);
 359       end Close;
 360
 361       ----------
 362       -- Done --
 363       ----------
 364
 365       function Done return Boolean is (Next_Index > Length (Messages));
 366
 367       ---------
 368       -- Get --
 369       ---------
 370
 371       function Get return Message_And_Location is
 372          Value : constant JSON_Value := Get (Messages, Next_Index);
 373
 374          function Get_Message (Kind :  Message_Kind) return SA_Message;
 375          --  Return SA_Message of given kind, filling in any non-discriminant
 376          --  by reading from Value.
 377
 378          function Make
 379            (Location : Source_Location;
 380             Message  : SA_Message) return Message_And_Location;
 381          --  Constructor
 382
 383          function To_Location
 384            (Encoded   : JSON_Array;
 385             Full_Path : Boolean) return Source_Location;
 386          --  Decode a Source_Location from JSON_Array representation
 387
 388          function To_Simple_Location
 389            (Encoded   : JSON_Value;
 390             Full_Path : Boolean) return Simple_Source_Location;
 391          --  Decode a Simple_Source_Location from JSON_Value representation
 392
 393          -----------------
 394          -- Get_Message --
 395          -----------------
 396
 397          function Get_Message (Kind :  Message_Kind) return SA_Message is
 398          begin
 399             --  If we had AI12-0086, then we could use aggregates here (which
 400             --  would be better than field-by-field assignment for the usual
 401             --  maintainability reasons). But we don't, so we won't.
 402
 403             return Result : SA_Message (Kind => Kind) do
 404                if Kind in Check_Kind then
 405                   Result.Check_Result :=
 406                     SA_Check_Result'Value
 407                       (Get (Value, Field_Names.Check_Result));
 408                end if;
 409             end return;
 410          end Get_Message;
 411
 412          ----------
 413          -- Make --
 414          ----------
 415
 416          function Make
 417            (Location : Source_Location;
 418             Message  : SA_Message) return Message_And_Location
 419          is
 420            (Count => Location.Count, Message => Message, Location => Location);
 421
 422          -----------------
 423          -- To_Location --
 424          -----------------
 425
 426          function To_Location
 427            (Encoded   : JSON_Array;
 428             Full_Path : Boolean) return Source_Location is
 429          begin
 430             return Result : Source_Location (Count => Length (Encoded)) do
 431                for I in Result.Locations'Range loop
 432                   Result.Locations (I) :=
 433                     To_Simple_Location (Get (Encoded, I), Full_Path);
 434                end loop;
 435             end return;
 436          end To_Location;
 437
 438          ------------------------
 439          -- To_Simple_Location --
 440          ------------------------
 441
 442          function To_Simple_Location
 443            (Encoded   : JSON_Value;
 444             Full_Path : Boolean) return Simple_Source_Location
 445          is
 446             function Get_Iteration_Id
 447               (Kind : Iteration_Kind) return Iteration_Id;
 448             --  Given the discriminant for an Iteration_Id value, return the
 449             --  entire value.
 450
 451             ----------------------
 452             -- Get_Iteration_Id --
 453             ----------------------
 454
 455             function Get_Iteration_Id (Kind : Iteration_Kind)
 456               return Iteration_Id
 457             is
 458             begin
 459                --  Initialize non-discriminant fields, if any
 460
 461                return Result : Iteration_Id (Kind => Kind) do
 462                   if Kind = Numbered then
 463                      Result :=
 464                        (Kind     => Numbered,
 465                         Number   =>
 466                           Get (Encoded, Field_Names.Iteration_Number),
 467                         Of_Total =>
 468                           Get (Encoded, Field_Names.Iteration_Of_Total));
 469                   end if;
 470                end return;
 471             end Get_Iteration_Id;
 472
 473             --  Local variables
 474
 475             FN : constant Unbounded_String :=
 476                    Get (Encoded, Field_Names.File_Name);
 477
 478          --  Start of processing for To_Simple_Location
 479
 480          begin
 481             return
 482               (File_Name =>
 483                  (if Full_Path then
 484                      FN
 485                   else
 486                      To_Unbounded_String (Simple_Name (To_String (FN)))),
 487                Line      =>
 488                  Line_Number (Integer'(Get (Encoded, Field_Names.Line))),
 489                Column    =>
 490                  Column_Number (Integer'(Get (Encoded, Field_Names.Column))),
 491                Iteration =>
 492                  Get_Iteration_Id
 493                    (Kind => Iteration_Kind'Val (Integer'(Get
 494                               (Encoded, Field_Names.Iteration_Kind)))));
 495          end To_Simple_Location;
 496
 497       --  Start of processing for Get
 498
 499       begin
 500          Next_Index := Next_Index + 1;
 501
 502          return Make
 503            (Message  =>
 504               Get_Message
 505                 (Message_Kind'Value (Get (Value, Field_Names.Message_Kind))),
 506             Location =>
 507               To_Location
 508                 (Get (Value, Field_Names.Locations), Parse_Full_Path));
 509       end Get;
 510
 511       -------------
 512       -- Is_Open --
 513       -------------
 514
 515       function Is_Open return Boolean is (Is_Open (File));
 516
 517       ----------
 518       -- Open --
 519       ----------
 520
 521       procedure Open (File_Name : String; Full_Path : Boolean := True) is
 522          File_Text : Unbounded_String := Null_Unbounded_String;
 523
 524       begin
 525          Parse_Full_Path := Full_Path;
 526          Open (File => File, Mode => In_File, Name => File_Name);
 527
 528          --  File read here, not in Get, but that's an implementation detail
 529
 530          while not End_Of_File (File) loop
 531             Append (File_Text, Get_Line (File));
 532          end loop;
 533
 534          Messages   := Get (Read (File_Text), Field_Names.Messages);
 535          Next_Index := 1;
 536       end Open;
 537    end Reading;
 538
 539 end SA_Messages;