From 987a94c378dfb969e8bb7f1b734f29a33e63212e Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Thu, 9 May 2019 18:24:08 +0200
Subject: Move errorout from vhdl/ to src/

---
 src/errorout-memory.adb | 103 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 103 insertions(+)
 create mode 100644 src/errorout-memory.adb

(limited to 'src/errorout-memory.adb')

diff --git a/src/errorout-memory.adb b/src/errorout-memory.adb
new file mode 100644
index 000000000..83b694b74
--- /dev/null
+++ b/src/errorout-memory.adb
@@ -0,0 +1,103 @@
+--  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_Record;
+      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);
+
+   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_Record 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
+   begin
+      Errors.Append ((E, Messages.Last + 1));
+   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 Install_Handler is
+   begin
+      Set_Report_Handler ((Memory_Error_Start'Access,
+                           Memory_Message'Access,
+                           Memory_Message_End'Access));
+   end Install_Handler;
+
+end Errorout.Memory;
-- 
cgit v1.2.3