From da7132b9db95271a7a97315d5da821d87f7a8afb Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 6 Jan 2015 09:53:40 +0000 Subject: [PATCH] 2015-01-06 Robert Dewar * s-valint.adb, s-valuns.adb (Value_Integer): Deal with case where Str'Last = Positive'Last 2015-01-06 Thomas Quinot * xoscons.adb: Display exception information and return non-zero exit status in top level exception handler. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@219242 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 10 ++++++++++ gcc/ada/s-valint.adb | 30 ++++++++++++++++++++++++------ gcc/ada/s-valuns.adb | 11 ++++++++--- gcc/ada/xoscons.adb | 8 +++++--- 4 files changed, 47 insertions(+), 12 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1950ea8..784e9c7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2015-01-06 Robert Dewar + + * s-valint.adb, s-valuns.adb (Value_Integer): Deal with case where + Str'Last = Positive'Last + +2015-01-06 Thomas Quinot + + * xoscons.adb: Display exception information and return non-zero + exit status in top level exception handler. + 2015-01-06 Ed Schonberg * sem_ch8.adb: Code clean up. diff --git a/gcc/ada/s-valint.adb b/gcc/ada/s-valint.adb index d77de09..25b9216 100644 --- a/gcc/ada/s-valint.adb +++ b/gcc/ada/s-valint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -89,12 +89,30 @@ package body System.Val_Int is ------------------- function Value_Integer (Str : String) return Integer is - V : Integer; - P : aliased Integer := Str'First; begin - V := Scan_Integer (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Integer (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Integer; + P : aliased Integer := Str'First; + begin + V := Scan_Integer (Str, P'Access, Str'Length); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; end Value_Integer; end System.Val_Int; diff --git a/gcc/ada/s-valuns.adb b/gcc/ada/s-valuns.adb index 44754cf..062b6d7 100644 --- a/gcc/ada/s-valuns.adb +++ b/gcc/ada/s-valuns.adb @@ -289,11 +289,16 @@ package body System.Val_Uns is -------------------- function Value_Unsigned (Str : String) return Unsigned is + subtype NT is String (1 .. Str'Length); + -- We use this subtype to convert Str for the calls below to deal with + -- the obscure case where Str'Last is Positive'Last. Without these + -- conversions, such a case would raise Constraint_Error. + V : Unsigned; - P : aliased Integer := Str'First; + P : aliased Integer := 1; begin - V := Scan_Unsigned (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); + V := Scan_Unsigned (NT (Str), P'Access, Str'Length); + Scan_Trailing_Blanks (NT (Str), P); return V; end Value_Unsigned; diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 095101f..3d5bfab 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -47,6 +47,7 @@ pragma Warnings (Off); with System.Unsigned_Types; use System.Unsigned_Types; pragma Warnings (On); +with GNAT.OS_Lib; with GNAT.String_Split; use GNAT.String_Split; with GNAT.Table; @@ -700,6 +701,7 @@ begin Close (Tmpl_File); exception - when others => - Put_Line ("xoscons "); + when E : others => + Put_Line ("raised " & Ada.Exceptions.Exception_Information (E)); + GNAT.OS_Lib.OS_Exit (1); end XOSCons; -- 2.7.4