-- Error message handling. -- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 2 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . with Types; use Types; package Errorout is Compilation_Error: exception; -- The number of errors (ie, number of calls to error_msg*). Nbr_Errors : Natural := 0; -- Maximum number of errors, before silent them. Max_Nbr_Errors : Natural := 100; type Msgid_Type is ( -- Any note Msgid_Note, -- Specific warnings -- Design unit redefines another design unit. Warnid_Library, -- Option is deprecated. Warnid_Deprecated_Option, -- Unexpected option. Warnid_Unexpected_Option, -- Missing Xref in pretty print. Warnid_Missing_Xref, -- No default binding for a component instantiation. Warnid_Default_Binding, -- Unbound component. Warnid_Binding, -- Unconnected IN port without defaults (in relaxed mode). Warnid_Port, -- Vhdl93 reserved word is used as a vhdl87 identifier. Warnid_Reserved_Word, -- Anything about pragma: unknown pragma, nested pragma... Warnid_Pragma, -- Start of block comment ('/*') appears in a block comment. Warnid_Nested_Comment, -- Use of a tool directive. Warnid_Directive, -- Weird use of parenthesis. Warnid_Parenthesis, -- Generic of a vital entity is not a vital name. Warnid_Vital_Generic, -- Delayed checks (checks performed at elaboration time). Warnid_Delayed_Checks, -- Package body is not required but is analyzed. Warnid_Body, -- An all/others specification does not apply, because there is no such -- named entities. Warnid_Specs, -- Incorrect use of universal value. Warnid_Universal, -- Mismatch of bounds between actual and formal in a scalar port -- association Warnid_Port_Bounds, -- Runtime error detected at analysis time. Warnid_Runtime_Error, -- 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, -- A declaration hides a previous one. Warnid_Hide, -- Emit a warning when a declaration is never used. -- FIXME: currently only subprograms are handled. Warnid_Unused, -- Others choice is not needed, all values are already covered. Warnid_Others, -- Violation of pure rules. Warnid_Pure, -- Assertion during analysis. Warnid_Analyze_Assert, -- Incorrect use of attributes (like non-object prefix). Warnid_Attribute, -- Violation of staticness rules Warnid_Static, -- Any warning Msgid_Warning, -- Any error Msgid_Error, -- Any fatal error Msgid_Fatal ); -- All specific warning messages. subtype Msgid_Warnings is Msgid_Type range Warnid_Library .. Warnid_Static; subtype Msgid_All_Warnings is Msgid_Type range Msgid_Warnings'First .. Msgid_Warning; -- Get the image of a warning. This correspond the the identifier of ID, -- in lower case, without the Msgid_Warn_ prefix and with '_' replaced -- by '-'. function Warning_Image (Id : Msgid_Warnings) return String; -- Enable or disable a warning. procedure Enable_Warning (Id : Msgid_Warnings; Enable : Boolean); -- Get enable status of a warning. function Is_Warning_Enabled (Id : Msgid_Warnings) return Boolean; -- Consider a warning as an error. procedure Warning_Error (Id : Msgid_All_Warnings; As_Error : Boolean); -- State of warnings. type Warnings_Setting is private; -- Global control of warnings. -- Used to disable warnings while a referenced unit is analyzed. procedure Save_Warnings_Setting (Res : out Warnings_Setting); procedure Disable_All_Warnings; procedure Restore_Warnings_Setting (Res : Warnings_Setting); type Earg_Type is private; type Earg_Arr is array (Natural range <>) of Earg_Type; -- An empty array (for no arguments). No_Eargs : constant Earg_Arr; -- Report display: -- %%: % -- %i: identifier -- %c: character -- %t: token -- %l: location -- %n: node name -- %s: a string -- %v: value -- TODO: %m: mode, %y: type of function "+" (V : Location_Type) return Earg_Type; function "+" (V : Name_Id) return Earg_Type; function "+" (V : Character) return Earg_Type; function "+" (V : String8_Len_Type) return Earg_Type; function "+" (V : Uns32) return Earg_Type; function "+" (V : Int32) return Earg_Type; -- Convert location. function "+" (L : Location_Type) return Source_Coord_Type; -- Pass that detected the error. type Report_Origin is (Option, Library, Scan, Parse, Semantic, Elaboration); -- Generic report message. -- If ORIGIN is Option or Library, LOC must be No_Source_Coord and the -- program name is displayed. procedure Report_Msg (Id : Msgid_Type; Origin : Report_Origin; Loc : Source_Coord_Type; Msg : String; Args : Earg_Arr := No_Eargs); -- Group several messages (for multi-lines messages). -- Report_Start_Group must be called before the first Report_Msg call, -- and Report_End_Group after the last one. procedure Report_Start_Group; procedure Report_End_Group; -- Disp an error, prepended with program name. -- This is used for errors before initialisation, such as bad option or -- bad filename. procedure Error_Msg_Option (Msg: String); -- Warn about an option. procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String); -- Low level part. type Error_Record is record Origin : Report_Origin; Id : Msgid_Type; -- Error soure file. File : Source_File_Entry; -- The first line is line 1, 0 can be used when line number is not -- relevant. Line : Natural; -- Offset in the line. The first character is at offset 0. Offset : Natural; -- Length of the location (for a range). It is assumed to be on the -- same line; use 0 when unknown. Length : Natural; end record; type Error_Start_Handler is access procedure (Err : Error_Record); type Message_Str_Handler is access procedure (Str : String); type Message_End_Handler is access procedure; type Message_Group_Handler is access procedure (Start : Boolean); type Report_Msg_Handler is record Error_Start : Error_Start_Handler; Message : Message_Str_Handler; Message_End : Message_End_Handler; Message_Group : Message_Group_Handler; end record; procedure Set_Report_Handler (Handler : Report_Msg_Handler); type Earg_Kind is (Earg_None, Earg_Location, Earg_Id, Earg_Char, Earg_String8, Earg_Uns32, Earg_Int32, Earg_Vhdl_Node, Earg_Vhdl_Token, Earg_Synth_Instance, Earg_Synth_Net, Earg_Synth_Name); subtype Earg_Lang_Kind is Earg_Kind range Earg_Vhdl_Node .. Earg_Kind'Last; type Earg_Handler is access procedure (Format : Character; Err : Error_Record; Val : Uns32); procedure Register_Earg_Handler (Kind : Earg_Kind; Handler : Earg_Handler); procedure Output_Quoted_Identifier (Id : Name_Id); procedure Output_Identifier (Id : Name_Id); procedure Output_Location (Err : Error_Record; Loc : Location_Type); procedure Output_Message (S : String); procedure Output_Uns32 (V : Uns32); function Make_Earg_Vhdl_Node (V : Uns32) return Earg_Type; function Make_Earg_Vhdl_Token (V : Uns32) return Earg_Type; function Make_Earg_Synth_Instance (V : Uns32) return Earg_Type; function Make_Earg_Synth_Net (V : Uns32) return Earg_Type; function Make_Earg_Synth_Name (V : Uns32) return Earg_Type; private type Earg_Type (Kind : Earg_Kind := Earg_None) is record case Kind is when Earg_None => null; when Earg_Location => Val_Loc : Location_Type; when Earg_Id => Val_Id : Name_Id; when Earg_Char => Val_Char : Character; when Earg_String8 => Val_Str8 : String8_Len_Type; when Earg_Uns32 => Val_Uns32 : Uns32; when Earg_Int32 => Val_Int32 : Int32; when Earg_Lang_Kind => Val_Lang : Uns32; end case; end record; No_Eargs : constant Earg_Arr := (1 .. 0 => (Kind => Earg_None)); type Warning_Control_Type is record Enabled : Boolean; Error : Boolean; end record; type Warnings_Setting is array (Msgid_All_Warnings) of Warning_Control_Type; Default_Warnings : constant Warnings_Setting := (Warnid_Library | Warnid_Binding | Warnid_Port | Warnid_Shared | Warnid_Runtime_Error | Warnid_Pure | Warnid_Specs | Warnid_Hide | Warnid_Pragma | Warnid_Analyze_Assert | Warnid_Attribute | Warnid_Deprecated_Option | Warnid_Unexpected_Option | Msgid_Warning => (Enabled => True, Error => False), Warnid_Delta_Cycle | Warnid_Body | Warnid_Static | Warnid_Nested_Comment | Warnid_Universal | Warnid_Port_Bounds | Warnid_Others | Warnid_Reserved_Word | Warnid_Directive | Warnid_Parenthesis | Warnid_Delayed_Checks | Warnid_Default_Binding | Warnid_Vital_Generic | Warnid_Missing_Xref | Warnid_Unused => (Enabled => False, Error => False)); -- Compute the column from Error_Record E. function Get_Error_Col (E : Error_Record) return Natural; -- Image of VAL, without the leading space. function Natural_Image (Val: Natural) return String; end Errorout; hlight .ne { color: #bb0066; font-weight: bold } /* Name.Exception */ .highlight .nf { color: #0066bb; font-weight: bold } /* Name.Function */ .highlight .nl { color: #336699; font-style: italic } /* Name.Label */ .highlight .nn { color: #bb0066; font-weight: bold } /* Name.Namespace */ .highlight .py { color: #336699; font-weight: bold } /* Name.Property */ .highlight .nt { color: #bb0066; font-weight: bold } /* Name.Tag */ .highlight .nv { color: #336699 } /* Name.Variable */ .highlight .ow { color: #008800 } /* Operator.Word */ .highlight .w { color: #bbbbbb } /* Text.Whitespace */ .highlight .mb { color: #0000DD; font-weight: bold } /* Literal.Number.Bin */ .highlight .mf { color: #0000DD; font-weight: bold } /* Literal.Number.Float */ .highlight .mh { color: #0000DD; font-weight: bold } /* Literal.Number.Hex */ .highlight .mi { color: #0000DD; font-weight: bold } /* Literal.Number.Integer */ .highlight .mo { color: #0000DD; font-weight: bold } /* Literal.Number.Oct */ .highlight .sa { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Affix */ .highlight .sb { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Backtick */ .highlight .sc { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Char */ .highlight .dl { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Delimiter */ .highlight .sd { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Doc */ .highlight .s2 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Double */ .highlight .se { color: #0044dd; background-color: #fff0f0 } /* Literal.String.Escape */ .highlight .sh { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Heredoc */ .highlight .si { color: #3333bb; background-color: #fff0f0 } /* Literal.String.Interpol */ .highlight .sx { color: #22bb22; background-color: #f0fff0 } /* Literal.String.Other */ .highlight .sr { color: #008800; background-color: #fff0ff } /* Literal.String.Regex */ .highlight .s1 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Single */ .highlight .ss { color: #aa6600; background-color: #fff0f0 } /* Literal.String.Symbol */ .highlight .bp { color: #003388 } /* Name.Builtin.Pseudo */ .highlight .fm { color: #0066bb; font-weight: bold } /* Name.Function.Magic */ .highlight .vc { color: #336699 } /* Name.Variable.Class */ .highlight .vg { color: #dd7700 } /* Name.Variable.Global */ .highlight .vi { color: #3333bb } /* Name.Variable.Instance */ .highlight .vm { color: #336699 } /* Name.Variable.Magic */ .highlight .il { color: #0000DD; font-weight: bold } /* Literal.Number.Integer.Long */
--  Fixed-length lists.
--  Copyright (C) 2017 Tristan Gingold
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation, either version 2 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program.  If not, see <gnu.org/licenses>.

with Tables;

package body Flists is
   --  Index of elements.
   type El_Index_Type is new Int32;

   --  Describe an flist.
   type Entry_Type is record
      --  Index of the first element (in the element table).
      Els : El_Index_Type;

      --  Length of the list.
      Len : Nat32;
   end record;

   --  Flists descriptors.
   package Flistt is new Tables
     (Table_Component_Type => Entry_Type,
      Table_Index_Type => Flist_Type,
      Table_Low_Bound => 4,
      Table_Initial => 32);

   --  Table of all elements.
   package Els is new Tables
     (Table_Component_Type => El_Type,
      Table_Index_Type => El_Index_Type,
      Table_Low_Bound => 0,
      Table_Initial => 128);

   type Flist_Array is array (Natural range <>) of Flist_Type;

   --  Linked list of free flist.  For length less than the last index, the
   --  index corresponds to the length.  All free lists whose length is equal
   --  or greater than the last index are grouped to the last index.
   Free_Flists : Flist_Array (0 .. 16) := (others => Null_Flist);

   --  Get the chain for a free flist for large length.  It is stored at the
   --  first element of the list.
   function Free_Next (Flist : Flist_Type) return Flist_Type is
   begin
      return Flist_Type (Els.Table (Flistt.Table (Flist).Els));
   end Free_Next;

   function Create_Flist (Len : Natural) return Flist_Type
   is
      Res : Flist_Type;
      Prev : Flist_Type;
      Next : Flist_Type;
   begin
      if Len >= Free_Flists'Last then
         --  Large length.
         Res := Free_Flists (Free_Flists'Last);
         Prev := Null_Flist;
         while Res /= Null_Flist and then Length (Res) /= Len loop
            Prev := Res;
            Res := Free_Next (Res);
         end loop;
         if Res /= Null_Flist then
            Next := Free_Next (Res);
            if Prev = Null_Flist then
               Free_Flists (Free_Flists'Last) := Next;
            else
               Els.Table (Flistt.Table (Prev).Els) := El_Type (Next);
            end if;
         end if;
      else
         --  Small length.  The Len field contains the next free list.
         Res := Free_Flists (Len);
         if Res /= Null_Flist then
            Free_Flists (Len) := Flist_Type (Flistt.Table (Res).Len);
            Flistt.Table (Res).Len := Nat32 (Len);
         elsif Len = 0 then
            --  Quick case for len = 0.
            Res := Flistt.Allocate (1);
            Flistt.Table (Res) := (Els => 0, Len => 0);
            return Res;
         end if;
      end if;

      if Res = Null_Flist then