git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r185051
This commit is contained in:
Arnaud Charlet 2012-03-07 15:45:51 +01:00
parent 62db841a08
commit e761d11c7d
18 changed files with 580 additions and 1257 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gcc/ada/ChangeLog
View File

@ -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> 2012-03-07 Ed Schonberg <schonberg@adacore.com>
* checks.adb (Apply_Predicate_Check): Do not generate a predicate * checks.adb (Apply_Predicate_Check): Do not generate a predicate

38
gcc/ada/a-chahan.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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; end To_Basic;
function To_Basic (Item : String) return String is function To_Basic (Item : String) return String is
Result : String (1 .. Item'Length);
begin begin
for J in Item'Range loop return Result : String (1 .. Item'Length) do
Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); for J in Item'Range loop
end loop; Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J));
end loop;
return Result; end return;
end To_Basic; end To_Basic;
------------------ ------------------
@ -485,14 +483,12 @@ package body Ada.Characters.Handling is
end To_Lower; end To_Lower;
function To_Lower (Item : String) return String is function To_Lower (Item : String) return String is
Result : String (1 .. Item'Length);
begin begin
for J in Item'Range loop return Result : String (1 .. Item'Length) do
Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); for J in Item'Range loop
end loop; Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J));
end loop;
return Result; end return;
end To_Lower; end To_Lower;
--------------- ---------------
@ -527,14 +523,12 @@ package body Ada.Characters.Handling is
function To_Upper function To_Upper
(Item : String) return String (Item : String) return String
is is
Result : String (1 .. Item'Length);
begin begin
for J in Item'Range loop return Result : String (1 .. Item'Length) do
Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); for J in Item'Range loop
end loop; Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J));
end loop;
return Result; end return;
end To_Upper; end To_Upper;
----------------------- -----------------------

