Add color diagnostics, show diagnostic option.

9 files changed, 245 insertions, 56 deletions

diff --git a/doc/Invoking_GHDL.rst b/doc/Invoking_GHDL.rst
index fb121ed22..f75345f2f 100644
--- a/doc/Invoking_GHDL.rst
+++ b/doc/Invoking_GHDL.rst
@@ -414,6 +414,9 @@ manual for details.
   :samp:`state1` are homograph, the enumeration literal is hidden in the
   immediate scope of the constant).
 
+  This option also relaxes the rules about pure functions.  Violations
+  result in warnings instead of errors.
+
 
 .. option:: -fpsl
 
@@ -480,6 +483,7 @@ manual for details.
   Be verbose.  For example, for analysis, elaboration and make commands, GHDL
   displays the commands executed.
 
+
 Passing options to other programs
 =================================
 
@@ -507,6 +511,20 @@ GCC manual for details on GCC options.
 
   Pass `OPTION` as an option to the linker.
 
+GHDL Diagnostics Control
+========================
+
+.. option:: -f[no-]color-diagnostics
+
+  Control whether diagnostic messages are displayed in color.  The
+  default is on when the standard output is a terminal.
+
+.. option:: -f[no-]diagnostics-show-option
+
+  Control whether the warning option is displayed at the end of
+  warning messages, so that user can easily know how to disable it.
+
+
 GHDL warnings
 =============
 
@@ -514,8 +532,8 @@ Some constructions are not erroneous but dubious.  Warnings are diagnostic
 messages that report such constructions.  Some warnings are reported only
 during analysis, others during elaboration.
 
-You could disable a warning by using the :samp:`--warn-no-XXX`
-instead of :samp:`--warn-XXX`.
+You could disable a warning by using the :samp:`--warn-no-XXX` or
+:samp:`-Wno-XX` instead of :samp:`--warn-XXX` or :samp:`-WXXX`.
 
 
 .. option:: --warn-reserved
@@ -592,6 +610,22 @@ instead of :samp:`--warn-XXX`.
   When this option is set, warnings are considered as errors.
 
 
+.. option:: --warn-nested-comment
+
+  Emit a warning if a :samp:`/*` appears within a block comment (vhdl 2008).
+
+
+.. option:: --warn-parenthesis
+
+  Emit a warning in case of weird use of parenthesis
+
+
+.. option:: --warn-runtime-error
+
+  Emit a warning in case of runtime error that is detected during
+  analysis.
+
+
 Rebuilding commands
 ===================
 
diff --git a/src/flags.ads b/src/flags.ads
index 1bb59c806..cdcdd0202 100644
--- a/src/flags.ads
+++ b/src/flags.ads
@@ -153,4 +153,18 @@ package Flags is
    --  --warn-error
    --  Turns warnings into errors.
    Warn_Error : Boolean := False;
+
+   --  If True, disp original source line and a caret indicating the column.
+   Flag_Caret_Diagnostics : Boolean := False;
+
+   type On_Off_Auto_Type is (On, Off, Auto);
+
+   --  -fcolor-diagnostics
+   --  -fno-color-diagnostics
+   --  Enable colors in diagnostic messages.  The default is auto, which turns
+   --  on when a terminal is detected on the standard error.
+   Flag_Color_Diagnostics : On_Off_Auto_Type := Auto;
+
+   --  -fdiagnostics-show-option
+   Flag_Diagnostics_Show_Option : Boolean := True;
 end Flags;
diff --git a/src/libraries.adb b/src/libraries.adb
index 3f737f466..a49931071 100644
--- a/src/libraries.adb
+++ b/src/libraries.adb
@@ -63,12 +63,6 @@ package body Libraries is
       Report_Msg (Msgid_Error, Library, No_Location, Msg, (1 => Arg1));
    end Error_Lib_Msg;
 
-   --  Report a warning message.
-   procedure Warning_Lib_Msg (Msg : String; Args : Earg_Arr := No_Eargs) is
-   begin
-      Report_Msg (Msgid_Warning, Library, No_Location, Msg, Args);
-   end Warning_Lib_Msg;
-
    --  Initialize pathes table.
    --  Set the local path.
    procedure Init_Pathes
