mirror of git://gcc.gnu.org/git/gcc.git
[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
parent
62db841a08
commit
e761d11c7d
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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;
|
||||
|
||||
return Result;
|
||||
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
|
||||
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;
|
||||
|
||||
return Result;
|
||||
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
|
||||
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;
|
||||
|
||||
return Result;
|
||||
end return;
|
||||
end To_Upper;
|
||||
|
||||
-----------------------
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
begin
|
||||
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);
|
||||
return Values;
|
||||
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
|
||||
return R : Real_Matrix (X'Range (2), X'Range (1)) do
|
||||
Transpose (X, R);
|
||||
return R;
|
||||
end return;
|
||||
end Transpose;
|
||||
|
||||
-----------------
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
begin
|
||||
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;
|
||||
else
|
||||
end if;
|
||||
|
||||
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;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Super_String;
|
||||
Right : String) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
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
|
||||
end if;
|
||||
|
||||
Result.Current_Length := Nlen;
|
||||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Llen + 1 .. Nlen) := Right;
|
||||
end if;
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : String;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Right.Max_Length);
|
||||
|
||||
begin
|
||||
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;
|
||||
else
|
||||
end if;
|
||||
|
||||
Result.Current_Length := Nlen;
|
||||
Result.Data (1 .. Llen) := Left;
|
||||
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Super_String;
|
||||
Right : Character) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
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;
|
||||
else
|
||||
end if;
|
||||
|
||||
Result.Current_Length := Llen + 1;
|
||||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Result.Current_Length) := Right;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Character;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Right.Max_Length);
|
||||
begin
|
||||
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;
|
||||
else
|
||||
Result.Current_Length := Rlen + 1;
|
||||
Result.Data (1) := Left;
|
||||
Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
|
||||
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
|
||||
|
||||
return R : String (Low .. High) do
|
||||
if Low > Source.Current_Length + 1
|
||||
or else High > Source.Current_Length
|
||||
then
|
||||
raise Index_Error;
|
||||
else
|
||||
return Source.Data (Low .. High);
|
||||
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
|
||||
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;
|
||||
|
||||
return Result;
|
||||
Result.Current_Length := High - Low + 1;
|
||||
Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High);
|
||||
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;
|
||||
|
||||
---------------------
|
||||
|
|
|
|||
|
|
@ -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,7 +42,9 @@ package body Ada.Strings.Wide_Superbounded is
|
|||
(Left : Super_String;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
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;
|
||||
|
|
@ -55,17 +57,18 @@ package body Ada.Strings.Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Super_String;
|
||||
Right : Wide_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
return Result : Super_String (Left.Max_Length) do
|
||||
declare
|
||||
Llen : constant Natural := Left.Current_Length;
|
||||
|
||||
Nlen : constant Natural := Llen + Right'Length;
|
||||
|
||||
begin
|
||||
|
|
@ -76,14 +79,17 @@ package body Ada.Strings.Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Llen + 1 .. Nlen) := Right;
|
||||
end if;
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Wide_String;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Right.Max_Length);
|
||||
begin
|
||||
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;
|
||||
|
|
@ -96,15 +102,17 @@ package body Ada.Strings.Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left;
|
||||
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Super_String;
|
||||
Right : Wide_Character) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
return Result : Super_String (Left.Max_Length) do
|
||||
declare
|
||||
Llen : constant Natural := Left.Current_Length;
|
||||
|
||||
begin
|
||||
|
|
@ -115,15 +123,17 @@ package body Ada.Strings.Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Result.Current_Length) := Right;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Wide_Character;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Right.Max_Length);
|
||||
begin
|
||||
return Result : Super_String (Right.Max_Length) do
|
||||
declare
|
||||
Rlen : constant Natural := Right.Current_Length;
|
||||
|
||||
begin
|
||||
|
|
@ -132,10 +142,11 @@ package body Ada.Strings.Wide_Superbounded is
|
|||
else
|
||||
Result.Current_Length := Rlen + 1;
|
||||
Result.Data (1) := Left;
|
||||
Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
|
||||
Result.Data (2 .. Result.Current_Length) :=
|
||||
Right.Data (1 .. Rlen);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
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
|
||||
|
||||
return R : Wide_String (Low .. High) do
|
||||
if Low > Source.Current_Length + 1
|
||||
or else High > Source.Current_Length
|
||||
then
|
||||
raise Index_Error;
|
||||
else
|
||||
return Source.Data (Low .. High);
|
||||
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
|
||||
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;
|
||||
|
||||
return Result;
|
||||
Result.Current_Length := High - Low + 1;
|
||||
Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High);
|
||||
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;
|
||||
|
||||
---------------------
|
||||
|
|
|
|||
|
|
@ -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,7 +42,9 @@ package body Ada.Strings.Wide_Wide_Superbounded is
|
|||
(Left : Super_String;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
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;
|
||||
|
|
@ -55,17 +57,18 @@ package body Ada.Strings.Wide_Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Super_String;
|
||||
Right : Wide_Wide_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
return Result : Super_String (Left.Max_Length) do
|
||||
declare
|
||||
Llen : constant Natural := Left.Current_Length;
|
||||
|
||||
Nlen : constant Natural := Llen + Right'Length;
|
||||
|
||||
begin
|
||||
|
|
@ -76,14 +79,17 @@ package body Ada.Strings.Wide_Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Llen + 1 .. Nlen) := Right;
|
||||
end if;
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Wide_Wide_String;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Right.Max_Length);
|
||||
begin
|
||||
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;
|
||||
|
|
@ -96,15 +102,17 @@ package body Ada.Strings.Wide_Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left;
|
||||
Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Super_String;
|
||||
Right : Wide_Wide_Character) return Super_String
|
||||
is
|
||||
Result : Super_String (Left.Max_Length);
|
||||
begin
|
||||
return Result : Super_String (Left.Max_Length) do
|
||||
declare
|
||||
Llen : constant Natural := Left.Current_Length;
|
||||
|
||||
begin
|
||||
|
|
@ -115,15 +123,17 @@ package body Ada.Strings.Wide_Wide_Superbounded is
|
|||
Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
|
||||
Result.Data (Result.Current_Length) := Right;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end;
|
||||
end return;
|
||||
end Concat;
|
||||
|
||||
function Concat
|
||||
(Left : Wide_Wide_Character;
|
||||
Right : Super_String) return Super_String
|
||||
is
|
||||
Result : Super_String (Right.Max_Length);
|
||||
begin
|
||||
return Result : Super_String (Right.Max_Length) do
|
||||
declare
|
||||
Rlen : constant Natural := Right.Current_Length;
|
||||
|
||||
begin
|
||||
|
|
@ -132,10 +142,11 @@ package body Ada.Strings.Wide_Wide_Superbounded is
|
|||
else
|
||||
Result.Current_Length := Rlen + 1;
|
||||
Result.Data (1) := Left;
|
||||
Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
|
||||
Result.Data (2 .. Result.Current_Length) :=
|
||||
Right.Data (1 .. Rlen);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
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
|
||||
|
||||
return R : Wide_Wide_String (Low .. High) do
|
||||
if Low > Source.Current_Length + 1
|
||||
or else High > Source.Current_Length
|
||||
then
|
||||
raise Index_Error;
|
||||
else
|
||||
return Source.Data (Low .. High);
|
||||
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
|
||||
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);
|
||||
Result.Data (1 .. Result.Current_Length) :=
|
||||
Source.Data (Low .. High);
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
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;
|
||||
|
||||
---------------------
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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;
|
||||
|
||||
return R;
|
||||
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
|
||||
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;
|
||||
|
||||
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
|
||||
return R : Result_Vector (X'Range) do
|
||||
for J in R'Range loop
|
||||
R (J) := Operation (X (J));
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
end return;
|
||||
end Vector_Elementwise_Operation;
|
||||
|
||||
-----------------------------------------
|
||||
|
|
@ -421,9 +415,8 @@ 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
|
||||
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)
|
||||
|
|
@ -442,8 +435,7 @@ package body System.Generic_Array_Operations is
|
|||
K - R'First (2) + Right'First (2)));
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
end return;
|
||||
end Matrix_Matrix_Elementwise_Operation;
|
||||
|
||||
------------------------------------------------
|
||||
|
|
@ -453,11 +445,9 @@ 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
|
||||
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)
|
||||
|
|
@ -476,8 +466,7 @@ package body System.Generic_Array_Operations is
|
|||
Z);
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
end return;
|
||||
end Matrix_Matrix_Scalar_Elementwise_Operation;
|
||||
|
||||
-----------------------------------------
|
||||
|
|
@ -488,9 +477,8 @@ package body System.Generic_Array_Operations is
|
|||
(Left : Left_Vector;
|
||||
Right : Right_Vector) return Result_Vector
|
||||
is
|
||||
R : Result_Vector (Left'Range);
|
||||
|
||||
begin
|
||||
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";
|
||||
|
|
@ -499,8 +487,7 @@ package body System.Generic_Array_Operations is
|
|||
for J in R'Range loop
|
||||
R (J) := Operation (Left (J), Right (J - R'First + Right'First));
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
end return;
|
||||
end Vector_Vector_Elementwise_Operation;
|
||||
|
||||
------------------------------------------------
|
||||
|
|
@ -510,11 +497,9 @@ 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
|
||||
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";
|
||||
|
|
@ -523,8 +508,7 @@ package body System.Generic_Array_Operations is
|
|||
for J in R'Range loop
|
||||
R (J) := Operation (X (J), Y (J - X'First + Y'First), Z);
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
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
|
||||
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;
|
||||
|
||||
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
|
||||
return R : Result_Vector (Left'Range) do
|
||||
for J in R'Range loop
|
||||
R (J) := Operation (Left (J), Right);
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
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
|
||||
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;
|
||||
|
||||
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
|
||||
return R : Result_Vector (Right'Range) do
|
||||
for J in R'Range loop
|
||||
R (J) := Operation (Left, Right (J));
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
end return;
|
||||
end Scalar_Vector_Elementwise_Operation;
|
||||
|
||||
----------
|
||||
|
|
@ -662,9 +638,8 @@ 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
|
||||
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";
|
||||
|
|
@ -678,15 +653,15 @@ package body System.Generic_Array_Operations is
|
|||
begin
|
||||
for M in Left'Range (2) loop
|
||||
S := S + Left (J, M) *
|
||||
Right (M - Left'First (2) + Right'First (1), K);
|
||||
Right
|
||||
(M - Left'First (2) + Right'First (1), K);
|
||||
end loop;
|
||||
|
||||
R (J, K) := S;
|
||||
end;
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
end return;
|
||||
end Matrix_Matrix_Product;
|
||||
|
||||
----------------------------
|
||||
|
|
@ -766,9 +741,8 @@ package body System.Generic_Array_Operations is
|
|||
(Left : Matrix;
|
||||
Right : Right_Vector) return Result_Vector
|
||||
is
|
||||
R : Result_Vector (Left'Range (1));
|
||||
|
||||
begin
|
||||
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";
|
||||
|
|
@ -780,14 +754,14 @@ package body System.Generic_Array_Operations is
|
|||
|
||||
begin
|
||||
for K in Left'Range (2) loop
|
||||
S := S + Left (J, K) * Right (K - Left'First (2) + Right'First);
|
||||
S := S + Left (J, K)
|
||||
* Right (K - Left'First (2) + Right'First);
|
||||
end loop;
|
||||
|
||||
R (J) := S;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
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
|
||||
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;
|
||||
|
||||
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
|
||||
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;
|
||||
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
|
||||
return R : Vector (First .. Check_Unit_Last (Index, Order, First)) do
|
||||
R := (others => Zero);
|
||||
R (Index) := One;
|
||||
return R;
|
||||
end return;
|
||||
end Unit_Vector;
|
||||
|
||||
---------------------------
|
||||
|
|
@ -921,9 +892,8 @@ package body System.Generic_Array_Operations is
|
|||
(Left : Left_Vector;
|
||||
Right : Matrix) return Result_Vector
|
||||
is
|
||||
R : Result_Vector (Right'Range (2));
|
||||
|
||||
begin
|
||||
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";
|
||||
|
|
@ -935,14 +905,14 @@ package body System.Generic_Array_Operations is
|
|||
|
||||
begin
|
||||
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)
|
||||
+ Left'First) * Right (K, J);
|
||||
end loop;
|
||||
|
||||
R (J) := S;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
return R;
|
||||
end return;
|
||||
end Vector_Matrix_Product;
|
||||
|
||||
end System.Generic_Array_Operations;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
@ -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;
|
||||
|
|
@ -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 --
|
||||
-----------------
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
|
|
@ -201,15 +201,6 @@ package body System.Vax_Float_Operations is
|
|||
return B;
|
||||
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 --
|
||||
-----------
|
||||
|
|
|
|||
|
|
@ -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- --
|
||||
|
|
@ -443,15 +443,6 @@ package body System.Vax_Float_Operations is
|
|||
return X - Y;
|
||||
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 --
|
||||
------------
|
||||
|
|
@ -461,6 +452,15 @@ package body System.Vax_Float_Operations is
|
|||
return G (X);
|
||||
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 --
|
||||
-------------
|
||||
|
|
|
|||
|
|
@ -1655,9 +1655,8 @@ package body Sem_Ch5 is
|
|||
Analyzed_Bound : Node_Id) return Node_Id
|
||||
is
|
||||
Assign : Node_Id;
|
||||
Id : Entity_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
|
||||
|
|
|
|||
Loading…
Reference in New Issue