21
gcc/ada/a-ngrear.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 function Eigenvalues (A : Real_Matrix) return Real_Vector is
Values : Real_Vector (A'Range (1));
Vectors : Real_Matrix (1 .. 0, 1 .. 0);
begin begin
Jacobi (A, Values, Vectors, Compute_Vectors => False); return Values : Real_Vector (A'Range (1)) do
Sort_Eigensystem (Values, Vectors); declare
return Values; Vectors : Real_Matrix (1 .. 0, 1 .. 0);
begin
Jacobi (A, Values, Vectors, Compute_Vectors => False);
Sort_Eigensystem (Values, Vectors);
end;
end return;
end Eigenvalues; end Eigenvalues;
------------- -------------
@ -742,10 +745,10 @@ package body Ada.Numerics.Generic_Real_Arrays is
--------------- ---------------
function Transpose (X : Real_Matrix) return Real_Matrix is function Transpose (X : Real_Matrix) return Real_Matrix is
R : Real_Matrix (X'Range (2), X'Range (1));
begin begin
Transpose (X, R); return R : Real_Matrix (X'Range (2), X'Range (1)) do
return R; Transpose (X, R);
end return;
end Transpose; end Transpose;
----------------- -----------------

24
gcc/ada/a-ngrear.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- 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 -- front end always inline these, the expense of the unconstrained returns
-- can be avoided. -- can be avoided.
pragma Inline_Always ("+"); pragma Inline ("+");
pragma Inline_Always ("-"); pragma Inline ("-");
pragma Inline_Always ("*"); pragma Inline ("*");
pragma Inline_Always ("/"); pragma Inline ("/");
pragma Inline_Always ("abs"); pragma Inline ("abs");
pragma Inline_Always (Eigenvalues); pragma Inline (Eigenvalues);
pragma Inline_Always (Inverse); pragma Inline (Inverse);
pragma Inline_Always (Solve); pragma Inline (Solve);
pragma Inline_Always (Transpose); pragma Inline (Transpose);
pragma Inline_Always (Unit_Matrix); pragma Inline (Unit_Matrix);
pragma Inline_Always (Unit_Vector); pragma Inline (Unit_Vector);
end Ada.Numerics.Generic_Real_Arrays; end Ada.Numerics.Generic_Real_Arrays;

167
gcc/ada/a-strsup.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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; (Left : Super_String;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is 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 begin
if Nlen > Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Nlen; Rlen : constant Natural := Right.Current_Length;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen); Nlen : constant Natural := Llen + Rlen;
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); begin
end if; 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; end Concat;
function Concat function Concat
(Left : Super_String; (Left : Super_String;
Right : String) return Super_String Right : String) return Super_String
is is
Result : Super_String (Left.Max_Length);
Llen : constant Natural := Left.Current_Length;
Nlen : constant Natural := Llen + Right'Length;
begin begin
if Nlen > Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Nlen; Nlen : constant Natural := Llen + Right'Length;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen); begin
Result.Data (Llen + 1 .. Nlen) := Right; if Nlen > Left.Max_Length then
end if; raise Ada.Strings.Length_Error;
return Result; 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; end Concat;
function Concat function Concat
(Left : String; (Left : String;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is is
Result : Super_String (Right.Max_Length);
Llen : constant Natural := Left'Length;
Rlen : constant Natural := Right.Current_Length;
Nlen : constant Natural := Llen + Rlen;
begin begin
if Nlen > Right.Max_Length then return Result : Super_String (Right.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left'Length;
Result.Current_Length := Nlen; Rlen : constant Natural := Right.Current_Length;
Result.Data (1 .. Llen) := Left; Nlen : constant Natural := Llen + Rlen;
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); begin
end if; 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; end Concat;
function Concat function Concat
(Left : Super_String; (Left : Super_String;
Right : Character) return Super_String Right : Character) return Super_String
is is
Result : Super_String (Left.Max_Length);
Llen : constant Natural := Left.Current_Length;
begin begin
if Llen = Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Llen + 1; begin
Result.Data (1 .. Llen) := Left.Data (1 .. Llen); if Llen = Left.Max_Length then
Result.Data (Result.Current_Length) := Right; raise Ada.Strings.Length_Error;
end if; 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; end Concat;
function Concat function Concat
(Left : Character; (Left : Character;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is is
Result : Super_String (Right.Max_Length);
Rlen : constant Natural := Right.Current_Length;
begin begin
if Rlen = Right.Max_Length then return Result : Super_String (Right.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Rlen : constant Natural := Right.Current_Length;
Result.Current_Length := Rlen + 1; begin
Result.Data (1) := Left; if Rlen = Right.Max_Length then
Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen); raise Ada.Strings.Length_Error;
end if; 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; end Concat;
----------- -----------
@ -1459,13 +1466,15 @@ package body Ada.Strings.Superbounded is
begin begin
-- Note: test of High > Length is in accordance with AI95-00128 -- Note: test of High > Length is in accordance with AI95-00128
if Low > Source.Current_Length + 1 return R : String (Low .. High) do
or else High > Source.Current_Length if Low > Source.Current_Length + 1
then or else High > Source.Current_Length
raise Index_Error; then
else raise Index_Error;
return Source.Data (Low .. High); end if;
end if;
R := Source.Data (Low .. High);
end return;
end Super_Slice; end Super_Slice;
function Super_Slice function Super_Slice
@ -1473,19 +1482,17 @@ package body Ada.Strings.Superbounded is
Low : Positive; Low : Positive;
High : Natural) return Super_String High : Natural) return Super_String
is is
Result : Super_String (Source.Max_Length);
begin begin
if Low > Source.Current_Length + 1 return Result : Super_String (Source.Max_Length) do
or else High > Source.Current_Length if Low > Source.Current_Length + 1
then or else High > Source.Current_Length
raise Index_Error; then
else raise Index_Error;
end if;
Result.Current_Length := High - Low + 1; Result.Current_Length := High - Low + 1;
Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High);
end if; end return;
return Result;
end Super_Slice; end Super_Slice;
procedure 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 function Super_To_String (Source : Super_String) return String is
begin 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; end Super_To_String;
--------------------- ---------------------

173
gcc/ada/a-stwisu.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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; (Left : Super_String;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is 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 begin
if Nlen > Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Nlen; Rlen : constant Natural := Right.Current_Length;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen); Nlen : constant Natural := Llen + Rlen;
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
end if;
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; end Concat;
function Concat function Concat
(Left : Super_String; (Left : Super_String;
Right : Wide_String) return Super_String Right : Wide_String) return Super_String
is is
Result : Super_String (Left.Max_Length);
Llen : constant Natural := Left.Current_Length;
Nlen : constant Natural := Llen + Right'Length;
begin begin
if Nlen > Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Nlen; Nlen : constant Natural := Llen + Right'Length;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
Result.Data (Llen + 1 .. Nlen) := Right; begin
end if; if Nlen > Left.Max_Length then
return Result; 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; end Concat;
function Concat function Concat
(Left : Wide_String; (Left : Wide_String;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is is
Result : Super_String (Right.Max_Length);
Llen : constant Natural := Left'Length;
Rlen : constant Natural := Right.Current_Length;
Nlen : constant Natural := Llen + Rlen;
begin begin
if Nlen > Right.Max_Length then return Result : Super_String (Right.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left'Length;
Result.Current_Length := Nlen; Rlen : constant Natural := Right.Current_Length;
Result.Data (1 .. Llen) := Left; Nlen : constant Natural := Llen + Rlen;
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
end if;
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; end Concat;
function Concat function Concat
(Left : Super_String; (Left : Super_String;
Right : Wide_Character) return Super_String Right : Wide_Character) return Super_String
is is
Result : Super_String (Left.Max_Length);
Llen : constant Natural := Left.Current_Length;
begin begin
if Llen = Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Llen + 1;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
Result.Data (Result.Current_Length) := Right;
end if;
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; end Concat;
function Concat function Concat
(Left : Wide_Character; (Left : Wide_Character;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is is
Result : Super_String (Right.Max_Length);
Rlen : constant Natural := Right.Current_Length;
begin begin
if Rlen = Right.Max_Length then return Result : Super_String (Right.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Rlen : constant Natural := Right.Current_Length;
Result.Current_Length := Rlen + 1;
Result.Data (1) := Left;
Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
end if;
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; end Concat;
----------- -----------
@ -1462,13 +1473,15 @@ package body Ada.Strings.Wide_Superbounded is
begin begin
-- Note: test of High > Length is in accordance with AI95-00128 -- Note: test of High > Length is in accordance with AI95-00128
if Low > Source.Current_Length + 1 return R : Wide_String (Low .. High) do
or else High > Source.Current_Length if Low > Source.Current_Length + 1
then or else High > Source.Current_Length
raise Index_Error; then
else raise Index_Error;
return Source.Data (Low .. High); end if;
end if;
R := Source.Data (Low .. High);
end return;
end Super_Slice; end Super_Slice;
function Super_Slice function Super_Slice
@ -1476,19 +1489,17 @@ package body Ada.Strings.Wide_Superbounded is
Low : Positive; Low : Positive;
High : Natural) return Super_String High : Natural) return Super_String
is is
Result : Super_String (Source.Max_Length);
begin begin
if Low > Source.Current_Length + 1 return Result : Super_String (Source.Max_Length) do
or else High > Source.Current_Length if Low > Source.Current_Length + 1
then or else High > Source.Current_Length
raise Index_Error; then
else raise Index_Error;
end if;
Result.Current_Length := High - Low + 1; Result.Current_Length := High - Low + 1;
Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High);
end if; end return;
return Result;
end Super_Slice; end Super_Slice;
procedure 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 function Super_To_String (Source : Super_String) return Wide_String is
begin 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; end Super_To_String;
--------------------- ---------------------

178
gcc/ada/a-stzsup.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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; (Left : Super_String;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is 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 begin
if Nlen > Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Nlen; Rlen : constant Natural := Right.Current_Length;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen); Nlen : constant Natural := Llen + Rlen;
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
end if;
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; end Concat;
function Concat function Concat
(Left : Super_String; (Left : Super_String;
Right : Wide_Wide_String) return Super_String Right : Wide_Wide_String) return Super_String
is is
Result : Super_String (Left.Max_Length);
Llen : constant Natural := Left.Current_Length;
Nlen : constant Natural := Llen + Right'Length;
begin begin
if Nlen > Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Nlen; Nlen : constant Natural := Llen + Right'Length;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
Result.Data (Llen + 1 .. Nlen) := Right; begin
end if; if Nlen > Left.Max_Length then
return Result; 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; end Concat;
function Concat function Concat
(Left : Wide_Wide_String; (Left : Wide_Wide_String;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is is
Result : Super_String (Right.Max_Length);
Llen : constant Natural := Left'Length;
Rlen : constant Natural := Right.Current_Length;
Nlen : constant Natural := Llen + Rlen;
begin begin
if Nlen > Right.Max_Length then return Result : Super_String (Right.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left'Length;
Result.Current_Length := Nlen; Rlen : constant Natural := Right.Current_Length;
Result.Data (1 .. Llen) := Left; Nlen : constant Natural := Llen + Rlen;
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
end if;
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; end Concat;
function Concat function Concat
(Left : Super_String; (Left : Super_String;
Right : Wide_Wide_Character) return Super_String Right : Wide_Wide_Character) return Super_String
is is
Result : Super_String (Left.Max_Length);
Llen : constant Natural := Left.Current_Length;
begin begin
if Llen = Left.Max_Length then return Result : Super_String (Left.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Llen : constant Natural := Left.Current_Length;
Result.Current_Length := Llen + 1;
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
Result.Data (Result.Current_Length) := Right;
end if;
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; end Concat;
function Concat function Concat
(Left : Wide_Wide_Character; (Left : Wide_Wide_Character;
Right : Super_String) return Super_String Right : Super_String) return Super_String
is is
Result : Super_String (Right.Max_Length);
Rlen : constant Natural := Right.Current_Length;
begin begin
if Rlen = Right.Max_Length then return Result : Super_String (Right.Max_Length) do
raise Ada.Strings.Length_Error; declare
else Rlen : constant Natural := Right.Current_Length;
Result.Current_Length := Rlen + 1;
Result.Data (1) := Left;
Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
end if;
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; end Concat;
----------- -----------
@ -1469,13 +1480,15 @@ package body Ada.Strings.Wide_Wide_Superbounded is
begin begin
-- Note: test of High > Length is in accordance with AI95-00128 -- Note: test of High > Length is in accordance with AI95-00128
if Low > Source.Current_Length + 1 return R : Wide_Wide_String (Low .. High) do
or else High > Source.Current_Length if Low > Source.Current_Length + 1
then or else High > Source.Current_Length
raise Index_Error; then
else raise Index_Error;
return Source.Data (Low .. High); end if;
end if;
R := Source.Data (Low .. High);
end return;
end Super_Slice; end Super_Slice;
function Super_Slice function Super_Slice
@ -1483,19 +1496,18 @@ package body Ada.Strings.Wide_Wide_Superbounded is
Low : Positive; Low : Positive;
High : Natural) return Super_String High : Natural) return Super_String
is is
Result : Super_String (Source.Max_Length);
begin begin
if Low > Source.Current_Length + 1 return Result : Super_String (Source.Max_Length) do
or else High > Source.Current_Length if Low > Source.Current_Length + 1
then or else High > Source.Current_Length
raise Index_Error; then
else raise Index_Error;
Result.Current_Length := High - Low + 1; else
Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); Result.Current_Length := High - Low + 1;
end if; Result.Data (1 .. Result.Current_Length) :=
Source.Data (Low .. High);
return Result; end if;
end return;
end Super_Slice; end Super_Slice;
procedure Super_Slice procedure Super_Slice
@ -1627,7 +1639,9 @@ package body Ada.Strings.Wide_Wide_Superbounded is
(Source : Super_String) return Wide_Wide_String (Source : Super_String) return Wide_Wide_String
is is
begin 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; end Super_To_String;
--------------------- ---------------------

11
gcc/ada/exp_ch4.adb
View File

@ -702,13 +702,16 @@ package body Exp_Ch4 is
(Is_Class_Wide_Type (Etype (Exp)) (Is_Class_Wide_Type (Etype (Exp))
and then Scope (PtrT) /= Current_Scope)) and then Scope (PtrT) /= Current_Scope))
then 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 -- to the access object initialized to the result of the allocator
-- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
-- it is the entity associated with the object containing the -- Remove_Side_Effects for cases where the build-in-place call may
-- address of the allocated object. -- 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 if Built_In_Place then
Remove_Side_Effects (Ref);
New_Node := New_Copy (Ref); New_Node := New_Copy (Ref);
else else
New_Node := New_Reference_To (Ref, Loc); New_Node := New_Reference_To (Ref, Loc);

17
gcc/ada/exp_ch6.adb
View File

@ -4243,6 +4243,23 @@ package body Exp_Ch6 is
Error_Msg_N ("call to recursive subprogram cannot be inlined?", N); Error_Msg_N ("call to recursive subprogram cannot be inlined?", N);
Set_Is_Inlined (Subp, False); Set_Is_Inlined (Subp, False);
return; 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; end if;
if Nkind (Orig_Bod) = N_Defining_Identifier if Nkind (Orig_Bod) = N_Defining_Identifier

6
gcc/ada/gcc-interface/Makefile.in
View File

@ -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-memory.ads<s-memory-vms_64.ads \
s-osprim.adb<s-osprim-vms.adb \ s-osprim.adb<s-osprim-vms.adb \
s-osprim.ads<s-osprim-vms.ads \ 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-taprop.adb<s-taprop-vms.adb \
s-tasdeb.adb<s-tasdeb-vms.adb \ s-tasdeb.adb<s-tasdeb-vms.adb \
s-taspri.ads<s-taspri-vms.ads \ 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 \ g-trasym.adb<g-trasym-vms-ia64.adb \
s-asthan.adb<s-asthan-vms-ia64.adb \ s-asthan.adb<s-asthan-vms-ia64.adb \
s-auxdec.adb<s-auxdec-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 \ s-vaflop.adb<s-vaflop-vms-ia64.adb \
system.ads<system-vms-ia64.ads \ system.ads<system-vms-ia64.ads \
s-parame.ads<s-parame-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 \ g-trasym.adb<g-trasym-vms-alpha.adb \
s-asthan.adb<s-asthan-vms-alpha.adb \ s-asthan.adb<s-asthan-vms-alpha.adb \
s-auxdec.adb<s-auxdec-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.adb<s-traent-vms.adb \
s-traent.ads<s-traent-vms.ads \ s-traent.ads<s-traent-vms.ads \
s-vaflop.adb<s-vaflop-vms-alpha.adb \ s-vaflop.adb<s-vaflop-vms-alpha.adb \

356
gcc/ada/s-gearop.adb
View File

@ -51,14 +51,12 @@ package body System.Generic_Array_Operations is
function Diagonal (A : Matrix) return Vector is function Diagonal (A : Matrix) return Vector is
N : constant Natural := Natural'Min (A'Length (1), A'Length (2)); N : constant Natural := Natural'Min (A'Length (1), A'Length (2));
R : Vector (A'First (1) .. A'First (1) + N - 1);
begin begin
for J in 0 .. N - 1 loop return R : Vector (A'First (1) .. A'First (1) + N - 1) do
R (R'First + J) := A (A'First (1) + J, A'First (2) + J); for J in 0 .. N - 1 loop
end loop; R (R'First + J) := A (A'First (1) + J, A'First (2) + J);
end loop;
return R; end return;
end Diagonal; end Diagonal;
-------------------------- --------------------------
@ -386,16 +384,14 @@ package body System.Generic_Array_Operations is
---------------------------------- ----------------------------------
function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is
R : Result_Matrix (X'Range (1), X'Range (2));
begin begin
for J in R'Range (1) loop return R : Result_Matrix (X'Range (1), X'Range (2)) do
for K in R'Range (2) loop for J in R'Range (1) loop
R (J, K) := Operation (X (J, K)); for K in R'Range (2) loop
R (J, K) := Operation (X (J, K));
end loop;
end loop; end loop;
end loop; end return;
return R;
end Matrix_Elementwise_Operation; 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 function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector is
R : Result_Vector (X'Range);
begin begin
for J in R'Range loop return R : Result_Vector (X'Range) do
R (J) := Operation (X (J)); for J in R'Range loop
end loop; R (J) := Operation (X (J));
end loop;
return R; end return;
end Vector_Elementwise_Operation; end Vector_Elementwise_Operation;
----------------------------------------- -----------------------------------------
@ -421,29 +415,27 @@ package body System.Generic_Array_Operations is
(Left : Left_Matrix; (Left : Left_Matrix;
Right : Right_Matrix) return Result_Matrix Right : Right_Matrix) return Result_Matrix
is is
R : Result_Matrix (Left'Range (1), Left'Range (2));
begin 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 or else
Left'Length (2) /= Right'Length (2) Left'Length (2) /= Right'Length (2)
then then
raise Constraint_Error with raise Constraint_Error with
"matrices are of different dimension in elementwise operation"; "matrices are of different dimension in elementwise operation";
end if; end if;
for J in R'Range (1) loop for J in R'Range (1) loop
for K in R'Range (2) loop for K in R'Range (2) loop
R (J, K) := R (J, K) :=
Operation Operation
(Left (J, K), (Left (J, K),
Right Right
(J - R'First (1) + Right'First (1), (J - R'First (1) + Right'First (1),
K - R'First (2) + Right'First (2))); K - R'First (2) + Right'First (2)));
end loop;
end loop; end loop;
end loop; end return;
return R;
end Matrix_Matrix_Elementwise_Operation; end Matrix_Matrix_Elementwise_Operation;
------------------------------------------------ ------------------------------------------------
@ -453,31 +445,28 @@ package body System.Generic_Array_Operations is
function Matrix_Matrix_Scalar_Elementwise_Operation function Matrix_Matrix_Scalar_Elementwise_Operation
(X : X_Matrix; (X : X_Matrix;
Y : Y_Matrix; Y : Y_Matrix;
Z : Z_Scalar) return Result_Matrix Z : Z_Scalar) return Result_Matrix is
is
R : Result_Matrix (X'Range (1), X'Range (2));
begin 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 or else
X'Length (2) /= Y'Length (2) X'Length (2) /= Y'Length (2)
then then
raise Constraint_Error with raise Constraint_Error with
"matrices are of different dimension in elementwise operation"; "matrices are of different dimension in elementwise operation";
end if; end if;
for J in R'Range (1) loop for J in R'Range (1) loop
for K in R'Range (2) loop for K in R'Range (2) loop
R (J, K) := R (J, K) :=
Operation Operation
(X (J, K), (X (J, K),
Y (J - R'First (1) + Y'First (1), Y (J - R'First (1) + Y'First (1),
K - R'First (2) + Y'First (2)), K - R'First (2) + Y'First (2)),
Z); Z);
end loop;
end loop; end loop;
end loop; end return;
return R;
end Matrix_Matrix_Scalar_Elementwise_Operation; end Matrix_Matrix_Scalar_Elementwise_Operation;
----------------------------------------- -----------------------------------------
@ -488,19 +477,17 @@ package body System.Generic_Array_Operations is
(Left : Left_Vector; (Left : Left_Vector;
Right : Right_Vector) return Result_Vector Right : Right_Vector) return Result_Vector
is is
R : Result_Vector (Left'Range);
begin begin
if Left'Length /= Right'Length then return R : Result_Vector (Left'Range) do
raise Constraint_Error with if Left'Length /= Right'Length then
"vectors are of different length in elementwise operation"; raise Constraint_Error with
end if; "vectors are of different length in elementwise operation";
end if;
for J in R'Range loop for J in R'Range loop
R (J) := Operation (Left (J), Right (J - R'First + Right'First)); R (J) := Operation (Left (J), Right (J - R'First + Right'First));
end loop; end loop;
end return;
return R;
end Vector_Vector_Elementwise_Operation; end Vector_Vector_Elementwise_Operation;
------------------------------------------------ ------------------------------------------------
@ -510,21 +497,18 @@ package body System.Generic_Array_Operations is
function Vector_Vector_Scalar_Elementwise_Operation function Vector_Vector_Scalar_Elementwise_Operation
(X : X_Vector; (X : X_Vector;
Y : Y_Vector; Y : Y_Vector;
Z : Z_Scalar) return Result_Vector Z : Z_Scalar) return Result_Vector is
is
R : Result_Vector (X'Range);
begin begin
if X'Length /= Y'Length then return R : Result_Vector (X'Range) do
raise Constraint_Error with if X'Length /= Y'Length then
"vectors are of different length in elementwise operation"; raise Constraint_Error with
end if; "vectors are of different length in elementwise operation";
end if;
for J in R'Range loop for J in R'Range loop
R (J) := Operation (X (J), Y (J - X'First + Y'First), Z); R (J) := Operation (X (J), Y (J - X'First + Y'First), Z);
end loop; end loop;
end return;
return R;
end Vector_Vector_Scalar_Elementwise_Operation; end Vector_Vector_Scalar_Elementwise_Operation;
----------------------------------------- -----------------------------------------
@ -535,16 +519,14 @@ package body System.Generic_Array_Operations is
(Left : Left_Matrix; (Left : Left_Matrix;
Right : Right_Scalar) return Result_Matrix Right : Right_Scalar) return Result_Matrix
is is
R : Result_Matrix (Left'Range (1), Left'Range (2));
begin begin
for J in R'Range (1) loop return R : Result_Matrix (Left'Range (1), Left'Range (2)) do
for K in R'Range (2) loop for J in R'Range (1) loop
R (J, K) := Operation (Left (J, K), Right); for K in R'Range (2) loop
R (J, K) := Operation (Left (J, K), Right);
end loop;
end loop; end loop;
end loop; end return;
return R;
end Matrix_Scalar_Elementwise_Operation; end Matrix_Scalar_Elementwise_Operation;
----------------------------------------- -----------------------------------------
@ -555,14 +537,12 @@ package body System.Generic_Array_Operations is
(Left : Left_Vector; (Left : Left_Vector;
Right : Right_Scalar) return Result_Vector Right : Right_Scalar) return Result_Vector
is is
R : Result_Vector (Left'Range);
begin begin
for J in R'Range loop return R : Result_Vector (Left'Range) do
R (J) := Operation (Left (J), Right); for J in R'Range loop
end loop; R (J) := Operation (Left (J), Right);
end loop;
return R; end return;
end Vector_Scalar_Elementwise_Operation; end Vector_Scalar_Elementwise_Operation;
----------------------------------------- -----------------------------------------
@ -573,16 +553,14 @@ package body System.Generic_Array_Operations is
(Left : Left_Scalar; (Left : Left_Scalar;
Right : Right_Matrix) return Result_Matrix Right : Right_Matrix) return Result_Matrix
is is
R : Result_Matrix (Right'Range (1), Right'Range (2));
begin begin
for J in R'Range (1) loop return R : Result_Matrix (Right'Range (1), Right'Range (2)) do
for K in R'Range (2) loop for J in R'Range (1) loop
R (J, K) := Operation (Left, Right (J, K)); for K in R'Range (2) loop
R (J, K) := Operation (Left, Right (J, K));
end loop;
end loop; end loop;
end loop; end return;
return R;
end Scalar_Matrix_Elementwise_Operation; end Scalar_Matrix_Elementwise_Operation;
----------------------------------------- -----------------------------------------
@ -593,14 +571,12 @@ package body System.Generic_Array_Operations is
(Left : Left_Scalar; (Left : Left_Scalar;
Right : Right_Vector) return Result_Vector Right : Right_Vector) return Result_Vector
is is
R : Result_Vector (Right'Range);
begin begin
for J in R'Range loop return R : Result_Vector (Right'Range) do
R (J) := Operation (Left, Right (J)); for J in R'Range loop
end loop; R (J) := Operation (Left, Right (J));
end loop;
return R; end return;
end Scalar_Vector_Elementwise_Operation; end Scalar_Vector_Elementwise_Operation;
---------- ----------
@ -662,31 +638,30 @@ package body System.Generic_Array_Operations is
(Left : Left_Matrix; (Left : Left_Matrix;
Right : Right_Matrix) return Result_Matrix Right : Right_Matrix) return Result_Matrix
is is
R : Result_Matrix (Left'Range (1), Right'Range (2));
begin begin
if Left'Length (2) /= Right'Length (1) then return R : Result_Matrix (Left'Range (1), Right'Range (2)) do
raise Constraint_Error with if Left'Length (2) /= Right'Length (1) then
"incompatible dimensions in matrix multiplication"; raise Constraint_Error with
end if; "incompatible dimensions in matrix multiplication";
end if;
for J in R'Range (1) loop for J in R'Range (1) loop
for K in R'Range (2) loop for K in R'Range (2) loop
declare declare
S : Result_Scalar := Zero; S : Result_Scalar := Zero;
begin begin
for M in Left'Range (2) loop for M in Left'Range (2) loop
S := S + Left (J, M) * S := S + Left (J, M) *
Right (M - Left'First (2) + Right'First (1), K); Right
end loop; (M - Left'First (2) + Right'First (1), K);
end loop;
R (J, K) := S; R (J, K) := S;
end; end;
end loop;
end loop; end loop;
end loop; end return;
return R;
end Matrix_Matrix_Product; end Matrix_Matrix_Product;
---------------------------- ----------------------------
@ -766,28 +741,27 @@ package body System.Generic_Array_Operations is
(Left : Matrix; (Left : Matrix;
Right : Right_Vector) return Result_Vector Right : Right_Vector) return Result_Vector
is is
R : Result_Vector (Left'Range (1));
begin begin
if Left'Length (2) /= Right'Length then return R : Result_Vector (Left'Range (1)) do
raise Constraint_Error with if Left'Length (2) /= Right'Length then
"incompatible dimensions in matrix-vector multiplication"; raise Constraint_Error with
end if; "incompatible dimensions in matrix-vector multiplication";
end if;
for J in Left'Range (1) loop for J in Left'Range (1) loop
declare declare
S : Result_Scalar := Zero; S : Result_Scalar := Zero;
begin begin
for K in Left'Range (2) loop for K in Left'Range (2) loop
S := S + Left (J, K) * Right (K - Left'First (2) + Right'First); S := S + Left (J, K)
end loop; * Right (K - Left'First (2) + Right'First);
end loop;
R (J) := S; R (J) := S;
end; end;
end loop; end loop;
end return;
return R;
end Matrix_Vector_Product; end Matrix_Vector_Product;
------------------- -------------------
@ -798,16 +772,14 @@ package body System.Generic_Array_Operations is
(Left : Left_Vector; (Left : Left_Vector;
Right : Right_Vector) return Matrix Right : Right_Vector) return Matrix
is is
R : Matrix (Left'Range, Right'Range);
begin begin
for J in R'Range (1) loop return R : Matrix (Left'Range, Right'Range) do
for K in R'Range (2) loop for J in R'Range (1) loop
R (J, K) := Left (J) * Right (K); for K in R'Range (2) loop
R (J, K) := Left (J) * Right (K);
end loop;
end loop; end loop;
end loop; end return;
return R;
end Outer_Product; end Outer_Product;
----------------- -----------------
@ -884,17 +856,16 @@ package body System.Generic_Array_Operations is
First_1 : Integer := 1; First_1 : Integer := 1;
First_2 : Integer := 1) return Matrix First_2 : Integer := 1) return Matrix
is is
R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1),
First_2 .. Check_Unit_Last (First_2, Order, First_2));
begin 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 for J in 0 .. Order - 1 loop
R (First_1 + J, First_2 + J) := One; R (First_1 + J, First_2 + J) := One;
end loop; end loop;
end return;
return R;
end Unit_Matrix; end Unit_Matrix;
----------------- -----------------
@ -906,11 +877,11 @@ package body System.Generic_Array_Operations is
Order : Positive; Order : Positive;
First : Integer := 1) return Vector First : Integer := 1) return Vector
is is
R : Vector (First .. Check_Unit_Last (Index, Order, First));
begin begin
R := (others => Zero); return R : Vector (First .. Check_Unit_Last (Index, Order, First)) do
R (Index) := One; R := (others => Zero);
return R; R (Index) := One;
end return;
end Unit_Vector; end Unit_Vector;
--------------------------- ---------------------------
@ -921,28 +892,27 @@ package body System.Generic_Array_Operations is
(Left : Left_Vector; (Left : Left_Vector;
Right : Matrix) return Result_Vector Right : Matrix) return Result_Vector
is is
R : Result_Vector (Right'Range (2));
begin begin
if Left'Length /= Right'Length (2) then return R : Result_Vector (Right'Range (2)) do
raise Constraint_Error with if Left'Length /= Right'Length (2) then
"incompatible dimensions in vector-matrix multiplication"; raise Constraint_Error with
end if; "incompatible dimensions in vector-matrix multiplication";
end if;
for J in Right'Range (2) loop for J in Right'Range (2) loop
declare declare
S : Result_Scalar := Zero; S : Result_Scalar := Zero;
begin begin
for K in Right'Range (1) loop for K in Right'Range (1) loop
S := S + Left (J - Right'First (1) + Left'First) * Right (K, J); S := S + Left (J - Right'First (1)
end loop; + Left'First) * Right (K, J);
end loop;
R (J) := S; R (J) := S;
end; end;
end loop; end loop;
end return;
return R;
end Vector_Matrix_Product; end Vector_Matrix_Product;
end System.Generic_Array_Operations; end System.Generic_Array_Operations;

58
gcc/ada/s-osinte-vms-ia64.adb
View File

@ -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;

652
gcc/ada/s-osinte-vms-ia64.ads
View File

@ -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;

22
gcc/ada/s-osinte-vms.adb
View File

@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- 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 -- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System. -- that are needed by children of System.
@ -40,27 +40,9 @@ pragma Polling (Off);
-- tasking operations. It causes infinite loops and other problems. -- tasking operations. It causes infinite loops and other problems.
with Interfaces.C; use Interfaces.C; with Interfaces.C; use Interfaces.C;
with System.Machine_Code; use System.Machine_Code;
package body System.OS_Interface is 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 -- -- sched_yield --
----------------- -----------------

8
gcc/ada/s-osinte-vms.ads
View File

@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- 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 -- This package encapsulates all direct interfaces to OS services
-- that are needed by the tasking run-time (libgnarl). -- that are needed by the tasking run-time (libgnarl).
@ -47,9 +47,6 @@ with System.Aux_DEC;
package System.OS_Interface is package System.OS_Interface is
pragma Preelaborate; 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"); -- pragma Linker_Options ("--for-linker=/threads_enable");
-- Enable upcalls and multiple kernel threads. -- Enable upcalls and multiple kernel threads.
@ -558,6 +555,7 @@ package System.OS_Interface is
pragma Import (C, pthread_exit, "PTHREAD_EXIT"); pragma Import (C, pthread_exit, "PTHREAD_EXIT");
function pthread_self return pthread_t; function pthread_self return pthread_t;
pragma Import (C, pthread_self, "PTHREAD_SELF");
-------------------------- --------------------------
-- POSIX.1c Section 17 -- -- POSIX.1c Section 17 --

20
gcc/ada/s-vaflop-vms-alpha.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1997-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1997-2012, Free Software Foundation, Inc. --
-- (Version for Alpha OpenVMS) -- -- (Version for Alpha OpenVMS) --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
@ -201,15 +201,6 @@ package body System.Vax_Float_Operations is
return B; return B;
end S_To_F; 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 -- -- T_To_G --
------------ ------------
@ -223,6 +214,15 @@ package body System.Vax_Float_Operations is
return B; return B;
end T_To_G; 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 -- -- Abs_F --
----------- -----------

20
gcc/ada/s-vaflop.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -443,15 +443,6 @@ package body System.Vax_Float_Operations is
return X - Y; return X - Y;
end Sub_G; end Sub_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;
------------ ------------
-- T_To_G -- -- T_To_G --
------------ ------------
@ -461,6 +452,15 @@ package body System.Vax_Float_Operations is
return G (X); return G (X);
end T_To_G; 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;
------------- -------------
-- Valid_D -- -- Valid_D --
------------- -------------

22
gcc/ada/sem_ch5.adb
View File

@ -1654,10 +1654,9 @@ package body Sem_Ch5 is
(Original_Bound : Node_Id; (Original_Bound : Node_Id;
Analyzed_Bound : Node_Id) return Node_Id Analyzed_Bound : Node_Id) return Node_Id
is is
Assign : Node_Id; Assign : Node_Id;
Id : Entity_Id; Decl : Node_Id;
Decl : Node_Id; Id : Entity_Id;
begin begin
-- If the bound is a constant or an object, no need for a separate -- If the bound is a constant or an object, no need for a separate
-- declaration. If the bound is the result of previous expansion -- declaration. If the bound is the result of previous expansion
@ -1677,10 +1676,6 @@ package body Sem_Ch5 is
return Original_Bound; return Original_Bound;
end if; 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 -- Normally, the best approach is simply to generate a constant
-- declaration that captures the bound. However, there is a nasty -- declaration that captures the bound. However, there is a nasty
-- case where this is wrong. If the bound is complex, and has a -- 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 -- proper trace of the value, useful in optimizations that get rid
-- of junk range checks. -- 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); Force_Evaluation (Original_Bound);
return Original_Bound; return Original_Bound;
end if; end if;
@ -1712,14 +1708,6 @@ package body Sem_Ch5 is
Name => New_Occurrence_Of (Id, Loc), Name => New_Occurrence_Of (Id, Loc),
Expression => Relocate_Node (Original_Bound)); 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)); Insert_Actions (Parent (N), New_List (Decl, Assign));
-- Now that this temporary variable is initialized we decorate it -- Now that this temporary variable is initialized we decorate it