@@ -190,11 +184,14 @@ package body Libraries is
    procedure Set_Work_Library_Path (Path : String) is
    begin
       Work_Directory := Path_To_Id (Path);
-      if not GNAT.OS_Lib.Is_Directory (Get_Address (Work_Directory)) then
+      if not GNAT.OS_Lib.Is_Directory (Get_Address (Work_Directory))
+        and then Is_Warning_Enabled (Warnid_Library)
+      then
          --  This is a warning, since 'clean' action should not fail in
          --  this cases.
-         Warning_Lib_Msg
-           ("directory '" & Path & "' set by --workdir= does not exist");
+         Warning_Msg_Option
+           (Warnid_Library,
+            "directory '" & Path & "' set by --workdir= does not exist");
          --  raise Option_Error;
       end if;
    end Set_Work_Library_Path;
@@ -1054,13 +1051,16 @@ package body Libraries is
                if Is_Warning_Enabled (Warnid_Library) then
                   if Get_Kind (Library_Unit) /= Get_Kind (New_Library_Unit)
                   then
-                     Warning_Lib_Msg
-                       ("changing definition of a library unit:");
-                     Warning_Lib_Msg
-                       ("%n is now %n", (+Library_Unit, +New_Library_Unit));
+                     Warning_Msg_Sem
+                       (Warnid_Library, +Unit,
+                        "changing definition of a library unit:");
+                     Warning_Msg_Sem
+                       (Warnid_Library, +Unit,
+                        "%n is now %n", (+Library_Unit, +New_Library_Unit));
                   end if;
