diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-11-04 10:55:41 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-11-04 10:55:41 +0000 |
| commit | 37c52aaf103bd08476c8fc78be33539866bcef1d (patch) | |
| tree | a2ed65f5513e0ee836542dd2d9c685f3e21743b9 | |
| parent | e39ec8de8ec870b849c254a1904e45776cf9983a (diff) | |
| download | gcc-37c52aaf103bd08476c8fc78be33539866bcef1d.tar.gz | |
2011-11-04 Robert Dewar <dewar@adacore.com>
* sem_warn.adb (Warn_On_Useless_Assignment): More accurate test
for call vs assign.
* gcc-interface/Make-lang.in: Update dependencies.
2011-11-04 Robert Dewar <dewar@adacore.com>
* sem_prag.adb: Detect more cases of Long_Float inconsistencies at
compile time.
2011-11-04 Matthew Heaney <heaney@adacore.com>
* Makefile.rtl, impunit.adb: Added a-sfecin.ads,
* a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb], a-sbhcin.ad[sb],
a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb], a-sulcin.ad[sb]
* a-sfecin.ads, a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb],
a-sbhcin.ad[sb], a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb],
a-sulcin.ad[sb]: New files.
2011-11-04 Geert Bosch <bosch@adacore.com>
* i-forbla-unimplemented.ads, s-gecola.adb, s-gecola.ads,
s-gerebl.adb, s-gerebl.ads, i-forbla.adb, i-forbla.ads,
i-forlap.ads, i-forbla-darwin.adb, s-gecobl.adb, s-gecobl.ads,
s-gerela.adb, s-gerela.ads: Remove partial interface to BLAS/LAPACK.
* gcc-interface/Makefile.in: Remove libgnala and related objects.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@180935 138bc75d-0d04-0410-961f-82ee72b054a4
32 files changed, 696 insertions, 2967 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3c3c4870eda..752037820fc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,7 +1,30 @@ -2011-11-04 Eric Botcazou <ebotcazou@adacore.com> +2011-11-04 Robert Dewar <dewar@adacore.com> - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Do not assert - that the type of the parameters isn't dummy in type_annotate_only mode. + * sem_warn.adb (Warn_On_Useless_Assignment): More accurate test + for call vs assign. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb: Detect more cases of Long_Float inconsistencies at + compile time. + +2011-11-04 Matthew Heaney <heaney@adacore.com> + + * Makefile.rtl, impunit.adb: Added a-sfecin.ads, + * a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb], a-sbhcin.ad[sb], + a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb], a-sulcin.ad[sb] + * a-sfecin.ads, a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb], + a-sbhcin.ad[sb], a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb], + a-sulcin.ad[sb]: New files. + +2011-11-04 Geert Bosch <bosch@adacore.com> + + * i-forbla-unimplemented.ads, s-gecola.adb, s-gecola.ads, + s-gerebl.adb, s-gerebl.ads, i-forbla.adb, i-forbla.ads, + i-forlap.ads, i-forbla-darwin.adb, s-gecobl.adb, s-gecobl.ads, + s-gerela.adb, s-gerela.ads: Remove partial interface to BLAS/LAPACK. + * gcc-interface/Makefile.in: Remove libgnala and related objects. 2011-11-04 Matthew Heaney <heaney@adacore.com> @@ -11,6 +34,11 @@ a-convec.ad[sb], a-coinve.ad[sb] (Assign, Copy): New operations added to package. +2011-11-04 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Do not assert + that the type of the parameters isn't dummy in type_annotate_only mode. + 2011-11-04 Robert Dewar <dewar@adacore.com> * sem_ch12.adb: Minor reformatting diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 4e03c9e178e..4c481d17f65 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -214,9 +214,15 @@ GNATRTL_NONTASKING_OBJS= \ a-rbtgbo$(objext) \ a-rbtgbk$(objext) \ a-rbtgso$(objext) \ + a-sbecin$(objext) \ + a-sbhcin$(objext) \ + a-sblcin$(objext) \ a-scteio$(objext) \ a-secain$(objext) \ a-sequio$(objext) \ + a-sfecin$(objext) \ + a-sfhcin$(objext) \ + a-sflcin$(objext) \ a-sfteio$(objext) \ a-sfwtio$(objext) \ a-sfztio$(objext) \ @@ -261,10 +267,13 @@ GNATRTL_NONTASKING_OBJS= \ a-stzsea$(objext) \ a-stzsup$(objext) \ a-stzunb$(objext) \ + a-suecin$(objext) \ a-suenco$(objext) \ a-suenst$(objext) \ a-suewst$(objext) \ a-suezst$(objext) \ + a-suhcin$(objext) \ + a-sulcin$(objext) \ a-suteio$(objext) \ a-swbwha$(objext) \ a-swfwha$(objext) \ diff --git a/gcc/ada/i-forbla-darwin.adb b/gcc/ada/a-sbecin.adb index 825a8840414..78000176844 100644 --- a/gcc/ada/i-forbla-darwin.adb +++ b/gcc/ada/a-sbecin.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME COMPONENTS -- +-- GNAT LIBRARY COMPONENTS -- -- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- +-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- -- -- --- B o d y -- +-- B o d y -- -- -- --- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, 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- -- @@ -24,15 +24,17 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- Version for Mac OS X +with Ada.Strings.Equal_Case_Insensitive; -package body Interfaces.Fortran.BLAS is - pragma Linker_Options ("-lgnala"); - pragma Linker_Options ("-lm"); - pragma Linker_Options ("-Wl,-framework,vecLib"); -end Interfaces.Fortran.BLAS; +function Ada.Strings.Bounded.Equal_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean +is +begin + return Ada.Strings.Equal_Case_Insensitive + (Left => Bounded.To_String (Left), + Right => Bounded.To_String (Right)); +end Ada.Strings.Bounded.Equal_Case_Insensitive; diff --git a/gcc/ada/i-forbla.adb b/gcc/ada/a-sbecin.ads index 4445c5124cb..115c7220606 100644 --- a/gcc/ada/i-forbla.adb +++ b/gcc/ada/a-sbecin.ads @@ -1,12 +1,16 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME COMPONENTS -- +-- GNAT LIBRARY COMPONENTS -- -- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- +-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- -- -- --- B o d y -- +-- S p e c -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- @@ -24,19 +28,15 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- This Interfaces.Fortran.Blas package body contains the required linker --- pragmas for automatically linking with the LAPACK linear algebra support --- library, and the systems math library. Alternative bodies can be supplied --- if different sets of libraries are needed. +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Equal_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean; -package body Interfaces.Fortran.BLAS is - pragma Linker_Options ("-lgnala"); - pragma Linker_Options ("-llapack"); - pragma Linker_Options ("-lblas"); - pragma Linker_Options ("-lm"); -end Interfaces.Fortran.BLAS; +pragma Preelaborate (Ada.Strings.Bounded.Equal_Case_Insensitive); diff --git a/gcc/ada/a-sbhcin.adb b/gcc/ada/a-sbhcin.adb new file mode 100644 index 00000000000..8c69290e0d0 --- /dev/null +++ b/gcc/ada/a-sbhcin.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Bounded.Hash_Case_Insensitive + (Key : Bounded.Bounded_String) + return Containers.Hash_Type +is +begin + return Ada.Strings.Hash_Case_Insensitive (Bounded.To_String (Key)); +end Ada.Strings.Bounded.Hash_Case_Insensitive; diff --git a/gcc/ada/i-forbla-unimplemented.ads b/gcc/ada/a-sbhcin.ads index deea344bbf2..c291f53db9a 100644 --- a/gcc/ada/i-forbla-unimplemented.ads +++ b/gcc/ada/a-sbhcin.ads @@ -1,12 +1,16 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME COMPONENTS -- +-- GNAT LIBRARY COMPONENTS -- -- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- +-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- -- -- -- 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- -- @@ -24,22 +28,17 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- This package provides a thin binding to the standard Fortran BLAS library. --- Documentation and a reference BLAS implementation is available from --- ftp://ftp.netlib.org. The main purpose of this package is to facilitate --- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and --- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS --- routines may be added over time. - --- This unit is not implemented in this GNAT configuration +with Ada.Containers; -package Interfaces.Fortran.BLAS is +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); - pragma Unimplemented_Unit; +function Ada.Strings.Bounded.Hash_Case_Insensitive + (Key : Bounded.Bounded_String) + return Containers.Hash_Type; -end Interfaces.Fortran.BLAS; +pragma Preelaborate (Ada.Strings.Bounded.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sblcin.adb b/gcc/ada/a-sblcin.adb new file mode 100644 index 00000000000..e2ce4d3f384 --- /dev/null +++ b/gcc/ada/a-sblcin.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Bounded.Less_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean +is +begin + return Ada.Strings.Less_Case_Insensitive + (Left => Bounded.To_String (Left), + Right => Bounded.To_String (Right)); +end Ada.Strings.Bounded.Less_Case_Insensitive; diff --git a/gcc/ada/a-sblcin.ads b/gcc/ada/a-sblcin.ads new file mode 100644 index 00000000000..d7284110aef --- /dev/null +++ b/gcc/ada/a-sblcin.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Less_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Bounded.Less_Case_Insensitive); diff --git a/gcc/ada/a-sfecin.ads b/gcc/ada/a-sfecin.ads new file mode 100644 index 00000000000..592b69166c9 --- /dev/null +++ b/gcc/ada/a-sfecin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Equal_Case_Insensitive; + +function Ada.Strings.Fixed.Equal_Case_Insensitive + (Left, Right : String) + return Boolean renames Ada.Strings.Equal_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Equal_Case_Insensitive); diff --git a/gcc/ada/a-sfhcin.ads b/gcc/ada/a-sfhcin.ads new file mode 100644 index 00000000000..86f60f68944 --- /dev/null +++ b/gcc/ada/a-sfhcin.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Fixed.Hash_Case_Insensitive + (Key : String) + return Containers.Hash_Type renames Ada.Strings.Hash_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sflcin.ads b/gcc/ada/a-sflcin.ads new file mode 100644 index 00000000000..8af21fe9e55 --- /dev/null +++ b/gcc/ada/a-sflcin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Fixed.Less_Case_Insensitive + (Left, Right : String) + return Boolean renames Ada.Strings.Less_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Less_Case_Insensitive); diff --git a/gcc/ada/a-suecin.adb b/gcc/ada/a-suecin.adb new file mode 100644 index 00000000000..73ebae57156 --- /dev/null +++ b/gcc/ada/a-suecin.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Equal_Case_Insensitive; + +function Ada.Strings.Unbounded.Equal_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean +is + SL, SR : Aux.Big_String_Access; + LL, LR : Natural; + +begin + Aux.Get_String (Left, SL, LL); + Aux.Get_String (Right, SR, LR); + + return Ada.Strings.Equal_Case_Insensitive + (Left => SL (1 .. LL), + Right => SR (1 .. LR)); +end Ada.Strings.Unbounded.Equal_Case_Insensitive; diff --git a/gcc/ada/a-suecin.ads b/gcc/ada/a-suecin.ads new file mode 100644 index 00000000000..08960241c8e --- /dev/null +++ b/gcc/ada/a-suecin.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Unbounded.Equal_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Unbounded.Equal_Case_Insensitive); diff --git a/gcc/ada/a-suhcin.adb b/gcc/ada/a-suhcin.adb new file mode 100644 index 00000000000..0417c15db24 --- /dev/null +++ b/gcc/ada/a-suhcin.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Unbounded.Hash_Case_Insensitive + (Key : Unbounded.Unbounded_String) + return Containers.Hash_Type +is + S : Aux.Big_String_Access; + L : Natural; + +begin + Aux.Get_String (Key, S, L); + return Ada.Strings.Hash_Case_Insensitive (S (1 .. L)); +end Ada.Strings.Unbounded.Hash_Case_Insensitive; diff --git a/gcc/ada/a-suhcin.ads b/gcc/ada/a-suhcin.ads new file mode 100644 index 00000000000..180d4a4391a --- /dev/null +++ b/gcc/ada/a-suhcin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Unbounded.Hash_Case_Insensitive + (Key : Unbounded.Unbounded_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Unbounded.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sulcin.adb b/gcc/ada/a-sulcin.adb new file mode 100644 index 00000000000..9f1f3c4aca9 --- /dev/null +++ b/gcc/ada/a-sulcin.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Unbounded.Less_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean +is + SL, SR : Aux.Big_String_Access; + LL, LR : Natural; + +begin + Aux.Get_String (Left, SL, LL); + Aux.Get_String (Right, SR, LR); + + return Ada.Strings.Less_Case_Insensitive + (Left => SL (1 .. LL), + Right => SR (1 .. LR)); +end Ada.Strings.Unbounded.Less_Case_Insensitive; diff --git a/gcc/ada/a-sulcin.ads b/gcc/ada/a-sulcin.ads new file mode 100644 index 00000000000..fafb546ca77 --- /dev/null +++ b/gcc/ada/a-sulcin.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Unbounded.Less_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Unbounded.Less_Case_Insensitive); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 43d42f658b5..d178f65aa01 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1953,32 +1953,35 @@ ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \ - ada/erroutc.ads ada/erroutc.adb ada/exp_ch2.ads ada/exp_ch2.adb \ - ada/exp_code.ads ada/exp_smem.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_vfpt.ads ada/expander.ads ada/fname.ads ada/gnat.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib-load.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ + ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ + ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ + ada/errout.adb ada/erroutc.ads ada/erroutc.adb ada/eval_fat.ads \ + ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch2.adb ada/exp_ch4.ads \ + ada/exp_code.ads ada/exp_pakd.ads ada/exp_smem.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_vfpt.ads ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/lib.ads ada/lib-load.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/par_sco.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads \ + ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_util.ads ada/sem_warn.ads ada/sem_warn.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 990a6987736..d9215dfb092 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -2116,7 +2116,6 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) SO_OPTS = -shared-libgcc LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-darwin.ads \ - i-forbla.adb<i-forbla-darwin.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-osinte.adb<s-osinte-darwin.adb \ s-osinte.ads<s-osinte-darwin.ads \ @@ -2238,10 +2237,8 @@ LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \ include $(fsrcdir)/ada/Makefile.rtl -GNATRTL_LINEARALGEBRA_OBJS = i-forbla.o i-forlap.o - GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \ - $(GNATRTL_LINEARALGEBRA_OBJS) memtrack.o + memtrack.o # Default run time files @@ -2538,9 +2535,6 @@ gnatlib: ../stamp-gnatlib1-$(RTSDIR) ../stamp-gnatlib2-$(RTSDIR) $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnarl$(arext) \ $(addprefix $(RTSDIR)/,$(GNATRTL_TASKING_OBJS)) $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnarl$(arext) - $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnala$(arext) \ - $(addprefix $(RTSDIR)/,$(GNATRTL_LINEARALGEBRA_OBJS)) - $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnala$(arext) ifeq ($(GMEM_LIB),gmemlib) $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgmem$(arext) \ $(RTSDIR)/memtrack.o diff --git a/gcc/ada/i-forbla.ads b/gcc/ada/i-forbla.ads deleted file mode 100644 index 3910349a652..00000000000 --- a/gcc/ada/i-forbla.ads +++ /dev/null @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a thin binding to the standard Fortran BLAS library. --- Documentation and a reference BLAS implementation is available from --- ftp://ftp.netlib.org. The main purpose of this package is to facilitate --- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and --- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS --- routines may be added over time. - --- As actual linker arguments to link with the BLAS implementation differs --- according to platform and chosen BLAS implementation, the linker arguments --- are given in the body of this package. The body may need to be modified in --- order to link with different BLAS implementations tuned to the specific --- target. - -package Interfaces.Fortran.BLAS is - pragma Pure; - pragma Elaborate_Body; - - No_Trans : aliased constant Character := 'N'; - Trans : aliased constant Character := 'T'; - Conj_Trans : aliased constant Character := 'C'; - - -- Vector types - - type Real_Vector is array (Integer range <>) of Real; - - type Complex_Vector is array (Integer range <>) of Complex; - - type Double_Precision_Vector is array (Integer range <>) - of Double_Precision; - - type Double_Complex_Vector is array (Integer range <>) of Double_Complex; - - -- Matrix types - - type Real_Matrix is array (Integer range <>, Integer range <>) - of Real; - - type Double_Precision_Matrix is array (Integer range <>, Integer range <>) - of Double_Precision; - - type Complex_Matrix is array (Integer range <>, Integer range <>) - of Complex; - - type Double_Complex_Matrix is array (Integer range <>, Integer range <>) - of Double_Complex; - - -- BLAS Level 1 - - function sdot - (N : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Y : Real_Vector; - Inc_Y : Integer := 1) return Real; - - function ddot - (N : Positive; - X : Double_Precision_Vector; - Inc_X : Integer := 1; - Y : Double_Precision_Vector; - Inc_Y : Integer := 1) return Double_Precision; - - function cdotu - (N : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Y : Complex_Vector; - Inc_Y : Integer := 1) return Complex; - - function zdotu - (N : Positive; - X : Double_Complex_Vector; - Inc_X : Integer := 1; - Y : Double_Complex_Vector; - Inc_Y : Integer := 1) return Double_Complex; - - function snrm2 - (N : Natural; - X : Real_Vector; - Inc_X : Integer := 1) return Real; - - function dnrm2 - (N : Natural; - X : Double_Precision_Vector; - Inc_X : Integer := 1) return Double_Precision; - - function scnrm2 - (N : Natural; - X : Complex_Vector; - Inc_X : Integer := 1) return Real; - - function dznrm2 - (N : Natural; - X : Double_Complex_Vector; - Inc_X : Integer := 1) return Double_Precision; - - -- BLAS Level 2 - - procedure sgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Positive; - X : Real_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Real := 0.0; - Y : in out Real_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - procedure dgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Double_Precision := 1.0; - A : Double_Precision_Matrix; - Ld_A : Positive; - X : Double_Precision_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Double_Precision := 0.0; - Y : in out Double_Precision_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - procedure cgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Complex := (1.0, 1.0); - A : Complex_Matrix; - Ld_A : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Complex := (0.0, 0.0); - Y : in out Complex_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - procedure zgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Double_Complex := (1.0, 1.0); - A : Double_Complex_Matrix; - Ld_A : Positive; - X : Double_Complex_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Double_Complex := (0.0, 0.0); - Y : in out Double_Complex_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - -- BLAS Level 3 - - procedure sgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Integer; - B : Real_Matrix; - Ld_B : Integer; - Beta : Real := 0.0; - C : in out Real_Matrix; - Ld_C : Integer); - - procedure dgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Double_Precision := 1.0; - A : Double_Precision_Matrix; - Ld_A : Integer; - B : Double_Precision_Matrix; - Ld_B : Integer; - Beta : Double_Precision := 0.0; - C : in out Double_Precision_Matrix; - Ld_C : Integer); - - procedure cgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Complex := (1.0, 1.0); - A : Complex_Matrix; - Ld_A : Integer; - B : Complex_Matrix; - Ld_B : Integer; - Beta : Complex := (0.0, 0.0); - C : in out Complex_Matrix; - Ld_C : Integer); - - procedure zgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Double_Complex := (1.0, 1.0); - A : Double_Complex_Matrix; - Ld_A : Integer; - B : Double_Complex_Matrix; - Ld_B : Integer; - Beta : Double_Complex := (0.0, 0.0); - C : in out Double_Complex_Matrix; - Ld_C : Integer); - -private - pragma Import (Fortran, cdotu, "cdotu_"); - pragma Import (Fortran, cgemm, "cgemm_"); - pragma Import (Fortran, cgemv, "cgemv_"); - pragma Import (Fortran, ddot, "ddot_"); - pragma Import (Fortran, dgemm, "dgemm_"); - pragma Import (Fortran, dgemv, "dgemv_"); - pragma Import (Fortran, dnrm2, "dnrm2_"); - pragma Import (Fortran, dznrm2, "dznrm2_"); - pragma Import (Fortran, scnrm2, "scnrm2_"); - pragma Import (Fortran, sdot, "sdot_"); - pragma Import (Fortran, sgemm, "sgemm_"); - pragma Import (Fortran, sgemv, "sgemv_"); - pragma Import (Fortran, snrm2, "snrm2_"); - pragma Import (Fortran, zdotu, "zdotu_"); - pragma Import (Fortran, zgemm, "zgemm_"); - pragma Import (Fortran, zgemv, "zgemv_"); -end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/i-forlap.ads b/gcc/ada/i-forlap.ads deleted file mode 100644 index ebb08abe654..00000000000 --- a/gcc/ada/i-forlap.ads +++ /dev/null @@ -1,414 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required if non-RM package ??? - -with Interfaces.Fortran.BLAS; -package Interfaces.Fortran.LAPACK is - pragma Pure; - - type Integer_Vector is array (Integer range <>) of Integer; - - Upper : aliased constant Character := 'U'; - Lower : aliased constant Character := 'L'; - - subtype Real_Vector is BLAS.Real_Vector; - subtype Real_Matrix is BLAS.Real_Matrix; - subtype Double_Precision_Vector is BLAS.Double_Precision_Vector; - subtype Double_Precision_Matrix is BLAS.Double_Precision_Matrix; - subtype Complex_Vector is BLAS.Complex_Vector; - subtype Complex_Matrix is BLAS.Complex_Matrix; - subtype Double_Complex_Vector is BLAS.Double_Complex_Vector; - subtype Double_Complex_Matrix is BLAS.Double_Complex_Matrix; - - -- LAPACK Computational Routines - - -- gerfs Refines the solution of a system of linear equations with - -- a general matrix and estimates its error - -- getrf Computes LU factorization of a general m-by-n matrix - -- getri Computes inverse of an LU-factored general matrix - -- square matrix, with multiple right-hand sides - -- getrs Solves a system of linear equations with an LU-factored - -- square matrix, with multiple right-hand sides - -- hetrd Reduces a complex Hermitian matrix to tridiagonal form - -- heevr Computes selected eigenvalues and, optionally, eigenvectors of - -- a Hermitian matrix using the Relatively Robust Representations - -- orgtr Generates the real orthogonal matrix Q determined by sytrd - -- steqr Computes all eigenvalues and eigenvectors of a symmetric or - -- Hermitian matrix reduced to tridiagonal form (QR algorithm) - -- sterf Computes all eigenvalues of a real symmetric - -- tridiagonal matrix using QR algorithm - -- sytrd Reduces a real symmetric matrix to tridiagonal form - - procedure sgetrf - (M : Natural; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure dgetrf - (M : Natural; - N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure cgetrf - (M : Natural; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure zgetrf - (M : Natural; - N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure sgetri - (N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure dgetri - (N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Double_Precision_Vector; - L_Work : Integer; - Info : access Integer); - - procedure cgetri - (N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure zgetri - (N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Double_Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure sgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Real_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure dgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Double_Precision_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Double_Precision_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure cgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Complex_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure zgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Double_Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Double_Complex_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure cheevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - M : out Integer; - W : out Real_Vector; - Z : out Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Complex_Vector; - L_Work : Integer; - R_Work : out Real_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer); - - procedure zheevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Double_Precision := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Double_Precision := 0.0; - M : out Integer; - W : out Double_Precision_Vector; - Z : out Double_Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Double_Complex_Vector; - L_Work : Integer; - R_Work : out Double_Precision_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer); - - procedure chetrd - (Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Complex_Vector; - Work : out Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure zhetrd - (Uplo : access constant Character; - N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - D : out Double_Precision_Vector; - E : out Double_Precision_Vector; - Tau : out Double_Complex_Vector; - Work : out Double_Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure ssytrd - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure dsytrd - (Uplo : access constant Character; - N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - D : out Double_Precision_Vector; - E : out Double_Precision_Vector; - Tau : out Double_Precision_Vector; - Work : out Double_Precision_Vector; - L_Work : Integer; - Info : access Integer); - - procedure ssterf - (N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Info : access Integer); - - procedure dsterf - (N : Natural; - D : in out Double_Precision_Vector; - E : in out Double_Precision_Vector; - Info : access Integer); - - procedure sorgtr - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - Tau : Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure dorgtr - (Uplo : access constant Character; - N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - Tau : Double_Precision_Vector; - Work : out Double_Precision_Vector; - L_Work : Integer; - Info : access Integer); - - procedure sstebz - (Rng : access constant Character; - Order : access constant Character; - N : Natural; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - D : Real_Vector; - E : Real_Vector; - M : out Natural; - N_Split : out Natural; - W : out Real_Vector; - I_Block : out Integer_Vector; - I_Split : out Integer_Vector; - Work : out Real_Vector; - I_Work : out Integer_Vector; - Info : access Integer); - - procedure dstebz - (Rng : access constant Character; - Order : access constant Character; - N : Natural; - Vl, Vu : Double_Precision := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Double_Precision := 0.0; - D : Double_Precision_Vector; - E : Double_Precision_Vector; - M : out Natural; - N_Split : out Natural; - W : out Double_Precision_Vector; - I_Block : out Integer_Vector; - I_Split : out Integer_Vector; - Work : out Double_Precision_Vector; - I_Work : out Integer_Vector; - Info : access Integer); - - procedure ssteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Real_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - - procedure dsteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Double_Precision_Vector; - E : in out Double_Precision_Vector; - Z : in out Double_Precision_Matrix; - Ld_Z : Positive; - Work : out Double_Precision_Vector; - Info : access Integer); - - procedure csteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Complex_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - - procedure zsteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Double_Precision_Vector; - E : in out Double_Precision_Vector; - Z : in out Double_Complex_Matrix; - Ld_Z : Positive; - Work : out Double_Precision_Vector; - Info : access Integer); - -private - pragma Import (Fortran, csteqr, "csteqr_"); - pragma Import (Fortran, cgetrf, "cgetrf_"); - pragma Import (Fortran, cgetri, "cgetri_"); - pragma Import (Fortran, cgetrs, "cgetrs_"); - pragma Import (Fortran, cheevr, "cheevr_"); - pragma Import (Fortran, chetrd, "chetrd_"); - pragma Import (Fortran, dgetrf, "dgetrf_"); - pragma Import (Fortran, dgetri, "dgetri_"); - pragma Import (Fortran, dgetrs, "dgetrs_"); - pragma Import (Fortran, dsytrd, "dsytrd_"); - pragma Import (Fortran, dstebz, "dstebz_"); - pragma Import (Fortran, dsterf, "dsterf_"); - pragma Import (Fortran, dorgtr, "dorgtr_"); - pragma Import (Fortran, dsteqr, "dsteqr_"); - pragma Import (Fortran, sgetrf, "sgetrf_"); - pragma Import (Fortran, sgetri, "sgetri_"); - pragma Import (Fortran, sgetrs, "sgetrs_"); - pragma Import (Fortran, sorgtr, "sorgtr_"); - pragma Import (Fortran, sstebz, "sstebz_"); - pragma Import (Fortran, ssterf, "ssterf_"); - pragma Import (Fortran, ssteqr, "ssteqr_"); - pragma Import (Fortran, ssytrd, "ssytrd_"); - pragma Import (Fortran, zgetrf, "zgetrf_"); - pragma Import (Fortran, zgetri, "zgetri_"); - pragma Import (Fortran, zgetrs, "zgetrs_"); - pragma Import (Fortran, zheevr, "zheevr_"); - pragma Import (Fortran, zhetrd, "zhetrd_"); - pragma Import (Fortran, zsteqr, "zsteqr_"); -end Interfaces.Fortran.LAPACK; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index dfe176bf38d..8f4fc298ddf 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -487,9 +487,6 @@ package body Impunit is ("a-ciormu", F), -- Ada.Containers.Indefinite_Ordered_Multisets ("a-coormu", F), -- Ada.Containers.Ordered_Multisets ("a-crdlli", F), -- Ada.Containers.Restricted_Doubly_Linked_Lists - ("a-secain", F), -- Ada.Strings.Equal_Case_Insensitive - ("a-shcain", F), -- Ada.Strings.Hash_Case_Insensitive - ("a-slcain", F), -- Ada.Strings.Less_Case_Insensitive ("a-szuzti", F), -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO ("a-zchuni", F), -- Ada.Wide_Wide_Characters.Unicode ("a-ztcstr", F), -- Ada.Wide_Wide_Text_IO.C_Streams @@ -497,6 +494,18 @@ package body Impunit is -- Note: strictly the following should be Ada 2012 units, but it seems -- harmless (and useful) to make then available in Ada 2005 mode. + ("a-secain", T), -- Ada.Strings.Equal_Case_Insensitive + ("a-shcain", T), -- Ada.Strings.Hash_Case_Insensitive + ("a-slcain", T), -- Ada.Strings.Less_Case_Insensitive + ("a-sfecin", T), -- Ada.Strings.Fixed.Equal_Case_Insensitive + ("a-sfhcin", T), -- Ada.Strings.Fixed.Hash_Case_Insensitive + ("a-sflcin", T), -- Ada.Strings.Fixed.Less_Case_Insensitive + ("a-sbecin", T), -- Ada.Strings.Bounded.Equal_Case_Insensitive + ("a-sbhcin", T), -- Ada.Strings.Bounded.Hash_Case_Insensitive + ("a-sblcin", T), -- Ada.Strings.Bounded.Less_Case_Insensitive + ("a-suecin", T), -- Ada.Strings.Unbounded.Equal_Case_Insensitive + ("a-suhcin", T), -- Ada.Strings.Unbounded.Hash_Case_Insensitive + ("a-sulcin", T), -- Ada.Strings.Unbounded.Less_Case_Insensitive ("a-suezst", T), -- Ada.Strings.UTF_Encoding.Wide_Wide_Strings --------------------------- diff --git a/gcc/ada/s-gecobl.adb b/gcc/ada/s-gecobl.adb deleted file mode 100644 index d20b53f31b4..00000000000 --- a/gcc/ada/s-gecobl.adb +++ /dev/null @@ -1,350 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Complex_BLAS is - - Is_Single : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double : constant Boolean := - Real'Machine_Mantissa = Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = Double_Precision'First - and then - Double_Precision (Real'Last) = Double_Precision'Last; - - subtype Complex is Complex_Types.Complex; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline (To_Double_Precision); - - function To_Double_Complex (X : Complex) return Double_Complex; - pragma Inline (To_Double_Complex); - - function To_Complex (X : Double_Complex) return Complex; - function To_Complex (X : Fortran.Complex) return Complex; - pragma Inline (To_Complex); - - function To_Fortran (X : Complex) return Fortran.Complex; - pragma Inline (To_Fortran); - - -- Instantiations - - function To_Double_Complex is new - Vector_Elementwise_Operation - (X_Scalar => Complex_Types.Complex, - Result_Scalar => Fortran.Double_Complex, - X_Vector => Complex_Vector, - Result_Vector => BLAS.Double_Complex_Vector, - Operation => To_Double_Complex); - - function To_Complex is new - Vector_Elementwise_Operation - (X_Scalar => Fortran.Double_Complex, - Result_Scalar => Complex, - X_Vector => BLAS.Double_Complex_Vector, - Result_Vector => Complex_Vector, - Operation => To_Complex); - - function To_Double_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Double_Complex, - X_Matrix => Complex_Matrix, - Result_Matrix => BLAS.Double_Complex_Matrix, - Operation => To_Double_Complex); - - function To_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Complex, - Result_Scalar => Complex, - X_Matrix => BLAS.Double_Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => To_Complex); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Double_Complex (X : Complex) return Double_Complex is - begin - return (To_Double_Precision (X.Re), To_Double_Precision (X.Im)); - end To_Double_Complex; - - function To_Complex (X : Double_Complex) return Complex is - begin - return (Real (X.Re), Real (X.Im)); - end To_Complex; - - function To_Complex (X : Fortran.Complex) return Complex is - begin - return (Real (X.Re), Real (X.Im)); - end To_Complex; - - function To_Fortran (X : Complex) return Fortran.Complex is - begin - return (Fortran.Real (X.Re), Fortran.Real (X.Im)); - end To_Fortran; - - --------- - -- dot -- - --------- - - function dot - (N : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Y : Complex_Vector; - Inc_Y : Integer := 1) return Complex - is - begin - if Is_Single then - declare - type X_Ptr is access all BLAS.Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Complex_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return To_Complex (BLAS.cdotu (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - elsif Is_Double then - declare - type X_Ptr is access all BLAS.Double_Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return To_Complex (BLAS.zdotu (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - else - return To_Complex (BLAS.zdotu (N, To_Double_Complex (X), Inc_X, - To_Double_Complex (Y), Inc_Y)); - end if; - end dot; - - ---------- - -- gemm -- - ---------- - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Integer; - B : Complex_Matrix; - Ld_B : Integer; - Beta : Complex := (0.0, 0.0); - C : in out Complex_Matrix; - Ld_C : Integer) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is BLAS.Complex_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is - access all BLAS.Complex_Matrix (C'Range (1), C'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is - new Unchecked_Conversion (Complex_Matrix, B_Type); - function Conv_C is - new Unchecked_Conversion (Address, C_Ptr); - begin - BLAS.cgemm (Trans_A, Trans_B, M, N, K, To_Fortran (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, To_Fortran (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - elsif Is_Double then - declare - subtype A_Type is - BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is - BLAS.Double_Complex_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is access all - BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is - new Unchecked_Conversion (Complex_Matrix, B_Type); - function Conv_C is new Unchecked_Conversion (Address, C_Ptr); - begin - BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, - To_Double_Complex (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - else - declare - DP_C : BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2)); - begin - if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then - DP_C := To_Double_Complex (C); - end if; - - BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha), - To_Double_Complex (A), Ld_A, - To_Double_Complex (B), Ld_B, To_Double_Complex (Beta), - DP_C, Ld_C); - - C := To_Complex (DP_C); - end; - end if; - end gemm; - - ---------- - -- gemv -- - ---------- - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Beta : Complex := (0.0, 0.0); - Y : in out Complex_Vector; - Inc_Y : Integer := 1) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is BLAS.Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Complex_Vector (Y'Range); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - function Conv_Y is - new Unchecked_Conversion (Address, Y_Ptr); - begin - BLAS.cgemv (Trans, M, N, To_Fortran (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, To_Fortran (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - elsif Is_Double then - declare - subtype A_Type is - BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is - BLAS.Double_Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - function Conv_Y is - new Unchecked_Conversion (Address, Y_Ptr); - begin - BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, - To_Double_Complex (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - else - declare - DP_Y : BLAS.Double_Complex_Vector (Y'Range); - begin - if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then - DP_Y := To_Double_Complex (Y); - end if; - - BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha), - To_Double_Complex (A), Ld_A, - To_Double_Complex (X), Inc_X, To_Double_Complex (Beta), - DP_Y, Inc_Y); - - Y := To_Complex (DP_Y); - end; - end if; - end gemv; - - ---------- - -- nrm2 -- - ---------- - - function nrm2 - (N : Natural; - X : Complex_Vector; - Inc_X : Integer := 1) return Real - is - begin - if Is_Single then - declare - subtype X_Type is BLAS.Complex_Vector (X'Range); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - begin - return Real (BLAS.scnrm2 (N, Conv_X (X), Inc_X)); - end; - - elsif Is_Double then - declare - subtype X_Type is BLAS.Double_Complex_Vector (X'Range); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - begin - return Real (BLAS.dznrm2 (N, Conv_X (X), Inc_X)); - end; - - else - return Real (BLAS.dznrm2 (N, To_Double_Complex (X), Inc_X)); - end if; - end nrm2; - -end System.Generic_Complex_BLAS; diff --git a/gcc/ada/s-gecobl.ads b/gcc/ada/s-gecobl.ads deleted file mode 100644 index 85bd3b50bf0..00000000000 --- a/gcc/ada/s-gecobl.ads +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -with Ada.Numerics.Generic_Complex_Types; - -generic - type Real is digits <>; - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - type Complex_Vector is array (Integer range <>) of Complex; - type Complex_Matrix is array (Integer range <>, Integer range <>) - of Complex; -package System.Generic_Complex_BLAS is - pragma Pure; - - -- Although BLAS support is only available for IEEE single and double - -- compatible floating-point types, this unit will accept any type - -- and apply conversions as necessary, with possible loss of - -- precision and range. - - No_Trans : aliased constant Character := 'N'; - Trans : aliased constant Character := 'T'; - Conj_Trans : aliased constant Character := 'C'; - - -- BLAS Level 1 Subprograms and Types - - function dot - (N : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Y : Complex_Vector; - Inc_Y : Integer := 1) return Complex; - - function nrm2 - (N : Natural; - X : Complex_Vector; - Inc_X : Integer := 1) return Real; - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Complex := (0.0, 0.0); - Y : in out Complex_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - -- BLAS Level 3 - - -- gemm s, d, c, z Matrix-matrix product of general matrices - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Integer; - B : Complex_Matrix; - Ld_B : Integer; - Beta : Complex := (0.0, 0.0); - C : in out Complex_Matrix; - Ld_C : Integer); - -end System.Generic_Complex_BLAS; diff --git a/gcc/ada/s-gecola.adb b/gcc/ada/s-gecola.adb deleted file mode 100644 index ad69fee9bc5..00000000000 --- a/gcc/ada/s-gecola.adb +++ /dev/null @@ -1,493 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Complex_LAPACK is - - Is_Single : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double : constant Boolean := - Real'Machine_Mantissa = Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = Double_Precision'First - and then - Double_Precision (Real'Last) = Double_Precision'Last; - - subtype Complex is Complex_Types.Complex; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline (To_Double_Precision); - - function To_Real (X : Double_Precision) return Real; - pragma Inline (To_Real); - - function To_Double_Complex (X : Complex) return Double_Complex; - pragma Inline (To_Double_Complex); - - function To_Complex (X : Double_Complex) return Complex; - pragma Inline (To_Complex); - - -- Instantiations - - function To_Double_Precision is new - Vector_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Vector => Real_Vector, - Result_Vector => Double_Precision_Vector, - Operation => To_Double_Precision); - - function To_Real is new - Vector_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Vector => Double_Precision_Vector, - Result_Vector => Real_Vector, - Operation => To_Real); - - function To_Double_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Double_Complex, - X_Matrix => Complex_Matrix, - Result_Matrix => Double_Complex_Matrix, - Operation => To_Double_Complex); - - function To_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Complex, - Result_Scalar => Complex, - X_Matrix => Double_Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => To_Complex); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Real (X : Double_Precision) return Real is - begin - return Real (X); - end To_Real; - - function To_Double_Complex (X : Complex) return Double_Complex is - begin - return (To_Double_Precision (X.Re), To_Double_Precision (X.Im)); - end To_Double_Complex; - - function To_Complex (X : Double_Complex) return Complex is - begin - return (Real (X.Re), Real (X.Im)); - end To_Complex; - - ----------- - -- getrf -- - ----------- - - procedure getrf - (M : Natural; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer) - is - begin - if Is_Single then - declare - type A_Ptr is - access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - cgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - elsif Is_Double then - declare - type A_Ptr is - access all Double_Complex_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - zgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - begin - DP_A := To_Double_Complex (A); - zgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info); - A := To_Complex (DP_A); - end; - end if; - end getrf; - - ----------- - -- getri -- - ----------- - - procedure getri - (N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Complex_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Single then - declare - type A_Ptr is - access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all BLAS.Complex_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - cgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - elsif Is_Double then - declare - type A_Ptr is - access all Double_Complex_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all Double_Complex_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - zgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - DP_Work : Double_Complex_Vector (Work'Range); - begin - DP_A := To_Double_Complex (A); - zgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), - DP_Work, L_Work, Info); - A := To_Complex (DP_A); - Work (1) := To_Complex (DP_Work (1)); - end; - end if; - end getri; - - ----------- - -- getrs -- - ----------- - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Complex_Matrix; - Ld_B : Positive; - Info : access Integer) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all BLAS.Complex_Matrix (B'Range (1), B'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - cgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - elsif Is_Double then - declare - subtype A_Type is - Double_Complex_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all Double_Complex_Matrix (B'Range (1), B'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - zgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - DP_B : Double_Complex_Matrix (B'Range (1), B'Range (2)); - begin - DP_A := To_Double_Complex (A); - DP_B := To_Double_Complex (B); - zgetrs (Trans, N, N_Rhs, - DP_A, Ld_A, - LAPACK.Integer_Vector (I_Piv), - DP_B, Ld_B, - Info); - B := To_Complex (DP_B); - end; - end if; - end getrs; - - procedure heevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - M : out Integer; - W : out Real_Vector; - Z : out Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Complex_Vector; - L_Work : Integer; - R_Work : out Real_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer) - is - begin - if Is_Single then - declare - type A_Ptr is - access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - type W_Ptr is - access all BLAS.Real_Vector (W'Range); - type Z_Ptr is - access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is access all BLAS.Complex_Vector (Work'Range); - type R_Work_Ptr is access all BLAS.Real_Vector (R_Work'Range); - - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_W is new Unchecked_Conversion (Address, W_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - function Conv_R_Work is - new Unchecked_Conversion (Address, R_Work_Ptr); - begin - cheevr (Job_Z, Rng, Uplo, N, - Conv_A (A'Address).all, Ld_A, - Fortran.Real (Vl), Fortran.Real (Vu), - Il, Iu, Fortran.Real (Abs_Tol), M, - Conv_W (W'Address).all, - Conv_Z (Z'Address).all, Ld_Z, - LAPACK.Integer_Vector (I_Supp_Z), - Conv_Work (Work'Address).all, L_Work, - Conv_R_Work (R_Work'Address).all, LR_Work, - LAPACK.Integer_Vector (I_Work), LI_Work, Info); - end; - - elsif Is_Double then - declare - type A_Ptr is - access all BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); - type W_Ptr is - access all BLAS.Double_Precision_Vector (W'Range); - type Z_Ptr is - access all BLAS.Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all BLAS.Double_Complex_Vector (Work'Range); - type R_Work_Ptr is - access all BLAS.Double_Precision_Vector (R_Work'Range); - - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_W is new Unchecked_Conversion (Address, W_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - function Conv_R_Work is - new Unchecked_Conversion (Address, R_Work_Ptr); - begin - zheevr (Job_Z, Rng, Uplo, N, - Conv_A (A'Address).all, Ld_A, - Double_Precision (Vl), Double_Precision (Vu), - Il, Iu, Double_Precision (Abs_Tol), M, - Conv_W (W'Address).all, - Conv_Z (Z'Address).all, Ld_Z, - LAPACK.Integer_Vector (I_Supp_Z), - Conv_Work (Work'Address).all, L_Work, - Conv_R_Work (R_Work'Address).all, LR_Work, - LAPACK.Integer_Vector (I_Work), LI_Work, Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - DP_W : Double_Precision_Vector (W'Range); - DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - DP_Work : Double_Complex_Vector (Work'Range); - DP_R_Work : Double_Precision_Vector (R_Work'Range); - - begin - DP_A := To_Double_Complex (A); - - zheevr (Job_Z, Rng, Uplo, N, - DP_A, Ld_A, - Double_Precision (Vl), Double_Precision (Vu), - Il, Iu, Double_Precision (Abs_Tol), M, - DP_W, DP_Z, Ld_Z, - LAPACK.Integer_Vector (I_Supp_Z), - DP_Work, L_Work, - DP_R_Work, LR_Work, - LAPACK.Integer_Vector (I_Work), LI_Work, Info); - - A := To_Complex (DP_A); - W := To_Real (DP_W); - Z := To_Complex (DP_Z); - - Work (1) := To_Complex (DP_Work (1)); - R_Work (1) := To_Real (DP_R_Work (1)); - end; - end if; - end heevr; - - ----------- - -- steqr -- - ----------- - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Complex_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer) - is - begin - if Is_Single then - declare - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - type Z_Ptr is - access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - csteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - elsif Is_Double then - declare - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - type Z_Ptr is - access all Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - zsteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - else - declare - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_D := To_Double_Precision (D); - DP_E := To_Double_Precision (E); - - if Comp_Z.all = 'V' then - DP_Z := To_Double_Complex (Z); - end if; - - zsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info); - - D := To_Real (DP_D); - E := To_Real (DP_E); - - if Comp_Z.all /= 'N' then - Z := To_Complex (DP_Z); - end if; - end; - end if; - end steqr; - -end System.Generic_Complex_LAPACK; diff --git a/gcc/ada/s-gecola.ads b/gcc/ada/s-gecola.ads deleted file mode 100644 index eb8741ac046..00000000000 --- a/gcc/ada/s-gecola.ads +++ /dev/null @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -with Ada.Numerics.Generic_Complex_Types; -generic - type Real is digits <>; - type Real_Vector is array (Integer range <>) of Real; - - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - type Complex_Vector is array (Integer range <>) of Complex; - type Complex_Matrix is array (Integer range <>, Integer range <>) - of Complex; -package System.Generic_Complex_LAPACK is - pragma Pure; - - type Integer_Vector is array (Integer range <>) of Integer; - - Upper : aliased constant Character := 'U'; - Lower : aliased constant Character := 'L'; - - -- LAPACK Computational Routines - - -- getrf computes LU factorization of a general m-by-n matrix - - procedure getrf - (M : Natural; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - -- getri computes inverse of an LU-factored square matrix, - -- with multiple right-hand sides - - procedure getri - (N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Complex_Vector; - L_Work : Integer; - Info : access Integer); - - -- getrs solves a system of linear equations with an LU-factored - -- square matrix, with multiple right-hand sides - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Complex_Matrix; - Ld_B : Positive; - Info : access Integer); - - -- heevr computes selected eigenvalues and, optionally, - -- eigenvectors of a Hermitian matrix using the Relatively - -- Robust Representations - - procedure heevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - M : out Integer; - W : out Real_Vector; - Z : out Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Complex_Vector; - L_Work : Integer; - R_Work : out Real_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer); - - -- steqr computes all eigenvalues and eigenvectors of a symmetric or - -- Hermitian matrix reduced to tridiagonal form (QR algorithm) - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Complex_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - -end System.Generic_Complex_LAPACK; diff --git a/gcc/ada/s-gerebl.adb b/gcc/ada/s-gerebl.adb deleted file mode 100644 index fc2f5d7d604..00000000000 --- a/gcc/ada/s-gerebl.adb +++ /dev/null @@ -1,311 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ R E A L _ B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Real_BLAS is - - Is_Single : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double : constant Boolean := - Real'Machine_Mantissa = Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = Double_Precision'First - and then - Double_Precision (Real'Last) = Double_Precision'Last; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline_Always (To_Double_Precision); - - function To_Real (X : Double_Precision) return Real; - pragma Inline_Always (To_Real); - - -- Instantiations - - function To_Double_Precision is new - Vector_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Vector => Real_Vector, - Result_Vector => Double_Precision_Vector, - Operation => To_Double_Precision); - - function To_Real is new - Vector_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Vector => Double_Precision_Vector, - Result_Vector => Real_Vector, - Operation => To_Real); - - function To_Double_Precision is new - Matrix_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Matrix => Real_Matrix, - Result_Matrix => Double_Precision_Matrix, - Operation => To_Double_Precision); - - function To_Real is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Matrix => Double_Precision_Matrix, - Result_Matrix => Real_Matrix, - Operation => To_Real); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Real (X : Double_Precision) return Real is - begin - return Real (X); - end To_Real; - - --------- - -- dot -- - --------- - - function dot - (N : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Y : Real_Vector; - Inc_Y : Integer := 1) return Real - is - begin - if Is_Single then - declare - type X_Ptr is access all BLAS.Real_Vector (X'Range); - type Y_Ptr is access all BLAS.Real_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return Real (sdot (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - elsif Is_Double then - declare - type X_Ptr is access all BLAS.Double_Precision_Vector (X'Range); - type Y_Ptr is access all BLAS.Double_Precision_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return Real (ddot (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - else - return Real (ddot (N, To_Double_Precision (X), Inc_X, - To_Double_Precision (Y), Inc_Y)); - end if; - end dot; - - ---------- - -- gemm -- - ---------- - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Integer; - B : Real_Matrix; - Ld_B : Integer; - Beta : Real := 0.0; - C : in out Real_Matrix; - Ld_C : Integer) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is BLAS.Real_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is - access all BLAS.Real_Matrix (C'Range (1), C'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type); - function Conv_C is new Unchecked_Conversion (Address, C_Ptr); - begin - sgemm (Trans_A, Trans_B, M, N, K, Fortran.Real (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, Fortran.Real (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - elsif Is_Double then - declare - subtype A_Type is - Double_Precision_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is - Double_Precision_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is - access all Double_Precision_Matrix (C'Range (1), C'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type); - function Conv_C is new Unchecked_Conversion (Address, C_Ptr); - begin - dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, Double_Precision (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - else - declare - DP_C : Double_Precision_Matrix (C'Range (1), C'Range (2)); - begin - if Beta /= 0.0 then - DP_C := To_Double_Precision (C); - end if; - - dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha), - To_Double_Precision (A), Ld_A, - To_Double_Precision (B), Ld_B, Double_Precision (Beta), - DP_C, Ld_C); - - C := To_Real (DP_C); - end; - end if; - end gemm; - - ---------- - -- gemv -- - ---------- - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Beta : Real := 0.0; - Y : in out Real_Vector; - Inc_Y : Integer := 1) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is BLAS.Real_Vector (X'Range); - type Y_Ptr is access all BLAS.Real_Vector (Y'Range); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - sgemv (Trans, M, N, Fortran.Real (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, Fortran.Real (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - elsif Is_Double then - declare - subtype A_Type is - Double_Precision_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is Double_Precision_Vector (X'Range); - type Y_Ptr is access all Double_Precision_Vector (Y'Range); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - dgemv (Trans, M, N, Double_Precision (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, - Double_Precision (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - else - declare - DP_Y : Double_Precision_Vector (Y'Range); - begin - if Beta /= 0.0 then - DP_Y := To_Double_Precision (Y); - end if; - - dgemv (Trans, M, N, Double_Precision (Alpha), - To_Double_Precision (A), Ld_A, - To_Double_Precision (X), Inc_X, Double_Precision (Beta), - DP_Y, Inc_Y); - - Y := To_Real (DP_Y); - end; - end if; - end gemv; - - ---------- - -- nrm2 -- - ---------- - - function nrm2 - (N : Natural; - X : Real_Vector; - Inc_X : Integer := 1) return Real - is - begin - if Is_Single then - declare - subtype X_Type is BLAS.Real_Vector (X'Range); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - begin - return Real (snrm2 (N, Conv_X (X), Inc_X)); - end; - - elsif Is_Double then - declare - subtype X_Type is Double_Precision_Vector (X'Range); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - begin - return Real (dnrm2 (N, Conv_X (X), Inc_X)); - end; - - else - return Real (dnrm2 (N, To_Double_Precision (X), Inc_X)); - end if; - end nrm2; - -end System.Generic_Real_BLAS; diff --git a/gcc/ada/s-gerebl.ads b/gcc/ada/s-gerebl.ads deleted file mode 100644 index dacbf7bdb13..00000000000 --- a/gcc/ada/s-gerebl.ads +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.GENERIC_REAL_BLAS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -generic - type Real is digits <>; - type Real_Vector is array (Integer range <>) of Real; - type Real_Matrix is array (Integer range <>, Integer range <>) of Real; -package System.Generic_Real_BLAS is - pragma Pure; - - -- Although BLAS support is only available for IEEE single and double - -- compatible floating-point types, this unit will accept any type - -- and apply conversions as necessary, with possible loss of - -- precision and range. - - No_Trans : aliased constant Character := 'N'; - Trans : aliased constant Character := 'T'; - Conj_Trans : aliased constant Character := 'C'; - - -- BLAS Level 1 Subprograms and Types - - function dot - (N : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Y : Real_Vector; - Inc_Y : Integer := 1) return Real; - - function nrm2 - (N : Natural; - X : Real_Vector; - Inc_X : Integer := 1) return Real; - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Positive; - X : Real_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Real := 0.0; - Y : in out Real_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - -- BLAS Level 3 - - -- gemm s, d, c, z Matrix-matrix product of general matrices - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Integer; - B : Real_Matrix; - Ld_B : Integer; - Beta : Real := 0.0; - C : in out Real_Matrix; - Ld_C : Integer); - -end System.Generic_Real_BLAS; diff --git a/gcc/ada/s-gerela.adb b/gcc/ada/s-gerela.adb deleted file mode 100644 index 57d3640ad4d..00000000000 --- a/gcc/ada/s-gerela.adb +++ /dev/null @@ -1,564 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.GENERIC_REAL_LAPACK -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Real_LAPACK is - - Is_Real : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double_Precision : constant Boolean := - Real'Machine_Mantissa = - Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = - Double_Precision'First - and then - Double_Precision (Real'Last) = - Double_Precision'Last; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline_Always (To_Double_Precision); - - function To_Real (X : Double_Precision) return Real; - pragma Inline_Always (To_Real); - - -- Instantiations - - function To_Double_Precision is new - Vector_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Vector => Real_Vector, - Result_Vector => Double_Precision_Vector, - Operation => To_Double_Precision); - - function To_Real is new - Vector_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Vector => Double_Precision_Vector, - Result_Vector => Real_Vector, - Operation => To_Real); - - function To_Double_Precision is new - Matrix_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Matrix => Real_Matrix, - Result_Matrix => Double_Precision_Matrix, - Operation => To_Double_Precision); - - function To_Real is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Matrix => Double_Precision_Matrix, - Result_Matrix => Real_Matrix, - Operation => To_Real); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Real (X : Double_Precision) return Real is - begin - return Real (X); - end To_Real; - - ----------- - -- getrf -- - ----------- - - procedure getrf - (M : Natural; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - sgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - dgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - begin - DP_A := To_Double_Precision (A); - dgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info); - A := To_Real (DP_A); - end; - end if; - end getrf; - - ----------- - -- getri -- - ----------- - - procedure getri - (N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Real_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - sgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_A := To_Double_Precision (A); - dgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), - DP_Work, L_Work, Info); - A := To_Real (DP_A); - Work (1) := To_Real (DP_Work (1)); - end; - end if; - end getri; - - ----------- - -- getrs -- - ----------- - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Real_Matrix; - Ld_B : Positive; - Info : access Integer) - is - begin - if Is_Real then - declare - subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all BLAS.Real_Matrix (B'Range (1), B'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - sgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - elsif Is_Double_Precision then - declare - subtype A_Type is - Double_Precision_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all Double_Precision_Matrix (B'Range (1), B'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - dgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_B : Double_Precision_Matrix (B'Range (1), B'Range (2)); - begin - DP_A := To_Double_Precision (A); - DP_B := To_Double_Precision (B); - dgetrs (Trans, N, N_Rhs, - DP_A, Ld_A, - LAPACK.Integer_Vector (I_Piv), - DP_B, Ld_B, - Info); - B := To_Real (DP_B); - end; - end if; - end getrs; - - ----------- - -- orgtr -- - ----------- - - procedure orgtr - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - Tau : Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - subtype Tau_Type is BLAS.Real_Vector (Tau'Range); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Tau is - new Unchecked_Conversion (Real_Vector, Tau_Type); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - sorgtr (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_Tau (Tau), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - subtype Tau_Type is Double_Precision_Vector (Tau'Range); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Tau is - new Unchecked_Conversion (Real_Vector, Tau_Type); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dorgtr (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_Tau (Tau), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - DP_Tau : Double_Precision_Vector (Tau'Range); - begin - DP_A := To_Double_Precision (A); - DP_Tau := To_Double_Precision (Tau); - dorgtr (Uplo, N, DP_A, Ld_A, DP_Tau, DP_Work, L_Work, Info); - A := To_Real (DP_A); - Work (1) := To_Real (DP_Work (1)); - end; - end if; - end orgtr; - - ----------- - -- steqr -- - ----------- - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Real_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer) - is - begin - if Is_Real then - declare - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - type Z_Ptr is - access all BLAS.Real_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - ssteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - elsif Is_Double_Precision then - declare - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - type Z_Ptr is - access all Double_Precision_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dsteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - else - declare - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - DP_Z : Double_Precision_Matrix (Z'Range (1), Z'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_D := To_Double_Precision (D); - DP_E := To_Double_Precision (E); - - if Comp_Z.all = 'V' then - DP_Z := To_Double_Precision (Z); - end if; - - dsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info); - - D := To_Real (DP_D); - E := To_Real (DP_E); - Z := To_Real (DP_Z); - end; - end if; - end steqr; - - ----------- - -- sterf -- - ----------- - - procedure sterf - (N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Info : access Integer) - is - begin - if Is_Real then - declare - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - begin - ssterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info); - end; - - elsif Is_Double_Precision then - declare - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - begin - dsterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info); - end; - - else - declare - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - - begin - DP_D := To_Double_Precision (D); - DP_E := To_Double_Precision (E); - - dsterf (N, DP_D, DP_E, Info); - - D := To_Real (DP_D); - E := To_Real (DP_E); - end; - end if; - end sterf; - - ----------- - -- sytrd -- - ----------- - - procedure sytrd - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - type Tau_Ptr is access all BLAS.Real_Vector (Tau'Range); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - ssytrd (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Tau (Tau'Address).all, - Conv_Work (Work'Address).all, - L_Work, - Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - type Tau_Ptr is access all Double_Precision_Vector (Tau'Range); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dsytrd (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Tau (Tau'Address).all, - Conv_Work (Work'Address).all, - L_Work, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - DP_Tau : Double_Precision_Vector (Tau'Range); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_A := To_Double_Precision (A); - - dsytrd (Uplo, N, DP_A, Ld_A, DP_D, DP_E, DP_Tau, - DP_Work, L_Work, Info); - - if L_Work /= -1 then - A := To_Real (DP_A); - D := To_Real (DP_D); - E := To_Real (DP_E); - Tau := To_Real (DP_Tau); - end if; - - Work (1) := To_Real (DP_Work (1)); - end; - end if; - end sytrd; - -end System.Generic_Real_LAPACK; diff --git a/gcc/ada/s-gerela.ads b/gcc/ada/s-gerela.ads deleted file mode 100644 index c09ce81d027..00000000000 --- a/gcc/ada/s-gerela.ads +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ R E A L _ L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -generic - type Real is digits <>; - type Real_Vector is array (Integer range <>) of Real; - type Real_Matrix is array (Integer range <>, Integer range <>) of Real; -package System.Generic_Real_LAPACK is - pragma Pure; - - type Integer_Vector is array (Integer range <>) of Integer; - - Upper : aliased constant Character := 'U'; - Lower : aliased constant Character := 'L'; - - -- LAPACK Computational Routines - - -- gerfs Refines the solution of a system of linear equations with - -- a general matrix and estimates its error - -- getrf Computes LU factorization of a general m-by-n matrix - -- getri Computes inverse of an LU-factored general matrix - -- square matrix, with multiple right-hand sides - -- getrs Solves a system of linear equations with an LU-factored - -- square matrix, with multiple right-hand sides - -- orgtr Generates the Float orthogonal matrix Q determined by sytrd - -- steqr Computes all eigenvalues and eigenvectors of a symmetric or - -- Hermitian matrix reduced to tridiagonal form (QR algorithm) - -- sterf Computes all eigenvalues of a Float symmetric - -- tridiagonal matrix using QR algorithm - -- sytrd Reduces a Float symmetric matrix to tridiagonal form - - procedure getrf - (M : Natural; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure getri - (N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Real_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure orgtr - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - Tau : Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure sterf - (N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Info : access Integer); - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Real_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - - procedure sytrd - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - -end System.Generic_Real_LAPACK; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9de2f1f0320..70270aba268 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10952,7 +10952,8 @@ package body Sem_Prag is -- pragma Long_Float (D_Float | G_Float); - when Pragma_Long_Float => + when Pragma_Long_Float => Long_Float : declare + begin GNAT_Pragma; Check_Valid_Configuration_Pragma; Check_Arg_Count (1); @@ -10967,22 +10968,42 @@ package body Sem_Prag is if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then if Opt.Float_Format_Long = 'G' then - Error_Pragma ("G_Float previously specified"); - end if; + Error_Pragma_Arg + ("G_Float previously specified", Arg1); + + elsif Current_Sem_Unit /= Main_Unit + and then Opt.Float_Format_Long /= 'D' + then + Error_Pragma_Arg + ("main unit not compiled with pragma Long_Float (D_Float)", + "\pragma% must be used consistently for whole partition", + Arg1); - Opt.Float_Format_Long := 'D'; + else + Opt.Float_Format_Long := 'D'; + end if; -- G_Float case (this is the default, does not need overriding) else if Opt.Float_Format_Long = 'D' then Error_Pragma ("D_Float previously specified"); - end if; - Opt.Float_Format_Long := 'G'; + elsif Current_Sem_Unit /= Main_Unit + and then Opt.Float_Format_Long /= 'G' + then + Error_Pragma_Arg + ("main unit not compiled with pragma Long_Float (G_Float)", + "\pragma% must be used consistently for whole partition", + Arg1); + + else + Opt.Float_Format_Long := 'G'; + end if; end if; Set_Standard_Fpt_Formats; + end Long_Float; ----------------------- -- Machine_Attribute -- diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 9f0b259311c..99b71c00fbf 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3993,39 +3993,59 @@ package body Sem_Warn is -- Case of assigned value never referenced if No (N) then + declare + LA : constant Node_Id := Last_Assignment (Ent); - -- Don't give this for OUT and IN OUT formals, since - -- clearly caller may reference the assigned value. Also - -- never give such warnings for internal variables. + begin + -- Don't give this for OUT and IN OUT formals, since + -- clearly caller may reference the assigned value. Also + -- never give such warnings for internal variables. - if Ekind (Ent) = E_Variable - and then not Is_Internal_Name (Chars (Ent)) - then - if Referenced_As_Out_Parameter (Ent) then - Error_Msg_NE - ("?& modified by call, but value never referenced", - Last_Assignment (Ent), Ent); - else - Error_Msg_NE -- CODEFIX - ("?useless assignment to&, value never referenced!", - Last_Assignment (Ent), Ent); + if Ekind (Ent) = E_Variable + and then not Is_Internal_Name (Chars (Ent)) + then + -- Give appropriate message, distinguishing between + -- assignment statements and out parameters. + + if Nkind_In (Parent (LA), N_Procedure_Call_Statement, + N_Parameter_Association) + then + Error_Msg_NE + ("?& modified by call, but value never " + & "referenced", LA, Ent); + + else + Error_Msg_NE -- CODEFIX + ("?useless assignment to&, value never " + & "referenced!", LA, Ent); + end if; end if; - end if; + end; -- Case of assigned value overwritten else - Error_Msg_Sloc := Sloc (N); + declare + LA : constant Node_Id := Last_Assignment (Ent); - if Referenced_As_Out_Parameter (Ent) then - Error_Msg_NE - ("?& modified by call, but value overwritten #!", - Last_Assignment (Ent), Ent); - else - Error_Msg_NE -- CODEFIX - ("?useless assignment to&, value overwritten #!", - Last_Assignment (Ent), Ent); - end if; + begin + Error_Msg_Sloc := Sloc (N); + + -- Give appropriate message, distinguishing between + -- assignment statements and out parameters. + + if Nkind_In (Parent (LA), N_Procedure_Call_Statement, + N_Parameter_Association) + then + Error_Msg_NE + ("?& modified by call, but value overwritten #!", + LA, Ent); + else + Error_Msg_NE -- CODEFIX + ("?useless assignment to&, value overwritten #!", + LA, Ent); + end if; + end; end if; -- Clear last assignment indication and we are done |