diff options
Diffstat (limited to 'gcc/ada')
109 files changed, 3345 insertions, 3761 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 350f8e9c47f..51b2719a387 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,403 @@ +2011-11-07 Olivier Hainque <hainque@adacore.com> + + * sigtramp-ppcvxw.c: Add general comments. + (CFI_COMMON_REGS): Remove rule for r1, as in other unwinders. Add + rules for r2 to r13, plus CTR and XER. + (CFA_REG): New, register number used to hold the local CFA. + (CFI_DEF_CFA, SIGTRAMP_BODY): Use it. + Make that 15, not 14, with documentation. + (TCR): Undef before definition, preventing conflict with reg number in + VxWorks headers. + +2011-11-07 Robert Dewar <dewar@adacore.com> + + * exp_util.ads, exp_alfa.adb, a-cohama.adb, a-cohama.ads, sem_ch4.adb, + aspects.ads, exp_ch8.adb, exp_ch8.ads, atree.ads: Minor reformatting. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-11-07 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb: A tagged type is a legal actual for an aliased + formal. + +2011-11-07 Pascal Obry <obry@adacore.com> + + * g-socket.adb, g-socket.ads: Minor reformatting. + +2011-11-07 Robert Dewar <dewar@adacore.com> + + * sem_res.adb (Resolve_Actuals): Minor error message improvement. + +2011-11-07 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Add discussion of default mode handling of + source representation with no -gnatW option given, in particular + noting that NEL (next line) is not recognized in this context. + +2011-11-07 Yannick Moy <moy@adacore.com> + + * sem_util.adb (Note_Possible_Modification): In Alfa mode, + generate a reference for a modification even when the modification + does not come from source. + +2011-11-07 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop): For the "of" iterator form, + use the indexing attributes rather than the Element function, + to obtain variable references. + * sem_ch4.adb (Try_Container_Indexing): Code cleanup. Use + Find_Aspect rather than iterating over representation + items. Improve error message. + * a-cohama.adb, a-cohama.ads Update to latest RM, with two versions + of Reference functions. + +2011-11-07 Yannick Moy <moy@adacore.com> + + * sem_util.adb (Unique_Entity): For a parameter on a subprogram + body that has a corresponding parameter on the subprogram + declaration, define the unique entity as being the declaration + one. + +2011-11-07 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Return_Type): In Ada 2012 mode, if the + return type of a function is the class-wide type of an incomplete + type T, T can be a Taft-amendment type and does not have to be + completed in the current private part. + +2011-11-07 Ed Schonberg <schonberg@adacore.com> + + * aspects.ads (Inherited_Aspect): Map that indicates type aspects + that are inherited by default, and apply to the class-wide type + as well. + * aspects.adb (Find_Aspect): If the entity is class-wide and the + aspect is inherited, use the aspect of the specific type. + +2011-11-07 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_alfa.adb: Remove with and use clause for + Exp_Ch8. Add with and use clause for Exp_Util. + Remove local constant Disable_Processing_Of_Renamings. + (Expand_Alfa_N_Object_Renaming_Declaration): The expansion of + object renamings has been reenabled. + (Expand_Possible_Renaming): + The expansion of identifier and expanded names has been + reenabled. Perform the substitutions only for entities that + denote an object. + * exp_ch8.ads, exp_ch8.adb (Evaluate_Name): Moved to Exp_Util. + * exp_util.adb (Evaluate_Name): Moved from Exp_Ch8. + (Remove_Side_Effects): Alphabetize local variables. Add a guard + to avoid the infinite expansion of an expression in Alfa mode. Add + processing for function calls in Alfa mode. + * exp_util.ads (Evaliate_Name): Moved from Exp_Ch8. + +2011-11-07 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Entity): If the entity is an access to + subprogram whose designated type is itself a subprogram type, + its own return type must be decorated with size information. + +2011-11-04 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * sprint.adb (Sprint_Node_Actual, case Qualified_Expression): + Avoid junk semicolon after argument of machine code Asm operand. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * exp_ch11.adb (Generate_Push_Pop): Inhibit push/pop nodes in + CodePeer mode or if restriction No_Exception_Handlers is present. + * exp_ch6.adb (Expand_N_Subprogram_Body): (Inhibit push/pop + nodes in CodePeer mode or if restriction No_Exception_Handlers + is present. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * s-tassta.adb, atree.ads, errout.adb, sinput.adb: Minor reformatting. + +2011-11-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Specification): The + specification is legal if it is a function that returns an + abstract type, if it comes from an attribute renaming of a stream + attribute of an abstract type. + +2011-11-04 Gary Dismukes <dismukes@adacore.com> + + * exp_util.adb (Is_Possibly_Unaligned_Object): In case of indexed + components, check whether recursively check whether the prefix + denotes an unaligned object. + +2011-11-04 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case Debug): The argument of + the pragma is legal if it is an expanded name that denotes a + procedure that be can called without parameters. + +2011-11-04 Eric Botcazou <ebotcazou@adacore.com> + + * gnat_ugn.texi (Performance Considerations) <Vectorization + of loops>: New sub-section. <Other Optimization Switches>: + Minor tweak. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Minor reformatting. + +2011-11-04 Matthew Heaney <heaney@adacore.com> + + * a-convec.adb, a-coinve.adb, a-cobove.adb (Merge): Raise PE + when Target and Source denote same non-empty object + * a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb (Merge): Ditto + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb: Minor reformatting. + +2011-11-04 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Assign_Record): Do not generate a + discriminant assignment within an initialization proc if the + record is an unchecked union, as it can only come from the + initialization of an unchecked union component. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Minor reformatting. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * par-labl.adb (Rewrite_As_Loop): Generate info msg rather than + warning message. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb: Minor code reorganization (remove junk obsolete + var Save_Space). + +2011-11-04 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_alfa.adb: Add local constant + Disable_Processing_Of_Renamings; + (Expand_Alfa_N_Object_Renaming_Declaration): Disable + the name evaluation of object renamings for now. + (Expand_Potential_Renaming): Do not perform the substitution + for now. + * exp_util.adb (Remove_Side_Effects): Remove processing for + functions with side effects in Alfa mode. + +2011-11-04 Gary Dismukes <dismukes@adacore.com> + + * bindgen.adb (Gen_Elab_Calls): In the case + of the AAMP target, set elaboration entities to 1 rather than + incrementing. + +2011-11-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Install_Limited_With_Unit): To establish the + proper entities on the ancestors of a child unit that appear + in a limited_with clause, follow the unit links because the + units are not analyzed and scope information is incomplete. + +2011-11-04 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_Selected_Component): Refine code + setting the Atomic_Sync_Required flag to detect one more case. + * exp_util.adb (Activate_Atomic_Synchronization): Refine code + setting the Atomic_Sync_Required flag to exclude more cases, + depending on the parent of the node to be examined. + +2011-11-04 Bob Duff <duff@adacore.com> + + * g-excact.adb: Minor: use named notation. + +2011-11-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb: Improve error messages for illegal iterators. + +2011-11-04 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_alfa.adb: Add with and use clauses for Exp_Ch8 and + Sem_Util. + (Expand_Alfa): Alphabetize cases on first choice. Add + processing for object renaming declarations, identifiers and + expanded names. + (Expand_Alfa_N_In): Remove useless return. + (Expand_Alfa_N_Object_Renaming_Declaration): New routine. + (Expand_Potential_Renaming): New routine. + * exp_ch8.adb (Evaluate_Name): Moved to the top level. + (Expand_N_Object_Declaration): Alphabetize local variables. Move + Evaluate_Name out to the top level. + * exp_ch8.ads (Evaluate_Name): Moved from body to package spec. + * exp_util.adb (Remove_Side_Effects): Add processing for + functions with side effects in Alfa mode. + +2011-11-04 Hristian Kirtchev <kirtchev@adacore.com> + + * gnat_rm.texi: Add entries for + restrictions No_Relative_Delay, No_Requeue_Statements and + No_Stream_Optimizations. + +2011-11-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb: Set type of entity in prefixed call, for + completeness in a generic context. + +2011-11-04 Yannick Moy <moy@adacore.com> + + * sem_prag.adb: Minor refactoring (renaming of a parameter). + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * atree.ads: Minor reformatting. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * checks.adb (Atomic_Synchronization_Disabled): Check -gnatd.d + and -gnatd.e here + * exp_ch2.adb (Expand_Entity_Reference): Use + Activate_Atomic_Synchronization + * exp_ch4.adb (Expand_N_Explicit_Dereference): Use + Activate_Atomic_Synchronization (Expand_N_Indexed_Compoonent): + Activate_Atomic_Synchronization (Expand_N_Selected_Component): + Use Activate_Atomic_Synchronization + * exp_util.ads, exp_util.adb (Activate_Atomic_Synchronization): New + procedure. + * sinfo.ads, sinfo.adb (Atomic_Sync_Required): Can now apply to + N_Selected_Component node + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, atree.ads, prj-env.adb, prj-env.ads: Minor reformatting. + +2011-11-04 Yannick Moy <moy@adacore.com> + + * atree.adb, atree.ads (Set_Original_Node): New set procedure. + * sem_ch13.adb (Analyze_Aspect_Specifications/Pre_Post_Aspects): + In ASIS mode, no splitting of aspects between conjuncts. + (Analyze_Aspect_Specifications/Aspect_Test_Case): Make pragma + expressions refer to the original aspect expressions through + the Original_Node link. This is used in semantic analysis for + ASIS mode, so that the original expression also gets analyzed. + * sem_prag.adb (Preanalyze_TC_Args, + Check_Precondition_Postcondition, + Analyze_Pragma/Pragma_Test_Case): In ASIS mode, for a pragma + generated from a source aspect, also analyze the original aspect + expression. + (Check_Expr_Is_Static_Expression): New procedure + similar to existing procedure Check_Arg_Is_Static_Expression, + except called on expression inside pragma. + +2011-11-04 Tristan Gingold <gingold@adacore.com> + + * prj-env.adb, prj-env.ads (Find_Name_In_Path): New function, from + Find_Project.Try_Path_Name. + (Find_Project): Use Find_Name_In_Path to implement Try_Path_Name. + +2011-11-04 Eric Botcazou <ebotcazou@adacore.com> + + * s-atocou.ads (Atomic_Counter): Remove redundant pragma Volatile. + +2011-11-04 Pascal Obry <obry@adacore.com> + + * projects.texi: Add short description for qualifiers aggregate + and aggregate library. + +2011-11-04 Matthew Heaney <heaney@adacore.com> + + * Makefile.rtl, impunit.adb: Added a-cogeso.ad[sb] + * a-cgaaso.adb: Replaced implementation with instantiation + of Generic_Sort. + * a-cogeso.ad[sb] This is the new Ada 2012 unit + Ada.Containers.Generic_Sort + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * exp_ch2.adb (Expand_Entity_Reference): Do not set + Atomic_Sync_Required for the case of a prefix of an attribute. + * exp_ch4.adb (Expand_N_Explicit_Dereference): May require + atomic synchronization + (Expand_N_Indexed_Component): Ditto. + (Expand_B_Selected_Component): Ditto. + * sem_prag.adb (Process_Suppress_Unsuppress): + Disable/Enable_Atomic_Synchronization can now occur for array + types with pragma Atomic_Components. + * sinfo.ads, sinfo.adb (Atomic_Sync_Required): Can now occur on + N_Explicit_Dereference nodes and on N_Indexed_Component nodes. + +2011-11-04 Gary Dismukes <dismukes@adacore.com> + + * gnat_ugn.texi: Editorial corrections for gnattest section. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb: Minor reformatting. + * gnat_rm.texi: Update documentation for pragma Warnings (Off, + "***") usage. + * exp_ch2.adb (Expand_Entity_Reference): Only set + Atomic_Sync_Required on entities that are variables. Doesn't + make any sense on anything else. + +2011-11-04 Robert Dewar <dewar@adacore.com> + + * exp_ch2.adb (Expand_Entity_Reference): Extend handling of + atomic sync to type case. + * sem_prag.adb (Process_Suppress_Unsuppress): Atomic Sync can + apply to types. + +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. + +2011-11-04 Matthew Heaney <heaney@adacore.com> + + * a-cdlili.ad[sb], a-cidlli.ad[sb], a-coorse.ad[sb], a-ciorse.ad[sb], + a-coorma.ad[sb], a-ciorma.ad[sb], a-coormu.ad[sb], a-ciormu.ad[sb], + a-cohama.ad[sb], a-cihama.ad[sb], a-cohase.ad[sb], a-cihase.ad[sb], + 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 + +2011-11-04 Gary Dismukes <dismukes@adacore.com> + + * bindgen.adb (Gen_Elab_Calls): In the case of the AAMP target, + initialize elaboration entities to zero when specs are processed. + 2011-10-28 Iain Sandoe <iains@gcc.gnu.org> Eric Botcazou <ebotcazou@adacore.com> diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 4e03c9e178e..50e8a96a3d3 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -122,6 +122,7 @@ GNATRTL_NONTASKING_OBJS= \ a-ciormu$(objext) \ a-ciorse$(objext) \ a-clrefi$(objext) \ + a-cogeso$(objext) \ a-cohama$(objext) \ a-cohase$(objext) \ a-cohata$(objext) \ @@ -214,9 +215,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 +268,13 @@ GNATRTL_NONTASKING_OBJS= \ a-stzsea$(objext) \ a-stzsup$(objext) \ a-stzunb$(objext) \ + a-suecin$(objext) \ a-suenco$(objext) \ a-suenst$(objext) \ a-suewst$(objext) \ a-suezst$(objext) \ + a-suhcin$(objext) \ + a-sulcin$(objext) \ a-suteio$(objext) \ a-swbwha$(objext) \ a-swfwha$(objext) \ diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index 1b10d42b4a3..e1f7725d5cd 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -713,10 +713,24 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is LI, RI : Cursor; begin - if Target'Address = Source'Address then + + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then return; end if; + if Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 497a1112d43..8b513222ef8 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -146,6 +146,27 @@ package body Ada.Containers.Doubly_Linked_Lists is Insert (Container, No_Element, New_Item, Count); end Append; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + + Node := Source.First; + while Node /= null loop + Target.Append (Node.Element); + Node := Node.Next; + end loop; + end Assign; + ----------- -- Clear -- ----------- @@ -206,6 +227,17 @@ package body Ada.Containers.Doubly_Linked_Lists is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : List) return List is + begin + return Target : List do + Target.Assign (Source); + end return; + end Copy; + ------------ -- Delete -- ------------ @@ -483,10 +515,24 @@ package body Ada.Containers.Doubly_Linked_Lists is LI, RI : Cursor; begin - if Target'Address = Source'Address then + + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then return; end if; + if Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index d38b0d08ba3..2de03e520aa 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -90,6 +90,10 @@ package Ada.Containers.Doubly_Linked_Lists is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + procedure Assign (Target : in out List; Source : List); + + function Copy (Source : List) return List; + procedure Move (Target : in out List; Source : in out List); diff --git a/gcc/ada/a-cgaaso.adb b/gcc/ada/a-cgaaso.adb index abb8631d55c..12763f12a67 100644 --- a/gcc/ada/a-cgaaso.adb +++ b/gcc/ada/a-cgaaso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -27,103 +27,21 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb]) +-- This unit was originally a GNAT-specific addition to Ada 2005. A unit +-- providing the same feature, Ada.Containers.Generic_Sort, was defined for +-- Ada 2012. We retain Generic_Anonymous_Array_Sort for compatibility, but +-- implement it in terms of the official unit, Generic_Sort. -with System; +with Ada.Containers.Generic_Sort; procedure Ada.Containers.Generic_Anonymous_Array_Sort (First, Last : Index_Type'Base) is - type T is range System.Min_Int .. System.Max_Int; - - function To_Index (J : T) return Index_Type; - pragma Inline (To_Index); - - function Lt (J, K : T) return Boolean; - pragma Inline (Lt); - - procedure Xchg (J, K : T); - pragma Inline (Xchg); - - procedure Sift (S : T); - - -------------- - -- To_Index -- - -------------- - - function To_Index (J : T) return Index_Type is - K : constant T'Base := Index_Type'Pos (First) + J - T'(1); - begin - return Index_Type'Val (K); - end To_Index; - - -------- - -- Lt -- - -------- - - function Lt (J, K : T) return Boolean is - begin - return Less (To_Index (J), To_Index (K)); - end Lt; - - ---------- - -- Xchg -- - ---------- - - procedure Xchg (J, K : T) is - begin - Swap (To_Index (J), To_Index (K)); - end Xchg; - - Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1); - - ---------- - -- Sift -- - ---------- - - procedure Sift (S : T) is - C : T := S; - Son : T; - Father : T; - - begin - loop - Son := C + C; - - if Son < Max then - if Lt (Son, Son + 1) then - Son := Son + 1; - end if; - elsif Son > Max then - exit; - end if; - - Xchg (Son, C); - C := Son; - end loop; - - while C /= S loop - Father := C / 2; - - if Lt (Father, C) then - Xchg (Father, C); - C := Father; - else - exit; - end if; - end loop; - end Sift; - --- Start of processing for Generic_Anonymous_Array_Sort + procedure Sort is new Ada.Containers.Generic_Sort + (Index_Type => Index_Type, + Before => Less, + Swap => Swap); begin - for J in reverse 1 .. Max / 2 loop - Sift (J); - end loop; - - while Max > 1 loop - Xchg (1, Max); - Max := Max - 1; - Sift (1); - end loop; + Sort (First, Last); end Ada.Containers.Generic_Anonymous_Array_Sort; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 849cb53c64a..dbdc6de47d4 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -171,6 +171,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Insert (Container, No_Element, New_Item, Count); end Append; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + + Node := Source.First; + while Node /= null loop + Target.Append (Node.Element.all); + Node := Node.Next; + end loop; + end Assign; + ----------- -- Clear -- ----------- @@ -230,6 +251,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : List) return List is + begin + return Target : List do + Target.Assign (Source); + end return; + end Copy; + ------------ -- Delete -- ------------ @@ -531,10 +563,24 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is LI, RI : Cursor; begin - if Target'Address = Source'Address then + + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then return; end if; + if Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index 8a23fc75442..c40ad30b155 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -90,6 +90,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + procedure Assign (Target : in out List; Source : List); + + function Copy (Source : List) return List; + procedure Move (Target : in out List; Source : in out List); diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index d4f2c1d92dc..b90c5426481 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -35,6 +35,8 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Unchecked_Deallocation; +with System; use type System.Address; + package body Ada.Containers.Indefinite_Hashed_Maps is procedure Free_Key is @@ -132,6 +134,41 @@ package body Ada.Containers.Indefinite_Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + + if Target.Capacity < Source.Length then + Target.Reserve_Capacity (Source.Length); + end if; + + Insert_Items (Target.HT); + end Assign; + -------------- -- Capacity -- -------------- @@ -159,6 +196,34 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return Find (Container, Key) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Map; + Capacity : Count_Type := 0) return Map + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Map do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 1b16d8f4589..7c67c315583 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -134,6 +134,10 @@ package Ada.Containers.Indefinite_Hashed_Maps is -- Calls Process with the key (with only a constant view) and element (with -- a variable view) of the node designed by the cursor. + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map; + procedure Move (Target : in out Map; Source : in out Map); -- Clears Target (if it's not empty), and then moves (not copies) the -- buckets array and nodes from Source to Target. diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index e52f38bba9f..e29a204570e 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -173,6 +173,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Free_Element (X); end Assign; + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + -------------- -- Capacity -- -------------- @@ -200,6 +210,34 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Set; + Capacity : Count_Type := 0) return Set + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Set do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index 860034469ea..33994cdeffa 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -153,6 +153,10 @@ package Ada.Containers.Indefinite_Hashed_Sets is Position : Cursor) return Constant_Reference_Type; + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set; + procedure Move (Target : in out Set; Source : in out Set); -- Clears Target (if it's not empty), and then moves (not copies) the -- buckets array and nodes from Source to Target. diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index 3de57c76aa4..cd95b9fd5ab 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -35,6 +35,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); with Ada.Containers.Red_Black_Trees.Generic_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); +with System; use type System.Address; + package body Ada.Containers.Indefinite_Ordered_Maps is pragma Suppress (All_Checks); @@ -287,6 +289,37 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Adjust (Container.Tree); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is + new Tree_Operations.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Insert_Items (Target.Tree); + end Assign; + ------------- -- Ceiling -- ------------- @@ -340,6 +373,17 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return Find (Container, Key) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : Map) return Map is + begin + return Target : Map do + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index b31dc0d2e25..1c19b81161f 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -96,6 +96,10 @@ package Ada.Containers.Indefinite_Ordered_Maps is Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map) return Map; + procedure Move (Target : in out Map; Source : in out Map); procedure Insert diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 8c7055b2fef..e11d5045135 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -38,6 +38,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); +with System; use type System.Address; + package body Ada.Containers.Indefinite_Ordered_Multisets is ----------------------------- @@ -298,6 +300,20 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is Adjust (Container.Tree); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + ------------- -- Ceiling -- ------------- @@ -344,6 +360,17 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads index 80e21662b29..c1d81d5b753 100644 --- a/gcc/ada/a-ciormu.ads +++ b/gcc/ada/a-ciormu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -118,6 +118,10 @@ package Ada.Containers.Indefinite_Ordered_Multisets is -- change the value of the element while Process is executing (to "tamper -- with elements") will raise Program_Error. + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + procedure Move (Target : in out Set; Source : in out Set); -- If Target denotes the same object as Source, the operation does -- nothing. If either Target or Source is busy (cursor tampering is diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 4257f0974e6..56c33cfe670 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -38,6 +38,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with Ada.Unchecked_Deallocation; +with System; use type System.Address; + package body Ada.Containers.Indefinite_Ordered_Sets is type Iterator is new @@ -321,6 +323,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Adjust (Container.Tree); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + ------------- -- Ceiling -- ------------- @@ -363,6 +379,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index f397f1d464e..c0ead018bb2 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -111,6 +111,10 @@ package Ada.Containers.Indefinite_Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + procedure Move (Target : in out Set; Source : in out Set); procedure Insert diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 16d465d5f0e..e78e3ce12d3 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -788,16 +788,26 @@ package body Ada.Containers.Bounded_Vectors is I, J : Count_Type; begin - if Target.Is_Empty then - Move (Target => Target, Source => Source); + + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then return; end if; if Target'Address = Source'Address then - return; + raise Program_Error with + "Target and Source denote same non-empty container"; end if; - if Source.Is_Empty then + if Target.Is_Empty then + Move (Target => Target, Source => Source); return; end if; diff --git a/gcc/ada/a-cogeso.adb b/gcc/ada/a-cogeso.adb new file mode 100644 index 00000000000..fc2198cb4b1 --- /dev/null +++ b/gcc/ada/a-cogeso.adb @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_SORT -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb]) + +with System; + +procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base) is + type T is range System.Min_Int .. System.Max_Int; + + function To_Index (J : T) return Index_Type; + pragma Inline (To_Index); + + function Lt (J, K : T) return Boolean; + pragma Inline (Lt); + + procedure Xchg (J, K : T); + pragma Inline (Xchg); + + procedure Sift (S : T); + + -------------- + -- To_Index -- + -------------- + + function To_Index (J : T) return Index_Type is + K : constant T'Base := Index_Type'Pos (First) + J - T'(1); + begin + return Index_Type'Val (K); + end To_Index; + + -------- + -- Lt -- + -------- + + function Lt (J, K : T) return Boolean is + begin + return Before (To_Index (J), To_Index (K)); + end Lt; + + ---------- + -- Xchg -- + ---------- + + procedure Xchg (J, K : T) is + begin + Swap (To_Index (J), To_Index (K)); + end Xchg; + + Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1); + + ---------- + -- Sift -- + ---------- + + procedure Sift (S : T) is + C : T := S; + Son : T; + Father : T; + + begin + loop + Son := C + C; + + if Son < Max then + if Lt (Son, Son + 1) then + Son := Son + 1; + end if; + elsif Son > Max then + exit; + end if; + + Xchg (Son, C); + C := Son; + end loop; + + while C /= S loop + Father := C / 2; + + if Lt (Father, C) then + Xchg (Father, C); + C := Father; + else + exit; + end if; + end loop; + end Sift; + +-- Start of processing for Generic_Sort + +begin + for J in reverse 1 .. Max / 2 loop + Sift (J); + end loop; + + while Max > 1 loop + Xchg (1, Max); + Max := Max - 1; + Sift (1); + end loop; +end Ada.Containers.Generic_Sort; diff --git a/gcc/ada/a-cogeso.ads b/gcc/ada/a-cogeso.ads new file mode 100644 index 00000000000..ebf805ab79f --- /dev/null +++ b/gcc/ada/a-cogeso.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_SORT -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +------------------------------------------------------------------------------ + +-- Allows an anonymous array (or array-like container) to be sorted. Generic +-- formal Before returns the result of comparing the elements designated by +-- the indexes, and generic formal Swap exchanges the designated elements. + +generic + type Index_Type is (<>); + with function Before (Left, Right : Index_Type) return Boolean; + with procedure Swap (Left, Right : Index_Type); + +procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base); +pragma Pure (Ada.Containers.Generic_Sort); diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index c06ba9e35e4..351030d3a7b 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -35,6 +35,8 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with System; use type System.Address; + package body Ada.Containers.Hashed_Maps is type Iterator is new @@ -131,6 +133,41 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key, New_Item => Node.Element); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + + if Target.Capacity < Source.Length then + Target.Reserve_Capacity (Source.Length); + end if; + + Insert_Items (Target.HT); + end Assign; + -------------- -- Capacity -- -------------- @@ -158,6 +195,34 @@ package body Ada.Containers.Hashed_Maps is return Find (Container, Key) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Map; + Capacity : Count_Type := 0) return Map + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Map do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- @@ -780,14 +845,36 @@ package body Ada.Containers.Hashed_Maps is -- Reference -- --------------- - function Constant_Reference (Container : Map; Key : Key_Type) - return Constant_Reference_Type is + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + pragma Unreferenced (Container); + begin + return (Element => Element (Position)'Unrestricted_Access); + end Constant_Reference; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is + pragma Unreferenced (Container); + begin + return (Element => Element (Position)'Unrestricted_Access); + end Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is begin return (Element => Container.Element (Key)'Unrestricted_Access); end Constant_Reference; - function Reference (Container : Map; Key : Key_Type) - return Reference_Type is + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is begin return (Element => Container.Element (Key)'Unrestricted_Access); end Reference; diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 0d614bd4f8f..5f01994e8ad 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -148,6 +148,10 @@ package Ada.Containers.Hashed_Maps is -- Calls Process with the key (with only a constant view) and element (with -- a variable view) of the node designed by the cursor. + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map; + procedure Move (Target : in out Map; Source : in out Map); -- Clears Target (if it's not empty), and then moves (not copies) the -- buckets array and nodes from Source to Target. @@ -307,19 +311,28 @@ package Ada.Containers.Hashed_Maps is for Reference_Type'Read use Read; function Constant_Reference - (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED - return Constant_Reference_Type; + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; - function Reference (Container : Map; Key : Key_Type) - return Reference_Type; + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); -- Calls Process for each node in the map - function Iterate (Container : Map) - return Map_Iterator_Interfaces.Forward_Iterator'class; + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class; private pragma Inline ("="); diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 643dde5d964..e0b2345234b 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -159,6 +159,16 @@ package body Ada.Containers.Hashed_Sets is Node.Element := Item; end Assign; + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + -------------- -- Capacity -- -------------- @@ -186,6 +196,34 @@ package body Ada.Containers.Hashed_Sets is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Set; + Capacity : Count_Type := 0) return Set + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Set do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index a262dded097..0bb370bfe83 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -133,6 +133,10 @@ package Ada.Containers.Hashed_Sets is -- Calls Process with the element (having only a constant view) of the node -- designed by the cursor. + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set; + procedure Move (Target : in out Set; Source : in out Set); -- Clears Target (if it's not empty), and then moves (not copies) the -- buckets array and nodes from Source to Target. diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 3172bd2c7b5..e35f2f781de 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -616,6 +616,20 @@ package body Ada.Containers.Indefinite_Vectors is Count); end Append; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Append (Source); + end Assign; + -------------- -- Capacity -- -------------- @@ -698,6 +712,34 @@ package body Ada.Containers.Indefinite_Vectors is return Find_Index (Container, Item) /= No_Index; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Count_Type := 0) return Vector + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Vector do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + ------------ -- Delete -- ------------ @@ -1226,16 +1268,26 @@ package body Ada.Containers.Indefinite_Vectors is I, J : Index_Type'Base; begin - if Target.Last < Index_Type'First then - Move (Target => Target, Source => Source); + + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Last < Index_Type'First then -- Source is empty return; end if; if Target'Address = Source'Address then - return; + raise Program_Error with + "Target and Source denote same non-empty container"; end if; - if Source.Last < Index_Type'First then + if Target.Last < Index_Type'First then -- Target is empty + Move (Target => Target, Source => Source); return; end if; diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index a13003819b0..06568278997 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -204,6 +204,10 @@ package Ada.Containers.Indefinite_Vectors is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + procedure Assign (Target : in out Vector; Source : Vector); + + function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; + procedure Move (Target : in out Vector; Source : in out Vector); procedure Insert diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index a57f7fbd9a8..79071810182 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -432,6 +432,20 @@ package body Ada.Containers.Vectors is Count); end Append; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Append (Source); + end Assign; + -------------- -- Capacity -- -------------- @@ -471,6 +485,34 @@ package body Ada.Containers.Vectors is return Find_Index (Container, Item) /= No_Index; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Count_Type := 0) return Vector + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + else + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Vector do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + ------------ -- Delete -- ------------ @@ -867,16 +909,26 @@ package body Ada.Containers.Vectors is J : Index_Type'Base; begin - if Target.Last < Index_Type'First then - Move (Target => Target, Source => Source); + + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Last < Index_Type'First then -- Source is empty return; end if; if Target'Address = Source'Address then - return; + raise Program_Error with + "Target and Source denote same non-empty container"; end if; - if Source.Last < Index_Type'First then + if Target.Last < Index_Type'First then -- Target is empty + Move (Target => Target, Source => Source); return; end if; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index c90cf01bde9..9eb82c791fe 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -202,7 +202,12 @@ package Ada.Containers.Vectors is function Reference (Container : Vector; Position : Index_Type) return Reference_Type; + procedure Assign (Target : in out Vector; Source : Vector); + + function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; + procedure Move (Target : in out Vector; Source : in out Vector); + procedure Insert (Container : in out Vector; Before : Extended_Index; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index c1ae68297b3..e8099c3c297 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -35,6 +35,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); with Ada.Containers.Red_Black_Trees.Generic_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); +with System; use type System.Address; + package body Ada.Containers.Ordered_Maps is type Iterator is new @@ -248,6 +250,37 @@ package body Ada.Containers.Ordered_Maps is Adjust (Container.Tree); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is + new Tree_Operations.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key, New_Item => Node.Element); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Insert_Items (Target.Tree); + end Assign; + ------------- -- Ceiling -- ------------- @@ -304,6 +337,17 @@ package body Ada.Containers.Ordered_Maps is return Find (Container, Key) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : Map) return Map is + begin + return Target : Map do + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 6fd45b78253..53942b71fa2 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -96,6 +96,10 @@ package Ada.Containers.Ordered_Maps is Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map) return Map; + procedure Move (Target : in out Map; Source : in out Map); procedure Insert diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index b59f6f554ef..2ed14819243 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -38,6 +38,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); +with System; use type System.Address; + package body Ada.Containers.Ordered_Multisets is ----------------------------- @@ -266,6 +268,20 @@ package body Ada.Containers.Ordered_Multisets is Adjust (Container.Tree); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + ------------- -- Ceiling -- ------------- @@ -312,6 +328,17 @@ package body Ada.Containers.Ordered_Multisets is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads index bcc6eb5e9b8..6f9e3d0b2d8 100644 --- a/gcc/ada/a-coormu.ads +++ b/gcc/ada/a-coormu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -117,6 +117,10 @@ package Ada.Containers.Ordered_Multisets is -- change the value of the element while Process is executing (to "tamper -- with elements") will raise Program_Error. + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + procedure Move (Target : in out Set; Source : in out Set); -- If Target denotes the same object as Source, the operation does -- nothing. If either Target or Source is busy (cursor tampering is diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 915eed62117..4c6476864b8 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -38,6 +38,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); +with System; use type System.Address; + package body Ada.Containers.Ordered_Sets is type Iterator is new @@ -281,6 +283,20 @@ package body Ada.Containers.Ordered_Sets is Adjust (Container.Tree); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + ------------- -- Ceiling -- ------------- @@ -325,6 +341,17 @@ package body Ada.Containers.Ordered_Sets is return Find (Container, Item) /= No_Element; end Contains; + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + --------------- -- Copy_Node -- --------------- diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 8349ef85fb4..45e6ab90a73 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -113,6 +113,10 @@ package Ada.Containers.Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + procedure Move (Target : in out Set; Source : in out Set); procedure Insert diff --git a/gcc/ada/i-forbla-darwin.adb b/gcc/ada/a-sbecin.adb index 825a8840414..78000176844 100644 --- a/gcc/ada/i-forbla-darwin.adb +++ b/gcc/ada/a-sbecin.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME COMPONENTS -- +-- GNAT LIBRARY COMPONENTS -- -- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- +-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- -- -- --- B o d y -- +-- B o d y -- -- -- --- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,15 +24,17 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- Version for Mac OS X +with Ada.Strings.Equal_Case_Insensitive; -package body Interfaces.Fortran.BLAS is - pragma Linker_Options ("-lgnala"); - pragma Linker_Options ("-lm"); - pragma Linker_Options ("-Wl,-framework,vecLib"); -end Interfaces.Fortran.BLAS; +function Ada.Strings.Bounded.Equal_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean +is +begin + return Ada.Strings.Equal_Case_Insensitive + (Left => Bounded.To_String (Left), + Right => Bounded.To_String (Right)); +end Ada.Strings.Bounded.Equal_Case_Insensitive; diff --git a/gcc/ada/i-forbla.adb b/gcc/ada/a-sbecin.ads index 4445c5124cb..115c7220606 100644 --- a/gcc/ada/i-forbla.adb +++ b/gcc/ada/a-sbecin.ads @@ -1,12 +1,16 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME COMPONENTS -- +-- GNAT LIBRARY COMPONENTS -- -- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- +-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- -- -- --- B o d y -- +-- S p e c -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,19 +28,15 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- This Interfaces.Fortran.Blas package body contains the required linker --- pragmas for automatically linking with the LAPACK linear algebra support --- library, and the systems math library. Alternative bodies can be supplied --- if different sets of libraries are needed. +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Equal_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean; -package body Interfaces.Fortran.BLAS is - pragma Linker_Options ("-lgnala"); - pragma Linker_Options ("-llapack"); - pragma Linker_Options ("-lblas"); - pragma Linker_Options ("-lm"); -end Interfaces.Fortran.BLAS; +pragma Preelaborate (Ada.Strings.Bounded.Equal_Case_Insensitive); diff --git a/gcc/ada/a-sbhcin.adb b/gcc/ada/a-sbhcin.adb new file mode 100644 index 00000000000..8c69290e0d0 --- /dev/null +++ b/gcc/ada/a-sbhcin.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Bounded.Hash_Case_Insensitive + (Key : Bounded.Bounded_String) + return Containers.Hash_Type +is +begin + return Ada.Strings.Hash_Case_Insensitive (Bounded.To_String (Key)); +end Ada.Strings.Bounded.Hash_Case_Insensitive; diff --git a/gcc/ada/i-forbla-unimplemented.ads b/gcc/ada/a-sbhcin.ads index deea344bbf2..c291f53db9a 100644 --- a/gcc/ada/i-forbla-unimplemented.ads +++ b/gcc/ada/a-sbhcin.ads @@ -1,12 +1,16 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME COMPONENTS -- +-- GNAT LIBRARY COMPONENTS -- -- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- +-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,22 +28,17 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- This package provides a thin binding to the standard Fortran BLAS library. --- Documentation and a reference BLAS implementation is available from --- ftp://ftp.netlib.org. The main purpose of this package is to facilitate --- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and --- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS --- routines may be added over time. - --- This unit is not implemented in this GNAT configuration +with Ada.Containers; -package Interfaces.Fortran.BLAS is +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); - pragma Unimplemented_Unit; +function Ada.Strings.Bounded.Hash_Case_Insensitive + (Key : Bounded.Bounded_String) + return Containers.Hash_Type; -end Interfaces.Fortran.BLAS; +pragma Preelaborate (Ada.Strings.Bounded.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sblcin.adb b/gcc/ada/a-sblcin.adb new file mode 100644 index 00000000000..e2ce4d3f384 --- /dev/null +++ b/gcc/ada/a-sblcin.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Bounded.Less_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean +is +begin + return Ada.Strings.Less_Case_Insensitive + (Left => Bounded.To_String (Left), + Right => Bounded.To_String (Right)); +end Ada.Strings.Bounded.Less_Case_Insensitive; diff --git a/gcc/ada/a-sblcin.ads b/gcc/ada/a-sblcin.ads new file mode 100644 index 00000000000..d7284110aef --- /dev/null +++ b/gcc/ada/a-sblcin.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Less_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Bounded.Less_Case_Insensitive); diff --git a/gcc/ada/a-sfecin.ads b/gcc/ada/a-sfecin.ads new file mode 100644 index 00000000000..592b69166c9 --- /dev/null +++ b/gcc/ada/a-sfecin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Equal_Case_Insensitive; + +function Ada.Strings.Fixed.Equal_Case_Insensitive + (Left, Right : String) + return Boolean renames Ada.Strings.Equal_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Equal_Case_Insensitive); diff --git a/gcc/ada/a-sfhcin.ads b/gcc/ada/a-sfhcin.ads new file mode 100644 index 00000000000..86f60f68944 --- /dev/null +++ b/gcc/ada/a-sfhcin.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Fixed.Hash_Case_Insensitive + (Key : String) + return Containers.Hash_Type renames Ada.Strings.Hash_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sflcin.ads b/gcc/ada/a-sflcin.ads new file mode 100644 index 00000000000..8af21fe9e55 --- /dev/null +++ b/gcc/ada/a-sflcin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Fixed.Less_Case_Insensitive + (Left, Right : String) + return Boolean renames Ada.Strings.Less_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Less_Case_Insensitive); diff --git a/gcc/ada/a-suecin.adb b/gcc/ada/a-suecin.adb new file mode 100644 index 00000000000..73ebae57156 --- /dev/null +++ b/gcc/ada/a-suecin.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Equal_Case_Insensitive; + +function Ada.Strings.Unbounded.Equal_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean +is + SL, SR : Aux.Big_String_Access; + LL, LR : Natural; + +begin + Aux.Get_String (Left, SL, LL); + Aux.Get_String (Right, SR, LR); + + return Ada.Strings.Equal_Case_Insensitive + (Left => SL (1 .. LL), + Right => SR (1 .. LR)); +end Ada.Strings.Unbounded.Equal_Case_Insensitive; diff --git a/gcc/ada/a-suecin.ads b/gcc/ada/a-suecin.ads new file mode 100644 index 00000000000..08960241c8e --- /dev/null +++ b/gcc/ada/a-suecin.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Unbounded.Equal_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Unbounded.Equal_Case_Insensitive); diff --git a/gcc/ada/a-suhcin.adb b/gcc/ada/a-suhcin.adb new file mode 100644 index 00000000000..0417c15db24 --- /dev/null +++ b/gcc/ada/a-suhcin.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Unbounded.Hash_Case_Insensitive + (Key : Unbounded.Unbounded_String) + return Containers.Hash_Type +is + S : Aux.Big_String_Access; + L : Natural; + +begin + Aux.Get_String (Key, S, L); + return Ada.Strings.Hash_Case_Insensitive (S (1 .. L)); +end Ada.Strings.Unbounded.Hash_Case_Insensitive; diff --git a/gcc/ada/a-suhcin.ads b/gcc/ada/a-suhcin.ads new file mode 100644 index 00000000000..180d4a4391a --- /dev/null +++ b/gcc/ada/a-suhcin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Unbounded.Hash_Case_Insensitive + (Key : Unbounded.Unbounded_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Unbounded.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sulcin.adb b/gcc/ada/a-sulcin.adb new file mode 100644 index 00000000000..9f1f3c4aca9 --- /dev/null +++ b/gcc/ada/a-sulcin.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Unbounded.Less_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean +is + SL, SR : Aux.Big_String_Access; + LL, LR : Natural; + +begin + Aux.Get_String (Left, SL, LL); + Aux.Get_String (Right, SR, LR); + + return Ada.Strings.Less_Case_Insensitive + (Left => SL (1 .. LL), + Right => SR (1 .. LR)); +end Ada.Strings.Unbounded.Less_Case_Insensitive; diff --git a/gcc/ada/a-sulcin.ads b/gcc/ada/a-sulcin.ads new file mode 100644 index 00000000000..fafb546ca77 --- /dev/null +++ b/gcc/ada/a-sulcin.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Unbounded.Less_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Unbounded.Less_Case_Insensitive); diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 48a1c89e700..9b707734b76 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -127,7 +127,19 @@ package body Aspects is Ritem : Node_Id; begin - Ritem := First_Rep_Item (Ent); + + -- If the aspect is an inherited one and the entity is a class-wide + -- type, use the aspect of the specific type. + + if Is_Type (Ent) + and then Is_Class_Wide_Type (Ent) + and then Inherited_Aspect (A) + then + Ritem := First_Rep_Item (Etype (Ent)); + else + Ritem := First_Rep_Item (Ent); + end if; + while Present (Ritem) loop if Nkind (Ritem) = N_Aspect_Specification and then Get_Aspect_Id (Chars (Identifier (Ritem))) = A diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index dfca9b12af1..582a71e7a55 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -176,6 +176,18 @@ package Aspects is (Aspect_Test_Case => False, others => True); + -- The following array indicates type aspects that are inherited and apply + -- to the class-wide type as well. + + Inherited_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Implicit_Dereference => True, + Aspect_Iterator_Element => True, + Aspect_Remote_Types => True, + Aspect_Variable_Indexing => True, + others => False); + -- The following subtype defines aspects corresponding to library unit -- pragmas, these can only validly appear as aspects for library units, -- and result in a corresponding pragma being inserted immediately after diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 17c6814fb90..793da138861 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1797,6 +1797,15 @@ package body Atree is Nodes.Table (N).Has_Aspects := Val; end Set_Has_Aspects; + ----------------------- + -- Set_Original_Node -- + ----------------------- + + procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is + begin + Orig_Nodes.Table (N) := Val; + end Set_Original_Node; + --------------------- -- Set_Paren_Count -- --------------------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 4e20b0b0f00..305e914f97c 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -151,14 +151,14 @@ package Atree is -- it is useful to be able to do untyped traversals, and an internal -- package in Atree allows for direct untyped accesses in such cases. - -- Flag4 Sixteen Boolean flags (use depends on Nkind and + -- Flag4 Fifteen Boolean flags (use depends on Nkind and -- Flag5 Ekind, as described for FieldN). Again the access -- Flag6 is usually via subprograms in Sinfo and Einfo which -- Flag7 provide high-level synonyms for these flags, and -- Flag8 contain debugging code that checks that the values -- Flag9 in Nkind and Ekind are appropriate for the access. -- Flag10 - -- Flag11 Note that Flag1-2 are missing from this list. For + -- Flag11 Note that Flag1-3 are missing from this list. For -- Flag12 historical reasons, these flag names are unused. -- Flag13 -- Flag14 @@ -761,6 +761,14 @@ package Atree is procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True); pragma Inline (Set_Has_Aspects); + procedure Set_Original_Node (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Original_Node); + -- Note that this routine is used only in very peculiar cases. In normal + -- cases, the Original_Node link is set by calls to Rewrite. We currently + -- use it in ASIS mode to manually set the link from pragma expressions + -- to their aspect original source expressions, so that the original source + -- expressions accessed by ASIS are also semantically analyzed. + ------------------------------ -- Entity Update Procedures -- ------------------------------ @@ -887,9 +895,13 @@ package Atree is ----------------------------------- -- This subpackage provides the functions for accessing and procedures for - -- setting fields that are normally referenced by their logical synonyms - -- defined in packages Sinfo and Einfo. The implementations of these - -- packages use the package Atree.Unchecked_Access. + -- setting fields that are normally referenced by wrapper subprograms (e.g. + -- logical synonyms defined in packages Sinfo and Einfo, or specialized + -- routines such as Rewrite (for Original_Node), or the node creation + -- routines (for Set_Nkind). The implementations of these wrapper + -- subprograms use the package Atree.Unchecked_Access as do various + -- special case accesses where no wrapper applies. Documentation is always + -- required for such a special case access explaining why it is needed. package Unchecked_Access is diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index d75fe06c51b..a4b7d394deb 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -1050,9 +1050,8 @@ package body Bindgen is or else U.Unit_Kind /= 's') then - -- The only case in which we have to do something is if this - -- is a body, with a separate spec, where the separate spec - -- has an elaboration entity defined. In that case, this is + -- In the case of a body with a separate spec, where the + -- separate spec has an elaboration entity defined, this is -- where we increment the elaboration entity. if U.Utype = Is_Body @@ -1061,9 +1060,39 @@ package body Bindgen is then Set_String (" E"); Set_Unit_Number (Unum_Spec); - Set_String (" := E"); + + -- The AAMP target has no notion of shared libraries, and + -- there's no possibility of reelaboration, so we treat the + -- the elaboration var as a flag instead of a counter and + -- simply set it. + + if AAMP_On_Target then + Set_String (" := 1;"); + + -- Otherwise (normal case), increment elaboration counter + + else + Set_String (" := E"); + Set_Unit_Number (Unum_Spec); + Set_String (" + 1;"); + end if; + + Write_Statement_Buffer; + + -- In the special case where the target is AAMP and the unit is + -- a spec with a body, the elaboration entity is initialized + -- here. This is done because it's the only way to accomplish + -- initialization of such entities, as there is no mechanism + -- provided for initializing global variables at load time on + -- AAMP. + + elsif AAMP_On_Target + and then U.Utype = Is_Spec + and then Units.Table (Unum_Spec).Set_Elab_Entity + then + Set_String (" E"); Set_Unit_Number (Unum_Spec); - Set_String (" + 1;"); + Set_String (" := 0;"); Write_Statement_Buffer; end if; @@ -1087,6 +1116,23 @@ package body Bindgen is -- variables, only calls to 'Elab* subprograms. else + -- In the special case where the target is AAMP and the unit is + -- a spec with a body, the elaboration entity is initialized + -- here. This is done because it's the only way to accomplish + -- initialization of such entities, as there is no mechanism + -- provided for initializing global variables at load time on + -- AAMP. + + if AAMP_On_Target + and then U.Utype = Is_Spec + and then Units.Table (Unum_Spec).Set_Elab_Entity + then + Set_String (" E"); + Set_Unit_Number (Unum_Spec); + Set_String (" := 0;"); + Write_Statement_Buffer; + end if; + Check_Elab_Flag := not CodePeer_Mode and then (Force_Checking_Of_Elaboration_Flags @@ -1151,9 +1197,23 @@ package body Bindgen is then Set_String (" E"); Set_Unit_Number (Unum_Spec); - Set_String (" := E"); - Set_Unit_Number (Unum_Spec); - Set_String (" + 1;"); + + -- The AAMP target has no notion of shared libraries, and + -- there's no possibility of reelaboration, so we treat the + -- the elaboration var as a flag instead of a counter and + -- simply set it. + + if AAMP_On_Target then + Set_String (" := 1;"); + + -- Otherwise (normal case), increment elaboration counter + + else + Set_String (" := E"); + Set_Unit_Number (Unum_Spec); + Set_String (" + 1;"); + end if; + Write_Statement_Buffer; end if; end if; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index f3234865dbd..67febfe1919 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2565,8 +2565,25 @@ package body Checks is function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is begin - if Present (E) and then Checks_May_Be_Suppressed (E) then + -- If debug flag d.e is set, always return False, i.e. all atomic sync + -- looks enabled, since it is never disabled. + + if Debug_Flag_Dot_E then + return False; + + -- If debug flag d.d is set then always return True, i.e. all atomic + -- sync looks disabled, since it always tests True. + + elsif Debug_Flag_Dot_D then + return True; + + -- If entity present, then check result for that entity + + elsif Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Atomic_Synchronization); + + -- Otherwise result depends on current scope setting + else return Scope_Suppress (Atomic_Synchronization); end if; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 88482898a92..5993132cf81 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -439,7 +439,6 @@ package body Errout is Error_Msg_Internal ("?in inlined body #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); - else Error_Msg_Internal ("error in inlined body #", @@ -453,7 +452,6 @@ package body Errout is Error_Msg_Internal ("?in instantiation #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); - else Error_Msg_Internal ("instantiation error #", diff --git a/gcc/ada/exp_alfa.adb b/gcc/ada/exp_alfa.adb index 988d16fba1f..ab0e40fae5b 100644 --- a/gcc/ada/exp_alfa.adb +++ b/gcc/ada/exp_alfa.adb @@ -29,10 +29,12 @@ with Exp_Attr; use Exp_Attr; with Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; with Nlists; use Nlists; with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -56,12 +58,19 @@ package body Exp_Alfa is procedure Expand_Alfa_N_In (N : Node_Id); -- Expand set membership into individual ones + procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id); + -- Perform name evaluation for a renamed object + procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id); -- Insert conversion on function return if necessary procedure Expand_Alfa_Simple_Function_Return (N : Node_Id); -- Expand simple return from function + procedure Expand_Potential_Renaming (N : Node_Id); + -- N denotes a N_Identifier or N_Expanded_Name. If N references a renaming, + -- replace N with the renamed object. + ----------------- -- Expand_Alfa -- ----------------- @@ -69,22 +78,22 @@ package body Exp_Alfa is procedure Expand_Alfa (N : Node_Id) is begin case Nkind (N) is + when N_Attribute_Reference => + Expand_Alfa_N_Attribute_Reference (N); - when N_Package_Body | + when N_Block_Statement | + N_Package_Body | N_Package_Declaration | - N_Subprogram_Body | - N_Block_Statement => + N_Subprogram_Body => Qualify_Entity_Names (N); - when N_Simple_Return_Statement => - Expand_Alfa_N_Simple_Return_Statement (N); - when N_Function_Call | N_Procedure_Call_Statement => Expand_Alfa_Call (N); - when N_Attribute_Reference => - Expand_Alfa_N_Attribute_Reference (N); + when N_Expanded_Name | + N_Identifier => + Expand_Potential_Renaming (N); when N_In => Expand_Alfa_N_In (N); @@ -92,6 +101,12 @@ package body Exp_Alfa is when N_Not_In => Expand_N_Not_In (N); + when N_Object_Renaming_Declaration => + Expand_Alfa_N_Object_Renaming_Declaration (N); + + when N_Simple_Return_Statement => + Expand_Alfa_N_Simple_Return_Statement (N); + when others => null; end case; @@ -157,7 +172,6 @@ package body Exp_Alfa is Set_Entity (Name (Call_Node), Parent_Subp); end if; - end Expand_Alfa_Call; --------------------------------------- @@ -186,10 +200,20 @@ package body Exp_Alfa is begin if Present (Alternatives (N)) then Expand_Set_Membership (N); - return; end if; end Expand_Alfa_N_In; + ----------------------------------------------- + -- Expand_Alfa_N_Object_Renaming_Declaration -- + ----------------------------------------------- + + procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id) is + begin + -- Unconditionally remove all side effects from the name + + Evaluate_Name (Name (N)); + end Expand_Alfa_N_Object_Renaming_Declaration; + ------------------------------------------- -- Expand_Alfa_N_Simple_Return_Statement -- ------------------------------------------- @@ -218,7 +242,6 @@ package body Exp_Alfa is E_Entry | E_Entry_Family | E_Return_Statement => - -- Expand_Non_Function_Return (N); null; when others => @@ -265,4 +288,22 @@ package body Exp_Alfa is end if; end Expand_Alfa_Simple_Function_Return; + ------------------------------- + -- Expand_Potential_Renaming -- + ------------------------------- + + procedure Expand_Potential_Renaming (N : Node_Id) is + E : constant Entity_Id := Entity (N); + T : constant Entity_Id := Etype (N); + + begin + -- Replace a reference to a renaming with the actual renamed object + + if Ekind (E) in Object_Kind and then Present (Renamed_Object (E)) then + Rewrite (N, New_Copy_Tree (Renamed_Object (E))); + Reset_Analyzed_Flags (N); + Analyze_And_Resolve (N, T); + end if; + end Expand_Potential_Renaming; + end Exp_Alfa; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index db8f6a30d5d..57e94d29840 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4046,13 +4046,13 @@ package body Exp_Attr is X : constant Node_Id := Prefix (N); Y : constant Node_Id := First (Expressions (N)); - -- The argumens + -- The arguments X_Addr, Y_Addr : Node_Id; - -- the expressions for their addresses + -- Rhe expressions for their addresses X_Size, Y_Size : Node_Id; - -- the expressions for their sizes + -- Rhe expressions for their sizes begin -- The attribute is expanded as: diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index dca021f9237..b2bf98cd1db 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -334,7 +334,7 @@ package body Exp_Ch11 is -- raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are -- left unchanged and passed to the back end. - -- Instead, the front end generates two nodes + -- Instead, the front end generates three nodes -- N_Push_Constraint_Error_Label -- N_Push_Program_Error_Label @@ -356,6 +356,10 @@ package body Exp_Ch11 is -- field in the Push node will be empty signifying that for this region -- of code, no optimization is possible. + -- These Push/Pop nodes are inhibited if No_Exception_Handlers is set + -- since they are useless in this case, and in CodePeer mode, where + -- they serve no purpose and can intefere with the analysis. + -- The back end must maintain three stacks, one for each exception case, -- the Push node pushes an entry onto the corresponding stack, and Pop -- node pops off the entry. Then instead of calling Rcheck_nn, if the @@ -503,6 +507,12 @@ package body Exp_Ch11 is procedure Generate_Push_Pop (H : Node_Id) is begin + if Restriction_Active (No_Exception_Handlers) + or else CodePeer_Mode + then + return; + end if; + if Exc_Locally_Handled then return; else diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index a71ce69602e..80f381b82a1 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -401,46 +401,39 @@ package body Exp_Ch2 is -- Set Atomic_Sync_Required if necessary for atomic variable - if Is_Atomic (E) then + if Nkind_In (N, N_Identifier, N_Expanded_Name) + and then Ekind (E) = E_Variable + and then (Is_Atomic (E) or else Is_Atomic (Etype (E))) + then declare Set : Boolean; - MLoc : Node_Id; begin - -- Always set if debug flag d.e is set + -- If variable is atomic, but type is not, setting depends on + -- disable/enable state for the variable. - if Debug_Flag_Dot_E then - Set := True; + if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then + Set := not Atomic_Synchronization_Disabled (E); - -- Never set if debug flag d.d is set + -- If variable is not atomic, but its type is atomic, setting + -- depends on disable/enable state for the type. - elsif Debug_Flag_Dot_D then - Set := False; + elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then + Set := not Atomic_Synchronization_Disabled (Etype (E)); - -- Otherwise setting comes from Atomic_Synchronization state + -- Else both variable and type are atomic (see outer if), and we + -- disable if either variable or its type have sync disabled. else - Set := not Atomic_Synchronization_Disabled (E); + Set := (not Atomic_Synchronization_Disabled (E)) + and then + (not Atomic_Synchronization_Disabled (Etype (E))); end if; -- Set flag if required if Set then - - -- Generate info message if requested - - if Warn_On_Atomic_Synchronization then - if Nkind (N) = N_Identifier then - MLoc := N; - else - MLoc := Selector_Name (N); - end if; - - Error_Msg_N - ("?info: atomic synchronization set for &", MLoc); - end if; - - Set_Atomic_Sync_Required (N); + Activate_Atomic_Synchronization (N); end if; end; end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 87e02d0e1ee..d2f0668873e 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -591,8 +591,7 @@ package body Exp_Ch4 is -- 1) Get access to the allocated object Rewrite (N, - Make_Explicit_Dereference (Loc, - Relocate_Node (N))); + Make_Explicit_Dereference (Loc, Relocate_Node (N))); Set_Etype (N, Etyp); Set_Analyzed (N); @@ -2615,12 +2614,7 @@ package body Exp_Ch4 is -- Result of the concatenation (of type Ityp) Actions : constant List_Id := New_List; - -- Collect actions to be inserted if Save_Space is False - - Save_Space : Boolean; - pragma Warnings (Off, Save_Space); - -- Set to True if we are saving generated code space by calling routines - -- in packages System.Concat_n. + -- Collect actions to be inserted Known_Non_Null_Operand_Seen : Boolean; -- Set True during generation of the assignments of operands into @@ -4472,6 +4466,15 @@ package body Exp_Ch4 is -- Insert explicit dereference call for the checked storage pool case Insert_Dereference_Action (Prefix (N)); + + -- If the type is an Atomic type for which Atomic_Sync is enabled, then + -- we set the atomic sync flag. + + if Is_Atomic (Etype (N)) + and then not Atomic_Synchronization_Disabled (Etype (N)) + then + Activate_Atomic_Synchronization (N); + end if; end Expand_N_Explicit_Dereference; -------------------------------------- @@ -5245,6 +5248,7 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (N); P : constant Node_Id := Prefix (N); T : constant Entity_Id := Etype (P); + Atp : Entity_Id; begin -- A special optimization, if we have an indexed component that is @@ -5290,6 +5294,9 @@ package body Exp_Ch4 is if Is_Access_Type (T) then Insert_Explicit_Dereference (P); Analyze_And_Resolve (P, Designated_Type (T)); + Atp := Designated_Type (T); + else + Atp := T; end if; -- Generate index and validity checks @@ -5300,6 +5307,17 @@ package body Exp_Ch4 is Apply_Subscript_Validity_Checks (N); end if; + -- If selecting from an array with atomic components, and atomic sync + -- is not suppressed for this array type, set atomic sync flag. + + if (Has_Atomic_Components (Atp) + and then not Atomic_Synchronization_Disabled (Atp)) + or else (Is_Atomic (Typ) + and then not Atomic_Synchronization_Disabled (Typ)) + then + Activate_Atomic_Synchronization (N); + end if; + -- All done for the non-packed case if not Is_Packed (Etype (Prefix (N))) then @@ -7869,9 +7887,6 @@ package body Exp_Ch4 is -- Expand_N_Selected_Component -- --------------------------------- - -- If the selector is a discriminant of a concurrent object, rewrite the - -- prefix to denote the corresponding record type. - procedure Expand_N_Selected_Component (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Par : constant Node_Id := Parent (N); @@ -8175,6 +8190,46 @@ package body Exp_Ch4 is Rewrite (N, New_N); Analyze (N); end if; + + -- Set Atomic_Sync_Required if necessary for atomic component + + if Nkind (N) = N_Selected_Component then + declare + E : constant Entity_Id := Entity (Selector_Name (N)); + Set : Boolean; + + begin + -- If component is atomic, but type is not, setting depends on + -- disable/enable state for the component. + + if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then + Set := not Atomic_Synchronization_Disabled (E); + + -- If component is not atomic, but its type is atomic, setting + -- depends on disable/enable state for the type. + + elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then + Set := not Atomic_Synchronization_Disabled (Etype (E)); + + -- If both component and type are atomic, we disable if either + -- component or its type have sync disabled. + + elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then + Set := (not Atomic_Synchronization_Disabled (E)) + and then + (not Atomic_Synchronization_Disabled (Etype (E))); + + else + Set := False; + end if; + + -- Set flag if required + + if Set then + Activate_Atomic_Synchronization (N); + end if; + end; + end if; end Expand_N_Selected_Component; -------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 971d0ad65d2..fd75b158449 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1461,7 +1461,22 @@ package body Exp_Ch5 is end if; if Is_Unchecked_Union (Base_Type (R_Typ)) then - Insert_Action (N, Make_Field_Assign (CF, True)); + + -- Within an initialization procedure this is the + -- assignment to an unchecked union component, in which + -- case there is no discriminant to initialize. + + if Inside_Init_Proc then + null; + + else + -- The assignment is part of a conversion from a + -- derived unchecked union type with an inferable + -- discriminant, to a parent type. + + Insert_Action (N, Make_Field_Assign (CF, True)); + end if; + else Insert_Action (N, Make_Field_Assign (CF)); end if; @@ -3105,32 +3120,32 @@ package body Exp_Ch5 is end loop; -- Generate: - -- Id : Element_Type renames Pack.Element (Cursor); + -- Id : Element_Type renames Container (Cursor); + -- This assumes that the container type has an indexing + -- operation with Cursor. The check that this operation + -- exists is performed in Check_Container_Indexing. Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, - Subtype_Mark => + Subtype_Mark => New_Reference_To (Element_Type, Loc), - Name => + Name => Make_Indexed_Component (Loc, - Prefix => Make_Selected_Component (Loc, - Prefix => New_Reference_To (Pack, Loc), - Selector_Name => - Make_Identifier (Loc, Chars => Name_Element)), + Prefix => Relocate_Node (Container_Arg), Expressions => New_List (New_Occurrence_Of (Cursor, Loc)))); -- If the container holds controlled objects, wrap the loop -- statements and element renaming declaration with a block. - -- This ensures that the result of Element (Iterator) is + -- This ensures that the result of Element (Cusor) is -- cleaned up after each iteration of the loop. if Needs_Finalization (Element_Type) then -- Generate: -- declare - -- Id : Element_Type := Pack.Element (Iterator); + -- Id : Element_Type := Pack.Element (curosr); -- begin -- <original loop statements> -- end; @@ -3264,9 +3279,11 @@ package body Exp_Ch5 is -- The Iterator is not modified in the source, but of course will -- be updated in the generated code. Indicate that it is actually - -- set to prevent spurious warnings. + -- set to prevent spurious warnings. Ditto for the Cursor, which + -- is modified indirectly in generated code. Set_Never_Set_In_Source (Iterator, False); + Set_Never_Set_In_Source (Cursor, False); -- If the range of iteration is given by a function call that -- returns a container, the finalization actions have been saved diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 993fa40c3fa..6049c452cb8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2652,10 +2652,13 @@ package body Exp_Ch6 is end if; end if; - -- For Ada 2012, if a parameter is aliased, the actual must be an - -- aliased object. + -- For Ada 2012, if a parameter is aliased, the actual must be a + -- tagged type or an aliased view of an object. - if Is_Aliased (Formal) and then not Is_Aliased_View (Actual) then + if Is_Aliased (Formal) + and then not Is_Aliased_View (Actual) + and then not Is_Tagged_Type (Etype (Formal)) + then Error_Msg_NE ("actual for aliased formal& must be aliased object", Actual, Formal); @@ -5679,10 +5682,14 @@ package body Exp_Ch6 is end if; -- If local-exception-to-goto optimization active, insert dummy push - -- statements at start, and dummy pop statements at end. + -- statements at start, and dummy pop statements at end, but inhibit + -- this if we have No_Exception_Handlers, since they are useless and + -- intefere with analysis, e.g. by codepeer. if (Debug_Flag_Dot_G or else Restriction_Active (No_Exception_Propagation)) + and then not Restriction_Active (No_Exception_Handlers) + and then not CodePeer_Mode and then Is_Non_Empty_List (L) then declare diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index af33868b799..a0e9d4cf1be 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -50,7 +50,6 @@ package body Exp_Ch8 is procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is Decl : constant Node_Id := Debug_Renaming_Declaration (N); - begin if Present (Decl) then Insert_Action (N, Decl); @@ -91,114 +90,17 @@ package body Exp_Ch8 is procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is Nam : constant Node_Id := Name (N); - T : Entity_Id; Decl : Node_Id; - - procedure Evaluate_Name (Fname : Node_Id); - -- A recursive procedure used to freeze a name in the sense described - -- above, i.e. any variable references or function calls are removed. - -- Of course the outer level variable reference must not be removed. - -- For example in A(J,F(K)), A is left as is, but J and F(K) are - -- evaluated and removed. + T : Entity_Id; function Evaluation_Required (Nam : Node_Id) return Boolean; - -- Determines whether it is necessary to do static name evaluation - -- for renaming of Nam. It is considered necessary if evaluating the - -- name involves indexing a packed array, or extracting a component - -- of a record to which a component clause applies. Note that we are - -- only interested in these operations if they occur as part of the - -- name itself, subscripts are just values that are computed as part - -- of the evaluation, so their form is unimportant. - - ------------------- - -- Evaluate_Name -- - ------------------- - - procedure Evaluate_Name (Fname : Node_Id) is - K : constant Node_Kind := Nkind (Fname); - E : Node_Id; - - begin - -- For an explicit dereference, we simply force the evaluation - -- of the name expression. The dereference provides a value that - -- is the address for the renamed object, and it is precisely - -- this value that we want to preserve. - - if K = N_Explicit_Dereference then - Force_Evaluation (Prefix (Fname)); - - -- For a selected component, we simply evaluate the prefix - - elsif K = N_Selected_Component then - Evaluate_Name (Prefix (Fname)); - - -- For an indexed component, or an attribute reference, we evaluate - -- the prefix, which is itself a name, recursively, and then force - -- the evaluation of all the subscripts (or attribute expressions). - - elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then - Evaluate_Name (Prefix (Fname)); - - E := First (Expressions (Fname)); - while Present (E) loop - Force_Evaluation (E); - - if Original_Node (E) /= E then - Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); - end if; - - Next (E); - end loop; - - -- For a slice, we evaluate the prefix, as for the indexed component - -- case and then, if there is a range present, either directly or - -- as the constraint of a discrete subtype indication, we evaluate - -- the two bounds of this range. - - elsif K = N_Slice then - Evaluate_Name (Prefix (Fname)); - - declare - DR : constant Node_Id := Discrete_Range (Fname); - Constr : Node_Id; - Rexpr : Node_Id; - - begin - if Nkind (DR) = N_Range then - Force_Evaluation (Low_Bound (DR)); - Force_Evaluation (High_Bound (DR)); - - elsif Nkind (DR) = N_Subtype_Indication then - Constr := Constraint (DR); - - if Nkind (Constr) = N_Range_Constraint then - Rexpr := Range_Expression (Constr); - - Force_Evaluation (Low_Bound (Rexpr)); - Force_Evaluation (High_Bound (Rexpr)); - end if; - end if; - end; - - -- For a type conversion, the expression of the conversion must be - -- the name of an object, and we simply need to evaluate this name. - - elsif K = N_Type_Conversion then - Evaluate_Name (Expression (Fname)); - - -- For a function call, we evaluate the call - - elsif K = N_Function_Call then - Force_Evaluation (Fname); - - -- The remaining cases are direct name, operator symbol and - -- character literal. In all these cases, we do nothing, since - -- we want to reevaluate each time the renamed object is used. - - else - return; - end if; - end Evaluate_Name; + -- Determines whether it is necessary to do static name evaluation for + -- renaming of Nam. It is considered necessary if evaluating the name + -- involves indexing a packed array, or extracting a component of a + -- record to which a component clause applies. Note that we are only + -- interested in these operations if they occur as part of the name + -- itself, subscripts are just values that are computed as part of the + -- evaluation, so their form is unimportant. ------------------------- -- Evaluation_Required -- diff --git a/gcc/ada/exp_ch8.ads b/gcc/ada/exp_ch8.ads index 7df54f3069a..1dc066c0f4b 100644 --- a/gcc/ada/exp_ch8.ads +++ b/gcc/ada/exp_ch8.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index dd58b017d24..e675da82889 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -160,6 +160,76 @@ package body Exp_Util is -- or body. Flag Nested_Constructs should be set when any nested packages -- declared in L must be processed. + ------------------------------------- + -- Activate_Atomic_Synchronization -- + ------------------------------------- + + procedure Activate_Atomic_Synchronization (N : Node_Id) is + Msg_Node : Node_Id; + + begin + case Nkind (Parent (N)) is + + -- Check for cases of appearing in the prefix of a construct where + -- we don't need atomic synchronization for this kind of usage. + + when + -- Nothing to do if we are the prefix of an attribute, since we + -- do not want an atomic sync operation for things like 'Size. + + N_Attribute_Reference | + + -- The N_Reference node is like an attribute + + N_Reference | + + -- Nothing to do for a reference to a component (or components) + -- of a composite object. Only reads and updates of the object + -- as a whole require atomic synchronization (RM C.6 (15)). + + N_Indexed_Component | + N_Selected_Component | + N_Slice => + + -- For all the above cases, nothing to do if we are the prefix + + if Prefix (Parent (N)) = N then + return; + end if; + + when others => null; + end case; + + -- Go ahead and set the flag + + Set_Atomic_Sync_Required (N); + + -- Generate info message if requested + + if Warn_On_Atomic_Synchronization then + case Nkind (N) is + when N_Identifier => + Msg_Node := N; + + when N_Selected_Component | N_Expanded_Name => + Msg_Node := Selector_Name (N); + + when N_Explicit_Dereference | N_Indexed_Component => + Msg_Node := Empty; + + when others => + pragma Assert (False); + return; + end case; + + if Present (Msg_Node) then + Error_Msg_N ("?info: atomic synchronization set for &", Msg_Node); + else + Error_Msg_N ("?info: atomic synchronization set", N); + end if; + end if; + end Activate_Atomic_Synchronization; + ---------------------- -- Adjust_Condition -- ---------------------- @@ -1689,6 +1759,100 @@ package body Exp_Util is and then not Restriction_Active (No_Local_Allocators); end Entry_Names_OK; + ------------------- + -- Evaluate_Name -- + ------------------- + + procedure Evaluate_Name (Nam : Node_Id) is + K : constant Node_Kind := Nkind (Nam); + + begin + -- For an explicit dereference, we simply force the evaluation of the + -- name expression. The dereference provides a value that is the address + -- for the renamed object, and it is precisely this value that we want + -- to preserve. + + if K = N_Explicit_Dereference then + Force_Evaluation (Prefix (Nam)); + + -- For a selected component, we simply evaluate the prefix + + elsif K = N_Selected_Component then + Evaluate_Name (Prefix (Nam)); + + -- For an indexed component, or an attribute reference, we evaluate the + -- prefix, which is itself a name, recursively, and then force the + -- evaluation of all the subscripts (or attribute expressions). + + elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then + Evaluate_Name (Prefix (Nam)); + + declare + E : Node_Id; + + begin + E := First (Expressions (Nam)); + while Present (E) loop + Force_Evaluation (E); + + if Original_Node (E) /= E then + Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); + end if; + + Next (E); + end loop; + end; + + -- For a slice, we evaluate the prefix, as for the indexed component + -- case and then, if there is a range present, either directly or as the + -- constraint of a discrete subtype indication, we evaluate the two + -- bounds of this range. + + elsif K = N_Slice then + Evaluate_Name (Prefix (Nam)); + + declare + DR : constant Node_Id := Discrete_Range (Nam); + Constr : Node_Id; + Rexpr : Node_Id; + + begin + if Nkind (DR) = N_Range then + Force_Evaluation (Low_Bound (DR)); + Force_Evaluation (High_Bound (DR)); + + elsif Nkind (DR) = N_Subtype_Indication then + Constr := Constraint (DR); + + if Nkind (Constr) = N_Range_Constraint then + Rexpr := Range_Expression (Constr); + + Force_Evaluation (Low_Bound (Rexpr)); + Force_Evaluation (High_Bound (Rexpr)); + end if; + end if; + end; + + -- For a type conversion, the expression of the conversion must be the + -- name of an object, and we simply need to evaluate this name. + + elsif K = N_Type_Conversion then + Evaluate_Name (Expression (Nam)); + + -- For a function call, we evaluate the call + + elsif K = N_Function_Call then + Force_Evaluation (Nam); + + -- The remaining cases are direct name, operator symbol and character + -- literal. In all these cases, we do nothing, since we want to + -- reevaluate each time the renamed object is used. + + else + return; + end if; + end Evaluate_Name; + --------------------- -- Evolve_And_Then -- --------------------- @@ -4203,9 +4367,14 @@ package body Exp_Util is return True; end if; - -- Case of component reference + -- Case of indexed component reference: test whether prefix is unaligned - if Nkind (N) = N_Selected_Component then + if Nkind (N) = N_Indexed_Component then + return Is_Possibly_Unaligned_Object (Prefix (N)); + + -- Case of selected component reference + + elsif Nkind (N) = N_Selected_Component then declare P : constant Node_Id := Prefix (N); C : constant Entity_Id := Entity (Selector_Name (N)); @@ -5846,11 +6015,11 @@ package body Exp_Util is Exp_Type : constant Entity_Id := Etype (Exp); Svg_Suppress : constant Suppress_Array := Scope_Suppress; Def_Id : Entity_Id; + E : Node_Id; + New_Exp : Node_Id; + Ptr_Typ_Decl : Node_Id; Ref_Type : Entity_Id; Res : Node_Id; - Ptr_Typ_Decl : Node_Id; - New_Exp : Node_Id; - E : Node_Id; function Side_Effect_Free (N : Node_Id) return Boolean; -- Determines if the tree N represents an expression that is known not @@ -6085,7 +6254,7 @@ package body Exp_Util is -- A binary operator is side effect free if and both operands are -- side effect free. For this purpose binary operators include - -- membership tests and short circuit forms + -- membership tests and short circuit forms. when N_Binary_Op | N_Membership_Test | N_Short_Circuit => return Side_Effect_Free (Left_Opnd (N)) @@ -6453,6 +6622,15 @@ package body Exp_Util is -- Otherwise we generate a reference to the value else + -- An expression which is in Alfa mode is considered side effect free + -- if the resulting value is captured by a variable or a constant. + + if Alfa_Mode + and then Nkind (Parent (Exp)) = N_Object_Declaration + then + return; + end if; + -- Special processing for function calls that return a limited type. -- We need to build a declaration that will enable build-in-place -- expansion of the call. This is not done if the context is already @@ -6461,10 +6639,10 @@ package body Exp_Util is -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have -- to accommodate functions returning limited objects by reference. - if Nkind (Exp) = N_Function_Call + if Ada_Version >= Ada_2005 + and then Nkind (Exp) = N_Function_Call and then Is_Immutably_Limited_Type (Etype (Exp)) and then Nkind (Parent (Exp)) /= N_Object_Declaration - and then Ada_Version >= Ada_2005 then declare Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp); @@ -6484,32 +6662,57 @@ package body Exp_Util is end; end if; - Ref_Type := Make_Temporary (Loc, 'A'); + Def_Id := Make_Temporary (Loc, 'R', Exp); + Set_Etype (Def_Id, Exp_Type); - Ptr_Typ_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ref_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Reference_To (Exp_Type, Loc))); + -- The regular expansion of functions with side effects involves the + -- generation of an access type to capture the return value found on + -- the secondary stack. Since Alfa (and why) cannot process access + -- types, use a different approach which ignores the secondary stack + -- and "copies" the returned object. - E := Exp; - Insert_Action (Exp, Ptr_Typ_Decl); + if Alfa_Mode then + Res := New_Reference_To (Def_Id, Loc); + Ref_Type := Exp_Type; - Def_Id := Make_Temporary (Loc, 'R', Exp); - Set_Etype (Def_Id, Exp_Type); + -- Regular expansion utilizing an access type and 'reference - Res := - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Def_Id, Loc)); + else + Res := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Def_Id, Loc)); + + -- Generate: + -- type Ann is access all <Exp_Type>; + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Exp_Type, Loc))); + + Insert_Action (Exp, Ptr_Typ_Decl); + end if; + + E := Exp; if Nkind (E) = N_Explicit_Dereference then New_Exp := Relocate_Node (Prefix (E)); else E := Relocate_Node (E); - New_Exp := Make_Reference (Loc, E); + + -- Do not generate a 'reference in Alfa mode since the access type + -- is not created in the first place. + + if Alfa_Mode then + New_Exp := E; + else + New_Exp := Make_Reference (Loc, E); + end if; end if; if Is_Delayed_Aggregate (E) then diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 1f0ee42fc5d..c0e0082185d 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -149,6 +149,14 @@ package Exp_Util is -- Other Subprograms -- ----------------------- + procedure Activate_Atomic_Synchronization (N : Node_Id); + -- N is a node for which atomic synchronization may be required (it is + -- either an identifier, expanded name, or selected/indexed component or + -- an explicit dereference). The caller has checked the basic conditions + -- (atomic variable appearing and Atomic_Sync not disabled). This function + -- checks if atomic synchronization is required and if so sets the flag + -- and if appropriate generates a warning (in -gnatw.n mode). + procedure Adjust_Condition (N : Node_Id); -- The node N is an expression whose root-type is Boolean, and which -- represents a boolean value used as a condition (i.e. a True/False @@ -343,6 +351,11 @@ package Exp_Util is -- which represent entry [family member] names. These strings are created -- by the compiler and used by GDB. + procedure Evaluate_Name (Nam : Node_Id); + -- Remove the all side effects from a name which appears as part of an + -- object renaming declaration. More comments are needed here that explain + -- how this differs from Force_Evaluation and Remove_Side_Effects ??? + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is -- Empty, then simply returns Cond1 (this allows the use of Empty to diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8c42fed255b..b1a33d58da1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4063,6 +4063,16 @@ package body Freeze is Layout_Type (E); end if; + -- If this is an access to subprogram whose designated type is itself + -- a subprogram type, the return type of this anonymous subprogram + -- type must be decorated as well. + + if Ekind (E) = E_Anonymous_Access_Subprogram_Type + and then Ekind (Designated_Type (E)) = E_Subprogram_Type + then + Layout_Type (Etype (Designated_Type (E))); + end if; + -- If the type has a Defaut_Value/Default_Component_Value aspect, -- this is where we analye the expression (after the type is frozen, -- since in the case of Default_Value, we are analyzing with the diff --git a/gcc/ada/g-excact.adb b/gcc/ada/g-excact.adb index 1ba4cf8d64e..ed454cefcde 100644 --- a/gcc/ada/g-excact.adb +++ b/gcc/ada/g-excact.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -97,7 +97,7 @@ package body GNAT.Exception_Actions is function Name_To_Id (Name : String) return Exception_Id is begin - return To_Id (Internal_Exception (Name, False)); + return To_Id (Internal_Exception (Name, Create_If_Not_Exist => False)); end Name_To_Id; --------------------------------- diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index bf1fe9fdde0..d48065a23f5 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -36,8 +36,8 @@ with Ada.Unchecked_Conversion; with Interfaces.C.Strings; -with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; -with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; +with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; +with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; with GNAT.Sockets.Linker_Options; pragma Warnings (Off, GNAT.Sockets.Linker_Options); @@ -246,11 +246,11 @@ package body GNAT.Sockets is -- Type and Stream_Socket_Stream_Type. procedure Wait_On_Socket - (Socket : Socket_Type; - For_Read : Boolean; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status); + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); -- Common code for variants of socket operations supporting a timeout: -- block in Check_Selector on Socket for at most the indicated timeout. -- If For_Read is True, Socket is added to the read set for this call, else @@ -490,8 +490,8 @@ package body GNAT.Sockets is -- that Fd is within range (otherwise behaviour is undefined). elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then - raise Constraint_Error with "invalid value for socket set: " - & Image (Fd); + raise Constraint_Error + with "invalid value for socket set: " & Image (Fd); end if; end Check_For_Fd_Set; @@ -731,11 +731,11 @@ package body GNAT.Sockets is -- Wait for socket to become available for writing Wait_On_Socket - (Socket => Socket, - For_Read => False, - Timeout => Timeout, - Selector => Selector, - Status => Status); + (Socket => Socket, + For_Read => False, + Timeout => Timeout, + Selector => Selector, + Status => Status); -- Reset the socket to blocking I/O @@ -1580,11 +1580,11 @@ package body GNAT.Sockets is -------------------- procedure Wait_On_Socket - (Socket : Socket_Type; - For_Read : Boolean; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status) + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) is type Local_Selector_Access is access Selector_Type; for Local_Selector_Access'Storage_Size use Selector_Type'Size; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 01983282ac7..462556265a6 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -432,8 +432,8 @@ package GNAT.Sockets is Immediate : constant Duration := 0.0; - Forever : constant Duration := - Duration'Min (Duration'Last, 1.0 * SOSC.MAX_tv_sec); + Forever : constant Duration := + Duration'Min (Duration'Last, 1.0 * SOSC.MAX_tv_sec); -- Largest possible Duration that is also a valid value for struct timeval subtype Timeval_Duration is Duration range Immediate .. Forever; @@ -1146,7 +1146,6 @@ private R_Sig_Socket : Socket_Type := No_Socket; W_Sig_Socket : Socket_Type := No_Socket; -- Signalling sockets used to abort a select operation - end case; end record; @@ -1234,10 +1233,10 @@ private end record; type Service_Entry_Type (Aliases_Length : Natural) is record - Official : Name_Type; - Aliases : Name_Array (1 .. Aliases_Length); - Port : Port_Type; - Protocol : Name_Type; + Official : Name_Type; + Aliases : Name_Array (1 .. Aliases_Length); + Port : Port_Type; + Protocol : Name_Type; end record; type Request_Flag_Type is mod 2 ** 8; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 43d42f658b5..221d326c6aa 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1773,11 +1773,12 @@ ada/exp_alfa.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/debug.ads ada/einfo.ads ada/einfo.adb \ ada/exp_alfa.ads ada/exp_alfa.adb ada/exp_attr.ads ada/exp_ch4.ads \ - ada/exp_ch6.ads ada/exp_dbug.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_res.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/exp_ch6.ads ada/exp_dbug.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.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-secsta.ads \ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ @@ -1953,32 +1954,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 \ @@ -4066,42 +4070,42 @@ ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/validsw.ads ada/warnsw.ads ada/widechar.ads ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.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/eval_fat.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/par_sco.ads ada/put_alfa.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_case.ads ada/sem_case.adb ada/sem_cat.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_ch4.adb ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb 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/tbuild.adb 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/widechar.ads + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ + ada/atree.adb ada/casing.ads ada/checks.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/eval_fat.ads ada/exp_ch11.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads \ + ada/put_alfa.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_case.ads \ + ada/sem_case.adb ada/sem_cat.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_ch4.adb ada/sem_ch5.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb 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/tbuild.adb 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/widechar.ads ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 990a6987736..d9215dfb092 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -2116,7 +2116,6 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) SO_OPTS = -shared-libgcc LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-darwin.ads \ - i-forbla.adb<i-forbla-darwin.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-osinte.adb<s-osinte-darwin.adb \ s-osinte.ads<s-osinte-darwin.ads \ @@ -2238,10 +2237,8 @@ LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \ include $(fsrcdir)/ada/Makefile.rtl -GNATRTL_LINEARALGEBRA_OBJS = i-forbla.o i-forlap.o - GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \ - $(GNATRTL_LINEARALGEBRA_OBJS) memtrack.o + memtrack.o # Default run time files @@ -2538,9 +2535,6 @@ gnatlib: ../stamp-gnatlib1-$(RTSDIR) ../stamp-gnatlib2-$(RTSDIR) $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnarl$(arext) \ $(addprefix $(RTSDIR)/,$(GNATRTL_TASKING_OBJS)) $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnarl$(arext) - $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnala$(arext) \ - $(addprefix $(RTSDIR)/,$(GNATRTL_LINEARALGEBRA_OBJS)) - $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnala$(arext) ifeq ($(GMEM_LIB),gmemlib) $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgmem$(arext) \ $(RTSDIR)/memtrack.o diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 49434430ecd..d7ca5dbbe6e 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -4185,7 +4185,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* The failure of this assertion will very likely come from an order of elaboration issue for the type of the parameter. */ gcc_assert (kind == E_Subprogram_Type - || !TYPE_IS_DUMMY_P (gnu_param_type)); + || !TYPE_IS_DUMMY_P (gnu_param_type) + || type_annotate_only); if (gnu_param) { diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 513bca20642..2d342c347bc 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -5318,7 +5318,7 @@ This pragma signals that the entities whose names are listed are deliberately not referenced in the current source unit. This suppresses warnings about the entities being unreferenced, and in addition a warning will be -generated if one of these entities is in fact referenced in the +generated if one of these entities is in fact subsequently referenced in the same unit as the pragma (or in the corresponding body, or one of its subunits). @@ -5575,7 +5575,7 @@ as possibly modified by compiler switches. Then each pragma Warning modifies this set of warnings as specified. This form of the pragma may also be used as a configuration pragma. -The fourth form, with an On|Off parameter and a string, is used to +The fourth form, with an @code{On|Off} parameter and a string, is used to control individual messages, based on their text. The string argument is a pattern that is used to match against the text of individual warning messages (not including the initial "warning: " tag). @@ -5587,7 +5587,7 @@ message @code{warning: 960 bits of "a" unused}. No other regular expression notations are permitted. All characters other than asterisk in these three specific cases are treated as literal characters in the match. -There are two ways to use this pragma. The OFF form can be used as a +There are two ways to use the pragma in this form. The OFF form can be used as a configuration pragma. The effect is to suppress all warnings (if any) that match the pattern string throughout the compilation. @@ -5604,6 +5604,13 @@ pragma Warnings (On, Pattern); In this usage, the pattern string must match in the Off and On pragmas, and at least one matching warning must be suppressed. +Note: to write a string that will match any warning, use the string +@code{"***"}. It will not work to use a single asterisk or two asterisks +since this looks like an operator name. This form with three asterisks +is similar in effect to specifying @code{pragma Warnings (Off)} except that a +matching @code{pragma Warnings (On, "***")} will be required. This can be +helpful in avoiding forgetting to turn warnings back on. + Note: the debug flag -gnatd.i (@code{/NOWARNINGS_PRAGMAS} in VMS) can be used to cause the compiler to entirely ignore all WARNINGS pragmas. This can be useful in checking whether obsolete pragmas in existing programs are hiding @@ -9117,6 +9124,17 @@ only declared at the library level. This restriction ensures at compile time that there are no allocator expressions that attempt to allocate protected objects. +@item No_Relative_Delay +@findex No_Relative_Delay +This restriction ensures at compile time that there are no delay relative +statements and prevents expressions such as @code{delay 1.23;} from appearing +in source code. + +@item No_Requeue_Statements +@findex No_Requeue_Statements +This restriction ensures at compile time that no requeue statements are +permitted and prevents keyword @code{requeue} from being used in source code. + @item No_Secondary_Stack @findex No_Secondary_Stack This restriction ensures at compile time that the generated code does not @@ -9138,6 +9156,14 @@ use the standard default storage pool. Any access type declared must have an explicit Storage_Pool attribute defined specifying a user-defined storage pool. +@item No_Stream_Optimizations +@findex No_Stream_Optimizations +This restriction affects the performance of stream operations on types +@code{String}, @code{Wide_String} and @code{Wide_Wide_String}. By default, the +compiler uses block reads and writes when manipulating @code{String} objects +due to their supperior performance. When this restriction is in effect, the +compiler performs all IO operations on a per-character basis. + @item No_Streams @findex No_Streams This restriction ensures at compile/bind time that there are no @@ -10196,7 +10222,7 @@ floating-point standard. Note that on machines that are not fully compliant with the IEEE floating-point standard, such as Alpha, the @option{-mieee} compiler flag -must be used for achieving IEEE confirming behavior (although at the cost +must be used for achieving IEEE conforming behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index abf8093a8ed..253cfff172b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -337,6 +337,7 @@ Performance Considerations * Optimization Levels:: * Debugging Optimized Code:: * Inlining of Subprograms:: +* Vectorization of loops:: * Other Optimization Switches:: * Optimization and Strict Aliasing:: @ifset vms @@ -475,11 +476,11 @@ Creating Unit Tests Using gnattest * Switches for gnattest:: * Project Attributes for gnattest:: * Simple Example:: -* Setting Up and Tearing Down Testing Environment:: +* Setting Up and Tearing Down the Testing Environment:: * Regenerating Tests:: * Default Test Behavior:: * Testing Primitive Operations of Tagged Types:: -* Test Inheritance:: +* Testing Inheritance:: * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: @@ -5658,8 +5659,8 @@ This switch activates warnings to be generated for entities that are declared but not referenced, and for units that are @code{with}'ed and not referenced. In the case of packages, a warning is also generated if -no entities in the package are referenced. This means that if the package -is referenced but the only references are in @code{use} +no entities in the package are referenced. This means that if a with'ed +package is referenced but the only references are in @code{use} clauses or @code{renames} declarations, a warning is still generated. A warning is also generated for a generic package that is @code{with}'ed but never instantiated. @@ -7154,7 +7155,10 @@ used, it must be used consistently throughout the program. However, since brackets encoding is always recognized, it may be conveniently used in standard libraries, allowing these libraries to be used with any of the available coding schemes. -scheme. + +Note that brackets encoding only applies to program text. Within comments, +brackets are considered to be normal graphic characters, and bracket sequences +are never recognized as wide characters. If no @option{-gnatW?} parameter is present, then the default representation is normally Brackets encoding only. However, if the @@ -7168,6 +7172,27 @@ for Wide_Text_IO files if not specifically overridden by a WCEM form parameter. @end table + +When no @option{-gnatW?} is specified, then characters (other than wide +characters represented using brackets notation) are treated as 8-bit +Latin-1 codes. The codes recognized are the Latin-1 graphic characters, +and ASCII format effectors (CR, LF, HT, VT). Other lower half control +characters in the range 16#00#..16#1F# are not accepted in program text +or in comments. Upper half control characters (16#80#..16#9F#) are rejected +in program text, but allowed and ignored in comments. Note in particular +that the Next Line (NEL) character whose encoding is 16#85# is not recognized +as an end of line in this default mode. If your source program contains +instances of the NEL character used as a line terminator, +you must use UTF-8 encoding for the whole +source program. In default mode, all lines must be ended by a standard +end of line sequence (CR, CR/LF, or LF). + +Note that the convention of simply accepting all upper half characters in +comments means that programs that use standard ASCII for program text, but +UTF-8 encoding for comments are accepted in default mode, providing that the +comments are ended by an appropriate (CR, or CR/LF, or LF) line terminator. +This is a common mode for many programs with foreign language comments. + @node File Naming Control @subsection File Naming Control @@ -10150,6 +10175,7 @@ some guidelines on debugging optimized code. * Optimization Levels:: * Debugging Optimized Code:: * Inlining of Subprograms:: +* Vectorization of loops:: * Other Optimization Switches:: * Optimization and Strict Aliasing:: @@ -10595,6 +10621,103 @@ that you should not automatically assume that @option{-O3} is better than @option{-O2}, and indeed you should use @option{-O3} only if tests show that it actually improves performance. +@node Vectorization of loops +@subsection Vectorization of loops +@cindex Optimization Switches + +You can take advantage of the auto-vectorizer present in the @command{gcc} +back end to vectorize loops with GNAT. The corresponding command line switch +is @option{-ftree-vectorize} but, as it is enabled by default at @option{-O3} +and other aggressive optimizations helpful for vectorization also are enabled +by default at this level, using @option{-O3} directly is recommended. + +You also need to make sure that the target architecture features a supported +SIMD instruction set. For example, for the x86 architecture, you should at +least specify @option{-msse2} to get significant vectorization (but you don't +need to specify it for x86-64 as it is part of the base 64-bit architecture). +Similarly, for the PowerPC architecture, you should specify @option{-maltivec}. + +The preferred loop form for vectorization is the @code{for} iteration scheme. +Loops with a @code{while} iteration scheme can also be vectorized if they are +very simple, but the vectorizer will quickly give up otherwise. With either +iteration scheme, the flow of control must be straight, in particular no +@code{exit} statement may appear in the loop body. The loop may however +contain a single nested loop, if it can be vectorized when considered alone: + +@smallexample @c ada +@cartouche + A : array (1..4, 1..4) of Long_Float; + S : array (1..4) of Long_Float; + + procedure Sum is + begin + for I in A'Range(1) loop + for J in A'Range(2) loop + S (I) := S (I) + A (I, J); + end loop; + end loop; + end Sum; +@end cartouche +@end smallexample + +The vectorizable operations depend on the targeted SIMD instruction set, but +the adding and some of the multiplying operators are generally supported, as +well as the logical operators for modular types. Note that, in the former +case, enabling overflow checks, for example with @option{-gnato}, totally +disables vectorization. The other checks are not supposed to have the same +definitive effect, although compiling with @option{-gnatp} might well reveal +cases where some checks do thwart vectorization. + +Type conversions may also prevent vectorization if they involve semantics that +are not directly supported by the code generator or the SIMD instruction set. +A typical example is direct conversion from floating-point to integer types. +The solution in this case is to use the following idiom: + +@smallexample @c ada + Integer (S'Truncation (F)) +@end smallexample + +@noindent +if @code{S} is the subtype of floating-point object @code{F}. + +In most cases, the vectorizable loops are loops that iterate over arrays. +All kinds of array types are supported, i.e. constrained array types with +static bounds: + +@smallexample @c ada + type Array_Type is array (1 .. 4) of Long_Float; +@end smallexample + +@noindent +constrained array types with dynamic bounds: + +@smallexample @c ada + type Array_Type is array (1 .. Q.N) of Long_Float; + + type Array_Type is array (Q.K .. 4) of Long_Float; + + type Array_Type is array (Q.K .. Q.N) of Long_Float; +@end smallexample + +@noindent +or unconstrained array types: + +@smallexample @c ada + type Array_Type is array (Positive range <>) of Long_Float; +@end smallexample + +@noindent +The quality of the generated code decreases when the dynamic aspect of the +array type increases, the worst code being generated for unconstrained array +types. This is so because, the less information the compiler has about the +bounds of the array, the more fallback code it needs to generate in order to +fix things up at run time. + +You can obtain information about the vectorization performed by the compiler +by specifying @option{-ftree-vectorizer-verbose=N}. For more details of +this switch, see @ref{Debugging Options,,Options for Debugging Your Program +or GCC, gcc, Using the GNU Compiler Collection (GCC)}. + @node Other Optimization Switches @subsection Other Optimization Switches @cindex Optimization Switches @@ -10602,10 +10725,9 @@ it actually improves performance. Since @code{GNAT} uses the @command{gcc} back end, all the specialized @command{gcc} optimization switches are potentially usable. These switches have not been extensively tested with GNAT but can generally be expected -to work. Examples of switches in this category are -@option{-funroll-loops} and -the various target-specific @option{-m} options (in particular, it has been -observed that @option{-march=pentium4} can significantly improve performance +to work. Examples of switches in this category are @option{-funroll-loops} +and the various target-specific @option{-m} options (in particular, it has +been observed that @option{-march=xxx} can significantly improve performance on appropriate machines). For full details of these switches, see @ref{Submodel Options,, Hardware Models and Configurations, gcc, Using the GNU Compiler Collection (GCC)}. @@ -17491,7 +17613,7 @@ option @option{^--no-exception^/NO_EXCEPTION^} (see below). @section Running @command{gnatstub} @noindent -@command{gnatstub} has the command-line interface of the form +@command{gnatstub} has a command-line interface of the form: @smallexample @c $ gnatstub @ovar{switches} @var{filename} @ovar{directory} @@ -17673,34 +17795,34 @@ Verbose mode: generate version information. @findex gnattest @noindent -@command{gnattest} is an ASIS-based utility that creates unit tests stubs +@command{gnattest} is an ASIS-based utility that creates unit-test stubs as well as a test driver infrastructure (harness). @command{gnattest} creates a stub for each visible subprogram in the packages under consideration when they do not exist already. -In order to process source files from the project, @command{gnattest} has to -semantically analyze these Ada sources. Therefore, test stubs can only be -generated for legal Ada units. If a unit is dependent on some other units, -those units should be among source files of the project or of other projects +In order to process source files from a project, @command{gnattest} has to +semantically analyze the sources. Therefore, test stubs can only be +generated for legal Ada units. If a unit is dependent on other units, +those units should be among the source files of the project or of other projects imported by this one. -Generated stubs and harness are based on the AUnit testing framework. AUnit is -an Ada adaptation of the xxxUnit testing frameworks similar to JUnit for Java or -CppUnit for C++. While it is advised that gnattest users read AUnit manual, deep -knowledge of AUnit is not necessary for using gnattest. For correct operation of -@command{gnattest} AUnit should be installed and aunit.gpr must be on the -project path. This happens automatically when Aunit is installed at its default -location. +Generated stubs and harnesses are based on the AUnit testing framework. AUnit is +an Ada adaptation of the xxxUnit testing frameworks, similar to JUnit for Java +or CppUnit for C++. While it is advised that gnattest users read the AUnit +manual, deep knowledge of AUnit is not necessary for using gnattest. For correct +operation of @command{gnattest}, AUnit should be installed and aunit.gpr must be +on the project path. This happens automatically when Aunit is installed at its +default location. @menu * Running gnattest:: * Switches for gnattest:: * Project Attributes for gnattest:: * Simple Example:: -* Setting Up and Tearing Down Testing Environment:: +* Setting Up and Tearing Down the Testing Environment:: * Regenerating Tests:: * Default Test Behavior:: * Testing Primitive Operations of Tagged Types:: -* Test Inheritance:: +* Testing Inheritance:: * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: @@ -17711,7 +17833,7 @@ location. @section Running @command{gnattest} @noindent -@command{gnattest} has the command-line interface of the form +@command{gnattest} has a command-line interface of the form @smallexample @c $ gnattest @var{-Pprojname} @ovar{switches} @ovar{filename} @ovar{directory} @@ -17724,30 +17846,29 @@ where @table @var @item -Pprojname -specifies the project that allow locating the source files. When no [filenames] -are provided on the command line, all project sources are used as input. This -switch is mandatory. +specifies the project defining the location of source files. When no +file names are provided on the command line, all sources in the project +are used as input. This switch is required. @item --harness-dir=dirname -specifies directory to put harness packages and project file for the test -driver. The harness dir should be either specified by that switch or by -corresponding attribute in the argument project file. +specifies the directory that will hold the harness packages and project file +for the test driver. The harness directory should be specified either by that +switch or by the corresponding attribute in the project file. @item filename -is the name of the source file that contains a library unit package declaration -for which a test package must be created. The file name may contain the path -information. +is the name of the source file containing the library unit package declaration +for which a test package will be created. The file name may given with a path. @item @samp{@var{gcc_switches}} is a list of switches for -@command{gcc}. They will be passed on to all compiler invocations made by -@command{gnatstub} to generate the ASIS trees. Here you can provide +@command{gcc}. These switches will be passed on to all compiler invocations +made by @command{gnatstub} to generate a set of ASIS trees. Here you can provide @option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, use the @option{-gnatec} switch to set the configuration file, use the @option{-gnat05} switch if sources should be compiled in -Ada 2005 mode etc. +Ada 2005 mode, etc. @item switches -is an optional sequence of switches as described in the next section +is an optional sequence of switches as described in the next section. @end table @@ -17755,11 +17876,11 @@ is an optional sequence of switches as described in the next section @itemize @bullet @item automatic harness -the harnessing code which is located in the harness-dir as specified on the -comand line or in the project file. All this code is generated completely -automatically and can be destroyed and regenerated at will. It is not -recommended to modify manually this code since it might be overridden -easily. The entry point in this harnessing code is the project file called +the harness code, which is located either in the harness-dir as specified on +the command line or in the project file. All of this code is generated +completely automatically and can be destroyed and regenerated at will. It is not +recommended to modify this code manually, since it could easily be overridden +by mistake. The entry point in the harness code is the project file named @command{test_driver.gpr}. Tests can be compiled and run using a command such as: @@ -17772,12 +17893,12 @@ test_runner a test stub for each visible subprogram is created in a separate file, if it doesn't exist already. By default, those separate test files are located in a "tests" directory that is created in the directory containing the source file -itself. if it is not appropriate to create the tests in subdirs of the source, -option @option{--separate-root} can be used. So let say for instance that -a source file my_unit.ads in directory src contains a visible subprogram Proc. -Then, the corresponding unit test will be found in file -src/tests/my_unit-tests-proc_<code>.adb. <code> is an signature encoding used to -differentiate test names in case of overloading. +itself. If it is not appropriate to create the tests in subdirectories of the +source, option @option{--separate-root} can be used. For example, if a source +file my_unit.ads in directory src contains a visible subprogram Proc, then +the corresponding unit test will be found in file +src/tests/my_unit-tests-proc_<code>.adb. <code> is a signature encoding used to +differentiate test names in cases of overloading. @end itemize @node Switches for gnattest @@ -17789,7 +17910,7 @@ differentiate test names in case of overloading. @item --harness-only @cindex @option{--harness-only} (@command{gnattest}) When this option is given, @command{gnattest} creates a harness for all -sources treating them as test packages. +sources, treating them as test packages. @item --additional-tests=@var{projname} @cindex @option{--additional-tests} (@command{gnattest}) @@ -17798,15 +17919,15 @@ manual tests to be added to the test suite. @item -r @cindex @option{-r} (@command{gnattest}) -Consider recursively all sources from all projects. +Recursively consider all sources from all projects. @item -q @cindex @option{-q} (@command{gnattest}) -Supresses non-critical output messages. +Suppresses noncritical output messages. @item -v @cindex @option{-v} (@command{gnattest}) -Verbose mode: generate version information. +Verbose mode: generates version information. @item --liskov @cindex @option{--liskov} (@command{gnattest}) @@ -17820,14 +17941,14 @@ Specifies the default behavior of generated stubs. @var{val} can be either @item --separate-root=@var{dirname} @cindex @option{--separate-root} (@command{gnattest}) -Directory hierarchy of tested sources is recreated in the @var{dirname} directory, -test packages are placed in corresponding dirs. +The directory hierarchy of tested sources is recreated in the @var{dirname} +directory, and test packages are placed in corresponding directories. @item --subdir=@var{dirname} @cindex @option{--subdir} (@command{gnattest}) -Test packages are placed in subdirectories. That's the default output mode since -it does not require any additional input from the user. Subdirs called "tests" -will be created by default. +Test packages are placed in subdirectories. This is the default output mode +since it does not require any additional input from the user. Subdirectories +named "tests" will be created by default. @end table @@ -17838,36 +17959,36 @@ will be created by default. @noindent -Most of the command line options can be also given to the tool by adding +Most of the command-line options can also be passed to the tool by adding special attributes to the project file. Those attributes should be put in -package gnattest. Here is the list of the attributes. +package gnattest. Here is the list of attributes: @itemize @bullet @item Separate_Stub_Root is used to select the same output mode as with the --separate-root option. -This attribute cannot be used togather with Stub_Subdir. +This attribute cannot be used together with Stub_Subdir. @item Stub_Subdir -is used to select the same output mode as with the --sudbir option. -This attribute cannot be used togather with Separate_Stub_Root. +is used to select the same output mode as with the --subdir option. +This attribute cannot be used together with Separate_Stub_Root. @item Harness_Dir -is used to specify the directory to place harness packages and project +is used to specify the directory in which to place harness packages and project file for the test driver, otherwise specified by --harness-dir. @item Additional_Tests -is used to specify the project file otherwise given by +is used to specify the project file, otherwise given by --additional-tests switch. @item Stubs_Default is used to specify the default behaviour of test stubs, otherwise -specified by --stub-default option. The value for this attribute -shoul be either "pass" or "fail" +specified by --stub-default option. The value of this attribute +should be either "pass" or "fail". @end itemize -All those attributes can be overridden from command line if needed. +Each of those attributes can be overridden from the command line if needed. Other @command{gnattest} switches can also be passed via the project file as an attribute list called GNATtest_Switches. @@ -17877,19 +17998,19 @@ file as an attribute list called GNATtest_Switches. @noindent Let's take a very simple example using the first @command{gnattest} example -located at +located in: @smallexample <install_prefix>/share/examples/gnattest/simple @end smallexample -This project contains a simple package containing one subprogram. By running gnattest +This project contains a simple package containing one subprogram. By running gnattest: @smallexample $ gnattest --harness-dir=driver -Psimple.gpr @end smallexample -a test driver is created in dir "driver". It can be compiled and run: +a test driver is created in directory "driver". It can be compiled and run: @smallexample $ cd driver @@ -17898,8 +18019,8 @@ $ test_runner @end smallexample One failed test with diagnosis "test not implemented" is reported. -Since no special output option was specified the test package Simple.Tests -is located in +Since no special output option was specified, the test package Simple.Tests +is located in: @smallexample <install_prefix>/share/examples/gnattest/simple/src/tests @@ -17907,25 +18028,25 @@ is located in For each package containing visible subprograms, a child test package is generated. It contains one test routine per tested subprogram. Each -declaration of test subprogram has a comment specifying to which tested -subprogram it corresponds. All the test routines have separated bodies. -The test routine locates at simple-tests-test_inc_5eaee3.adb has a single -statement - procedure Assert. It has two arguments: the boolean expression -which we want to check and the diagnosis message to display if the condition -is false. +declaration of a test subprogram has a comment specifying which tested +subprogram it corresponds to. All of the test routines have separate bodies. +The test routine located at simple-tests-test_inc_5eaee3.adb contains a single +statement: a call to procedure Assert. It has two arguments: the Boolean +expression we want to check and the diagnosis message to display if +the condition is false. That is where actual testing code should be written after a proper setup. -An actual check can be performed by replacing the assert statement with +An actual check can be performed by replacing the Assert call with: @smallexample @c ada Assert (Inc (1) = 2, "wrong incrementation"); @end smallexample -After recompiling and running the test driver one successfully passed test +After recompiling and running the test driver, one successfully passed test is reported. -@node Setting Up and Tearing Down Testing Environment -@section Setting Up and Tearing Down Testing Environment +@node Setting Up and Tearing Down the Testing Environment +@section Setting Up and Tearing Down the Testing Environment @noindent @@ -17934,7 +18055,7 @@ Env_Mgmt that has two procedures: User_Set_Up and User_Tear_Down. User_Set_Up is called before each test routine of the package and User_Tear_Down is called after each test routine. Those two procedures can be used to perform necessary initialization and finalization, -memory allocation etc. +memory allocation, etc. @node Regenerating Tests @section Regenerating Tests @@ -17943,12 +18064,12 @@ memory allocation etc. Bodies of test routines and env_mgmt packages are never overridden after they have been created once. As long as the name of the subprogram, full expanded Ada -names and order of its parameters are the same, the old test routine will -fit in it's place and no test stub will be generated for this subprogram. +names, and the order of its parameters is the same, the old test routine will +fit in its place and no test stub will be generated for the subprogram. This can be demonstrated with the previous example. By uncommenting declaration and body of function Dec in simple.ads and simple.adb, running -@command{gnattest} on the project and then running the test driver: +@command{gnattest} on the project, and then running the test driver: @smallexample gnattest --harness-dir=driver -Psimple.gpr @@ -17957,10 +18078,10 @@ gprbuild -Ptest_driver test_runner @end smallexample -the old test is not replaced with a stub neither lost but a new test stub is +the old test is not replaced with a stub, nor is it lost, but a new test stub is created for function Dec. -The only way for regenerating tests stubs is t oremove the previously created +The only way of regenerating tests stubs is to remove the previously created tests. @node Default Test Behavior @@ -17968,18 +18089,18 @@ tests. @noindent -Generated test driver can treat all unimplemented tests in two ways: -either count them all as failed (this is usefull to see which tests are still -left to implement) or as passed (to sort out unimplemented ones from those -actually failing for a reason). +The generated test driver can treat unimplemented tests in two ways: +either count them all as failed (this is useful to see which tests are still +left to implement) or as passed (to sort out unimplemented ones from those +actually failing). -Test driver accepts a switch to specify this behavior: --stub-default=val, +The test driver accepts a switch to specify this behavior: --stub-default=val, where val is either "pass" or "fail" (exactly as for @command{gnattest}). The default behavior of the test driver is set with the same switch -passed to gnattest when generating the test driver. +as passed to gnattest when generating the test driver. -Passing it to the driver generated on the first example +Passing it to the driver generated on the first example: @smallexample test_runner --stub-default=pass @@ -17992,15 +18113,15 @@ makes both tests pass, even the unimplemented one. @noindent -Creating test stubs for primitive operations of tagged types have a number +Creation of test stubs for primitive operations of tagged types entails a number of features. Test routines for all primitives of a given tagged type are -placed in a separate child package named after the tagged type (so if you -have tagged type T in package P all tests for primitives of T will be in -P.T_Tests). +placed in a separate child package named according to the tagged type. For +example, if you have tagged type T in package P, all tests for primitives +of T will be in P.T_Tests. -By running gnattest on the second example (actual tests for this example -are already written so no need to worry if the tool reports that 0 new stubs -were generated). +Consider running gnattest on the second example (note: actual tests for this +example already exist, so there's no need to worry if the tool reports that +no new stubs were generated): @smallexample cd <install_prefix>/share/examples/gnattest/tagged_rec @@ -18008,42 +18129,42 @@ gnattest --harness-dir=driver -Ptagged_rec.gpr @end smallexample Taking a closer look at the test type declared in the test package -Speed1.Controller_Tests is necessary. It is declared in +Speed1.Controller_Tests is necessary. It is declared in: @smallexample <install_prefix>/share/examples/gnattest/tagged_rec/src/tests @end smallexample Test types are direct or indirect descendants of -AUnit.Test_Fixtures.Test_Fixture type. For non-primitive tested subprograms -there is no need for the user to care about them. However when generating -test packages for primitive operations, there are some things the user -should know. +AUnit.Test_Fixtures.Test_Fixture type. In the case of nonprimitive tested +subprograms, the user doesn't need to be concerned with them. However, +when generating test packages for primitive operations, there are some things +the user needs to know. -Type Test_Controller has component that allows to assign it all kinds of +Type Test_Controller has components that allow assignment of various derivations of type Controller. And if you look at the specification of -package Speed2.Auto_Controller, you can see, that Test_Auto_Controller -actually derives from Test_Controller rather that AUnit type Test_Fixture. -Thus test types repeat the hierarchy of tested types. +package Speed2.Auto_Controller, you will see that Test_Auto_Controller +actually derives from Test_Controller rather than AUnit type Test_Fixture. +Thus, test types mirror the hierarchy of tested types. The User_Set_Up procedure of Env_Mgmt package corresponding to a test package -of primitive operations of type T assigns Fixture with a reference to an -object of that exact type T. Notice however, that if the tagged type has -discriminants, the User_Set_Up only has a commented template of setting -up the fixture since filling the discriminant with actual value is up +of primitive operations of type T assigns to Fixture a reference to an +object of that exact type T. Notice, however, that if the tagged type has +discriminants, the User_Set_Up only has a commented template for setting +up the fixture, since filling the discriminant with actual value is up to the user. -The knowledge of the structure if test types allows to have additional testing +The knowledge of the structure of test types allows additional testing without additional effort. Those possibilities are described below. -@node Test Inheritance -@section Test Inheritance +@node Testing Inheritance +@section Testing Inheritance @noindent -Since test type hierarchy mimics the hierarchy of tested types, the -inheritance of tests take place. An example of such inheritance can be -shown by running the test driver generated for second example. As previously +Since the test type hierarchy mimics the hierarchy of tested types, the +inheritance of tests takes place. An example of such inheritance can be +seen by running the test driver generated for the second example. As previously mentioned, actual tests are already written for this example. @smallexample @@ -18052,8 +18173,8 @@ gprbuild -Ptest_driver test_runner @end smallexample -There are 6 passed tests while there are only 5 testable subprograms. Test -routine for function Speed has been inherited and ran against objects of the +There are 6 passed tests while there are only 5 testable subprograms. The test +routine for function Speed has been inherited and run against objects of the derived type. @node Tagged Types Substitutability Testing @@ -18061,29 +18182,28 @@ derived type. @noindent -Tagged Types Substitutability Testing is a way of verifying by testing -the Liskov substitution principle (LSP). LSP is a principle stating that if +Tagged Types Substitutability Testing is a way of verifying the Liskov +substitution principle (LSP) by testing. LSP is a principle stating that if S is a subtype of T (in Ada, S is a derived type of tagged type T), -then objects of type T may be replaced with objects of type S (i.e., objects -of type S may be substituted for objects of type T), without altering any of -the desirable properties of the program. When the properties of the program are -expressed in the form of subprogram pre & postconditions, LSP is formulated -as relations between the pre & post of primitive operations and the pre & post -of theirs derived operations. The pre of a derived operation should not be -stronger that the original pre, and the post of the derived operation should not -be weaker than the original post. Those relations insure that verifying if a -dyspatching call is safe can be done just with the pre & post of the root -operation. - -Verifying LSP by testing consists in running all the unit tests associated with +then objects of type T may be replaced with objects of type S (that is, +objects of type S may be substituted for objects of type T), without +altering any of the desirable properties of the program. When the properties +of the program are expressed in the form of subprogram preconditions and +postconditions (let's call them pre and post), LSP is formulated as relations +between the pre and post of primitive operations and the pre and post of their +derived operations. The pre of a derived operation should not be stronger than +the original pre, and the post of the derived operation should not be weaker +than the original post. Those relations ensure that verifying if a dispatching +call is safe can be done just by using the pre and post of the root operation. + +Verifying LSP by testing consists of running all the unit tests associated with the primitives of a given tagged type with objects of its derived types. -In the example used by the previous section there clearly have a violation of LSP. -The overriding primitive Adjust_Speed in package Speed2 removes the +In the example used in the previous section, there was clearly a violation of +LSP. The overriding primitive Adjust_Speed in package Speed2 removes the functionality of the overridden primitive and thus doesn't respect LSP. -Gnattest has a special option to run -overridden parent tests against objects of the type which have overriding -primitives. +Gnattest has a special option to run overridden parent tests against objects +of the type which have overriding primitives: @smallexample gnattest --harness-dir=driver --liskov -Ptagged_rec.gpr @@ -18093,21 +18213,21 @@ test_runner @end smallexample While all the tests pass by themselves, the parent test for Adjust_Speed fails -against object of derived type. +against objects of the derived type. @node Testing with Contracts @section Testing with Contracts @noindent -@command{gnattest} supports pragmas Precondition, Postcondition and Test_Case. -Test routines are generated one per each Test_Case associated with a tested +@command{gnattest} supports pragmas Precondition, Postcondition, and Test_Case. +Test routines are generated, one per each Test_Case associated with a tested subprogram. Those test routines have special wrappers for tested functions -that have composition of pre- and postcondition of the subprogram an -"requires" and "ensures" of the Test_Case (depending on the mode pre- and post -either count for Nominal mode or do not for Robustness mode). +that have composition of pre- and postcondition of the subprogram with +"requires" and "ensures" of the Test_Case (depending on the mode, pre and post +either count for Nominal mode or do not count for Robustness mode). -The third example demonstrates how it works: +The third example demonstrates how this works: @smallexample cd <install_prefix>/share/examples/gnattest/contracts @@ -18116,13 +18236,13 @@ gnattest --harness-dir=driver -Pcontracts.gpr Putting actual checks within the range of the contract does not cause any error reports. For example, for the test routine which corresponds to -test case 1 +test case 1: @smallexample @c ada Assert (Sqrt (9.0) = 3.0, "wrong sqrt"); @end smallexample -and for the test routine corresponding to test case 2 +and for the test routine corresponding to test case 2: @smallexample @c ada Assert (Sqrt (-5.0) = -1.0, "wrong error indication"); @@ -18136,9 +18256,9 @@ gprbuild -Ptest_driver test_runner @end smallexample -However, by by changing 9.0 to 25.0 and 3.0 to 5.0 for example you can get -a precondition violation for test case one. Also by putting any otherwise -correct but positive pair of numbers to the second test routine you can also +However, by changing 9.0 to 25.0 and 3.0 to 5.0, for example, you can get +a precondition violation for test case one. Also, by using any otherwise +correct but positive pair of numbers in the second test routine, you can also get a precondition violation. Postconditions are checked and reported the same way. @@ -18146,21 +18266,23 @@ the same way. @section Additional Tests @noindent -@command{gnattest} can add user written tests to the main suite of the test -driver. @command{gnattest} traverses given packages and searches for test +@command{gnattest} can add user-written tests to the main suite of the test +driver. @command{gnattest} traverses the given packages and searches for test routines. All procedures with a single in out parameter of a type which is -a derivation of AUnit.Test_Fixtures.Test_Fixture declared in package -specifications are added to the suites and then are executed by test driver. -(Set_Up and Tear_Down are filtered out). +derived from AUnit.Test_Fixtures.Test_Fixture and that are declared in package +specifications are added to the suites and are then executed by the test driver. +(Set_Up and Tear_Down are filtered out.) -An example illustrates two ways of crating test harness for user written tests. -Directory additional contains a AUnit based test driver written by hand. +An example illustrates two ways of creating test harnesses for user-written +tests. Directory additional_tests contains an AUnit-based test driver written +by hand. @smallexample <install_prefix>/share/examples/gnattest/additional_tests/ @end smallexample -To create a test driver for already written tests use --harness-only option: +To create a test driver for already-written tests, use the --harness-only +option: @smallexample gnattest -Padditional/harness/harness.gpr --harness-dir=harness_only \ @@ -18169,7 +18291,7 @@ gnatmake -Pharness_only/test_driver.gpr harness_only/test_runner @end smallexample -Additional tests can also be executed together withgenerated tests: +Additional tests can also be executed together with generated tests: @smallexample gnattest -Psimple.gpr --additional-tests=additional/harness/harness.gpr \ @@ -18187,8 +18309,8 @@ The tool currently does not support following features: @itemize @bullet @item generic tests for generic packages and package instantiations -@item tests for protected operations and entries -@item acpects Pre-, Postcondition and Test_Case +@item tests for protected subprograms and entries +@item aspects Precondition, Postcondition, and Test_Case @end itemize @c ********************************* diff --git a/gcc/ada/i-forbla.ads b/gcc/ada/i-forbla.ads deleted file mode 100644 index 3910349a652..00000000000 --- a/gcc/ada/i-forbla.ads +++ /dev/null @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a thin binding to the standard Fortran BLAS library. --- Documentation and a reference BLAS implementation is available from --- ftp://ftp.netlib.org. The main purpose of this package is to facilitate --- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and --- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS --- routines may be added over time. - --- As actual linker arguments to link with the BLAS implementation differs --- according to platform and chosen BLAS implementation, the linker arguments --- are given in the body of this package. The body may need to be modified in --- order to link with different BLAS implementations tuned to the specific --- target. - -package Interfaces.Fortran.BLAS is - pragma Pure; - pragma Elaborate_Body; - - No_Trans : aliased constant Character := 'N'; - Trans : aliased constant Character := 'T'; - Conj_Trans : aliased constant Character := 'C'; - - -- Vector types - - type Real_Vector is array (Integer range <>) of Real; - - type Complex_Vector is array (Integer range <>) of Complex; - - type Double_Precision_Vector is array (Integer range <>) - of Double_Precision; - - type Double_Complex_Vector is array (Integer range <>) of Double_Complex; - - -- Matrix types - - type Real_Matrix is array (Integer range <>, Integer range <>) - of Real; - - type Double_Precision_Matrix is array (Integer range <>, Integer range <>) - of Double_Precision; - - type Complex_Matrix is array (Integer range <>, Integer range <>) - of Complex; - - type Double_Complex_Matrix is array (Integer range <>, Integer range <>) - of Double_Complex; - - -- BLAS Level 1 - - function sdot - (N : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Y : Real_Vector; - Inc_Y : Integer := 1) return Real; - - function ddot - (N : Positive; - X : Double_Precision_Vector; - Inc_X : Integer := 1; - Y : Double_Precision_Vector; - Inc_Y : Integer := 1) return Double_Precision; - - function cdotu - (N : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Y : Complex_Vector; - Inc_Y : Integer := 1) return Complex; - - function zdotu - (N : Positive; - X : Double_Complex_Vector; - Inc_X : Integer := 1; - Y : Double_Complex_Vector; - Inc_Y : Integer := 1) return Double_Complex; - - function snrm2 - (N : Natural; - X : Real_Vector; - Inc_X : Integer := 1) return Real; - - function dnrm2 - (N : Natural; - X : Double_Precision_Vector; - Inc_X : Integer := 1) return Double_Precision; - - function scnrm2 - (N : Natural; - X : Complex_Vector; - Inc_X : Integer := 1) return Real; - - function dznrm2 - (N : Natural; - X : Double_Complex_Vector; - Inc_X : Integer := 1) return Double_Precision; - - -- BLAS Level 2 - - procedure sgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Positive; - X : Real_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Real := 0.0; - Y : in out Real_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - procedure dgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Double_Precision := 1.0; - A : Double_Precision_Matrix; - Ld_A : Positive; - X : Double_Precision_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Double_Precision := 0.0; - Y : in out Double_Precision_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - procedure cgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Complex := (1.0, 1.0); - A : Complex_Matrix; - Ld_A : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Complex := (0.0, 0.0); - Y : in out Complex_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - procedure zgemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Double_Complex := (1.0, 1.0); - A : Double_Complex_Matrix; - Ld_A : Positive; - X : Double_Complex_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Double_Complex := (0.0, 0.0); - Y : in out Double_Complex_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - -- BLAS Level 3 - - procedure sgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Integer; - B : Real_Matrix; - Ld_B : Integer; - Beta : Real := 0.0; - C : in out Real_Matrix; - Ld_C : Integer); - - procedure dgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Double_Precision := 1.0; - A : Double_Precision_Matrix; - Ld_A : Integer; - B : Double_Precision_Matrix; - Ld_B : Integer; - Beta : Double_Precision := 0.0; - C : in out Double_Precision_Matrix; - Ld_C : Integer); - - procedure cgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Complex := (1.0, 1.0); - A : Complex_Matrix; - Ld_A : Integer; - B : Complex_Matrix; - Ld_B : Integer; - Beta : Complex := (0.0, 0.0); - C : in out Complex_Matrix; - Ld_C : Integer); - - procedure zgemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Double_Complex := (1.0, 1.0); - A : Double_Complex_Matrix; - Ld_A : Integer; - B : Double_Complex_Matrix; - Ld_B : Integer; - Beta : Double_Complex := (0.0, 0.0); - C : in out Double_Complex_Matrix; - Ld_C : Integer); - -private - pragma Import (Fortran, cdotu, "cdotu_"); - pragma Import (Fortran, cgemm, "cgemm_"); - pragma Import (Fortran, cgemv, "cgemv_"); - pragma Import (Fortran, ddot, "ddot_"); - pragma Import (Fortran, dgemm, "dgemm_"); - pragma Import (Fortran, dgemv, "dgemv_"); - pragma Import (Fortran, dnrm2, "dnrm2_"); - pragma Import (Fortran, dznrm2, "dznrm2_"); - pragma Import (Fortran, scnrm2, "scnrm2_"); - pragma Import (Fortran, sdot, "sdot_"); - pragma Import (Fortran, sgemm, "sgemm_"); - pragma Import (Fortran, sgemv, "sgemv_"); - pragma Import (Fortran, snrm2, "snrm2_"); - pragma Import (Fortran, zdotu, "zdotu_"); - pragma Import (Fortran, zgemm, "zgemm_"); - pragma Import (Fortran, zgemv, "zgemv_"); -end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/i-forlap.ads b/gcc/ada/i-forlap.ads deleted file mode 100644 index ebb08abe654..00000000000 --- a/gcc/ada/i-forlap.ads +++ /dev/null @@ -1,414 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required if non-RM package ??? - -with Interfaces.Fortran.BLAS; -package Interfaces.Fortran.LAPACK is - pragma Pure; - - type Integer_Vector is array (Integer range <>) of Integer; - - Upper : aliased constant Character := 'U'; - Lower : aliased constant Character := 'L'; - - subtype Real_Vector is BLAS.Real_Vector; - subtype Real_Matrix is BLAS.Real_Matrix; - subtype Double_Precision_Vector is BLAS.Double_Precision_Vector; - subtype Double_Precision_Matrix is BLAS.Double_Precision_Matrix; - subtype Complex_Vector is BLAS.Complex_Vector; - subtype Complex_Matrix is BLAS.Complex_Matrix; - subtype Double_Complex_Vector is BLAS.Double_Complex_Vector; - subtype Double_Complex_Matrix is BLAS.Double_Complex_Matrix; - - -- LAPACK Computational Routines - - -- gerfs Refines the solution of a system of linear equations with - -- a general matrix and estimates its error - -- getrf Computes LU factorization of a general m-by-n matrix - -- getri Computes inverse of an LU-factored general matrix - -- square matrix, with multiple right-hand sides - -- getrs Solves a system of linear equations with an LU-factored - -- square matrix, with multiple right-hand sides - -- hetrd Reduces a complex Hermitian matrix to tridiagonal form - -- heevr Computes selected eigenvalues and, optionally, eigenvectors of - -- a Hermitian matrix using the Relatively Robust Representations - -- orgtr Generates the real orthogonal matrix Q determined by sytrd - -- steqr Computes all eigenvalues and eigenvectors of a symmetric or - -- Hermitian matrix reduced to tridiagonal form (QR algorithm) - -- sterf Computes all eigenvalues of a real symmetric - -- tridiagonal matrix using QR algorithm - -- sytrd Reduces a real symmetric matrix to tridiagonal form - - procedure sgetrf - (M : Natural; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure dgetrf - (M : Natural; - N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure cgetrf - (M : Natural; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure zgetrf - (M : Natural; - N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure sgetri - (N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure dgetri - (N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Double_Precision_Vector; - L_Work : Integer; - Info : access Integer); - - procedure cgetri - (N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure zgetri - (N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Double_Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure sgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Real_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure dgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Double_Precision_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Double_Precision_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure cgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Complex_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure zgetrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Double_Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Double_Complex_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure cheevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - M : out Integer; - W : out Real_Vector; - Z : out Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Complex_Vector; - L_Work : Integer; - R_Work : out Real_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer); - - procedure zheevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Double_Precision := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Double_Precision := 0.0; - M : out Integer; - W : out Double_Precision_Vector; - Z : out Double_Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Double_Complex_Vector; - L_Work : Integer; - R_Work : out Double_Precision_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer); - - procedure chetrd - (Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Complex_Vector; - Work : out Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure zhetrd - (Uplo : access constant Character; - N : Natural; - A : in out Double_Complex_Matrix; - Ld_A : Positive; - D : out Double_Precision_Vector; - E : out Double_Precision_Vector; - Tau : out Double_Complex_Vector; - Work : out Double_Complex_Vector; - L_Work : Integer; - Info : access Integer); - - procedure ssytrd - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure dsytrd - (Uplo : access constant Character; - N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - D : out Double_Precision_Vector; - E : out Double_Precision_Vector; - Tau : out Double_Precision_Vector; - Work : out Double_Precision_Vector; - L_Work : Integer; - Info : access Integer); - - procedure ssterf - (N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Info : access Integer); - - procedure dsterf - (N : Natural; - D : in out Double_Precision_Vector; - E : in out Double_Precision_Vector; - Info : access Integer); - - procedure sorgtr - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - Tau : Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure dorgtr - (Uplo : access constant Character; - N : Natural; - A : in out Double_Precision_Matrix; - Ld_A : Positive; - Tau : Double_Precision_Vector; - Work : out Double_Precision_Vector; - L_Work : Integer; - Info : access Integer); - - procedure sstebz - (Rng : access constant Character; - Order : access constant Character; - N : Natural; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - D : Real_Vector; - E : Real_Vector; - M : out Natural; - N_Split : out Natural; - W : out Real_Vector; - I_Block : out Integer_Vector; - I_Split : out Integer_Vector; - Work : out Real_Vector; - I_Work : out Integer_Vector; - Info : access Integer); - - procedure dstebz - (Rng : access constant Character; - Order : access constant Character; - N : Natural; - Vl, Vu : Double_Precision := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Double_Precision := 0.0; - D : Double_Precision_Vector; - E : Double_Precision_Vector; - M : out Natural; - N_Split : out Natural; - W : out Double_Precision_Vector; - I_Block : out Integer_Vector; - I_Split : out Integer_Vector; - Work : out Double_Precision_Vector; - I_Work : out Integer_Vector; - Info : access Integer); - - procedure ssteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Real_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - - procedure dsteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Double_Precision_Vector; - E : in out Double_Precision_Vector; - Z : in out Double_Precision_Matrix; - Ld_Z : Positive; - Work : out Double_Precision_Vector; - Info : access Integer); - - procedure csteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Complex_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - - procedure zsteqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Double_Precision_Vector; - E : in out Double_Precision_Vector; - Z : in out Double_Complex_Matrix; - Ld_Z : Positive; - Work : out Double_Precision_Vector; - Info : access Integer); - -private - pragma Import (Fortran, csteqr, "csteqr_"); - pragma Import (Fortran, cgetrf, "cgetrf_"); - pragma Import (Fortran, cgetri, "cgetri_"); - pragma Import (Fortran, cgetrs, "cgetrs_"); - pragma Import (Fortran, cheevr, "cheevr_"); - pragma Import (Fortran, chetrd, "chetrd_"); - pragma Import (Fortran, dgetrf, "dgetrf_"); - pragma Import (Fortran, dgetri, "dgetri_"); - pragma Import (Fortran, dgetrs, "dgetrs_"); - pragma Import (Fortran, dsytrd, "dsytrd_"); - pragma Import (Fortran, dstebz, "dstebz_"); - pragma Import (Fortran, dsterf, "dsterf_"); - pragma Import (Fortran, dorgtr, "dorgtr_"); - pragma Import (Fortran, dsteqr, "dsteqr_"); - pragma Import (Fortran, sgetrf, "sgetrf_"); - pragma Import (Fortran, sgetri, "sgetri_"); - pragma Import (Fortran, sgetrs, "sgetrs_"); - pragma Import (Fortran, sorgtr, "sorgtr_"); - pragma Import (Fortran, sstebz, "sstebz_"); - pragma Import (Fortran, ssterf, "ssterf_"); - pragma Import (Fortran, ssteqr, "ssteqr_"); - pragma Import (Fortran, ssytrd, "ssytrd_"); - pragma Import (Fortran, zgetrf, "zgetrf_"); - pragma Import (Fortran, zgetri, "zgetri_"); - pragma Import (Fortran, zgetrs, "zgetrs_"); - pragma Import (Fortran, zheevr, "zheevr_"); - pragma Import (Fortran, zhetrd, "zhetrd_"); - pragma Import (Fortran, zsteqr, "zsteqr_"); -end Interfaces.Fortran.LAPACK; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index dfe176bf38d..63ab9256953 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -487,9 +487,6 @@ package body Impunit is ("a-ciormu", F), -- Ada.Containers.Indefinite_Ordered_Multisets ("a-coormu", F), -- Ada.Containers.Ordered_Multisets ("a-crdlli", F), -- Ada.Containers.Restricted_Doubly_Linked_Lists - ("a-secain", F), -- Ada.Strings.Equal_Case_Insensitive - ("a-shcain", F), -- Ada.Strings.Hash_Case_Insensitive - ("a-slcain", F), -- Ada.Strings.Less_Case_Insensitive ("a-szuzti", F), -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO ("a-zchuni", F), -- Ada.Wide_Wide_Characters.Unicode ("a-ztcstr", F), -- Ada.Wide_Wide_Text_IO.C_Streams @@ -497,6 +494,19 @@ 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-cogeso", T), -- Ada.Containers.Generic_Sort + ("a-secain", T), -- Ada.Strings.Equal_Case_Insensitive + ("a-shcain", T), -- Ada.Strings.Hash_Case_Insensitive + ("a-slcain", T), -- Ada.Strings.Less_Case_Insensitive + ("a-sfecin", T), -- Ada.Strings.Fixed.Equal_Case_Insensitive + ("a-sfhcin", T), -- Ada.Strings.Fixed.Hash_Case_Insensitive + ("a-sflcin", T), -- Ada.Strings.Fixed.Less_Case_Insensitive + ("a-sbecin", T), -- Ada.Strings.Bounded.Equal_Case_Insensitive + ("a-sbhcin", T), -- Ada.Strings.Bounded.Hash_Case_Insensitive + ("a-sblcin", T), -- Ada.Strings.Bounded.Less_Case_Insensitive + ("a-suecin", T), -- Ada.Strings.Unbounded.Equal_Case_Insensitive + ("a-suhcin", T), -- Ada.Strings.Unbounded.Hash_Case_Insensitive + ("a-sulcin", T), -- Ada.Strings.Unbounded.Less_Case_Insensitive ("a-suezst", T), -- Ada.Strings.UTF_Encoding.Wide_Wide_Strings --------------------------- diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb index 8520292ecd2..9bafb07b7d1 100644 --- a/gcc/ada/par-labl.adb +++ b/gcc/ada/par-labl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -340,6 +340,7 @@ procedure Labl is New_Node (N_Loop_Statement, Sloc (Loop_Header)); Stat : Node_Id; Next_Stat : Node_Id; + begin Stat := Next (Loop_Header); while Stat /= Loop_End loop @@ -355,7 +356,7 @@ procedure Labl is Remove (Loop_Header); Rewrite (Loop_End, Loop_Stmt); Error_Msg_N - ("code between label and backwards goto rewritten as loop?", + ("info: code between label and backwards goto rewritten as loop?", Loop_End); end Rewrite_As_Loop; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 9f29313a0b6..898ba8dfa35 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -2058,91 +2058,93 @@ package body Prj.Env is Projects_Paths.Reset (Self.Cache); end Set_Path; - ------------------ - -- Find_Project -- - ------------------ + ----------------------- + -- Find_Name_In_Path -- + ----------------------- - procedure Find_Project - (Self : in out Project_Search_Path; - Project_File_Name : String; - Directory : String; - Path : out Namet.Path_Name_Type) + function Find_Name_In_Path + (Self : Project_Search_Path; + Path : String) return String_Access is - File : constant String := Project_File_Name; - -- Have to do a copy, in case the parameter is Name_Buffer, which we - -- modify below + First : Natural; + Last : Natural; - function Try_Path_Name (Path : String) return String_Access; - pragma Inline (Try_Path_Name); - -- Try the specified Path + begin + if Current_Verbosity = High then + Debug_Output ("Trying " & Path); + end if; - ------------------- - -- Try_Path_Name -- - ------------------- + if Is_Absolute_Path (Path) then + if Check_Filename (Path) then + return new String'(Path); + else + return null; + end if; - function Try_Path_Name (Path : String) return String_Access is - First : Natural; - Last : Natural; - Result : String_Access := null; + else + -- Because we don't want to resolve symbolic links, we cannot use + -- Locate_Regular_File. So, we try each possible path successively. - begin - if Current_Verbosity = High then - Debug_Output ("Trying " & Path); - end if; + First := Self.Path'First; + while First <= Self.Path'Last loop + while First <= Self.Path'Last + and then Self.Path (First) = Path_Separator + loop + First := First + 1; + end loop; - if Is_Absolute_Path (Path) then - if Is_Regular_File (Path) then - Result := new String'(Path); - end if; + exit when First > Self.Path'Last; - else - -- Because we don't want to resolve symbolic links, we cannot use - -- Locate_Regular_File. So, we try each possible path - -- successively. - - First := Self.Path'First; - while First <= Self.Path'Last loop - while First <= Self.Path'Last - and then Self.Path (First) = Path_Separator - loop - First := First + 1; - end loop; - - exit when First > Self.Path'Last; - - Last := First; - while Last < Self.Path'Last - and then Self.Path (Last + 1) /= Path_Separator - loop - Last := Last + 1; - end loop; - - Name_Len := 0; - - if not Is_Absolute_Path (Self.Path (First .. Last)) then - Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call - Add_Char_To_Name_Buffer (Directory_Separator); - end if; + Last := First; + while Last < Self.Path'Last + and then Self.Path (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; - Add_Str_To_Name_Buffer (Self.Path (First .. Last)); + Name_Len := 0; + + if not Is_Absolute_Path (Self.Path (First .. Last)) then + Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call Add_Char_To_Name_Buffer (Directory_Separator); - Add_Str_To_Name_Buffer (Path); + end if; - if Current_Verbosity = High then - Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len)); - end if; + Add_Str_To_Name_Buffer (Self.Path (First .. Last)); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Path); - if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then - Result := new String'(Name_Buffer (1 .. Name_Len)); - exit; - end if; + if Current_Verbosity = High then + Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len)); + end if; - First := Last + 1; - end loop; - end if; + if Check_Filename (Name_Buffer (1 .. Name_Len)) then + return new String'(Name_Buffer (1 .. Name_Len)); + end if; + + First := Last + 1; + end loop; + end if; + + return null; + end Find_Name_In_Path; - return Result; - end Try_Path_Name; + ------------------ + -- Find_Project -- + ------------------ + + procedure Find_Project + (Self : in out Project_Search_Path; + Project_File_Name : String; + Directory : String; + Path : out Namet.Path_Name_Type) + is + File : constant String := Project_File_Name; + -- Have to do a copy, in case the parameter is Name_Buffer, which we + -- modify below + + function Try_Path_Name is new Find_Name_In_Path + (Check_Filename => Is_Regular_File); + -- Find a file in the project search path. -- Local Declarations @@ -2194,27 +2196,29 @@ package body Prj.Env is if not Has_Dot then Result := Try_Path_Name - (Directory & Directory_Separator & + (Self, + Directory & Directory_Separator & File & Project_File_Extension); end if; -- Then we try <directory>/<file_name> if Result = null then - Result := Try_Path_Name (Directory & Directory_Separator & File); + Result := Try_Path_Name + (Self, Directory & Directory_Separator & File); end if; end if; -- Then we try <file_name>.<extension> if Result = null and then not Has_Dot then - Result := Try_Path_Name (File & Project_File_Extension); + Result := Try_Path_Name (Self, File & Project_File_Extension); end if; -- Then we try <file_name> if Result = null then - Result := Try_Path_Name (File); + Result := Try_Path_Name (Self, File); end if; -- If we cannot find the project file, we return an empty string diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index fd14a4a3c3d..79de6464a0a 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -210,6 +210,17 @@ package Prj.Env is -- Override the value of the project path. This also removes the implicit -- default search directories. + generic + with function Check_Filename (Name : String) return Boolean; + function Find_Name_In_Path + (Self : Project_Search_Path; + Path : String) return String_Access; + -- Find a name in the project search path of Self. Check_Filename is + -- the predicate to valid the search. If Path is an absolute filename, + -- simply calls the predicate with Path. Otherwise, calls the predicate + -- for each component of the path. Stops as soon as the predicate + -- returns True and returns the name, or returns null in case of failure. + procedure Find_Project (Self : in out Project_Search_Path; Project_File_Name : String; diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 356104f07c0..6970733bdaf 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -2915,8 +2915,10 @@ The current list of qualifiers is: qualified abstract project. @item @b{standard}: a standard project is a non library project with sources. This is the default (implicit) qualifier. -@item @b{aggregate}: for future extension -@item @b{aggregate library}: for future extension +@item @b{aggregate}: a project whose sources are aggregated from other +project files. +@item @b{aggregate library}: a library whose sources are aggregated +from other project or library project files. @item @b{library}: a library project must declare both attributes @code{Library_Name} and @code{Library_Dir}. @item @b{configuration}: a configuration project cannot be in a project tree. diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads index a78c4fd26cd..cad18d29896 100644 --- a/gcc/ada/s-atocou.ads +++ b/gcc/ada/s-atocou.ads @@ -72,7 +72,6 @@ private type Atomic_Counter is limited record Value : aliased Unsigned_32 := 1; pragma Atomic (Value); - pragma Volatile (Value); end record; end System.Atomic_Counters; diff --git a/gcc/ada/s-gecobl.adb b/gcc/ada/s-gecobl.adb deleted file mode 100644 index d20b53f31b4..00000000000 --- a/gcc/ada/s-gecobl.adb +++ /dev/null @@ -1,350 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Complex_BLAS is - - Is_Single : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double : constant Boolean := - Real'Machine_Mantissa = Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = Double_Precision'First - and then - Double_Precision (Real'Last) = Double_Precision'Last; - - subtype Complex is Complex_Types.Complex; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline (To_Double_Precision); - - function To_Double_Complex (X : Complex) return Double_Complex; - pragma Inline (To_Double_Complex); - - function To_Complex (X : Double_Complex) return Complex; - function To_Complex (X : Fortran.Complex) return Complex; - pragma Inline (To_Complex); - - function To_Fortran (X : Complex) return Fortran.Complex; - pragma Inline (To_Fortran); - - -- Instantiations - - function To_Double_Complex is new - Vector_Elementwise_Operation - (X_Scalar => Complex_Types.Complex, - Result_Scalar => Fortran.Double_Complex, - X_Vector => Complex_Vector, - Result_Vector => BLAS.Double_Complex_Vector, - Operation => To_Double_Complex); - - function To_Complex is new - Vector_Elementwise_Operation - (X_Scalar => Fortran.Double_Complex, - Result_Scalar => Complex, - X_Vector => BLAS.Double_Complex_Vector, - Result_Vector => Complex_Vector, - Operation => To_Complex); - - function To_Double_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Double_Complex, - X_Matrix => Complex_Matrix, - Result_Matrix => BLAS.Double_Complex_Matrix, - Operation => To_Double_Complex); - - function To_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Complex, - Result_Scalar => Complex, - X_Matrix => BLAS.Double_Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => To_Complex); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Double_Complex (X : Complex) return Double_Complex is - begin - return (To_Double_Precision (X.Re), To_Double_Precision (X.Im)); - end To_Double_Complex; - - function To_Complex (X : Double_Complex) return Complex is - begin - return (Real (X.Re), Real (X.Im)); - end To_Complex; - - function To_Complex (X : Fortran.Complex) return Complex is - begin - return (Real (X.Re), Real (X.Im)); - end To_Complex; - - function To_Fortran (X : Complex) return Fortran.Complex is - begin - return (Fortran.Real (X.Re), Fortran.Real (X.Im)); - end To_Fortran; - - --------- - -- dot -- - --------- - - function dot - (N : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Y : Complex_Vector; - Inc_Y : Integer := 1) return Complex - is - begin - if Is_Single then - declare - type X_Ptr is access all BLAS.Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Complex_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return To_Complex (BLAS.cdotu (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - elsif Is_Double then - declare - type X_Ptr is access all BLAS.Double_Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return To_Complex (BLAS.zdotu (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - else - return To_Complex (BLAS.zdotu (N, To_Double_Complex (X), Inc_X, - To_Double_Complex (Y), Inc_Y)); - end if; - end dot; - - ---------- - -- gemm -- - ---------- - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Integer; - B : Complex_Matrix; - Ld_B : Integer; - Beta : Complex := (0.0, 0.0); - C : in out Complex_Matrix; - Ld_C : Integer) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is BLAS.Complex_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is - access all BLAS.Complex_Matrix (C'Range (1), C'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is - new Unchecked_Conversion (Complex_Matrix, B_Type); - function Conv_C is - new Unchecked_Conversion (Address, C_Ptr); - begin - BLAS.cgemm (Trans_A, Trans_B, M, N, K, To_Fortran (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, To_Fortran (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - elsif Is_Double then - declare - subtype A_Type is - BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is - BLAS.Double_Complex_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is access all - BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is - new Unchecked_Conversion (Complex_Matrix, B_Type); - function Conv_C is new Unchecked_Conversion (Address, C_Ptr); - begin - BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, - To_Double_Complex (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - else - declare - DP_C : BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2)); - begin - if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then - DP_C := To_Double_Complex (C); - end if; - - BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha), - To_Double_Complex (A), Ld_A, - To_Double_Complex (B), Ld_B, To_Double_Complex (Beta), - DP_C, Ld_C); - - C := To_Complex (DP_C); - end; - end if; - end gemm; - - ---------- - -- gemv -- - ---------- - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Beta : Complex := (0.0, 0.0); - Y : in out Complex_Vector; - Inc_Y : Integer := 1) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is BLAS.Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Complex_Vector (Y'Range); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - function Conv_Y is - new Unchecked_Conversion (Address, Y_Ptr); - begin - BLAS.cgemv (Trans, M, N, To_Fortran (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, To_Fortran (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - elsif Is_Double then - declare - subtype A_Type is - BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is - BLAS.Double_Complex_Vector (X'Range); - type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - function Conv_Y is - new Unchecked_Conversion (Address, Y_Ptr); - begin - BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, - To_Double_Complex (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - else - declare - DP_Y : BLAS.Double_Complex_Vector (Y'Range); - begin - if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then - DP_Y := To_Double_Complex (Y); - end if; - - BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha), - To_Double_Complex (A), Ld_A, - To_Double_Complex (X), Inc_X, To_Double_Complex (Beta), - DP_Y, Inc_Y); - - Y := To_Complex (DP_Y); - end; - end if; - end gemv; - - ---------- - -- nrm2 -- - ---------- - - function nrm2 - (N : Natural; - X : Complex_Vector; - Inc_X : Integer := 1) return Real - is - begin - if Is_Single then - declare - subtype X_Type is BLAS.Complex_Vector (X'Range); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - begin - return Real (BLAS.scnrm2 (N, Conv_X (X), Inc_X)); - end; - - elsif Is_Double then - declare - subtype X_Type is BLAS.Double_Complex_Vector (X'Range); - function Conv_X is - new Unchecked_Conversion (Complex_Vector, X_Type); - begin - return Real (BLAS.dznrm2 (N, Conv_X (X), Inc_X)); - end; - - else - return Real (BLAS.dznrm2 (N, To_Double_Complex (X), Inc_X)); - end if; - end nrm2; - -end System.Generic_Complex_BLAS; diff --git a/gcc/ada/s-gecobl.ads b/gcc/ada/s-gecobl.ads deleted file mode 100644 index 85bd3b50bf0..00000000000 --- a/gcc/ada/s-gecobl.ads +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -with Ada.Numerics.Generic_Complex_Types; - -generic - type Real is digits <>; - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - type Complex_Vector is array (Integer range <>) of Complex; - type Complex_Matrix is array (Integer range <>, Integer range <>) - of Complex; -package System.Generic_Complex_BLAS is - pragma Pure; - - -- Although BLAS support is only available for IEEE single and double - -- compatible floating-point types, this unit will accept any type - -- and apply conversions as necessary, with possible loss of - -- precision and range. - - No_Trans : aliased constant Character := 'N'; - Trans : aliased constant Character := 'T'; - Conj_Trans : aliased constant Character := 'C'; - - -- BLAS Level 1 Subprograms and Types - - function dot - (N : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; - Y : Complex_Vector; - Inc_Y : Integer := 1) return Complex; - - function nrm2 - (N : Natural; - X : Complex_Vector; - Inc_X : Integer := 1) return Real; - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Positive; - X : Complex_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Complex := (0.0, 0.0); - Y : in out Complex_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - -- BLAS Level 3 - - -- gemm s, d, c, z Matrix-matrix product of general matrices - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Complex := (1.0, 0.0); - A : Complex_Matrix; - Ld_A : Integer; - B : Complex_Matrix; - Ld_B : Integer; - Beta : Complex := (0.0, 0.0); - C : in out Complex_Matrix; - Ld_C : Integer); - -end System.Generic_Complex_BLAS; diff --git a/gcc/ada/s-gecola.adb b/gcc/ada/s-gecola.adb deleted file mode 100644 index ad69fee9bc5..00000000000 --- a/gcc/ada/s-gecola.adb +++ /dev/null @@ -1,493 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Complex_LAPACK is - - Is_Single : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double : constant Boolean := - Real'Machine_Mantissa = Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = Double_Precision'First - and then - Double_Precision (Real'Last) = Double_Precision'Last; - - subtype Complex is Complex_Types.Complex; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline (To_Double_Precision); - - function To_Real (X : Double_Precision) return Real; - pragma Inline (To_Real); - - function To_Double_Complex (X : Complex) return Double_Complex; - pragma Inline (To_Double_Complex); - - function To_Complex (X : Double_Complex) return Complex; - pragma Inline (To_Complex); - - -- Instantiations - - function To_Double_Precision is new - Vector_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Vector => Real_Vector, - Result_Vector => Double_Precision_Vector, - Operation => To_Double_Precision); - - function To_Real is new - Vector_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Vector => Double_Precision_Vector, - Result_Vector => Real_Vector, - Operation => To_Real); - - function To_Double_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Double_Complex, - X_Matrix => Complex_Matrix, - Result_Matrix => Double_Complex_Matrix, - Operation => To_Double_Complex); - - function To_Complex is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Complex, - Result_Scalar => Complex, - X_Matrix => Double_Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => To_Complex); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Real (X : Double_Precision) return Real is - begin - return Real (X); - end To_Real; - - function To_Double_Complex (X : Complex) return Double_Complex is - begin - return (To_Double_Precision (X.Re), To_Double_Precision (X.Im)); - end To_Double_Complex; - - function To_Complex (X : Double_Complex) return Complex is - begin - return (Real (X.Re), Real (X.Im)); - end To_Complex; - - ----------- - -- getrf -- - ----------- - - procedure getrf - (M : Natural; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer) - is - begin - if Is_Single then - declare - type A_Ptr is - access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - cgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - elsif Is_Double then - declare - type A_Ptr is - access all Double_Complex_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - zgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - begin - DP_A := To_Double_Complex (A); - zgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info); - A := To_Complex (DP_A); - end; - end if; - end getrf; - - ----------- - -- getri -- - ----------- - - procedure getri - (N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Complex_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Single then - declare - type A_Ptr is - access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all BLAS.Complex_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - cgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - elsif Is_Double then - declare - type A_Ptr is - access all Double_Complex_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all Double_Complex_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - zgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - DP_Work : Double_Complex_Vector (Work'Range); - begin - DP_A := To_Double_Complex (A); - zgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), - DP_Work, L_Work, Info); - A := To_Complex (DP_A); - Work (1) := To_Complex (DP_Work (1)); - end; - end if; - end getri; - - ----------- - -- getrs -- - ----------- - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Complex_Matrix; - Ld_B : Positive; - Info : access Integer) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all BLAS.Complex_Matrix (B'Range (1), B'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - cgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - elsif Is_Double then - declare - subtype A_Type is - Double_Complex_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all Double_Complex_Matrix (B'Range (1), B'Range (2)); - function Conv_A is - new Unchecked_Conversion (Complex_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - zgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - DP_B : Double_Complex_Matrix (B'Range (1), B'Range (2)); - begin - DP_A := To_Double_Complex (A); - DP_B := To_Double_Complex (B); - zgetrs (Trans, N, N_Rhs, - DP_A, Ld_A, - LAPACK.Integer_Vector (I_Piv), - DP_B, Ld_B, - Info); - B := To_Complex (DP_B); - end; - end if; - end getrs; - - procedure heevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - M : out Integer; - W : out Real_Vector; - Z : out Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Complex_Vector; - L_Work : Integer; - R_Work : out Real_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer) - is - begin - if Is_Single then - declare - type A_Ptr is - access all BLAS.Complex_Matrix (A'Range (1), A'Range (2)); - type W_Ptr is - access all BLAS.Real_Vector (W'Range); - type Z_Ptr is - access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is access all BLAS.Complex_Vector (Work'Range); - type R_Work_Ptr is access all BLAS.Real_Vector (R_Work'Range); - - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_W is new Unchecked_Conversion (Address, W_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - function Conv_R_Work is - new Unchecked_Conversion (Address, R_Work_Ptr); - begin - cheevr (Job_Z, Rng, Uplo, N, - Conv_A (A'Address).all, Ld_A, - Fortran.Real (Vl), Fortran.Real (Vu), - Il, Iu, Fortran.Real (Abs_Tol), M, - Conv_W (W'Address).all, - Conv_Z (Z'Address).all, Ld_Z, - LAPACK.Integer_Vector (I_Supp_Z), - Conv_Work (Work'Address).all, L_Work, - Conv_R_Work (R_Work'Address).all, LR_Work, - LAPACK.Integer_Vector (I_Work), LI_Work, Info); - end; - - elsif Is_Double then - declare - type A_Ptr is - access all BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2)); - type W_Ptr is - access all BLAS.Double_Precision_Vector (W'Range); - type Z_Ptr is - access all BLAS.Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all BLAS.Double_Complex_Vector (Work'Range); - type R_Work_Ptr is - access all BLAS.Double_Precision_Vector (R_Work'Range); - - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_W is new Unchecked_Conversion (Address, W_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - function Conv_R_Work is - new Unchecked_Conversion (Address, R_Work_Ptr); - begin - zheevr (Job_Z, Rng, Uplo, N, - Conv_A (A'Address).all, Ld_A, - Double_Precision (Vl), Double_Precision (Vu), - Il, Iu, Double_Precision (Abs_Tol), M, - Conv_W (W'Address).all, - Conv_Z (Z'Address).all, Ld_Z, - LAPACK.Integer_Vector (I_Supp_Z), - Conv_Work (Work'Address).all, L_Work, - Conv_R_Work (R_Work'Address).all, LR_Work, - LAPACK.Integer_Vector (I_Work), LI_Work, Info); - end; - - else - declare - DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2)); - DP_W : Double_Precision_Vector (W'Range); - DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - DP_Work : Double_Complex_Vector (Work'Range); - DP_R_Work : Double_Precision_Vector (R_Work'Range); - - begin - DP_A := To_Double_Complex (A); - - zheevr (Job_Z, Rng, Uplo, N, - DP_A, Ld_A, - Double_Precision (Vl), Double_Precision (Vu), - Il, Iu, Double_Precision (Abs_Tol), M, - DP_W, DP_Z, Ld_Z, - LAPACK.Integer_Vector (I_Supp_Z), - DP_Work, L_Work, - DP_R_Work, LR_Work, - LAPACK.Integer_Vector (I_Work), LI_Work, Info); - - A := To_Complex (DP_A); - W := To_Real (DP_W); - Z := To_Complex (DP_Z); - - Work (1) := To_Complex (DP_Work (1)); - R_Work (1) := To_Real (DP_R_Work (1)); - end; - end if; - end heevr; - - ----------- - -- steqr -- - ----------- - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Complex_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer) - is - begin - if Is_Single then - declare - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - type Z_Ptr is - access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - csteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - elsif Is_Double then - declare - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - type Z_Ptr is - access all Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - zsteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - else - declare - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_D := To_Double_Precision (D); - DP_E := To_Double_Precision (E); - - if Comp_Z.all = 'V' then - DP_Z := To_Double_Complex (Z); - end if; - - zsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info); - - D := To_Real (DP_D); - E := To_Real (DP_E); - - if Comp_Z.all /= 'N' then - Z := To_Complex (DP_Z); - end if; - end; - end if; - end steqr; - -end System.Generic_Complex_LAPACK; diff --git a/gcc/ada/s-gecola.ads b/gcc/ada/s-gecola.ads deleted file mode 100644 index eb8741ac046..00000000000 --- a/gcc/ada/s-gecola.ads +++ /dev/null @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -with Ada.Numerics.Generic_Complex_Types; -generic - type Real is digits <>; - type Real_Vector is array (Integer range <>) of Real; - - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - type Complex_Vector is array (Integer range <>) of Complex; - type Complex_Matrix is array (Integer range <>, Integer range <>) - of Complex; -package System.Generic_Complex_LAPACK is - pragma Pure; - - type Integer_Vector is array (Integer range <>) of Integer; - - Upper : aliased constant Character := 'U'; - Lower : aliased constant Character := 'L'; - - -- LAPACK Computational Routines - - -- getrf computes LU factorization of a general m-by-n matrix - - procedure getrf - (M : Natural; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - -- getri computes inverse of an LU-factored square matrix, - -- with multiple right-hand sides - - procedure getri - (N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Complex_Vector; - L_Work : Integer; - Info : access Integer); - - -- getrs solves a system of linear equations with an LU-factored - -- square matrix, with multiple right-hand sides - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Complex_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Complex_Matrix; - Ld_B : Positive; - Info : access Integer); - - -- heevr computes selected eigenvalues and, optionally, - -- eigenvectors of a Hermitian matrix using the Relatively - -- Robust Representations - - procedure heevr - (Job_Z : access constant Character; - Rng : access constant Character; - Uplo : access constant Character; - N : Natural; - A : in out Complex_Matrix; - Ld_A : Positive; - Vl, Vu : Real := 0.0; - Il, Iu : Integer := 1; - Abs_Tol : Real := 0.0; - M : out Integer; - W : out Real_Vector; - Z : out Complex_Matrix; - Ld_Z : Positive; - I_Supp_Z : out Integer_Vector; - Work : out Complex_Vector; - L_Work : Integer; - R_Work : out Real_Vector; - LR_Work : Integer; - I_Work : out Integer_Vector; - LI_Work : Integer; - Info : access Integer); - - -- steqr computes all eigenvalues and eigenvectors of a symmetric or - -- Hermitian matrix reduced to tridiagonal form (QR algorithm) - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Complex_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - -end System.Generic_Complex_LAPACK; diff --git a/gcc/ada/s-gerebl.adb b/gcc/ada/s-gerebl.adb deleted file mode 100644 index fc2f5d7d604..00000000000 --- a/gcc/ada/s-gerebl.adb +++ /dev/null @@ -1,311 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ R E A L _ B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Real_BLAS is - - Is_Single : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double : constant Boolean := - Real'Machine_Mantissa = Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = Double_Precision'First - and then - Double_Precision (Real'Last) = Double_Precision'Last; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline_Always (To_Double_Precision); - - function To_Real (X : Double_Precision) return Real; - pragma Inline_Always (To_Real); - - -- Instantiations - - function To_Double_Precision is new - Vector_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Vector => Real_Vector, - Result_Vector => Double_Precision_Vector, - Operation => To_Double_Precision); - - function To_Real is new - Vector_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Vector => Double_Precision_Vector, - Result_Vector => Real_Vector, - Operation => To_Real); - - function To_Double_Precision is new - Matrix_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Matrix => Real_Matrix, - Result_Matrix => Double_Precision_Matrix, - Operation => To_Double_Precision); - - function To_Real is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Matrix => Double_Precision_Matrix, - Result_Matrix => Real_Matrix, - Operation => To_Real); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Real (X : Double_Precision) return Real is - begin - return Real (X); - end To_Real; - - --------- - -- dot -- - --------- - - function dot - (N : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Y : Real_Vector; - Inc_Y : Integer := 1) return Real - is - begin - if Is_Single then - declare - type X_Ptr is access all BLAS.Real_Vector (X'Range); - type Y_Ptr is access all BLAS.Real_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return Real (sdot (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - elsif Is_Double then - declare - type X_Ptr is access all BLAS.Double_Precision_Vector (X'Range); - type Y_Ptr is access all BLAS.Double_Precision_Vector (Y'Range); - function Conv_X is new Unchecked_Conversion (Address, X_Ptr); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - return Real (ddot (N, Conv_X (X'Address).all, Inc_X, - Conv_Y (Y'Address).all, Inc_Y)); - end; - - else - return Real (ddot (N, To_Double_Precision (X), Inc_X, - To_Double_Precision (Y), Inc_Y)); - end if; - end dot; - - ---------- - -- gemm -- - ---------- - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Integer; - B : Real_Matrix; - Ld_B : Integer; - Beta : Real := 0.0; - C : in out Real_Matrix; - Ld_C : Integer) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is BLAS.Real_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is - access all BLAS.Real_Matrix (C'Range (1), C'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type); - function Conv_C is new Unchecked_Conversion (Address, C_Ptr); - begin - sgemm (Trans_A, Trans_B, M, N, K, Fortran.Real (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, Fortran.Real (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - elsif Is_Double then - declare - subtype A_Type is - Double_Precision_Matrix (A'Range (1), A'Range (2)); - subtype B_Type is - Double_Precision_Matrix (B'Range (1), B'Range (2)); - type C_Ptr is - access all Double_Precision_Matrix (C'Range (1), C'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type); - function Conv_C is new Unchecked_Conversion (Address, C_Ptr); - begin - dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha), - Conv_A (A), Ld_A, Conv_B (B), Ld_B, Double_Precision (Beta), - Conv_C (C'Address).all, Ld_C); - end; - - else - declare - DP_C : Double_Precision_Matrix (C'Range (1), C'Range (2)); - begin - if Beta /= 0.0 then - DP_C := To_Double_Precision (C); - end if; - - dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha), - To_Double_Precision (A), Ld_A, - To_Double_Precision (B), Ld_B, Double_Precision (Beta), - DP_C, Ld_C); - - C := To_Real (DP_C); - end; - end if; - end gemm; - - ---------- - -- gemv -- - ---------- - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Beta : Real := 0.0; - Y : in out Real_Vector; - Inc_Y : Integer := 1) - is - begin - if Is_Single then - declare - subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is BLAS.Real_Vector (X'Range); - type Y_Ptr is access all BLAS.Real_Vector (Y'Range); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - sgemv (Trans, M, N, Fortran.Real (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, Fortran.Real (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - elsif Is_Double then - declare - subtype A_Type is - Double_Precision_Matrix (A'Range (1), A'Range (2)); - subtype X_Type is Double_Precision_Vector (X'Range); - type Y_Ptr is access all Double_Precision_Vector (Y'Range); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr); - begin - dgemv (Trans, M, N, Double_Precision (Alpha), - Conv_A (A), Ld_A, Conv_X (X), Inc_X, - Double_Precision (Beta), - Conv_Y (Y'Address).all, Inc_Y); - end; - - else - declare - DP_Y : Double_Precision_Vector (Y'Range); - begin - if Beta /= 0.0 then - DP_Y := To_Double_Precision (Y); - end if; - - dgemv (Trans, M, N, Double_Precision (Alpha), - To_Double_Precision (A), Ld_A, - To_Double_Precision (X), Inc_X, Double_Precision (Beta), - DP_Y, Inc_Y); - - Y := To_Real (DP_Y); - end; - end if; - end gemv; - - ---------- - -- nrm2 -- - ---------- - - function nrm2 - (N : Natural; - X : Real_Vector; - Inc_X : Integer := 1) return Real - is - begin - if Is_Single then - declare - subtype X_Type is BLAS.Real_Vector (X'Range); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - begin - return Real (snrm2 (N, Conv_X (X), Inc_X)); - end; - - elsif Is_Double then - declare - subtype X_Type is Double_Precision_Vector (X'Range); - function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type); - begin - return Real (dnrm2 (N, Conv_X (X), Inc_X)); - end; - - else - return Real (dnrm2 (N, To_Double_Precision (X), Inc_X)); - end if; - end nrm2; - -end System.Generic_Real_BLAS; diff --git a/gcc/ada/s-gerebl.ads b/gcc/ada/s-gerebl.ads deleted file mode 100644 index dacbf7bdb13..00000000000 --- a/gcc/ada/s-gerebl.ads +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.GENERIC_REAL_BLAS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -generic - type Real is digits <>; - type Real_Vector is array (Integer range <>) of Real; - type Real_Matrix is array (Integer range <>, Integer range <>) of Real; -package System.Generic_Real_BLAS is - pragma Pure; - - -- Although BLAS support is only available for IEEE single and double - -- compatible floating-point types, this unit will accept any type - -- and apply conversions as necessary, with possible loss of - -- precision and range. - - No_Trans : aliased constant Character := 'N'; - Trans : aliased constant Character := 'T'; - Conj_Trans : aliased constant Character := 'C'; - - -- BLAS Level 1 Subprograms and Types - - function dot - (N : Positive; - X : Real_Vector; - Inc_X : Integer := 1; - Y : Real_Vector; - Inc_Y : Integer := 1) return Real; - - function nrm2 - (N : Natural; - X : Real_Vector; - Inc_X : Integer := 1) return Real; - - procedure gemv - (Trans : access constant Character; - M : Natural := 0; - N : Natural := 0; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Positive; - X : Real_Vector; - Inc_X : Integer := 1; -- must be non-zero - Beta : Real := 0.0; - Y : in out Real_Vector; - Inc_Y : Integer := 1); -- must be non-zero - - -- BLAS Level 3 - - -- gemm s, d, c, z Matrix-matrix product of general matrices - - procedure gemm - (Trans_A : access constant Character; - Trans_B : access constant Character; - M : Positive; - N : Positive; - K : Positive; - Alpha : Real := 1.0; - A : Real_Matrix; - Ld_A : Integer; - B : Real_Matrix; - Ld_B : Integer; - Beta : Real := 0.0; - C : in out Real_Matrix; - Ld_C : Integer); - -end System.Generic_Real_BLAS; diff --git a/gcc/ada/s-gerela.adb b/gcc/ada/s-gerela.adb deleted file mode 100644 index 57d3640ad4d..00000000000 --- a/gcc/ada/s-gerela.adb +++ /dev/null @@ -1,564 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.GENERIC_REAL_LAPACK -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; use Ada; -with Interfaces; use Interfaces; -with Interfaces.Fortran; use Interfaces.Fortran; -with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS; -with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body System.Generic_Real_LAPACK is - - Is_Real : constant Boolean := - Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa - and then Fortran.Real (Real'First) = Fortran.Real'First - and then Fortran.Real (Real'Last) = Fortran.Real'Last; - - Is_Double_Precision : constant Boolean := - Real'Machine_Mantissa = - Double_Precision'Machine_Mantissa - and then - Double_Precision (Real'First) = - Double_Precision'First - and then - Double_Precision (Real'Last) = - Double_Precision'Last; - - -- Local subprograms - - function To_Double_Precision (X : Real) return Double_Precision; - pragma Inline_Always (To_Double_Precision); - - function To_Real (X : Double_Precision) return Real; - pragma Inline_Always (To_Real); - - -- Instantiations - - function To_Double_Precision is new - Vector_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Vector => Real_Vector, - Result_Vector => Double_Precision_Vector, - Operation => To_Double_Precision); - - function To_Real is new - Vector_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Vector => Double_Precision_Vector, - Result_Vector => Real_Vector, - Operation => To_Real); - - function To_Double_Precision is new - Matrix_Elementwise_Operation - (X_Scalar => Real, - Result_Scalar => Double_Precision, - X_Matrix => Real_Matrix, - Result_Matrix => Double_Precision_Matrix, - Operation => To_Double_Precision); - - function To_Real is new - Matrix_Elementwise_Operation - (X_Scalar => Double_Precision, - Result_Scalar => Real, - X_Matrix => Double_Precision_Matrix, - Result_Matrix => Real_Matrix, - Operation => To_Real); - - function To_Double_Precision (X : Real) return Double_Precision is - begin - return Double_Precision (X); - end To_Double_Precision; - - function To_Real (X : Double_Precision) return Real is - begin - return Real (X); - end To_Real; - - ----------- - -- getrf -- - ----------- - - procedure getrf - (M : Natural; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - sgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - begin - dgetrf (M, N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - begin - DP_A := To_Double_Precision (A); - dgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info); - A := To_Real (DP_A); - end; - end if; - end getrf; - - ----------- - -- getri -- - ----------- - - procedure getri - (N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Real_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - sgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dgetri (N, Conv_A (A'Address).all, Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_A := To_Double_Precision (A); - dgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), - DP_Work, L_Work, Info); - A := To_Real (DP_A); - Work (1) := To_Real (DP_Work (1)); - end; - end if; - end getri; - - ----------- - -- getrs -- - ----------- - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Real_Matrix; - Ld_B : Positive; - Info : access Integer) - is - begin - if Is_Real then - declare - subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all BLAS.Real_Matrix (B'Range (1), B'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - sgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - elsif Is_Double_Precision then - declare - subtype A_Type is - Double_Precision_Matrix (A'Range (1), A'Range (2)); - type B_Ptr is - access all Double_Precision_Matrix (B'Range (1), B'Range (2)); - function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type); - function Conv_B is new Unchecked_Conversion (Address, B_Ptr); - begin - dgetrs (Trans, N, N_Rhs, - Conv_A (A), Ld_A, - LAPACK.Integer_Vector (I_Piv), - Conv_B (B'Address).all, Ld_B, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_B : Double_Precision_Matrix (B'Range (1), B'Range (2)); - begin - DP_A := To_Double_Precision (A); - DP_B := To_Double_Precision (B); - dgetrs (Trans, N, N_Rhs, - DP_A, Ld_A, - LAPACK.Integer_Vector (I_Piv), - DP_B, Ld_B, - Info); - B := To_Real (DP_B); - end; - end if; - end getrs; - - ----------- - -- orgtr -- - ----------- - - procedure orgtr - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - Tau : Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - subtype Tau_Type is BLAS.Real_Vector (Tau'Range); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Tau is - new Unchecked_Conversion (Real_Vector, Tau_Type); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - sorgtr (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_Tau (Tau), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - subtype Tau_Type is Double_Precision_Vector (Tau'Range); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_Tau is - new Unchecked_Conversion (Real_Vector, Tau_Type); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dorgtr (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_Tau (Tau), - Conv_Work (Work'Address).all, L_Work, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - DP_Tau : Double_Precision_Vector (Tau'Range); - begin - DP_A := To_Double_Precision (A); - DP_Tau := To_Double_Precision (Tau); - dorgtr (Uplo, N, DP_A, Ld_A, DP_Tau, DP_Work, L_Work, Info); - A := To_Real (DP_A); - Work (1) := To_Real (DP_Work (1)); - end; - end if; - end orgtr; - - ----------- - -- steqr -- - ----------- - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Real_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer) - is - begin - if Is_Real then - declare - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - type Z_Ptr is - access all BLAS.Real_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - ssteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - elsif Is_Double_Precision then - declare - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - type Z_Ptr is - access all Double_Precision_Matrix (Z'Range (1), Z'Range (2)); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dsteqr (Comp_Z, N, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Z (Z'Address).all, - Ld_Z, - Conv_Work (Work'Address).all, - Info); - end; - - else - declare - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - DP_Z : Double_Precision_Matrix (Z'Range (1), Z'Range (2)); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_D := To_Double_Precision (D); - DP_E := To_Double_Precision (E); - - if Comp_Z.all = 'V' then - DP_Z := To_Double_Precision (Z); - end if; - - dsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info); - - D := To_Real (DP_D); - E := To_Real (DP_E); - Z := To_Real (DP_Z); - end; - end if; - end steqr; - - ----------- - -- sterf -- - ----------- - - procedure sterf - (N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Info : access Integer) - is - begin - if Is_Real then - declare - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - begin - ssterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info); - end; - - elsif Is_Double_Precision then - declare - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - begin - dsterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info); - end; - - else - declare - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - - begin - DP_D := To_Double_Precision (D); - DP_E := To_Double_Precision (E); - - dsterf (N, DP_D, DP_E, Info); - - D := To_Real (DP_D); - E := To_Real (DP_E); - end; - end if; - end sterf; - - ----------- - -- sytrd -- - ----------- - - procedure sytrd - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer) - is - begin - if Is_Real then - declare - type A_Ptr is - access all BLAS.Real_Matrix (A'Range (1), A'Range (2)); - type D_Ptr is access all BLAS.Real_Vector (D'Range); - type E_Ptr is access all BLAS.Real_Vector (E'Range); - type Tau_Ptr is access all BLAS.Real_Vector (Tau'Range); - type Work_Ptr is - access all BLAS.Real_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - ssytrd (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Tau (Tau'Address).all, - Conv_Work (Work'Address).all, - L_Work, - Info); - end; - - elsif Is_Double_Precision then - declare - type A_Ptr is - access all Double_Precision_Matrix (A'Range (1), A'Range (2)); - type D_Ptr is access all Double_Precision_Vector (D'Range); - type E_Ptr is access all Double_Precision_Vector (E'Range); - type Tau_Ptr is access all Double_Precision_Vector (Tau'Range); - type Work_Ptr is - access all Double_Precision_Vector (Work'Range); - function Conv_A is new Unchecked_Conversion (Address, A_Ptr); - function Conv_D is new Unchecked_Conversion (Address, D_Ptr); - function Conv_E is new Unchecked_Conversion (Address, E_Ptr); - function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr); - function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr); - begin - dsytrd (Uplo, N, - Conv_A (A'Address).all, Ld_A, - Conv_D (D'Address).all, - Conv_E (E'Address).all, - Conv_Tau (Tau'Address).all, - Conv_Work (Work'Address).all, - L_Work, - Info); - end; - - else - declare - DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2)); - DP_D : Double_Precision_Vector (D'Range); - DP_E : Double_Precision_Vector (E'Range); - DP_Tau : Double_Precision_Vector (Tau'Range); - DP_Work : Double_Precision_Vector (Work'Range); - begin - DP_A := To_Double_Precision (A); - - dsytrd (Uplo, N, DP_A, Ld_A, DP_D, DP_E, DP_Tau, - DP_Work, L_Work, Info); - - if L_Work /= -1 then - A := To_Real (DP_A); - D := To_Real (DP_D); - E := To_Real (DP_E); - Tau := To_Real (DP_Tau); - end if; - - Work (1) := To_Real (DP_Work (1)); - end; - end if; - end sytrd; - -end System.Generic_Real_LAPACK; diff --git a/gcc/ada/s-gerela.ads b/gcc/ada/s-gerela.ads deleted file mode 100644 index c09ce81d027..00000000000 --- a/gcc/ada/s-gerela.ads +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ R E A L _ L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -generic - type Real is digits <>; - type Real_Vector is array (Integer range <>) of Real; - type Real_Matrix is array (Integer range <>, Integer range <>) of Real; -package System.Generic_Real_LAPACK is - pragma Pure; - - type Integer_Vector is array (Integer range <>) of Integer; - - Upper : aliased constant Character := 'U'; - Lower : aliased constant Character := 'L'; - - -- LAPACK Computational Routines - - -- gerfs Refines the solution of a system of linear equations with - -- a general matrix and estimates its error - -- getrf Computes LU factorization of a general m-by-n matrix - -- getri Computes inverse of an LU-factored general matrix - -- square matrix, with multiple right-hand sides - -- getrs Solves a system of linear equations with an LU-factored - -- square matrix, with multiple right-hand sides - -- orgtr Generates the Float orthogonal matrix Q determined by sytrd - -- steqr Computes all eigenvalues and eigenvectors of a symmetric or - -- Hermitian matrix reduced to tridiagonal form (QR algorithm) - -- sterf Computes all eigenvalues of a Float symmetric - -- tridiagonal matrix using QR algorithm - -- sytrd Reduces a Float symmetric matrix to tridiagonal form - - procedure getrf - (M : Natural; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : out Integer_Vector; - Info : access Integer); - - procedure getri - (N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - Work : in out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure getrs - (Trans : access constant Character; - N : Natural; - N_Rhs : Natural; - A : Real_Matrix; - Ld_A : Positive; - I_Piv : Integer_Vector; - B : in out Real_Matrix; - Ld_B : Positive; - Info : access Integer); - - procedure orgtr - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - Tau : Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - - procedure sterf - (N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Info : access Integer); - - procedure steqr - (Comp_Z : access constant Character; - N : Natural; - D : in out Real_Vector; - E : in out Real_Vector; - Z : in out Real_Matrix; - Ld_Z : Positive; - Work : out Real_Vector; - Info : access Integer); - - procedure sytrd - (Uplo : access constant Character; - N : Natural; - A : in out Real_Matrix; - Ld_A : Positive; - D : out Real_Vector; - E : out Real_Vector; - Tau : out Real_Vector; - Work : out Real_Vector; - L_Work : Integer; - Info : access Integer); - -end System.Generic_Real_LAPACK; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 27c847df6e9..410cc8c0f06 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -1156,7 +1156,7 @@ package body System.Tasking.Stages is Stack_Guard (Self_ID, True); -- Initialize low-level TCB components, that cannot be initialized by - -- the creator. Enter_Task sets Self_ID.LL.Thread + -- the creator. Enter_Task sets Self_ID.LL.Thread. Enter_Task (Self_ID); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 98a57e2556e..34346e39925 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -5013,12 +5013,16 @@ package body Sem_Ch10 is -- Set entity of parent identifiers if the unit is a child -- unit. This ensures that the tree is properly formed from - -- semantic point of view (e.g. for ASIS queries). + -- semantic point of view (e.g. for ASIS queries). The unit + -- entities are not fully analyzed, so we need to follow unit + -- links in the tree. Set_Entity (Nam, Ent); Nam := Prefix (Nam); - Ent := Scope (Ent); + Ent := + Defining_Entity + (Unit (Parent_Spec (Unit_Declaration_Node (Ent)))); -- Set entity of last ancestor diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e62629e2a22..e51b8029803 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7549,16 +7549,14 @@ package body Sem_Ch12 is Scop := Scope (Scop); end loop; - if Scop = Par_I then - - -- Previous instance encloses current instance + -- Previous instance encloses current instance + if Scop = Par_I then null; - elsif Is_Generic_Instance (Scop) then - - -- Current instance is within an unrelated instance + -- Current instance is within an unrelated instance + elsif Is_Generic_Instance (Scop) then null; else diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d30ba09635d..acfb989dc3c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1231,8 +1231,13 @@ package body Sem_Ch13 is -- We do not do this for Pre'Class, since we have to put -- these conditions together in a complex OR expression - if Pname = Name_Postcondition - or else not Class_Present (Aspect) + -- We do not do this in ASIS mode, as ASIS relies on the + -- original node representing the complete expression, when + -- retrieving it through the source aspect table. + + if not ASIS_Mode + and then (Pname = Name_Postcondition + or else not Class_Present (Aspect)) then while Nkind (Expr) = N_And_Then loop Insert_After (Aspect, @@ -1385,6 +1390,7 @@ package body Sem_Ch13 is Args : List_Id; Comp_Expr : Node_Id; Comp_Assn : Node_Id; + New_Expr : Node_Id; begin Args := New_List; @@ -1401,11 +1407,18 @@ package body Sem_Ch13 is goto Continue; end if; + -- Make pragma expressions refer to the original aspect + -- expressions through the Original_Node link. This is used + -- in semantic analysis for ASIS mode, so that the original + -- expression also gets analyzed. + Comp_Expr := First (Expressions (Expr)); while Present (Comp_Expr) loop + New_Expr := Relocate_Node (Comp_Expr); + Set_Original_Node (New_Expr, Comp_Expr); Append (Make_Pragma_Argument_Association (Sloc (Comp_Expr), - Expression => Relocate_Node (Comp_Expr)), + Expression => New_Expr), Args); Next (Comp_Expr); end loop; @@ -1421,10 +1434,12 @@ package body Sem_Ch13 is goto Continue; end if; + New_Expr := Relocate_Node (Expression (Comp_Assn)); + Set_Original_Node (New_Expr, Expression (Comp_Assn)); Append (Make_Pragma_Argument_Association ( Sloc => Sloc (Comp_Assn), Chars => Chars (First (Choices (Comp_Assn))), - Expression => Relocate_Node (Expression (Comp_Assn))), + Expression => New_Expr), Args); Next (Comp_Assn); end loop; @@ -8732,8 +8747,8 @@ package body Sem_Ch13 is Source : constant Entity_Id := T.Source; Target : constant Entity_Id := T.Target; - Source_Siz : Uint; - Target_Siz : Uint; + Source_Siz : Uint; + Target_Siz : Uint; begin -- This validation check, which warns if we have unequal sizes for diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index efc76f11398..4b438e13f1c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6427,38 +6427,20 @@ package body Sem_Ch4 is Func : Entity_Id; Func_Name : Node_Id; Indexing : Node_Id; - Is_Var : Boolean; - Ritem : Node_Id; begin -- Check whether type has a specified indexing aspect Func_Name := Empty; - Is_Var := False; - Ritem := First_Rep_Item (Etype (Prefix)); - while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification then - - -- Prefer Variable_Indexing, but will settle for Constant - - if Get_Aspect_Id (Chars (Identifier (Ritem))) = - Aspect_Constant_Indexing - then - Func_Name := Expression (Ritem); - - elsif Get_Aspect_Id (Chars (Identifier (Ritem))) = - Aspect_Variable_Indexing - then - Func_Name := Expression (Ritem); - Is_Var := True; - exit; - end if; - end if; + if Is_Variable (Prefix) then + Func_Name := Find_Aspect (Etype (Prefix), Aspect_Variable_Indexing); + end if; - Next_Rep_Item (Ritem); - end loop; + if No (Func_Name) then + Func_Name := Find_Aspect (Etype (Prefix), Aspect_Constant_Indexing); + end if; -- If aspect does not exist the expression is illegal. Error is -- diagnosed in caller. @@ -6478,12 +6460,6 @@ package body Sem_Ch4 is end if; end if; - if Is_Var - and then not Is_Variable (Prefix) - then - Error_Msg_N ("Variable indexing cannot be applied to a constant", N); - end if; - if not Is_Overloaded (Func_Name) then Func := Entity (Func_Name); Indexing := Make_Function_Call (Loc, @@ -6526,11 +6502,11 @@ package body Sem_Ch4 is Analyze_One_Call (N, It.Nam, False, Success); if Success then Set_Etype (Name (N), It.Typ); + Set_Entity (Name (N), It.Nam); -- Add implicit dereference interpretation Disc := First_Discriminant (Etype (It.Nam)); - while Present (Disc) loop if Has_Implicit_Dereference (Disc) then Add_One_Interp @@ -6540,12 +6516,21 @@ package body Sem_Ch4 is Next_Discriminant (Disc); end loop; + + exit; end if; Get_Next_Interp (I, It); end loop; end; end if; + if Etype (N) = Any_Type then + Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr)); + Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); + else + Analyze (N); + end if; + return True; end Try_Container_Indexing; @@ -6863,7 +6848,8 @@ package body Sem_Ch4 is First_Actual := First (Parameter_Associations (Call_Node)); -- For cross-reference purposes, treat the new node as being in - -- the source if the original one is. + -- the source if the original one is. Set entity and type, even + -- though they may be overwritten during resolution if overloaded. Set_Comes_From_Source (Subprog, Comes_From_Source (N)); Set_Comes_From_Source (Call_Node, Comes_From_Source (N)); @@ -6872,6 +6858,7 @@ package body Sem_Ch4 is and then not Inside_A_Generic then Set_Entity (Selector_Name (N), Entity (Subprog)); + Set_Etype (Selector_Name (N), Etype (Entity (Subprog))); end if; -- If need be, rewrite first actual as an explicit dereference diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 1b0f919d3ff..0e6c5cf98bd 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2429,8 +2429,17 @@ package body Sem_Ch5 is -- The type of the loop variable is the Iterator_Element aspect of -- the container type. - Set_Etype (Def_Id, - Entity (Find_Aspect (Typ, Aspect_Iterator_Element))); + declare + Element : constant Entity_Id := + Find_Aspect (Typ, Aspect_Iterator_Element); + begin + if No (Element) then + Error_Msg_NE ("cannot iterate over&", N, Typ); + return; + else + Set_Etype (Def_Id, Entity (Element)); + end if; + end; else -- For an iteration of the form IN, the name must denote an @@ -2440,12 +2449,17 @@ package body Sem_Ch5 is if Is_Entity_Name (Original_Node (Name (N))) and then not Is_Iterator (Typ) then - Error_Msg_N - ("name must be an iterator, not a container", Name (N)); + if No (Find_Aspect (Typ, Aspect_Iterator_Element)) then + Error_Msg_NE + ("cannot iterate over&", Name (N), Typ); + else + Error_Msg_N + ("name must be an iterator, not a container", Name (N)); + end if; Error_Msg_NE - ("\to iterate directly over a container, write `of &`", - Name (N), Original_Node (Name (N))); + ("\to iterate directly over the elements of a container, " & + "write `of &`", Name (N), Original_Node (Name (N))); end if; -- The result type of Iterate function is the classwide type of diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3dbf782b60b..a9f84d34faa 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1641,10 +1641,13 @@ package body Sem_Ch6 is -- The type must be completed in the current package. This -- is checked at the end of the package declaraton, when - -- Taft amemdment types are identified. + -- Taft-amendment types are identified. If the return type + -- is class-wide, there is no required check, the type can + -- be a bona fide TAT. if Ekind (Scope (Current_Scope)) = E_Package and then In_Private_Part (Scope (Current_Scope)) + and then not Is_Class_Wide_Type (Typ) then Append_Elmt (Designator, Private_Dependents (Typ)); end if; @@ -3415,14 +3418,17 @@ package body Sem_Ch6 is -- Ada 2005 (AI-251): If the return type is abstract, verify that -- the subprogram is abstract also. This does not apply to renaming - -- declarations, where abstractness is inherited. + -- declarations, where abstractness is inherited, and to subprogram + -- bodies generated for stream operations, which become renamings as + -- bodies. -- In case of primitives associated with abstract interface types -- the check is applied later (see Analyze_Subprogram_Declaration). - if not Nkind_In (Parent (N), N_Subprogram_Renaming_Declaration, - N_Abstract_Subprogram_Declaration, - N_Formal_Abstract_Subprogram_Declaration) + if not Nkind_In (Original_Node (Parent (N)), + N_Subprogram_Renaming_Declaration, + N_Abstract_Subprogram_Declaration, + N_Formal_Abstract_Subprogram_Declaration) then if Is_Abstract_Type (Etype (Designator)) and then not Is_Interface (Etype (Designator)) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9de2f1f0320..397c73380a2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -181,7 +181,7 @@ package body Sem_Prag is -- original one, following the renaming chain) is returned. Otherwise the -- entity is returned unchanged. Should be in Einfo??? - procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id); + procedure Preanalyze_TC_Args (N, Arg_Req, Arg_Ens : Node_Id); -- Preanalyze the boolean expressions in the Requires and Ensures arguments -- of a Test_Case pragma if present (possibly Empty). We treat these as -- spec expressions (i.e. similar to a default expression). @@ -260,8 +260,17 @@ package body Sem_Prag is -- Preanalyze the boolean expression, we treat this as a spec expression -- (i.e. similar to a default expression). - Preanalyze_Spec_Expression - (Get_Pragma_Arg (Arg1), Standard_Boolean); + Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); + + -- In ASIS mode, for a pragma generated from a source aspect, also + -- analyze the original aspect expression. + + if ASIS_Mode + and then Present (Corresponding_Aspect (N)) + then + Preanalyze_Spec_Expression + (Expression (Corresponding_Aspect (N)), Standard_Boolean); + end if; -- For a class-wide condition, a reference to a controlling formal must -- be interpreted as having the class-wide type (or an access to such) @@ -518,6 +527,15 @@ package body Sem_Prag is -- This procedure checks for possible duplications if this is the export -- case, and if found, issues an appropriate error message. + procedure Check_Expr_Is_Static_Expression + (Expr : Node_Id; + Typ : Entity_Id := Empty); + -- Check the specified expression Expr to make sure that it is a static + -- expression of the given type (i.e. it will be analyzed and resolved + -- using this type, which can be any valid argument to Resolve, e.g. + -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If + -- Typ is left Empty, then any static expression is allowed. + procedure Check_First_Subtype (Arg : Node_Id); -- Checks that Arg, whose expression is an entity name, references a -- first subtype. @@ -1199,53 +1217,8 @@ package body Sem_Prag is (Arg : Node_Id; Typ : Entity_Id := Empty) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin - if Present (Typ) then - Analyze_And_Resolve (Argx, Typ); - else - Analyze_And_Resolve (Argx); - end if; - - if Is_OK_Static_Expression (Argx) then - return; - - elsif Etype (Argx) = Any_Type then - raise Pragma_Exit; - - -- An interesting special case, if we have a string literal and we - -- are in Ada 83 mode, then we allow it even though it will not be - -- flagged as static. This allows the use of Ada 95 pragmas like - -- Import in Ada 83 mode. They will of course be flagged with - -- warnings as usual, but will not cause errors. - - elsif Ada_Version = Ada_83 - and then Nkind (Argx) = N_String_Literal - then - return; - - -- Static expression that raises Constraint_Error. This has already - -- been flagged, so just exit from pragma processing. - - elsif Is_Static_Expression (Argx) then - raise Pragma_Exit; - - -- Finally, we have a real error - - else - Error_Msg_Name_1 := Pname; - - declare - Msg : String := - "argument for pragma% must be a static expression!"; - begin - Fix_Error (Msg); - Flag_Non_Static_Expr (Msg, Argx); - end; - - raise Pragma_Exit; - end if; + Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ); end Check_Arg_Is_Static_Expression; ------------------------------------------ @@ -1478,6 +1451,61 @@ package body Sem_Prag is end if; end Check_Duplicated_Export_Name; + ------------------------------------- + -- Check_Expr_Is_Static_Expression -- + ------------------------------------- + + procedure Check_Expr_Is_Static_Expression + (Expr : Node_Id; + Typ : Entity_Id := Empty) + is + begin + if Present (Typ) then + Analyze_And_Resolve (Expr, Typ); + else + Analyze_And_Resolve (Expr); + end if; + + if Is_OK_Static_Expression (Expr) then + return; + + elsif Etype (Expr) = Any_Type then + raise Pragma_Exit; + + -- An interesting special case, if we have a string literal and we + -- are in Ada 83 mode, then we allow it even though it will not be + -- flagged as static. This allows the use of Ada 95 pragmas like + -- Import in Ada 83 mode. They will of course be flagged with + -- warnings as usual, but will not cause errors. + + elsif Ada_Version = Ada_83 + and then Nkind (Expr) = N_String_Literal + then + return; + + -- Static expression that raises Constraint_Error. This has already + -- been flagged, so just exit from pragma processing. + + elsif Is_Static_Expression (Expr) then + raise Pragma_Exit; + + -- Finally, we have a real error + + else + Error_Msg_Name_1 := Pname; + + declare + Msg : String := + "argument for pragma% must be a static expression!"; + begin + Fix_Error (Msg); + Flag_Non_Static_Expr (Msg, Expr); + end; + + raise Pragma_Exit; + end if; + end Check_Expr_Is_Static_Expression; + ------------------------- -- Check_First_Subtype -- ------------------------- @@ -1980,6 +2008,16 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); + + -- In ASIS mode, for a pragma generated from a source aspect, + -- also analyze the original aspect expression. + + if ASIS_Mode + and then Present (Corresponding_Aspect (N)) + then + Preanalyze_Spec_Expression + (Expression (Corresponding_Aspect (N)), Standard_Boolean); + end if; end if; In_Body := True; @@ -5462,10 +5500,10 @@ package body Sem_Prag is -- a non-atomic variable. if C = Atomic_Synchronization - and then not Is_Atomic (E) + and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) then Error_Msg_N - ("pragma & requires atomic variable", + ("pragma & requires atomic type or variable", Pragma_Identifier (Original_Node (N))); end if; @@ -7864,10 +7902,13 @@ package body Sem_Prag is N_Indexed_Component, N_Function_Call, N_Identifier, + N_Expanded_Name, N_Selected_Component) then -- If this pragma Debug comes from source, its argument was -- parsed as a name form (which is syntactically identical). + -- In a generic context a parameterless call will be left as + -- an expanded name (if global) or selected_component if local. -- Change it to a procedure call statement now. Change_Name_To_Procedure_Call_Statement (Call); @@ -10952,7 +10993,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 +11009,42 @@ package body Sem_Prag is if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then if Opt.Float_Format_Long = 'G' then - Error_Pragma ("G_Float previously specified"); - end if; + Error_Pragma_Arg + ("G_Float previously specified", Arg1); + + elsif Current_Sem_Unit /= Main_Unit + and then Opt.Float_Format_Long /= 'D' + then + Error_Pragma_Arg + ("main unit not compiled with pragma Long_Float (D_Float)", + "\pragma% must be used consistently for whole partition", + Arg1); - Opt.Float_Format_Long := 'D'; + else + Opt.Float_Format_Long := 'D'; + end if; -- G_Float case (this is the default, does not need overriding) else if Opt.Float_Format_Long = 'D' then Error_Pragma ("D_Float previously specified"); - end if; - Opt.Float_Format_Long := 'G'; + elsif Current_Sem_Unit /= Main_Unit + and then Opt.Float_Format_Long /= 'G' + then + Error_Pragma_Arg + ("main unit not compiled with pragma Long_Float (G_Float)", + "\pragma% must be used consistently for whole partition", + Arg1); + + else + Opt.Float_Format_Long := 'G'; + end if; end if; Set_Standard_Fpt_Formats; + end Long_Float; ----------------------- -- Machine_Attribute -- @@ -13657,6 +13719,17 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Name); Check_Arg_Is_Static_Expression (Arg1, Standard_String); + + -- In ASIS mode, for a pragma generated from a source aspect, also + -- analyze the original aspect expression. + + if ASIS_Mode + and then Present (Corresponding_Aspect (N)) + then + Check_Expr_Is_Static_Expression + (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); + end if; + Check_Optional_Identifier (Arg2, Name_Mode); Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); @@ -14374,7 +14447,7 @@ package body Sem_Prag is -- actual is a conversion. Retrieve the real entity name. if (In_Instance_Body - or else In_Inlined_Body) + or else In_Inlined_Body) and then Nkind (E_Id) = N_Unchecked_Type_Conversion then E_Id := Expression (E_Id); @@ -14545,7 +14618,8 @@ package body Sem_Prag is -- Preanalyze the boolean expressions, we treat these as spec -- expressions (i.e. similar to a default expression). - Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N), + Preanalyze_TC_Args (N, + Get_Requires_From_Test_Case_Pragma (N), Get_Ensures_From_Test_Case_Pragma (N)); -- Remove the subprogram from the scope stack now that the pre-analysis @@ -15065,7 +15139,7 @@ package body Sem_Prag is -- Preanalyze_TC_Args -- ------------------------ - procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id) is + procedure Preanalyze_TC_Args (N, Arg_Req, Arg_Ens : Node_Id) is begin -- Preanalyze the boolean expressions, we treat these as spec -- expressions (i.e. similar to a default expression). @@ -15073,11 +15147,31 @@ package body Sem_Prag is if Present (Arg_Req) then Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg_Req), Standard_Boolean); + + -- In ASIS mode, for a pragma generated from a source aspect, also + -- analyze the original aspect expression. + + if ASIS_Mode + and then Present (Corresponding_Aspect (N)) + then + Preanalyze_Spec_Expression + (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean); + end if; end if; if Present (Arg_Ens) then Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg_Ens), Standard_Boolean); + + -- In ASIS mode, for a pragma generated from a source aspect, also + -- analyze the original aspect expression. + + if ASIS_Mode + and then Present (Corresponding_Aspect (N)) + then + Preanalyze_Spec_Expression + (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean); + end if; end if; end Preanalyze_TC_Args; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index d94a6bfa328..ad59f952252 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3926,16 +3926,16 @@ package body Sem_Res is if Is_Atomic_Object (A) and then not Is_Atomic (Etype (F)) then - Error_Msg_N - ("cannot pass atomic argument to non-atomic formal", - N); + Error_Msg_NE + ("cannot pass atomic argument to non-atomic formal&", + A, F); elsif Is_Volatile_Object (A) and then not Is_Volatile (Etype (F)) then - Error_Msg_N - ("cannot pass volatile argument to non-volatile formal", - N); + Error_Msg_NE + ("cannot pass volatile argument to non-volatile formal&", + A, F); end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9dfecd3d956..1764da9db02 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10837,7 +10837,9 @@ package body Sem_Util is -- source. This excludes, for example, calls to a dispatching -- assignment operation when the left-hand side is tagged. - if Modification_Comes_From_Source then + if Modification_Comes_From_Source + or else Alfa_Mode + then Generate_Reference (Ent, Exp, 'm'); -- If the target of the assignment is the bound variable @@ -12835,6 +12837,11 @@ package body Sem_Util is U := Corresponding_Spec (P); end if; + when Formal_Kind => + if Present (Spec_Entity (E)) then + U := Spec_Entity (E); + end if; + when others => null; end case; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 9f0b259311c..99b71c00fbf 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3993,39 +3993,59 @@ package body Sem_Warn is -- Case of assigned value never referenced if No (N) then + declare + LA : constant Node_Id := Last_Assignment (Ent); - -- Don't give this for OUT and IN OUT formals, since - -- clearly caller may reference the assigned value. Also - -- never give such warnings for internal variables. + begin + -- Don't give this for OUT and IN OUT formals, since + -- clearly caller may reference the assigned value. Also + -- never give such warnings for internal variables. - if Ekind (Ent) = E_Variable - and then not Is_Internal_Name (Chars (Ent)) - then - if Referenced_As_Out_Parameter (Ent) then - Error_Msg_NE - ("?& modified by call, but value never referenced", - Last_Assignment (Ent), Ent); - else - Error_Msg_NE -- CODEFIX - ("?useless assignment to&, value never referenced!", - Last_Assignment (Ent), Ent); + if Ekind (Ent) = E_Variable + and then not Is_Internal_Name (Chars (Ent)) + then + -- Give appropriate message, distinguishing between + -- assignment statements and out parameters. + + if Nkind_In (Parent (LA), N_Procedure_Call_Statement, + N_Parameter_Association) + then + Error_Msg_NE + ("?& modified by call, but value never " + & "referenced", LA, Ent); + + else + Error_Msg_NE -- CODEFIX + ("?useless assignment to&, value never " + & "referenced!", LA, Ent); + end if; end if; - end if; + end; -- Case of assigned value overwritten else - Error_Msg_Sloc := Sloc (N); + declare + LA : constant Node_Id := Last_Assignment (Ent); - if Referenced_As_Out_Parameter (Ent) then - Error_Msg_NE - ("?& modified by call, but value overwritten #!", - Last_Assignment (Ent), Ent); - else - Error_Msg_NE -- CODEFIX - ("?useless assignment to&, value overwritten #!", - Last_Assignment (Ent), Ent); - end if; + begin + Error_Msg_Sloc := Sloc (N); + + -- Give appropriate message, distinguishing between + -- assignment statements and out parameters. + + if Nkind_In (Parent (LA), N_Procedure_Call_Statement, + N_Parameter_Association) + then + Error_Msg_NE + ("?& modified by call, but value overwritten #!", + LA, Ent); + else + Error_Msg_NE -- CODEFIX + ("?useless assignment to&, value overwritten #!", + LA, Ent); + end if; + end; end if; -- Clear last assignment indication and we are done diff --git a/gcc/ada/sigtramp-ppcvxw.c b/gcc/ada/sigtramp-ppcvxw.c index 57a02a7d162..bebe6572ee1 100644 --- a/gcc/ada/sigtramp-ppcvxw.c +++ b/gcc/ada/sigtramp-ppcvxw.c @@ -55,7 +55,11 @@ Checking which variant should apply and getting at sc_pregs is simpler to express in C (we can't use offsetof in toplevel asms and hardcoding constants is not workable with the flurry of VxWorks variants), so this - is the choice for our toplevel interface. */ + is the choice for our toplevel interface. + + Note that the registers we "restore" here are those to which we have + direct access through the system sigcontext structure, which includes + only a partial set of the non-volatiles ABI-wise. */ /* ----------------------------------------- -- Protypes for our internal asm stubs -- @@ -120,8 +124,9 @@ void __gnat_sigtramp (int signo, void *si, void *sc, /* REGNO constants, dwarf column numbers for registers of interest. */ #define REGNO_LR 65 -#define REGNO_XER 76 +#define REGNO_CTR 66 #define REGNO_CR 70 +#define REGNO_XER 76 #define REGNO_GR(N) (N) #define REGNO_PC 67 /* ARG_POINTER_REGNUM */ @@ -139,6 +144,8 @@ void __gnat_sigtramp (int signo, void *si, void *sc, multine contents: */ #define TAB(S) "\t" S #define CR(S) S "\n" + +#undef TCR #define TCR(S) TAB(CR(S)) /*------------------------------ @@ -147,11 +154,18 @@ void __gnat_sigtramp (int signo, void *si, void *sc, /* CFA setup block --------------- - Only non-volatile registers are suitable for a CFA base. We use r14 - here and set it to the value we need in stub body that follows. */ + Only non-volatile registers are suitable for a CFA base. These are the + only ones we can expect to be able retrieve from the unwinding context + while walking up the chain, saved by at least the bottom-most exception + propagation services. We use r15 here and set it to the value we need + in stub body that follows. Note that r14 is inappropriate here, even + though it is non-volatile according to the ABI, because GCC uses it as + an extra SCRATCH on SPE targets. */ + +#define CFA_REG 15 #define CFI_DEF_CFA \ -CR(".cfi_def_cfa 14, 0") +CR(".cfi_def_cfa " S(CFA_REG) ", 0") /* Register location blocks ------------------------ @@ -164,7 +178,18 @@ CR(".cfi_def_cfa 14, 0") #define CFI_COMMON_REGS \ CR("# CFI for common registers\n") \ -TCR(COMMON_CFI(GR(1))) \ +TCR(COMMON_CFI(GR(2))) \ +TCR(COMMON_CFI(GR(3))) \ +TCR(COMMON_CFI(GR(4))) \ +TCR(COMMON_CFI(GR(5))) \ +TCR(COMMON_CFI(GR(6))) \ +TCR(COMMON_CFI(GR(7))) \ +TCR(COMMON_CFI(GR(8))) \ +TCR(COMMON_CFI(GR(9))) \ +TCR(COMMON_CFI(GR(10))) \ +TCR(COMMON_CFI(GR(11))) \ +TCR(COMMON_CFI(GR(12))) \ +TCR(COMMON_CFI(GR(13))) \ TCR(COMMON_CFI(GR(14))) \ TCR(COMMON_CFI(GR(15))) \ TCR(COMMON_CFI(GR(16))) \ @@ -185,6 +210,8 @@ TCR(COMMON_CFI(GR(30))) \ TCR(COMMON_CFI(GR(31))) \ TCR(COMMON_CFI(LR)) \ TCR(COMMON_CFI(CR)) \ +TCR(COMMON_CFI(CTR)) \ +TCR(COMMON_CFI(XER)) \ TCR(COMMON_CFI(PC)) \ TCR(".cfi_return_column " S(REGNO_PC)) @@ -198,10 +225,10 @@ TCR("# registers we're going to modify") \ TCR("stwu %r1,-16(%r1)") \ TCR("mflr %r0") \ TCR("stw %r0,20(%r1)") \ -TCR("stw %r14,8(%r1)") \ +TCR("stw %r" S(CFA_REG) ",8(%r1)") \ TCR("") \ -TCR("# Setup r14 = sc_pregs, that we'll retrieve as our CFA value") \ -TCR("mr %r14, %r7") \ +TCR("# Setup CFA_REG = sc_pregs, that we'll retrieve as our CFA value") \ +TCR("mr %r" S(CFA_REG) ", %r7") \ TCR("") \ TCR("# Call the real handler. The signo, siginfo and sigcontext") \ TCR("# arguments are the same as those we received in r3, r4 and r5") \ @@ -209,7 +236,7 @@ TCR("mtctr %r6") \ TCR("bctrl") \ TCR("") \ TCR("# Restore our callee-saved items, release our frame and return") \ -TCR("lwz %r14,8(%r1)") \ +TCR("lwz %r" S(CFA_REG) ",8(%r1)") \ TCR("lwz %r0,20(%r1)") \ TCR("mtlr %r0") \ TCR("") \ diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 916e0ae5843..b36b930b8c4 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -254,7 +254,10 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Expanded_Name - or else NT (N).Nkind = N_Identifier); + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Indexed_Component + or else NT (N).Nkind = N_Selected_Component); return Flag14 (N); end Atomic_Sync_Required; @@ -3323,7 +3326,10 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Expanded_Name - or else NT (N).Nkind = N_Identifier); + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Indexed_Component + or else NT (N).Nkind = N_Selected_Component); Set_Flag14 (N, Val); end Set_Atomic_Sync_Required; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0b5a52f5dc7..35a73f9ad94 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -606,10 +606,8 @@ package Sinfo is -- harmless. -- Atomic_Sync_Required (Flag14-Sem) - -- This flag is set in an identifier or expanded name node if the - -- corresponding reference (or assignment when on the left side of - -- an assignment) requires atomic synchronization, as a result of - -- Atomic_Synchronization being enabled for the corresponding entity. + -- This flag is set on a node for which atomic synchronization is + -- required for the corresponding reference or modification. -- At_End_Proc (Node1) -- This field is present in an N_Handled_Sequence_Of_Statements node. @@ -3175,6 +3173,7 @@ package Sinfo is -- Sloc points to ALL -- Prefix (Node3) -- Actual_Designated_Subtype (Node4-Sem) + -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression ------------------------------- @@ -3197,6 +3196,7 @@ package Sinfo is -- Sloc contains a copy of the Sloc value of the Prefix -- Prefix (Node3) -- Expressions (List1) + -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression -- Note: if any of the subscripts requires a range check, then the @@ -3240,6 +3240,7 @@ package Sinfo is -- Associated_Node (Node4-Sem) -- Do_Discriminant_Check (Flag13-Sem) -- Is_In_Discriminant_Check (Flag11-Sem) + -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression -------------------------- diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 6d0be93a571..175af07969b 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -51,6 +51,7 @@ package body Sinput is -- Make control characters visible First_Time_Around : Boolean := True; + -- This needs a comment ??? -- Routines to support conversion between types Lines_Table_Ptr, -- Logical_Lines_Table_Ptr and System.Address. diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 3c45d789390..674c9db05ac 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2694,9 +2694,19 @@ package body Sprint is if Paren_Count (Expression (Node)) /= 0 then Sprint_Node (Expression (Node)); + else Write_Char ('('); Sprint_Node (Expression (Node)); + + -- Odd case, for the qualified expressions used in machine + -- code the argument may be a procedure call, resulting in + -- a junk semicolon before the right parent, get rid of it. + + Write_Erase_Char (';'); + + -- Now we can add the terminating right paren + Write_Char (')'); end if; |