aboutsummaryrefslogtreecommitdiffstats
path: root/src/errorout-memory.adb
blob: a13e5c668b83eb92122deb258dbe59c3f0bbf2cb (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
--  Store error messages
--  Copyright (C) 2018 Tristan Gingold
--
--  GHDL 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, or (at your option) any later
--  version.
--
--  GHDL 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 GHDL; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.

with Tables;

package body Errorout.Memory is

   type Char_Index is new Uns32;

   package Messages is new Tables
     (Table_Component_Type => Character,
      Table_Index_Type => Char_Index,
      Table_Low_Bound => 1,
      Table_Initial => 128);

   type Error_Element is record
      Header : Error_Message;
      Str : Char_Index;
   end record;

   package Errors is new Tables
     (Table_Component_Type => Error_Element,
      Table_Index_Type => Error_Index,
      Table_Low_Bound => 1,
      Table_Initial => 32);

   Group : Group_Type;

   function Get_Nbr_Messages return Error_Index is
   begin
      return Errors.Last;
   end Get_Nbr_Messages;

   function Get_Error_Record (Idx : Error_Index) return Error_Message is
   begin
      return Errors.Table (Idx).Header;
   end Get_Error_Record;

   function Get_Error_Message (Idx : Error_Index) return String
   is
      First : constant Char_Index := Errors.Table (Idx).Str;
      Last : Char_Index;
   begin
      if Idx = Errors.Last then
         Last := Messages.Last;
      else
         Last := Errors.Table (Idx + 1).Str - 1;
      end if;
      return String (Messages.Table (First .. Last - 1));
   end Get_Error_Message;

   function Get_Error_Message_Addr (Idx : Error_Index) return System.Address
   is
      First : constant Char_Index := Errors.Table (Idx).Str;
   begin
      return Messages.Table (First)'Address;
   end Get_Error_Message_Addr;

   procedure Clear_Errors is
   begin
      Errors.Init;
      Messages.Init;
      Nbr_Errors := 0;
   end Clear_Errors;

   procedure Memory_Error_Start (E : Error_Record)
   is
      Msg : constant Error_Message :=
        (Id => E.Id,
         Group => Group,
         File => E.File,
         Line => E.Line,
         Offset => E.Offset,
         Length => E.Length);
   begin
      Errors.Append ((Msg, Messages.Last + 1));
      if Group = Msg_Main then
         Group := Msg_Related;
      end if;
   end Memory_Error_Start;

   procedure Memory_Message (Str : String) is
   begin
      for I in Str'Range loop
         Messages.Append (Str (I));
      end loop;
   end Memory_Message;

   procedure Memory_Message_End is
   begin
      Messages.Append (ASCII.NUL);
   end Memory_Message_End;

   procedure Memory_Message_Group (Start : Boolean) is
   begin
      if Start then
         pragma Assert (Group = Msg_Single);
         Group := Msg_Main;
      else
         pragma Assert (Group /= Msg_Single);
         case Errors.Table (Errors.Last).Header.Group is
            when Msg_Single | Msg_Last =>
               --  Check consistency until messages are discarded.
               if Nbr_Errors <= Max_Nbr_Errors then
                  raise Internal_Error;
               end if;
            when Msg_Main =>
               Errors.Table (Errors.Last).Header.Group := Msg_Single;
            when Msg_Related =>
               Errors.Table (Errors.Last).Header.Group := Msg_Last;
         end case;
         Group := Msg_Single;
      end if;
   end Memory_Message_Group;

   procedure Install_Handler is
   begin
      Set_Report_Handler ((Memory_Error_Start'Access,
                           Memory_Message'Access,
                           Memory_Message_End'Access,
                           Memory_Message_Group'Access));
      Group := Msg_Single;
   end Install_Handler;

end Errorout.Memory;