From 1e5de3c73a5865cc0df2ee32d1d81c9718c5f44f Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 22 Jun 2016 20:53:13 +0200 Subject: grt: add grt-strings, use case insensitive compare for vpi_handle_by_name Fixes potentialventures/cocotb#460 --- src/grt/grt-options.adb | 10 +--------- src/grt/grt-sdf.adb | 41 +++++++++++------------------------------ src/grt/grt-strings.adb | 41 +++++++++++++++++++++++++++++++++++++++++ src/grt/grt-strings.ads | 36 ++++++++++++++++++++++++++++++++++++ src/grt/grt-values.adb | 22 +++------------------- src/grt/grt-values.ads | 6 ------ src/grt/grt-vpi.adb | 19 +++++++++++++------ 7 files changed, 105 insertions(+), 70 deletions(-) create mode 100644 src/grt/grt-strings.adb create mode 100644 src/grt/grt-strings.ads diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb index 3c4acb215..81fa962f0 100644 --- a/src/grt/grt-options.adb +++ b/src/grt/grt-options.adb @@ -23,6 +23,7 @@ -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. with Interfaces; use Interfaces; +with Grt.Strings; use Grt.Strings; with Grt.Errors; use Grt.Errors; with Grt.Astdio; with Grt.Hooks; @@ -210,15 +211,6 @@ package body Grt.Options is end loop; end Extract_Integer; - function To_Lower (C : Character) return Character is - begin - if C in 'A' .. 'Z' then - return Character'Val (Character'Pos (C) + 32); - else - return C; - end if; - end To_Lower; - procedure Decode_Option (Option : String; Status : out Decode_Option_Status) is diff --git a/src/grt/grt-sdf.adb b/src/grt/grt-sdf.adb index 75dfefe4d..1cb04e5e1 100644 --- a/src/grt/grt-sdf.adb +++ b/src/grt/grt-sdf.adb @@ -1,5 +1,5 @@ -- GHDL Run Time (GRT) - SDF parser. --- Copyright (C) 2002 - 2014 Tristan Gingold +-- Copyright (C) 2002 - 2016 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 @@ -22,17 +22,16 @@ -- covered by the GNU General Public License. This exception does not -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. -with System.Storage_Elements; -- Work around GNAT bug. -pragma Unreferenced (System.Storage_Elements); + with Grt.Stdio; use Grt.Stdio; with Grt.C; use Grt.C; +with Grt.Strings; use Grt.Strings; with Grt.Errors; use Grt.Errors; -with Ada.Characters.Latin_1; with Ada.Unchecked_Deallocation; with Grt.Vital_Annotate; package body Grt.Sdf is - EOT : constant Character := Character'Val (4); + use ASCII; type Sdf_Token_Type is ( @@ -71,10 +70,10 @@ package body Grt.Sdf is function Open_Sdf (Filename : String) return Boolean is N_Filename : String (1 .. Filename'Length + 1); - Mode : constant String := "rt" & NUL; + Mode : constant String := "rt" & ASCII.NUL; begin N_Filename (1 .. Filename'Length) := Filename; - N_Filename (N_Filename'Last) := NUL; + N_Filename (N_Filename'Last) := ASCII.NUL; Sdf_Stream := fopen (N_Filename'Address, Mode'Address); if Sdf_Stream = NULL_Stream then Error_C ("cannot open SDF file '"); @@ -212,7 +211,7 @@ package body Grt.Sdf is -- Continue to read. Read_Append; Pos := Pos - 1; - when NUL .. Character'Val (3) + when ASCII.NUL .. Character'Val (3) | Character'Val (5) .. Character'Val (31) | Character'Val (127) .. Character'Val (255) => Error_Bad_Character; @@ -295,9 +294,7 @@ package body Grt.Sdf is Pos := 1; end Refill_Buf; - procedure Skip_Spaces - is - use Ada.Characters.Latin_1; + procedure Skip_Spaces is begin -- Fast blanks skipping. while Buf (Pos) = ' ' loop @@ -359,9 +356,7 @@ package body Grt.Sdf is end loop; end Skip_Spaces; - function Get_Token return Sdf_Token_Type - is - use Ada.Characters.Latin_1; + function Get_Token return Sdf_Token_Type is begin Skip_Spaces; @@ -410,9 +405,7 @@ package body Grt.Sdf is end case; end Get_Token; - function Is_White_Space (C : Character) return Boolean - is - use Ada.Characters.Latin_1; + function Is_White_Space (C : Character) return Boolean is begin case C is when ' ' @@ -425,9 +418,7 @@ package body Grt.Sdf is end case; end Is_White_Space; - function Get_Edge_Token return Edge_Type - is - use Ada.Characters.Latin_1; + function Get_Edge_Token return Edge_Type is begin Skip_Spaces; @@ -664,16 +655,6 @@ package body Grt.Sdf is return True; end Expect_Rexpr_Cp_Op_Ident; - function To_Lower (C : Character) return Character is - begin - if C >= 'A' and C <= 'Z' then - return Character'Val (Character'Pos (C) - - Character'Pos ('A') + Character'Pos ('a')); - else - return C; - end if; - end To_Lower; - function Parse_Port_Path1 (Tok : Sdf_Token_Type) return Boolean is Port_Spec : Port_Spec_Type diff --git a/src/grt/grt-strings.adb b/src/grt/grt-strings.adb new file mode 100644 index 000000000..38e2c6b4e --- /dev/null +++ b/src/grt/grt-strings.adb @@ -0,0 +1,41 @@ +-- GHDL Run Time (GRT) - Misc subprograms for characters and strings +-- Copyright (C) 2016 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package body Grt.Strings is + function Is_Whitespace (C : in Character) return Boolean is + use ASCII; + begin + return C = ' ' or C = NBSP or C = HT; + end Is_Whitespace; + + function To_Lower (C : Character) return Character is + begin + if C in 'A' .. 'Z' then + return Character'Val (Character'Pos (C) + 32); + else + return C; + end if; + end To_Lower; +end Grt.Strings; diff --git a/src/grt/grt-strings.ads b/src/grt/grt-strings.ads new file mode 100644 index 000000000..d11c799f0 --- /dev/null +++ b/src/grt/grt-strings.ads @@ -0,0 +1,36 @@ +-- GHDL Run Time (GRT) - Misc subprograms for characters and strings +-- Copyright (C) 2016 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Strings is + pragma Pure; + + NBSP : constant Character := Character'Val (160); + + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean; + + -- Convert C to lowercase. + function To_Lower (C : Character) return Character; +end Grt.Strings; diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb index e87182791..e64e7b943 100644 --- a/src/grt/grt-values.adb +++ b/src/grt/grt-values.adb @@ -1,5 +1,5 @@ -- GHDL Run Time (GRT) - 'value subprograms. --- Copyright (C) 2002 - 2014 Tristan Gingold +-- Copyright (C) 2002 - 2016 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 @@ -24,18 +24,13 @@ -- covered by the GNU Public License. with Grt.Errors; use Grt.Errors; with Grt.Rtis_Utils; +with Grt.Strings; use Grt.Strings; package body Grt.Values is NBSP : constant Character := Character'Val (160); HT : constant Character := Character'Val (9); - -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) - function Is_Whitespace (C : in Character) return Boolean is - begin - return C = ' ' or C = NBSP or C = HT; - end Is_Whitespace; - -- Increase POS to skip leading whitespace characters, decrease LEN to -- skip trailing whitespaces in string S. procedure Remove_Whitespaces (S : Std_String_Basep; @@ -58,17 +53,6 @@ package body Grt.Values is end if; end Remove_Whitespaces; - -- Convert C to lowercase. - function To_LC (C : in Character) return Character is - begin - if C in 'A' .. 'Z' then - return Character'Val - (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A')); - else - return C; - end if; - end To_LC; - -- Return TRUE iff user string S (POS .. LEN - 1) is equal to REF. -- Comparaison is case insensitive, but REF must be lowercase (REF is -- supposed to come from an RTI). @@ -90,7 +74,7 @@ package body Grt.Values is end if; C_S := S (Pos + P); if not Is_Char then - C_S := To_LC (C_S); + C_S := To_Lower (C_S); end if; if C_S /= C_Ref or else C_Ref = ASCII.NUL then return False; diff --git a/src/grt/grt-values.ads b/src/grt/grt-values.ads index 5f1e5169d..ee76109d5 100644 --- a/src/grt/grt-values.ads +++ b/src/grt/grt-values.ads @@ -26,12 +26,6 @@ with Grt.Types; use Grt.Types; with Grt.Rtis; use Grt.Rtis; package Grt.Values is - -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) - function Is_Whitespace (C : in Character) return Boolean; - - -- Convert C to lowercase. - function To_LC (C : in Character) return Character; - -- Extract position of numeric literal and unit in string STR. -- Set IS_REAL if the unit is a real number (presence of '.'). -- Set UNIT_POS to the position of the first character of the unit name. diff --git a/src/grt/grt-vpi.adb b/src/grt/grt-vpi.adb index 90c75ef93..1a2af50d7 100644 --- a/src/grt/grt-vpi.adb +++ b/src/grt/grt-vpi.adb @@ -45,6 +45,7 @@ with Grt.Stdio; use Grt.Stdio; with Grt.C; use Grt.C; with Grt.Signals; use Grt.Signals; with Grt.Astdio; use Grt.Astdio; +with Grt.Strings; use Grt.Strings; with Grt.Hooks; use Grt.Hooks; with Grt.Options; with Grt.Vcd; use Grt.Vcd; @@ -1323,7 +1324,7 @@ package body Grt.Vpi is -- NUL not allowed in L. return False; end if; - if L (I) /= R (I - L'First + 1) then + if To_Lower (L (I)) /= R (I - L'First + 1) then return False; end if; end loop; @@ -1353,7 +1354,7 @@ package body Grt.Vpi is exit when Err /= AvhpiErrorOk; El_Name := Avhpi_Get_Base_Name (Res); - exit when Strcmp (Name , El_Name); + exit when Strcmp (Name, El_Name); end loop; end Find_By_Name; @@ -1561,11 +1562,17 @@ package body Grt.Vpi is return Err_Status; end vpi_chk_error; - function vpi_control (Op : Integer; Status : Integer) return Integer - is - pragma Unreferenced (Status); + function vpi_control (Op : Integer; Status : Integer) return Integer is begin - Vpi_Trace ("vpi_control"); + if Flag_Trace then + Trace_Start ("vpi_control ("); + Trace (Op); + Trace (", "); + Trace (Status); + Trace (")"); + Trace_Newline; + end if; + case Op is when vpiFinish | vpiStop => -- cgit v1.2.3