[multiple changes]

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.

From-SVN: r180935

gcc/ada/ChangeLog

-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

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) \

gcc/ada/a-sbecin.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--                ADA.STRINGS.BOUNDED.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.Equal_Case_Insensitive;
+
+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;

gcc/ada/a-sbecin.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--                ADA.STRINGS.BOUNDED.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.                  --
+------------------------------------------------------------------------------
+
+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;
+
+pragma Preelaborate (Ada.Strings.Bounded.Equal_Case_Insensitive);

gcc/ada/a-sbhcin.adb

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

gcc/ada/a-sbhcin.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--                 ADA.STRINGS.BOUNDED.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;
+
+generic
+   with package Bounded is
+     new Ada.Strings.Bounded.Generic_Bounded_Length (<>);
+
+function Ada.Strings.Bounded.Hash_Case_Insensitive
+  (Key : Bounded.Bounded_String)
+  return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Bounded.Hash_Case_Insensitive);

gcc/ada/a-sblcin.adb

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

gcc/ada/a-sblcin.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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);

gcc/ada/a-sfecin.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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);

gcc/ada/a-sfhcin.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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);

gcc/ada/i-forbla.adb → gcc/ada/a-sflcin.ads

 ------------------------------------------------------------------------------
 --                                                                          --
---                         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.FIXED.LESS_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,13 @@
 -- 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.
+with Ada.Strings.Less_Case_Insensitive;
+
+function Ada.Strings.Fixed.Less_Case_Insensitive
+  (Left, Right : String)
+  return Boolean renames Ada.Strings.Less_Case_Insensitive;
 
-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 Pure (Ada.Strings.Fixed.Less_Case_Insensitive);

gcc/ada/a-suecin.adb

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

gcc/ada/i-forbla-darwin.adb → gcc/ada/a-suecin.ads

 ------------------------------------------------------------------------------
 --                                                                          --
---                         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.UNBOUNDED.EQUAL_CASE_INSENSITIVE               --
 --                                                                          --
---                                 B o d y                                  --
+--                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2010, 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,15 +28,11 @@
 -- 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
+function Ada.Strings.Unbounded.Equal_Case_Insensitive
+  (Left, Right : Unbounded.Unbounded_String)
+  return Boolean;
 
-package body Interfaces.Fortran.BLAS is
-   pragma Linker_Options ("-lgnala");
-   pragma Linker_Options ("-lm");
-   pragma Linker_Options ("-Wl,-framework,vecLib");
-end Interfaces.Fortran.BLAS;
+pragma Preelaborate (Ada.Strings.Unbounded.Equal_Case_Insensitive);

gcc/ada/a-suhcin.adb

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

gcc/ada/a-suhcin.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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);

gcc/ada/a-sulcin.adb

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

gcc/ada/i-forbla-unimplemented.ads → gcc/ada/a-sulcin.ads

 ------------------------------------------------------------------------------
 --                                                                          --
---                         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.UNBOUNDED.LESS_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,11 @@
 -- 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
-
-package Interfaces.Fortran.BLAS is
-
-   pragma Unimplemented_Unit;
+function Ada.Strings.Unbounded.Less_Case_Insensitive
+  (Left, Right : Unbounded.Unbounded_String)
+  return Boolean;
 
-end Interfaces.Fortran.BLAS;
+pragma Preelaborate (Ada.Strings.Unbounded.Less_Case_Insensitive);

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 \

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

gcc/ada/i-forbla.ads

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

gcc/ada/i-forlap.ads

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

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

gcc/ada/s-gecobl.adb

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

gcc/ada/s-gecobl.ads

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

gcc/ada/s-gecola.adb

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

gcc/ada/s-gecola.ads

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

gcc/ada/s-gerebl.adb

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

gcc/ada/s-gerebl.ads

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

gcc/ada/s-gerela.adb

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

gcc/ada/s-gerela.ads

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

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);
 
+               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;
 
+               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 --

gcc/ada/sem_warn.adb

@@ -3993,7 +3993,10 @@ package body Sem_Warn is
                --  Case of assigned value never referenced
 
                if No (N) then
+                  declare
+                     LA : constant Node_Id := Last_Assignment (Ent);
 
+                  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.
@@ -4001,31 +4004,48 @@ package body Sem_Warn is
                      if Ekind (Ent) = E_Variable
                        and then not Is_Internal_Name (Chars (Ent))
                      then
-                     if Referenced_As_Out_Parameter (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",
-                           Last_Assignment (Ent), Ent);
+                             ("?& modified by call, but value never "
+                              & "referenced", LA, Ent);
+
                         else
                            Error_Msg_NE -- CODEFIX
-                          ("?useless assignment to&, value never referenced!",
-                           Last_Assignment (Ent), Ent);
+                             ("?useless assignment to&, value never "
+                              & "referenced!", LA, Ent);
                         end if;
                      end if;
+                  end;
 
                --  Case of assigned value overwritten
 
                else
+                  declare
+                     LA : constant Node_Id := Last_Assignment (Ent);
+
+                  begin
                      Error_Msg_Sloc := Sloc (N);
 
-                  if Referenced_As_Out_Parameter (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 overwritten #!",
-                        Last_Assignment (Ent), Ent);
+                           LA, Ent);
                      else
                         Error_Msg_NE -- CODEFIX
                           ("?useless assignment to&, value overwritten #!",
-                        Last_Assignment (Ent), Ent);
+                           LA, Ent);
                      end if;
+                  end;
                end if;
 
                --  Clear last assignment indication and we are done