-                  Warning_Lib_Msg
-                    ("library unit %i was also defined in file %i",
+                  Warning_Msg_Sem
+                    (Warnid_Library, +Unit,
+                     "library unit %i was also defined in file %i",
                      (+Library_Unit, +Get_Design_File_Filename (Design_File)));
                end if;
             end if;
diff --git a/src/options.adb b/src/options.adb
index adfb605d4..e36e8bedd 100644
--- a/src/options.adb
+++ b/src/options.adb
@@ -106,9 +106,15 @@ package body Options is
       elsif Opt'Length > 10 and then Opt (1 .. 10) = "--workdir=" then
          Libraries.Set_Work_Library_Path (Opt (11 .. Opt'Last));
       elsif Opt'Length > 10 and then Opt (1 .. 10) = "--warn-no-" then
+         --  Handle --warn-no before -warn-!
          return Option_Warning (Opt (11 .. Opt'Last), False);
       elsif Opt'Length > 7 and then Opt (1 .. 7) = "--warn-" then
          return Option_Warning (Opt (8 .. Opt'Last), True);
+      elsif Opt'Length > 5 and then Opt (1 .. 5) = "-Wno-" then
+         --  Handle -Wno before -W!
+         return Option_Warning (Opt (6 .. Opt'Last), False);
+      elsif Opt'Length > 2 and then Opt (1 .. 2) = "-W" then
+         return Option_Warning (Opt (3 .. Opt'Last), True);
       elsif Opt'Length > 7 and then Opt (1 .. 7) = "--work=" then
          declare
             use Name_Table;
@@ -120,6 +126,18 @@ package body Options is
          end;
       elsif Opt = "-C" or else Opt = "--mb-comments" then
          Mb_Comment := True;
+      elsif Opt = "-fcaret-diagnostics" then
+         Flag_Caret_Diagnostics := True;
+      elsif Opt = "-fno-caret-diagnostics" then
+         Flag_Caret_Diagnostics := False;
+      elsif Opt = "-fcolor-diagnostics" then
+         Flag_Color_Diagnostics := On;
+      elsif Opt = "-fno-color-diagnostics" then
+         Flag_Color_Diagnostics := Off;
+      elsif Opt = "-fdiagnostics-show-option" then
+         Flag_Diagnostics_Show_Option := True;
+      elsif Opt = "-fno-diagnostics-show-option" then
+         Flag_Diagnostics_Show_Option := False;
       elsif Opt = "--bootstrap" then
          Bootstrap := True;
       elsif Opt = "-fexplicit" then
@@ -212,15 +230,15 @@ package body Options is
       P ("  --[no-]vital-checks  do [not] check VITAL restrictions");
       P ("Warnings:");
 --    P ("  --warn-undriven    disp undriven signals");
-      P ("  --warn-binding     warns for component not bound");
-      P ("  --warn-reserved    warns use of 93 reserved words in vhdl87");
-      P ("  --warn-library     warns for redefinition of a design unit");
-      P ("  --warn-vital-generic  warns of non-vital generic names");
-      P ("  --warn-delayed-checks warns for checks performed at elaboration");
-      P ("  --warn-body        warns for not necessary package body");
-      P ("  --warn-specs       warns if a all/others spec does not apply");
-      P ("  --warn-unused      warns if a subprogram is never used");
-      P ("  --warn-error       turns warnings into errors");
+      P ("  -Wbinding          warns for component not bound");
+      P ("  -Wreserved         warns use of 93 reserved words in vhdl87");
+      P ("  -Wlibrary          warns for redefinition of a design unit");
+      P ("  -Wvital-generic    warns of non-vital generic names");
+      P ("  -Wdelayed-checks   warns for checks performed at elaboration");
+      P ("  -Wbody             warns for not necessary package body");
+      P ("  -Wspecs            warns if a all/others spec does not apply");
+      P ("  -Wunused           warns if a subprogram is never used");
+      P ("  -Werror            turns warnings into errors");
 --    P ("Simulation option:");
 --    P ("  --time-resolution=UNIT   set the resolution of type time");
 --    P ("            UNIT can be fs, ps, ns, us, ms, sec, min or hr");
diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb
index 60e77871a..a0b279752 100644
--- a/src/vhdl/errorout.adb
+++ b/src/vhdl/errorout.adb
@@ -22,16 +22,69 @@ with Iirs_Utils; use Iirs_Utils;
 with Files_Map; use Files_Map;
 with Ada.Strings.Unbounded;
 with Std_Names;
-with Flags;
+with Flags; use Flags;
 with PSL.Nodes;
 
 package body Errorout is
-   --  If True, disp original source line and a caret indicating the column.
-   Flag_Show_Caret : constant Boolean := False;
-
    --  Name of the program, used to report error message.
    Program_Name : String_Acc := null;
 
+   --  Terminal.
+
+   --  Set Flag_Color_Diagnostics to On or Off if is was Auto.
+   procedure Detect_Terminal
+   is
+      function isatty (Fd : Integer) return Integer;
+      pragma Import (C, isatty);
+   begin
+      if Flag_Color_Diagnostics = Auto then
+         if isatty (2) /= 0 then
+            Flag_Color_Diagnostics := On;
+         else
+            Flag_Color_Diagnostics := Off;
+         end if;
+      end if;
+   end Detect_Terminal;
+
+   --  Color to be used for various part of messages.
+   type Color_Type is (Color_Locus,
+                       Color_Note, Color_Warning, Color_Error, Color_Fatal,
+                       Color_Message,
+                       Color_None);
+
+   --  Switch to COLOR.
+   procedure Set_Color (Color : Color_Type)
+   is
+      procedure Put (S : String)
+      is
+         use Ada.Text_IO;
+      begin
+         Put (Standard_Error, S);
+      end Put;
+   begin
+      if Flag_Color_Diagnostics = Off then
+         return;
+      end if;
+
+      --  Use ANSI sequences.
+      --  They are also documented on msdn in 'Console Virtual Terminal
+      --  sequences'.
+
+      Put (ASCII.ESC & '[');
+      case Color is
+         when Color_Locus   => Put ("1");    --  Bold
+         when Color_Note    => Put ("1;36"); --  Bold, cyan
+         when Color_Warning => Put ("1;35"); --  Bold, magenta
+         when Color_Error   => Put ("1;31"); --  Bold, red
+         when Color_Fatal   => Put ("1;33"); --  Bold, yellow
+         when Color_Message => Put ("0;1");  --  Normal, bold
+         when Color_None    => Put ("0");    --  Normal
+      end case;
+      Put ("m");
+   end Set_Color;
+
+   --  Warnings.
+
    type Warning_Control_Type is record
       Enabled : Boolean;
       Error : Boolean;
@@ -40,8 +93,11 @@ package body Errorout is
    type Warnings_Array is array (Msgid_Warnings) of Warning_Control_Type;
 
    Warnings_Control : Warnings_Array :=
-     (Warnid_Binding => (Enabled => True, Error => False),
-      others         => (Enabled => False, Error => False));
+     (Warnid_Binding
+        | Warnid_Library => (Enabled => True, Error => False),
+      Warnid_Shared
+        | Warnid_Pure    => (Enabled => True, Error => False),
+      others             => (Enabled => False, Error => False));
 
    procedure Enable_Warning (Id : Msgid_Warnings; Enable : Boolean) is
    begin
@@ -56,12 +112,15 @@ package body Errorout is
    function Warning_Image (Id : Msgid_Warnings) return String
    is
       Img : constant String := Msgid_Warnings'Image (Id);
+
+      --  Prefix to strip.
       Prefix : constant String := "WARNID_";
       pragma Assert (Img'Length > Prefix'Length);
       pragma Assert (Img (1 .. Prefix'Length) = Prefix);
       Res : String (1 .. Img'Last - Prefix'Length);
       C : Character;
    begin
+      --  Convert to lower cases, and '_' to '-'.
       for I in Res'Range loop
          C := Img (Prefix'Length + I);
          case C is
@@ -74,6 +133,7 @@ package body Errorout is
          end case;
          Res (I) := C;
       end loop;
+
       return Res;
    end Warning_Image;
 
@@ -142,7 +202,7 @@ package body Errorout is
       Put (Standard_Error, C);
    end Put;
 
-   procedure Put_Line (Str : String)
+   procedure Put_Line (Str : String := "")
    is
       use Ada.Text_IO;
    begin
@@ -183,7 +243,11 @@ package body Errorout is
    procedure Disp_Location
      (File: Name_Id; Line: Natural; Col: Natural) is
    begin
-      Put (Name_Table.Image (File));
+      if File = Null_Identifier then
+         Put ("??");
+      else
+         Put (Name_Table.Image (File));
+      end if;
       Put (':');
       Disp_Natural (Line);
       Put (':');
@@ -238,6 +302,8 @@ package body Errorout is
       --  And no program name.
       Progname := False;
 
+      Detect_Terminal;
+
       case Origin is
          when Option
            | Library =>
@@ -276,12 +342,16 @@ package body Errorout is
 
       Msg_Len := 0;
 
+      if Flag_Color_Diagnostics = On then
+         Set_Color (Color_Locus);
+      end if;
+
       if Progname then
          Disp_Program_Name;
       elsif File /= No_Source_File_Entry then
          Disp_Location (Get_File_Name (File), Line, Col);
       else
-         Put ("??:??:??:");
+         Disp_Location (Null_Identifier, 0, 0);
       end if;
 
       --  Display level.
@@ -298,20 +368,38 @@ package body Errorout is
 
          case Id_Level is
             when Msgid_Note =>
+               if Flag_Color_Diagnostics = On then
+                  Set_Color (Color_Note);
+               end if;
                Put ("note:");
             when Msgid_Warning | Msgid_Warnings =>
+               if Flag_Color_Diagnostics = On then
+                  Set_Color (Color_Warning);
+               end if;
                Put ("warning:");
             when Msgid_Error =>
                Nbr_Errors := Nbr_Errors + 1;
-               if Msg_Len = 0 then
-                  --  'error:' is displayed only if not location is present.
+               if Flag_Color_Diagnostics = On then
+                  Set_Color (Color_Error);
+               end if;
+               if Msg_Len = 0
+                 or else Flag_Color_Diagnostics = On
+               then
+                  --  'error:' is displayed only if not location is present, or
+                  --  if messages are colored.
                   Put ("error:");
                end if;
             when Msgid_Fatal =>
+               if Flag_Color_Diagnostics = On then
+                  Set_Color (Color_Fatal);
+               end if;
                Put ("fatal:");
          end case;
       end;
 
+      if Flag_Color_Diagnostics = On then
+         Set_Color (Color_Message);
+      end if;
       Put (' ');
 
       --  Display message.
@@ -442,13 +530,27 @@ package body Errorout is
             end if;
             N := N + 1;
          end loop;
-         Put_Line (Msg (First .. N - 1));
+         Put (Msg (First .. N - 1));
 
          --  Are all arguments displayed ?
          pragma Assert (Argn > Args'Last);
       end;
 
-      if Flag_Show_Caret
+      if Flag_Diagnostics_Show_Option
+        and then Id in Msgid_Warnings
+      then
+         Put (" [-W");
+         Put (Warning_Image (Id));
+         Put ("]");
+      end if;
+
+      if Flag_Color_Diagnostics = On then
+         Set_Color (Color_None);
+      end if;
+
+      Put_Line;
+
+      if Flag_Caret_Diagnostics
         and then (File /= No_Source_File_Entry and Line /= 0)
       then
          declare
@@ -481,6 +583,11 @@ package body Errorout is
       raise Option_Error;
    end Error_Msg_Option;
 
+   procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String) is
+   begin
+      Report_Msg (Id, Option, No_Location, Msg);
+   end Warning_Msg_Option;
+
    procedure Warning_Msg_Sem (Id : Msgid_Warnings;
                               Loc : Location_Type;
                               Msg: String;
@@ -598,15 +705,18 @@ package body Errorout is
    end Error_Msg_Sem_1;
 
    procedure Error_Msg_Relaxed (Origin : Report_Origin;
+                                Id : Msgid_Warnings;
                                 Msg : String;
                                 Loc : Iir;
                                 Args : Earg_Arr := No_Eargs)
    is
-      use Flags;
       Level : Msgid_Type;
    begin
       if Flag_Relaxed_Rules or Vhdl_Std = Vhdl_93c then
-         Level := Msgid_Warning;
+         if not Is_Warning_Enabled (Id) then
+            return;
+         end if;
+         Level := Id;
       else
          Level := Msgid_Error;
       end if;
@@ -614,10 +724,11 @@ package body Errorout is
    end Error_Msg_Relaxed;
 
    procedure Error_Msg_Sem_Relaxed (Loc : Iir;
+                                    Id : Msgid_Warnings;
                                     Msg : String;
                                     Args : Earg_Arr := No_Eargs) is
    begin
-      Error_Msg_Relaxed (Semantic, Msg, Loc, Args);
+      Error_Msg_Relaxed (Semantic, Id, Msg, Loc, Args);
    end Error_Msg_Sem_Relaxed;
 
    -- Disp a message during elaboration.
@@ -1425,10 +1536,12 @@ package body Errorout is
          L := Loc;
       end if;
       Error_Msg_Relaxed
-        (Origin, "pure " & Disp_Node (Caller) & " cannot call (impure) "
+        (Origin, Warnid_Pure,
+         "pure " & Disp_Node (Caller) & " cannot call (impure) "
          & Disp_Node (Callee), L);
       Error_Msg_Relaxed
-        (Origin, "(" & Disp_Node (Callee) & " is defined here)", Callee);
+        (Origin, Warnid_Pure,
+         "(" & Disp_Node (Callee) & " is defined here)", Callee);
    end Error_Pure;
 
    procedure Error_Not_Match (Expr: Iir; A_Type: Iir)
diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads
index 793c7a36f..417ea9077 100644
--- a/src/vhdl/errorout.ads
+++ b/src/vhdl/errorout.ads
@@ -94,10 +94,16 @@ package Errorout is
       --  Signal assignment creates a delta cycle in a postponed process.
       Warnid_Delta_Cycle,
 
+      --  Declaration of a shared variable with a non-protected type.
+      Warnid_Shared,
+
       --  Emit a warning when a declaration is never used.
       --  FIXME: currently only subprograms are handled.
       Warnid_Unused,
 
+      --  Violation of pure rules.
+      Warnid_Pure,
+
       --  Any error
       Msgid_Error,
 
@@ -106,7 +112,7 @@ package Errorout is
 
    --  All specific warning messages.
    subtype Msgid_Warnings is Msgid_Type
-     range Warnid_Library .. Warnid_Unused;
+     range Warnid_Library .. Warnid_Pure;
 
    --  Get the image of a warning.  This correspond the the identifier of ID,
    --  in lower case, without the Msgid_Warn_ prefix and with '_' replaced
@@ -166,6 +172,9 @@ package Errorout is
    --  Same as Error_Msg_Option but do not raise Option_Error.
    procedure Error_Msg_Option_NR (Msg: String);
 
+   --  Warn about an option.
+   procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String);
+
    -- Disp a message during scan.
    -- The current location is automatically displayed before the message.
    procedure Error_Msg_Scan (Msg: String);
@@ -208,6 +217,7 @@ package Errorout is
 
    --  Like Error_Msg_Sem, but a warning if -frelaxed or --std=93c.
    procedure Error_Msg_Sem_Relaxed (Loc : Iir;
+                                    Id : Msgid_Warnings;
                                     Msg : String;
                                     Args : Earg_Arr := No_Eargs);
 
diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb
index a213ceee2..24c991a45 100644
--- a/src/vhdl/sem.adb
+++ b/src/vhdl/sem.adb
@@ -1879,7 +1879,7 @@ package body Sem is
                     and then Get_Pure_Flag (Subprg)
                   then
                      Error_Msg_Sem_Relaxed
-                       (Subprg,
+                       (Subprg, Warnid_Pure,
                         "result subtype of a pure function cannot denote an"
                           & " access type");
                   end if;
@@ -1889,7 +1889,8 @@ package body Sem is
                     and then Get_Pure_Flag (Subprg)
                   then
                      Error_Msg_Sem_Relaxed
-                       (Subprg, "result subtype of a pure function cannot have"
+                       (Subprg, Warnid_Pure,
+                        "result subtype of a pure function cannot have"
                           & " access subelements");
                   end if;
             end case;
diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb
index d39d0a978..122bcf17e 100644
--- a/src/vhdl/sem_decls.adb
+++ b/src/vhdl/sem_decls.adb
@@ -1938,19 +1938,16 @@ package body Sem_Decls is
             --  parse.
             if Flags.Vhdl_Std >= Vhdl_00 then
                declare
-                  Base_Type : Iir;
-                  Is_Protected : Boolean;
-               begin
-                  Base_Type := Get_Base_Type (Atype);
-                  Is_Protected :=
+                  Base_Type : constant Iir := Get_Base_Type (Atype);
+                  Is_Protected : constant Boolean :=
                     Get_Kind (Base_Type) = Iir_Kind_Protected_Type_Declaration;
-
+               begin
                   --  LRM00 4.3.1.3
                   --  The base type of the subtype indication of a
                   --  shared variable declaration must be a protected type.
                   if Get_Shared_Flag (Decl) and not Is_Protected then
                      Error_Msg_Sem_Relaxed
-                       (Decl,
+                       (Decl, Warnid_Shared,
                         "type of a shared variable must be a protected type");
                   end if;
 
@@ -2099,7 +2096,8 @@ package body Sem_Decls is
                Spec := Get_Subprogram_Specification (Parent);
                if Get_Pure_Flag (Spec) then
                   Error_Msg_Sem_Relaxed
-                    (Decl, "cannot declare a file in a pure function");
+                    (Decl, Warnid_Pure,
+                     "cannot declare a file in a pure function");
                end if;
             when Iir_Kind_Procedure_Body =>
                Spec := Get_Subprogram_Specification (Parent);
diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb
index ad82e329f..ca882c8db 100644
--- a/src/vhdl/sem_names.adb
+++ b/src/vhdl/sem_names.adb
@@ -1366,7 +1366,8 @@ package body Sem_Names is
       is
       begin
          Error_Msg_Sem_Relaxed
-           (Loc, "reference to %n violate pure rule for %n", (+Obj, +Subprg));
+           (Loc, Warnid_Pure,
+            "reference to %n violate pure rule for %n", (+Obj, +Subprg));
       end Error_Pure;
 
       Subprg : constant Iir := Sem_Stmts.Get_Current_Subprogram;