2015-01-06 Robert Dewar <dewar@adacore.com>

	* s-valint.adb, s-valuns.adb (Value_Integer): Deal with case where
	Str'Last = Positive'Last

2015-01-06  Thomas Quinot  <quinot@adacore.com>

	* 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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1950ea8..784e9c7 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2015-01-06  Robert Dewar  <dewar@adacore.com>
+
+       * s-valint.adb, s-valuns.adb (Value_Integer): Deal with case where
+       Str'Last = Positive'Last
+
+2015-01-06  Thomas Quinot  <quinot@adacore.com>
+
+       * xoscons.adb: Display exception information and return non-zero
+       exit status in top level exception handler.
+
 2015-01-06  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_ch8.adb: Code clean up.

diff --git a/gcc/ada/s-valint.adb b/gcc/ada/s-valint.adb
index d77de09..25b9216 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 <base_name>");
+   when E : others =>
+      Put_Line ("raised " & Ada.Exceptions.Exception_Information (E));
+      GNAT.OS_Lib.OS_Exit (1);
 end XOSCons;