From f05a43bbce85d50b25ab9eba2a15e1fec640133e Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Fri, 16 Nov 2018 20:21:21 +0100
Subject: errorout: add %s to display strings.

---
 src/types.ads         |  7 +++++++
 src/vhdl/errorout.adb | 27 +++++++++++++++++++++++++--
 src/vhdl/errorout.ads | 11 ++++++++---
 src/vhdl/parse.adb    |  9 +++++----
 4 files changed, 45 insertions(+), 9 deletions(-)

(limited to 'src')

diff --git a/src/types.ads b/src/types.ads
index 519ff94ee..876b3ca01 100644
--- a/src/types.ads
+++ b/src/types.ads
@@ -83,6 +83,13 @@ package Types is
 
    Null_String8 : constant String8_Id := 0;
 
+   --  The length of a string is not stored in the string table.  Create a
+   --  tuple that is meaningful.
+   type String8_Len_Type is record
+      Str : String8_Id;
+      Len : Nat32;
+   end record;
+
    --  Index type is the source file table.
    --  This table is defined in the files_map package.
    type Source_File_Entry is new Uns32;
diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb
index e068e113c..a86eb890b 100644
--- a/src/vhdl/errorout.adb
+++ b/src/vhdl/errorout.adb
@@ -26,6 +26,7 @@ with Ada.Strings.Unbounded;
 with Std_Names;
 with Flags; use Flags;
 with PSL.Nodes;
+with Str_Table;
 
 package body Errorout is
    --  Name of the program, used to report error message.
@@ -183,6 +184,11 @@ package body Errorout is
       return (Kind => Earg_Char, Val_Char => V);
    end "+";
 
+   function "+" (V : String8_Len_Type) return Earg_Type is
+   begin
+      return (Kind => Earg_String8, Val_Str8 => V);
+   end "+";
+
    function Get_Location_Safe (N : Iir) return Location_Type is
    begin
       if N = Null_Iir then
@@ -543,6 +549,22 @@ package body Errorout is
                               raise Internal_Error;
                         end case;
                      end;
+                  when 's' =>
+                     --  String
+                     declare
+                        Arg : Earg_Type renames Args (Argn);
+                     begin
+                        Put ('"');
+                        case Arg.Kind is
+                           when Earg_String8 =>
+                              Put (Str_Table.String_String8
+                                     (Arg.Val_Str8.Str, Arg.Val_Str8.Len));
+                           when others =>
+                              --  Invalid conversion to character.
+                              raise Internal_Error;
+                        end case;
+                        Put ('"');
+                     end;
                   when others =>
                      --  Unknown format.
                      raise Internal_Error;
@@ -680,9 +702,10 @@ package body Errorout is
       Report_Msg (Msgid_Error, Parse, No_Location, Msg);
    end Error_Msg_Parse_1;
 
-   procedure Error_Msg_Parse (Loc : Location_Type; Msg: String) is
+   procedure Error_Msg_Parse
+     (Loc : Location_Type; Msg: String; Args : Earg_Arr := No_Eargs) is
    begin
-      Report_Msg (Msgid_Error, Parse, Loc, Msg);
+      Report_Msg (Msgid_Error, Parse, Loc, Msg, Args);
    end Error_Msg_Parse;
 
    -- Disp a message during semantic analysis.
diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads
index f16f44fa9..a6cf848a0 100644
--- a/src/vhdl/errorout.ads
+++ b/src/vhdl/errorout.ads
@@ -161,12 +161,14 @@ package Errorout is
    --  %t: token
    --  %l: location
    --  %n: node name
-   --  TODO: %m: mode, %y: type of, %s: disp_subprg
+   --  %s: a string
+   --  TODO: %m: mode, %y: type of
    function "+" (V : Iir) return Earg_Type;
    function "+" (V : Location_Type) return Earg_Type;
    function "+" (V : Name_Id) return Earg_Type;
    function "+" (V : Tokens.Token_Type) return Earg_Type;
    function "+" (V : Character) return Earg_Type;
+   function "+" (V : String8_Len_Type) return Earg_Type;
 
    --  Convert location.
    function "+" (L : Iir) return Location_Type;
@@ -216,7 +218,8 @@ package Errorout is
    procedure Error_Msg_Parse (Msg: String; Arg1 : Earg_Type);
    procedure Error_Msg_Parse
      (Msg: String; Args : Earg_Arr := No_Eargs; Cont : Boolean := False);
-   procedure Error_Msg_Parse (Loc : Location_Type; Msg: String);
+   procedure Error_Msg_Parse
+     (Loc : Location_Type; Msg: String; Args : Earg_Arr := No_Eargs);
 
    -- Disp a message during semantic analysis.
    procedure Warning_Msg_Sem (Id : Msgid_Warnings;
@@ -319,7 +322,7 @@ package Errorout is
 private
    type Earg_Kind is
      (Earg_None,
-      Earg_Iir, Earg_Location, Earg_Id, Earg_Char, Earg_Token);
+      Earg_Iir, Earg_Location, Earg_Id, Earg_Char, Earg_Token, Earg_String8);
 
    type Earg_Type (Kind : Earg_Kind := Earg_None) is record
       case Kind is
@@ -335,6 +338,8 @@ private
             Val_Char : Character;
          when Earg_Token =>
             Val_Tok : Tokens.Token_Type;
+         when Earg_String8 =>
+            Val_Str8 : String8_Len_Type;
       end case;
    end record;
 
diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb
index 4ac5e0f2a..88ee15433 100644
--- a/src/vhdl/parse.adb
+++ b/src/vhdl/parse.adb
@@ -405,15 +405,16 @@ package body Parse is
 
       procedure Bad_Operator_Symbol is
       begin
-         Error_Msg_Parse (Loc, """" & Str_Table.String_String8 (Str_Id, Len)
-                          & """ is not an operator symbol");
+         Error_Msg_Parse
+           (+Loc, "%s is not an operator symbol", (1 => +((Str_Id, Len))));
       end Bad_Operator_Symbol;
 
       procedure Check_Vhdl93 is
       begin
          if Flags.Vhdl_Std = Vhdl_87 then
-            Error_Msg_Parse (Loc, """" & Str_Table.String_String8 (Str_Id, Len)
-                             & """ is not a vhdl87 operator symbol");
+            Error_Msg_Parse
+              (+Loc, "%s is not a vhdl87 operator symbol",
+               (1 => +((Str_Id, Len))));
          end if;
       end Check_Vhdl93;
 
-- 
cgit v1.2.3