diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 44 | ||||
| -rw-r--r-- | gcc/ada/a-chahan.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/a-ngrear.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/a-ngrear.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/a-strsup.adb | 167 | ||||
| -rw-r--r-- | gcc/ada/a-stwisu.adb | 173 | ||||
| -rw-r--r-- | gcc/ada/a-stzsup.adb | 178 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 6 | ||||
| -rw-r--r-- | gcc/ada/s-gearop.adb | 356 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vms-ia64.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vms-ia64.ads | 652 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vms.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-vms.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/s-vaflop-vms-alpha.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/s-vaflop.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 22 |
18 files changed, 579 insertions, 1256 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c5b2dbd..e92726a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2012-03-07 Gary Dismukes <dismukes@adacore.com> + + * exp_ch4.adb (Apply_Accessibility_Check): Call + Remove_Side_Effects in the build-in-place case, to ensure that + we capture the call and don't end up with two calls. + +2012-03-07 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Expand_Inlined_Call): Skip inlining of functions + that return unconstrained types using an extended return statement + since the support for inlining these functions has not been yet + added to the frontend. + * s-vaflop.adb, s-vaflop-vms-alpha.adb: Code reorganization. + * a-ngrear.ads: Replace all the Inline_Always pragmas by pragma + Inline. + * a-ngrear.adb (Eigenvalues, Transpose): Restructured to use + extended return statement. + * a-strsup.adb, a-stzsup.adb, a-stwisu.adb (Concat, Super_Slice, + Super_To_String): Restructured to use extended return statement. + * a-chahan.adb (To_Basic, To_Lower, To_Upper): Restructured to + use extended return statement. + * s-gearop.adb (Diagonal, Matrix_Elementwise_Operation, + Vector_Elementwise_Operation, Matrix_Elementwise_Operation, + Matrix_Matrix_Scalar_Elementwise_Operation, + Vector_Vector_Elementwise_Operation, + Vector_Vector_Scalar_Elementwise_Operation, + Matrix_Scalar_Elementwise_Operation, + Vector_Scalar_Elementwise_Operation, + Scalar_Matrix_Elementwise_Operation, + Scalar_Vector_Elementwise_Operation, Matrix_Matrix_Product, + Matrix_Vector_Product, Outer_Product, Unit_Matrix, Unit_Vector, + Vector_Matrix_Product): Restructured to use extended return + statement. + +2012-03-07 Vincent Pucci <pucci@adacore.com> + + * sem_ch5.adb (One_Bound): Minor reformatting. + +2012-03-07 Tristan Gingold <gingold@adacore.com> + + * s-osinte-vms-ia64.adb, s-osinte-vms-ia64.ads, s-osinte-vms.adb, + s-osinte-vms.ads, gcc-interface/Makefile.in: Merge s-osinte-vms and + s-osinte-vms-ia64. + 2012-03-07 Ed Schonberg <schonberg@adacore.com> * checks.adb (Apply_Predicate_Check): Do not generate a predicate diff --git a/gcc/ada/a-chahan.adb b/gcc/ada/a-chahan.adb index 61419b0..c7a77ea 100644 --- a/gcc/ada/a-chahan.adb +++ b/gcc/ada/a-chahan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -422,14 +422,12 @@ package body Ada.Characters.Handling is end To_Basic; function To_Basic (Item : String) return String is - Result : String (1 .. Item'Length); - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); - end loop; - - return Result; + return Result : String (1 .. Item'Length) do + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); + end loop; + end return; end To_Basic; ------------------ @@ -485,14 +483,12 @@ package body Ada.Characters.Handling is end To_Lower; function To_Lower (Item : String) return String is - Result : String (1 .. Item'Length); - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); - end loop; - - return Result; + return Result : String (1 .. Item'Length) do + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); + end loop; + end return; end To_Lower; --------------- @@ -527,14 +523,12 @@ package body Ada.Characters.Handling is function To_Upper (Item : String) return String is - Result : String (1 .. Item'Length); - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); - end loop; - - return Result; + return Result : String (1 .. Item'Length) do + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); + end loop; + end return; end To_Upper; ----------------------- diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb index 2a740b5..68d5365 100644 --- a/gcc/ada/a-ngrear.adb +++ b/gcc/ada/a-ngrear.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2012, 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- -- @@ -482,12 +482,15 @@ package body Ada.Numerics.Generic_Real_Arrays is ----------------- function Eigenvalues (A : Real_Matrix) return Real_Vector is - Values : Real_Vector (A'Range (1)); - Vectors : Real_Matrix (1 .. 0, 1 .. 0); begin - Jacobi (A, Values, Vectors, Compute_Vectors => False); - Sort_Eigensystem (Values, Vectors); - return Values; + return Values : Real_Vector (A'Range (1)) do + declare + Vectors : Real_Matrix (1 .. 0, 1 .. 0); + begin + Jacobi (A, Values, Vectors, Compute_Vectors => False); + Sort_Eigensystem (Values, Vectors); + end; + end return; end Eigenvalues; ------------- @@ -742,10 +745,10 @@ package body Ada.Numerics.Generic_Real_Arrays is --------------- function Transpose (X : Real_Matrix) return Real_Matrix is - R : Real_Matrix (X'Range (2), X'Range (1)); begin - Transpose (X, R); - return R; + return R : Real_Matrix (X'Range (2), X'Range (1)) do + Transpose (X, R); + end return; end Transpose; ----------------- diff --git a/gcc/ada/a-ngrear.ads b/gcc/ada/a-ngrear.ads index f244d65..f03ee37 100644 --- a/gcc/ada/a-ngrear.ads +++ b/gcc/ada/a-ngrear.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -125,15 +125,15 @@ private -- front end always inline these, the expense of the unconstrained returns -- can be avoided. - pragma Inline_Always ("+"); - pragma Inline_Always ("-"); - pragma Inline_Always ("*"); - pragma Inline_Always ("/"); - pragma Inline_Always ("abs"); - pragma Inline_Always (Eigenvalues); - pragma Inline_Always (Inverse); - pragma Inline_Always (Solve); - pragma Inline_Always (Transpose); - pragma Inline_Always (Unit_Matrix); - pragma Inline_Always (Unit_Vector); + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline ("*"); + pragma Inline ("/"); + pragma Inline ("abs"); + pragma Inline (Eigenvalues); + pragma Inline (Inverse); + pragma Inline (Solve); + pragma Inline (Transpose); + pragma Inline (Unit_Matrix); + pragma Inline (Unit_Vector); end Ada.Numerics.Generic_Real_Arrays; diff --git a/gcc/ada/a-strsup.adb b/gcc/ada/a-strsup.adb index 707d9ec..ed14e58 100644 --- a/gcc/ada/a-strsup.adb +++ b/gcc/ada/a-strsup.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2012, 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- -- @@ -42,100 +42,107 @@ package body Ada.Strings.Superbounded is (Left : Super_String; Right : Super_String) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + end if; - return Result; + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end; + end return; end Concat; function Concat (Left : Super_String; Right : String) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - - Nlen : constant Natural := Llen + Right'Length; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end if; - return Result; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Nlen : constant Natural := Llen + Right'Length; + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + end if; + + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end; + end return; end Concat; function Concat (Left : String; Right : Super_String) return Super_String is - Result : Super_String (Right.Max_Length); - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Right.Max_Length) do + declare + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + end if; - return Result; + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end; + end return; end Concat; function Concat (Left : Super_String; Right : Character) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - begin - if Llen = Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Current_Length) := Right; - end if; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + end if; - return Result; + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end; + end return; end Concat; function Concat (Left : Character; Right : Super_String) return Super_String is - Result : Super_String (Right.Max_Length); - Rlen : constant Natural := Right.Current_Length; - begin - if Rlen = Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Right.Max_Length) do + declare + Rlen : constant Natural := Right.Current_Length; + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + end if; - return Result; + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := + Right.Data (1 .. Rlen); + end; + end return; end Concat; ----------- @@ -1459,13 +1466,15 @@ package body Ada.Strings.Superbounded is begin -- Note: test of High > Length is in accordance with AI95-00128 - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else - return Source.Data (Low .. High); - end if; + return R : String (Low .. High) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + R := Source.Data (Low .. High); + end return; end Super_Slice; function Super_Slice @@ -1473,19 +1482,17 @@ package body Ada.Strings.Superbounded is Low : Positive; High : Natural) return Super_String is - Result : Super_String (Source.Max_Length); - begin - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else + return Result : Super_String (Source.Max_Length) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + Result.Current_Length := High - Low + 1; Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); - end if; - - return Result; + end return; end Super_Slice; procedure Super_Slice @@ -1615,7 +1622,9 @@ package body Ada.Strings.Superbounded is function Super_To_String (Source : Super_String) return String is begin - return Source.Data (1 .. Source.Current_Length); + return R : String (1 .. Source.Current_Length) do + R := Source.Data (1 .. Source.Current_Length); + end return; end Super_To_String; --------------------- diff --git a/gcc/ada/a-stwisu.adb b/gcc/ada/a-stwisu.adb index 2ffae81..10c2b23 100644 --- a/gcc/ada/a-stwisu.adb +++ b/gcc/ada/a-stwisu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2012, 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- -- @@ -42,100 +42,111 @@ package body Ada.Strings.Wide_Superbounded is (Left : Super_String; Right : Super_String) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; - return Result; + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; end Concat; function Concat (Left : Super_String; Right : Wide_String) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - - Nlen : constant Natural := Llen + Right'Length; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end if; - return Result; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Nlen : constant Natural := Llen + Right'Length; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end if; + end; + end return; end Concat; function Concat (Left : Wide_String; Right : Super_String) return Super_String is - Result : Super_String (Right.Max_Length); - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Right.Max_Length) do + declare + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; - return Result; + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; end Concat; function Concat (Left : Super_String; Right : Wide_Character) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - begin - if Llen = Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Current_Length) := Right; - end if; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; - return Result; + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end if; + end; + end return; end Concat; function Concat (Left : Wide_Character; Right : Super_String) return Super_String is - Result : Super_String (Right.Max_Length); - Rlen : constant Natural := Right.Current_Length; - begin - if Rlen = Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Right.Max_Length) do + declare + Rlen : constant Natural := Right.Current_Length; - return Result; + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := + Right.Data (1 .. Rlen); + end if; + end; + end return; end Concat; ----------- @@ -1462,13 +1473,15 @@ package body Ada.Strings.Wide_Superbounded is begin -- Note: test of High > Length is in accordance with AI95-00128 - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else - return Source.Data (Low .. High); - end if; + return R : Wide_String (Low .. High) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + R := Source.Data (Low .. High); + end return; end Super_Slice; function Super_Slice @@ -1476,19 +1489,17 @@ package body Ada.Strings.Wide_Superbounded is Low : Positive; High : Natural) return Super_String is - Result : Super_String (Source.Max_Length); - begin - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else + return Result : Super_String (Source.Max_Length) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + Result.Current_Length := High - Low + 1; Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); - end if; - - return Result; + end return; end Super_Slice; procedure Super_Slice @@ -1618,7 +1629,9 @@ package body Ada.Strings.Wide_Superbounded is function Super_To_String (Source : Super_String) return Wide_String is begin - return Source.Data (1 .. Source.Current_Length); + return R : Wide_String (1 .. Source.Current_Length) do + R := Source.Data (1 .. Source.Current_Length); + end return; end Super_To_String; --------------------- diff --git a/gcc/ada/a-stzsup.adb b/gcc/ada/a-stzsup.adb index efad7b0..a79dfa0 100644 --- a/gcc/ada/a-stzsup.adb +++ b/gcc/ada/a-stzsup.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2012, 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- -- @@ -42,100 +42,111 @@ package body Ada.Strings.Wide_Wide_Superbounded is (Left : Super_String; Right : Super_String) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; - return Result; + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; end Concat; function Concat (Left : Super_String; Right : Wide_Wide_String) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - - Nlen : constant Natural := Llen + Right'Length; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end if; - return Result; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Nlen : constant Natural := Llen + Right'Length; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end if; + end; + end return; end Concat; function Concat (Left : Wide_Wide_String; Right : Super_String) return Super_String is - Result : Super_String (Right.Max_Length); - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Right.Max_Length) do + declare + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; - return Result; + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; end Concat; function Concat (Left : Super_String; Right : Wide_Wide_Character) return Super_String is - Result : Super_String (Left.Max_Length); - Llen : constant Natural := Left.Current_Length; - begin - if Llen = Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Current_Length) := Right; - end if; + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; - return Result; + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end if; + end; + end return; end Concat; function Concat (Left : Wide_Wide_Character; Right : Super_String) return Super_String is - Result : Super_String (Right.Max_Length); - Rlen : constant Natural := Right.Current_Length; - begin - if Rlen = Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen); - end if; + return Result : Super_String (Right.Max_Length) do + declare + Rlen : constant Natural := Right.Current_Length; - return Result; + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := + Right.Data (1 .. Rlen); + end if; + end; + end return; end Concat; ----------- @@ -1469,13 +1480,15 @@ package body Ada.Strings.Wide_Wide_Superbounded is begin -- Note: test of High > Length is in accordance with AI95-00128 - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else - return Source.Data (Low .. High); - end if; + return R : Wide_Wide_String (Low .. High) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + R := Source.Data (Low .. High); + end return; end Super_Slice; function Super_Slice @@ -1483,19 +1496,18 @@ package body Ada.Strings.Wide_Wide_Superbounded is Low : Positive; High : Natural) return Super_String is - Result : Super_String (Source.Max_Length); - begin - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else - Result.Current_Length := High - Low + 1; - Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); - end if; - - return Result; + return Result : Super_String (Source.Max_Length) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + Result.Current_Length := High - Low + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (Low .. High); + end if; + end return; end Super_Slice; procedure Super_Slice @@ -1627,7 +1639,9 @@ package body Ada.Strings.Wide_Wide_Superbounded is (Source : Super_String) return Wide_Wide_String is begin - return Source.Data (1 .. Source.Current_Length); + return R : Wide_Wide_String (1 .. Source.Current_Length) do + R := Source.Data (1 .. Source.Current_Length); + end return; end Super_To_String; --------------------- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 416dd98..07885c2 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -702,13 +702,16 @@ package body Exp_Ch4 is (Is_Class_Wide_Type (Etype (Exp)) and then Scope (PtrT) /= Current_Scope)) then - -- If the allocator was built in place Ref is already a reference + -- If the allocator was built in place, Ref is already a reference -- to the access object initialized to the result of the allocator - -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise - -- it is the entity associated with the object containing the - -- address of the allocated object. + -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call + -- Remove_Side_Effects for cases where the build-in-place call may + -- still be the prefix of the reference (to avoid generating + -- duplicate calls). Otherwise, it is the entity associated with + -- the object containing the address of the allocated object. if Built_In_Place then + Remove_Side_Effects (Ref); New_Node := New_Copy (Ref); else New_Node := New_Reference_To (Ref, Loc); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 10ee14a..1299b15 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4243,6 +4243,23 @@ package body Exp_Ch6 is Error_Msg_N ("call to recursive subprogram cannot be inlined?", N); Set_Is_Inlined (Subp, False); return; + + -- Skip inlining if this is not a true inlining since the attribute + -- Body_To_Inline is also set for renamings (see sinfo.ads) + + elsif Nkind (Orig_Bod) in N_Entity then + return; + + -- Skip inlining if the function returns an unconstrained type using + -- an extended return statement since this part of the new model of + -- inlining which is not yet supported by the current implementation. + + elsif Is_Unc + and then + Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) + = N_Extended_Return_Statement + then + return; end if; if Nkind (Orig_Bod) = N_Defining_Identifier diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 19d9eb0..901ee2b 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1515,6 +1515,8 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) s-memory.ads<s-memory-vms_64.ads \ s-osprim.adb<s-osprim-vms.adb \ s-osprim.ads<s-osprim-vms.ads \ + s-osinte.adb<s-osinte-vms.adb \ + s-osinte.ads<s-osinte-vms.ads \ s-taprop.adb<s-taprop-vms.adb \ s-tasdeb.adb<s-tasdeb-vms.adb \ s-taspri.ads<s-taspri-vms.ads \ @@ -1528,8 +1530,6 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) g-trasym.adb<g-trasym-vms-ia64.adb \ s-asthan.adb<s-asthan-vms-ia64.adb \ s-auxdec.adb<s-auxdec-vms-ia64.adb \ - s-osinte.adb<s-osinte-vms-ia64.adb \ - s-osinte.ads<s-osinte-vms-ia64.ads \ s-vaflop.adb<s-vaflop-vms-ia64.adb \ system.ads<system-vms-ia64.ads \ s-parame.ads<s-parame-vms-ia64.ads \ @@ -1547,8 +1547,6 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) g-trasym.adb<g-trasym-vms-alpha.adb \ s-asthan.adb<s-asthan-vms-alpha.adb \ s-auxdec.adb<s-auxdec-vms-alpha.adb \ - s-osinte.adb<s-osinte-vms.adb \ - s-osinte.ads<s-osinte-vms.ads \ s-traent.adb<s-traent-vms.adb \ s-traent.ads<s-traent-vms.ads \ s-vaflop.adb<s-vaflop-vms-alpha.adb \ diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb index db18a7e..3d9e4bf 100644 --- a/gcc/ada/s-gearop.adb +++ b/gcc/ada/s-gearop.adb @@ -51,14 +51,12 @@ package body System.Generic_Array_Operations is function Diagonal (A : Matrix) return Vector is N : constant Natural := Natural'Min (A'Length (1), A'Length (2)); - R : Vector (A'First (1) .. A'First (1) + N - 1); - begin - for J in 0 .. N - 1 loop - R (R'First + J) := A (A'First (1) + J, A'First (2) + J); - end loop; - - return R; + return R : Vector (A'First (1) .. A'First (1) + N - 1) do + for J in 0 .. N - 1 loop + R (R'First + J) := A (A'First (1) + J, A'First (2) + J); + end loop; + end return; end Diagonal; -------------------------- @@ -386,16 +384,14 @@ package body System.Generic_Array_Operations is ---------------------------------- function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is - R : Result_Matrix (X'Range (1), X'Range (2)); - begin - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Operation (X (J, K)); + return R : Result_Matrix (X'Range (1), X'Range (2)) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Operation (X (J, K)); + end loop; end loop; - end loop; - - return R; + end return; end Matrix_Elementwise_Operation; ---------------------------------- @@ -403,14 +399,12 @@ package body System.Generic_Array_Operations is ---------------------------------- function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector is - R : Result_Vector (X'Range); - begin - for J in R'Range loop - R (J) := Operation (X (J)); - end loop; - - return R; + return R : Result_Vector (X'Range) do + for J in R'Range loop + R (J) := Operation (X (J)); + end loop; + end return; end Vector_Elementwise_Operation; ----------------------------------------- @@ -421,29 +415,27 @@ package body System.Generic_Array_Operations is (Left : Left_Matrix; Right : Right_Matrix) return Result_Matrix is - R : Result_Matrix (Left'Range (1), Left'Range (2)); - begin - if Left'Length (1) /= Right'Length (1) + return R : Result_Matrix (Left'Range (1), Left'Range (2)) do + if Left'Length (1) /= Right'Length (1) or else - Left'Length (2) /= Right'Length (2) - then - raise Constraint_Error with - "matrices are of different dimension in elementwise operation"; - end if; + Left'Length (2) /= Right'Length (2) + then + raise Constraint_Error with + "matrices are of different dimension in elementwise operation"; + end if; - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := - Operation - (Left (J, K), - Right - (J - R'First (1) + Right'First (1), - K - R'First (2) + Right'First (2))); + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := + Operation + (Left (J, K), + Right + (J - R'First (1) + Right'First (1), + K - R'First (2) + Right'First (2))); + end loop; end loop; - end loop; - - return R; + end return; end Matrix_Matrix_Elementwise_Operation; ------------------------------------------------ @@ -453,31 +445,28 @@ package body System.Generic_Array_Operations is function Matrix_Matrix_Scalar_Elementwise_Operation (X : X_Matrix; Y : Y_Matrix; - Z : Z_Scalar) return Result_Matrix - is - R : Result_Matrix (X'Range (1), X'Range (2)); - + Z : Z_Scalar) return Result_Matrix is begin - if X'Length (1) /= Y'Length (1) + return R : Result_Matrix (X'Range (1), X'Range (2)) do + if X'Length (1) /= Y'Length (1) or else - X'Length (2) /= Y'Length (2) - then - raise Constraint_Error with - "matrices are of different dimension in elementwise operation"; - end if; + X'Length (2) /= Y'Length (2) + then + raise Constraint_Error with + "matrices are of different dimension in elementwise operation"; + end if; - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := - Operation - (X (J, K), - Y (J - R'First (1) + Y'First (1), - K - R'First (2) + Y'First (2)), - Z); + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := + Operation + (X (J, K), + Y (J - R'First (1) + Y'First (1), + K - R'First (2) + Y'First (2)), + Z); + end loop; end loop; - end loop; - - return R; + end return; end Matrix_Matrix_Scalar_Elementwise_Operation; ----------------------------------------- @@ -488,19 +477,17 @@ package body System.Generic_Array_Operations is (Left : Left_Vector; Right : Right_Vector) return Result_Vector is - R : Result_Vector (Left'Range); - begin - if Left'Length /= Right'Length then - raise Constraint_Error with - "vectors are of different length in elementwise operation"; - end if; - - for J in R'Range loop - R (J) := Operation (Left (J), Right (J - R'First + Right'First)); - end loop; + return R : Result_Vector (Left'Range) do + if Left'Length /= Right'Length then + raise Constraint_Error with + "vectors are of different length in elementwise operation"; + end if; - return R; + for J in R'Range loop + R (J) := Operation (Left (J), Right (J - R'First + Right'First)); + end loop; + end return; end Vector_Vector_Elementwise_Operation; ------------------------------------------------ @@ -510,21 +497,18 @@ package body System.Generic_Array_Operations is function Vector_Vector_Scalar_Elementwise_Operation (X : X_Vector; Y : Y_Vector; - Z : Z_Scalar) return Result_Vector - is - R : Result_Vector (X'Range); - + Z : Z_Scalar) return Result_Vector is begin - if X'Length /= Y'Length then - raise Constraint_Error with - "vectors are of different length in elementwise operation"; - end if; - - for J in R'Range loop - R (J) := Operation (X (J), Y (J - X'First + Y'First), Z); - end loop; + return R : Result_Vector (X'Range) do + if X'Length /= Y'Length then + raise Constraint_Error with + "vectors are of different length in elementwise operation"; + end if; - return R; + for J in R'Range loop + R (J) := Operation (X (J), Y (J - X'First + Y'First), Z); + end loop; + end return; end Vector_Vector_Scalar_Elementwise_Operation; ----------------------------------------- @@ -535,16 +519,14 @@ package body System.Generic_Array_Operations is (Left : Left_Matrix; Right : Right_Scalar) return Result_Matrix is - R : Result_Matrix (Left'Range (1), Left'Range (2)); - begin - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Operation (Left (J, K), Right); + return R : Result_Matrix (Left'Range (1), Left'Range (2)) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Operation (Left (J, K), Right); + end loop; end loop; - end loop; - - return R; + end return; end Matrix_Scalar_Elementwise_Operation; ----------------------------------------- @@ -555,14 +537,12 @@ package body System.Generic_Array_Operations is (Left : Left_Vector; Right : Right_Scalar) return Result_Vector is - R : Result_Vector (Left'Range); - begin - for J in R'Range loop - R (J) := Operation (Left (J), Right); - end loop; - - return R; + return R : Result_Vector (Left'Range) do + for J in R'Range loop + R (J) := Operation (Left (J), Right); + end loop; + end return; end Vector_Scalar_Elementwise_Operation; ----------------------------------------- @@ -573,16 +553,14 @@ package body System.Generic_Array_Operations is (Left : Left_Scalar; Right : Right_Matrix) return Result_Matrix is - R : Result_Matrix (Right'Range (1), Right'Range (2)); - begin - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Operation (Left, Right (J, K)); + return R : Result_Matrix (Right'Range (1), Right'Range (2)) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Operation (Left, Right (J, K)); + end loop; end loop; - end loop; - - return R; + end return; end Scalar_Matrix_Elementwise_Operation; ----------------------------------------- @@ -593,14 +571,12 @@ package body System.Generic_Array_Operations is (Left : Left_Scalar; Right : Right_Vector) return Result_Vector is - R : Result_Vector (Right'Range); - begin - for J in R'Range loop - R (J) := Operation (Left, Right (J)); - end loop; - - return R; + return R : Result_Vector (Right'Range) do + for J in R'Range loop + R (J) := Operation (Left, Right (J)); + end loop; + end return; end Scalar_Vector_Elementwise_Operation; ---------- @@ -662,31 +638,30 @@ package body System.Generic_Array_Operations is (Left : Left_Matrix; Right : Right_Matrix) return Result_Matrix is - R : Result_Matrix (Left'Range (1), Right'Range (2)); - begin - if Left'Length (2) /= Right'Length (1) then - raise Constraint_Error with - "incompatible dimensions in matrix multiplication"; - end if; + return R : Result_Matrix (Left'Range (1), Right'Range (2)) do + if Left'Length (2) /= Right'Length (1) then + raise Constraint_Error with + "incompatible dimensions in matrix multiplication"; + end if; - for J in R'Range (1) loop - for K in R'Range (2) loop - declare - S : Result_Scalar := Zero; + for J in R'Range (1) loop + for K in R'Range (2) loop + declare + S : Result_Scalar := Zero; - begin - for M in Left'Range (2) loop - S := S + Left (J, M) * - Right (M - Left'First (2) + Right'First (1), K); - end loop; + begin + for M in Left'Range (2) loop + S := S + Left (J, M) * + Right + (M - Left'First (2) + Right'First (1), K); + end loop; - R (J, K) := S; - end; + R (J, K) := S; + end; + end loop; end loop; - end loop; - - return R; + end return; end Matrix_Matrix_Product; ---------------------------- @@ -766,28 +741,27 @@ package body System.Generic_Array_Operations is (Left : Matrix; Right : Right_Vector) return Result_Vector is - R : Result_Vector (Left'Range (1)); - begin - if Left'Length (2) /= Right'Length then - raise Constraint_Error with - "incompatible dimensions in matrix-vector multiplication"; - end if; - - for J in Left'Range (1) loop - declare - S : Result_Scalar := Zero; + return R : Result_Vector (Left'Range (1)) do + if Left'Length (2) /= Right'Length then + raise Constraint_Error with + "incompatible dimensions in matrix-vector multiplication"; + end if; - begin - for K in Left'Range (2) loop - S := S + Left (J, K) * Right (K - Left'First (2) + Right'First); - end loop; + for J in Left'Range (1) loop + declare + S : Result_Scalar := Zero; - R (J) := S; - end; - end loop; + begin + for K in Left'Range (2) loop + S := S + Left (J, K) + * Right (K - Left'First (2) + Right'First); + end loop; - return R; + R (J) := S; + end; + end loop; + end return; end Matrix_Vector_Product; ------------------- @@ -798,16 +772,14 @@ package body System.Generic_Array_Operations is (Left : Left_Vector; Right : Right_Vector) return Matrix is - R : Matrix (Left'Range, Right'Range); - begin - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Left (J) * Right (K); + return R : Matrix (Left'Range, Right'Range) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Left (J) * Right (K); + end loop; end loop; - end loop; - - return R; + end return; end Outer_Product; ----------------- @@ -884,17 +856,16 @@ package body System.Generic_Array_Operations is First_1 : Integer := 1; First_2 : Integer := 1) return Matrix is - R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1), - First_2 .. Check_Unit_Last (First_2, Order, First_2)); - begin - R := (others => (others => Zero)); + return R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1), + First_2 .. Check_Unit_Last (First_2, Order, First_2)) + do + R := (others => (others => Zero)); - for J in 0 .. Order - 1 loop - R (First_1 + J, First_2 + J) := One; - end loop; - - return R; + for J in 0 .. Order - 1 loop + R (First_1 + J, First_2 + J) := One; + end loop; + end return; end Unit_Matrix; ----------------- @@ -906,11 +877,11 @@ package body System.Generic_Array_Operations is Order : Positive; First : Integer := 1) return Vector is - R : Vector (First .. Check_Unit_Last (Index, Order, First)); begin - R := (others => Zero); - R (Index) := One; - return R; + return R : Vector (First .. Check_Unit_Last (Index, Order, First)) do + R := (others => Zero); + R (Index) := One; + end return; end Unit_Vector; --------------------------- @@ -921,28 +892,27 @@ package body System.Generic_Array_Operations is (Left : Left_Vector; Right : Matrix) return Result_Vector is - R : Result_Vector (Right'Range (2)); - begin - if Left'Length /= Right'Length (2) then - raise Constraint_Error with - "incompatible dimensions in vector-matrix multiplication"; - end if; - - for J in Right'Range (2) loop - declare - S : Result_Scalar := Zero; + return R : Result_Vector (Right'Range (2)) do + if Left'Length /= Right'Length (2) then + raise Constraint_Error with + "incompatible dimensions in vector-matrix multiplication"; + end if; - begin - for K in Right'Range (1) loop - S := S + Left (J - Right'First (1) + Left'First) * Right (K, J); - end loop; + for J in Right'Range (2) loop + declare + S : Result_Scalar := Zero; - R (J) := S; - end; - end loop; + begin + for K in Right'Range (1) loop + S := S + Left (J - Right'First (1) + + Left'First) * Right (K, J); + end loop; - return R; + R (J) := S; + end; + end loop; + end return; end Vector_Matrix_Product; end System.Generic_Array_Operations; diff --git a/gcc/ada/s-osinte-vms-ia64.adb b/gcc/ada/s-osinte-vms-ia64.adb deleted file mode 100644 index e37d3d2..0000000 --- a/gcc/ada/s-osinte-vms-ia64.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2010, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/IA64 version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; use Interfaces.C; - -package body System.OS_Interface is - - ----------------- - -- sched_yield -- - ----------------- - - function sched_yield return int is - procedure sched_yield_base; - pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP"); - - begin - sched_yield_base; - return 0; - end sched_yield; - -end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vms-ia64.ads b/gcc/ada/s-osinte-vms-ia64.ads deleted file mode 100644 index 99b91aa..0000000 --- a/gcc/ada/s-osinte-vms-ia64.ads +++ /dev/null @@ -1,652 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/IA64 version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by the tasking run-time (libgnarl). - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; - -with Ada.Unchecked_Conversion; - -with System.Aux_DEC; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("--for-linker=ia64$library:pthread$rtl.exe"); - -- Link in the DEC threads library - - -- pragma Linker_Options ("--for-linker=/threads_enable"); - -- Enable upcalls and multiple kernel threads. - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------------------------- - -- Signals (Interrupt IDs) -- - ----------------------------- - - -- Type signal has an arbitrary limit of 31 - - Max_Interrupt : constant := 31; - type Signal is new unsigned range 0 .. Max_Interrupt; - for Signal'Size use unsigned'Size; - - type sigset_t is array (Signal) of Boolean; - pragma Pack (sigset_t); - - -- Interrupt_Number_Type - -- Unsigned long integer denoting the number of an interrupt - - subtype Interrupt_Number_Type is unsigned_long; - - -- OpenVMS system services return values of type Cond_Value_Type - - subtype Cond_Value_Type is unsigned_long; - subtype Short_Cond_Value_Type is unsigned_short; - - type IO_Status_Block_Type is record - Status : Short_Cond_Value_Type; - Count : unsigned_short; - Dev_Info : unsigned_long; - end record; - - type AST_Handler is access procedure (Param : Address); - pragma Convention (C, AST_Handler); - No_AST_Handler : constant AST_Handler := null; - - CMB_M_READONLY : constant := 16#00000001#; - CMB_M_WRITEONLY : constant := 16#00000002#; - AGN_M_READONLY : constant := 16#00000001#; - AGN_M_WRITEONLY : constant := 16#00000002#; - - IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK - IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK - - ---------------- - -- Sys_Assign -- - ---------------- - -- - -- Assign I/O Channel - -- - -- Status = returned status - -- Devnam = address of device name or logical name string - -- descriptor - -- Chan = address of word to receive channel number assigned - -- Acmode = access mode associated with channel - -- Mbxnam = address of mailbox logical name string descriptor, if - -- mailbox associated with device - -- Flags = optional channel flags longword for specifying options - -- for the $ASSIGN operation - -- - - procedure Sys_Assign - (Status : out Cond_Value_Type; - Devnam : String; - Chan : out unsigned_short; - Acmode : unsigned_short := 0; - Mbxnam : String := String'Null_Parameter; - Flags : unsigned_long := 0); - pragma Interface (External, Sys_Assign); - pragma Import_Valued_Procedure - (Sys_Assign, "SYS$ASSIGN", - (Cond_Value_Type, String, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Descriptor (s), Reference, - Value, Descriptor (s), Value), - Flags); - - ---------------- - -- Sys_Cantim -- - ---------------- - -- - -- Cancel Timer - -- - -- Status = returned status - -- Reqidt = ID of timer to be cancelled - -- Acmode = Access mode - -- - procedure Sys_Cantim - (Status : out Cond_Value_Type; - Reqidt : Address; - Acmode : unsigned); - pragma Interface (External, Sys_Cantim); - pragma Import_Valued_Procedure - (Sys_Cantim, "SYS$CANTIM", - (Cond_Value_Type, Address, unsigned), - (Value, Value, Value)); - - ---------------- - -- Sys_Crembx -- - ---------------- - -- - -- Create mailbox - -- - -- Status = returned status - -- Prmflg = permanent flag - -- Chan = channel - -- Maxmsg = maximum message - -- Bufquo = buufer quote - -- Promsk = protection mast - -- Acmode = access mode - -- Lognam = logical name - -- Flags = flags - -- - procedure Sys_Crembx - (Status : out Cond_Value_Type; - Prmflg : unsigned_char; - Chan : out unsigned_short; - Maxmsg : unsigned_long := 0; - Bufquo : unsigned_long := 0; - Promsk : unsigned_short := 0; - Acmode : unsigned_short := 0; - Lognam : String; - Flags : unsigned_long := 0); - pragma Interface (External, Sys_Crembx); - pragma Import_Valued_Procedure - (Sys_Crembx, "SYS$CREMBX", - (Cond_Value_Type, unsigned_char, unsigned_short, - unsigned_long, unsigned_long, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Value, Reference, - Value, Value, Value, - Value, Descriptor (s), Value)); - - ------------- - -- Sys_QIO -- - ------------- - -- - -- Queue I/O - -- - -- Status = Returned status of call - -- EFN = event flag to be set when I/O completes - -- Chan = channel - -- Func = function - -- Iosb = I/O status block - -- Astadr = system trap to be generated when I/O completes - -- Astprm = AST parameter - -- P1-6 = optional parameters - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : unsigned_long := 0; - Chan : unsigned_short; - Func : unsigned_long := 0; - Iosb : out IO_Status_Block_Type; - Astadr : AST_Handler := No_AST_Handler; - Astprm : Address := Null_Address; - P1 : unsigned_long := 0; - P2 : unsigned_long := 0; - P3 : unsigned_long := 0; - P4 : unsigned_long := 0; - P5 : unsigned_long := 0; - P6 : unsigned_long := 0); - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : unsigned_long := 0; - Chan : unsigned_short; - Func : unsigned_long := 0; - Iosb : Address := Null_Address; - Astadr : AST_Handler := No_AST_Handler; - Astprm : Address := Null_Address; - P1 : unsigned_long := 0; - P2 : unsigned_long := 0; - P3 : unsigned_long := 0; - P4 : unsigned_long := 0; - P5 : unsigned_long := 0; - P6 : unsigned_long := 0); - - pragma Interface (External, Sys_QIO); - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - IO_Status_Block_Type, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Reference, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - Address, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Value, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - ---------------- - -- Sys_Setimr -- - ---------------- - -- - -- Set Timer - -- - -- Status = Returned status of call - -- EFN = event flag to be set when timer expires - -- Tim = expiration time - -- AST = system trap to be generated when timer expires - -- Redidt = returned ID of timer (e.g. to cancel timer) - -- Flags = flags - -- - procedure Sys_Setimr - (Status : out Cond_Value_Type; - EFN : unsigned_long; - Tim : Long_Integer; - AST : AST_Handler; - Reqidt : Address; - Flags : unsigned_long); - pragma Interface (External, Sys_Setimr); - pragma Import_Valued_Procedure - (Sys_Setimr, "SYS$SETIMR", - (Cond_Value_Type, unsigned_long, Long_Integer, - AST_Handler, Address, unsigned_long), - (Value, Value, Reference, - Value, Value, Value)); - - Interrupt_ID_0 : constant := 0; - Interrupt_ID_1 : constant := 1; - Interrupt_ID_2 : constant := 2; - Interrupt_ID_3 : constant := 3; - Interrupt_ID_4 : constant := 4; - Interrupt_ID_5 : constant := 5; - Interrupt_ID_6 : constant := 6; - Interrupt_ID_7 : constant := 7; - Interrupt_ID_8 : constant := 8; - Interrupt_ID_9 : constant := 9; - Interrupt_ID_10 : constant := 10; - Interrupt_ID_11 : constant := 11; - Interrupt_ID_12 : constant := 12; - Interrupt_ID_13 : constant := 13; - Interrupt_ID_14 : constant := 14; - Interrupt_ID_15 : constant := 15; - Interrupt_ID_16 : constant := 16; - Interrupt_ID_17 : constant := 17; - Interrupt_ID_18 : constant := 18; - Interrupt_ID_19 : constant := 19; - Interrupt_ID_20 : constant := 20; - Interrupt_ID_21 : constant := 21; - Interrupt_ID_22 : constant := 22; - Interrupt_ID_23 : constant := 23; - Interrupt_ID_24 : constant := 24; - Interrupt_ID_25 : constant := 25; - Interrupt_ID_26 : constant := 26; - Interrupt_ID_27 : constant := 27; - Interrupt_ID_28 : constant := 28; - Interrupt_ID_29 : constant := 29; - Interrupt_ID_30 : constant := 30; - Interrupt_ID_31 : constant := 31; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EINTR : constant := 4; -- Interrupted system call - EAGAIN : constant := 11; -- No more processes - ENOMEM : constant := 12; -- Not enough core - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 3; - SCHED_BG : constant := 4; - SCHED_LFI : constant := 5; - SCHED_LRR : constant := 6; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill); - - function getpid return pid_t; - pragma Import (C, getpid); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - pragma Convention (C, Thread_Body); - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_JOINABLE : constant := 0; - PTHREAD_CREATE_DETACHED : constant := 1; - - PTHREAD_CANCEL_DISABLE : constant := 0; - PTHREAD_CANCEL_ENABLE : constant := 1; - - PTHREAD_CANCEL_DEFERRED : constant := 0; - PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1; - - -- Don't use ERRORCHECK mutexes, they don't work when a thread is not - -- the owner. AST's, at least, unlock others threads mutexes. Even - -- if the error is ignored, they don't work. - PTHREAD_MUTEX_NORMAL_NP : constant := 0; - PTHREAD_MUTEX_RECURSIVE_NP : constant := 1; - PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2; - - PTHREAD_INHERIT_SCHED : constant := 0; - PTHREAD_EXPLICIT_SCHED : constant := 1; - - function pthread_cancel (thread : pthread_t) return int; - pragma Import (C, pthread_cancel, "PTHREAD_CANCEL"); - - procedure pthread_testcancel; - pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL"); - - function pthread_setcancelstate - (newstate : int; oldstate : access int) return int; - pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE"); - - function pthread_setcanceltype - (newtype : int; oldtype : access int) return int; - pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function pthread_lock_global_np return int; - pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP"); - - function pthread_unlock_global_np return int; - pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY"); - - function pthread_mutexattr_settype_np - (attr : access pthread_mutexattr_t; - mutextype : int) return int; - pragma Import (C, pthread_mutexattr_settype_np, - "PTHREAD_MUTEXATTR_SETTYPE_NP"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL"); - - function pthread_cond_signal_int_np - (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal_int_np, - "PTHREAD_COND_SIGNAL_INT_NP"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol, - "PTHREAD_MUTEXATTR_SETPROTOCOL"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - for struct_sched_param'Size use 8*4; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched, - "PTHREAD_ATTR_SETINHERITSCHED"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, - "PTHREAD_ATTR_SETSCHEDPOLICY"); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : int) return int; - pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM"); - - function sched_yield return int; - - -------------------------- - -- P1003.1c Section 16 -- - -------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate, - "PTHREAD_ATTR_SETDETACHSTATE"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "PTHREAD_CREATE"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "PTHREAD_EXIT"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "PTHREAD_SELF"); - -- ??? This can be inlined, see pthread.h - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC"); - - type destructor_pointer is access procedure (arg : System.Address); - pragma Convention (C, destructor_pointer); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE"); - -private - - type pid_t is new int; - - type pthreadLongAddr_p is mod 2 ** Long_Integer'Size; - - type pthreadLongAddr_t is mod 2 ** Long_Integer'Size; - type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size; - - type pthreadLongString_t is mod 2 ** Long_Integer'Size; - - type pthreadLongUint_t is mod 2 ** Long_Integer'Size; - type pthreadLongUint_array is array (Natural range <>) - of pthreadLongUint_t; - - type pthread_t is mod 2 ** Long_Integer'Size; - - type pthread_cond_t is record - state : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_t_ptr; - end record; - for pthread_cond_t'Size use 8*32; - pragma Convention (C, pthread_cond_t); - - type pthread_attr_t is record - valid : long; - name : pthreadLongString_t; - arg : pthreadLongUint_t; - reserved : pthreadLongUint_array (0 .. 18); - end record; - for pthread_attr_t'Size use 8*176; - pragma Convention (C, pthread_attr_t); - - type pthread_mutex_t is record - lock : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_p; - owner : unsigned; - depth : unsigned; - end record; - for pthread_mutex_t'Size use 8*40; - pragma Convention (C, pthread_mutex_t); - - type pthread_mutexattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 14); - end record; - for pthread_mutexattr_t'Size use 8*128; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_condattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 12); - end record; - for pthread_condattr_t'Size use 8*112; - pragma Convention (C, pthread_condattr_t); - - type pthread_key_t is new unsigned; - - pragma Inline (pthread_self); - -end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vms.adb b/gcc/ada/s-osinte-vms.adb index 277b837..ae8fc38 100644 --- a/gcc/ada/s-osinte-vms.adb +++ b/gcc/ada/s-osinte-vms.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2012, AdaCore -- -- -- -- 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- -- @@ -30,7 +30,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a OpenVMS/Alpha version of this package +-- This is the OpenVMS version of this package -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. @@ -40,27 +40,9 @@ pragma Polling (Off); -- tasking operations. It causes infinite loops and other problems. with Interfaces.C; use Interfaces.C; -with System.Machine_Code; use System.Machine_Code; package body System.OS_Interface is - ------------------ - -- pthread_self -- - ------------------ - - function pthread_self return pthread_t is - use ASCII; - Self : pthread_t; - - begin - Asm ("call_pal 0x9e" & LF & HT & - "bis $31, $0, %0", - Outputs => pthread_t'Asm_Output ("=r", Self), - Clobber => "$0", - Volatile => True); - return Self; - end pthread_self; - ----------------- -- sched_yield -- ----------------- diff --git a/gcc/ada/s-osinte-vms.ads b/gcc/ada/s-osinte-vms.ads index 7747d59..e325d0e 100644 --- a/gcc/ada/s-osinte-vms.ads +++ b/gcc/ada/s-osinte-vms.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2012, 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- -- @@ -30,7 +30,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a OpenVMS/Alpha version of this package +-- This is the OpenVMS version of this package -- This package encapsulates all direct interfaces to OS services -- that are needed by the tasking run-time (libgnarl). @@ -47,9 +47,6 @@ with System.Aux_DEC; package System.OS_Interface is pragma Preelaborate; - pragma Linker_Options ("--for-linker=sys$library:pthread$rtl.exe"); - -- Link in the DEC threads library - -- pragma Linker_Options ("--for-linker=/threads_enable"); -- Enable upcalls and multiple kernel threads. @@ -558,6 +555,7 @@ package System.OS_Interface is pragma Import (C, pthread_exit, "PTHREAD_EXIT"); function pthread_self return pthread_t; + pragma Import (C, pthread_self, "PTHREAD_SELF"); -------------------------- -- POSIX.1c Section 17 -- diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb index d03b047..5157172 100644 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- @@ -202,15 +202,6 @@ package body System.Vax_Float_Operations is end S_To_F; ------------ - -- T_To_D -- - ------------ - - function T_To_D (X : T) return D is - begin - return G_To_D (T_To_G (X)); - end T_To_D; - - ------------ -- T_To_G -- ------------ @@ -223,6 +214,15 @@ package body System.Vax_Float_Operations is return B; end T_To_G; + ------------ + -- T_To_D -- + ------------ + + function T_To_D (X : T) return D is + begin + return G_To_D (T_To_G (X)); + end T_To_D; + ----------- -- Abs_F -- ----------- diff --git a/gcc/ada/s-vaflop.adb b/gcc/ada/s-vaflop.adb index dbaa129..221506f 100644 --- a/gcc/ada/s-vaflop.adb +++ b/gcc/ada/s-vaflop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2012, 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- -- @@ -444,22 +444,22 @@ package body System.Vax_Float_Operations is end Sub_G; ------------ - -- T_To_D -- + -- T_To_G -- ------------ - function T_To_D (X : T) return D is + function T_To_G (X : T) return G is begin - return G_To_D (T_To_G (X)); - end T_To_D; + return G (X); + end T_To_G; ------------ - -- T_To_G -- + -- T_To_D -- ------------ - function T_To_G (X : T) return G is + function T_To_D (X : T) return D is begin - return G (X); - end T_To_G; + return G_To_D (T_To_G (X)); + end T_To_D; ------------- -- Valid_D -- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index fadfd6d..e776b58 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1654,10 +1654,9 @@ package body Sem_Ch5 is (Original_Bound : Node_Id; Analyzed_Bound : Node_Id) return Node_Id is - Assign : Node_Id; - Id : Entity_Id; - Decl : Node_Id; - + Assign : Node_Id; + Decl : Node_Id; + Id : Entity_Id; begin -- If the bound is a constant or an object, no need for a separate -- declaration. If the bound is the result of previous expansion @@ -1677,10 +1676,6 @@ package body Sem_Ch5 is return Original_Bound; end if; - -- Here we need to capture the value - - Analyze_And_Resolve (Original_Bound, Typ); - -- Normally, the best approach is simply to generate a constant -- declaration that captures the bound. However, there is a nasty -- case where this is wrong. If the bound is complex, and has a @@ -1692,7 +1687,8 @@ package body Sem_Ch5 is -- proper trace of the value, useful in optimizations that get rid -- of junk range checks. - if not Has_Call_Using_Secondary_Stack (Original_Bound) then + if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then + Analyze_And_Resolve (Original_Bound, Typ); Force_Evaluation (Original_Bound); return Original_Bound; end if; @@ -1712,14 +1708,6 @@ package body Sem_Ch5 is Name => New_Occurrence_Of (Id, Loc), Expression => Relocate_Node (Original_Bound)); - -- We must recursively clean in the relocated expression the flag - -- analyzed to ensure that the expression is reanalyzed. Required - -- to ensure that the transient scope is established now (because - -- Establish_Transient_Scope discarded generating transient scopes - -- in the analysis of the iteration scheme). - - Reset_Analyzed_Flags (Expression (Assign)); - Insert_Actions (Parent (N), New_List (Decl, Assign)); -- Now that this temporary variable is initialized we decorate it |