From b5ace3b78346ae029998488057606133f714f222 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 31 Oct 2006 19:21:54 +0100 Subject: [PATCH] Resync. From-SVN: r118333 --- gcc/ada/a-crdlli.adb | 1505 ++++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-crdlli.ads | 220 ++++++ gcc/ada/a-wtenio.adb | 6 - gcc/ada/elists.adb | 9 +- gcc/ada/exp_tss.ads | 22 +- gcc/ada/fname.adb | 2 +- gcc/ada/gnatvsn.ads | 29 +- gcc/ada/impunit.ads | 2 +- gcc/ada/initialize.c | 2 +- gcc/ada/s-dsaser.ads | 47 ++ gcc/ada/s-imgdec.ads | 5 +- gcc/ada/s-osinte-vms.ads | 28 +- gcc/ada/sem_ch13.ads | 2 +- gcc/ada/system-linux-ppc.ads | 17 +- 14 files changed, 1829 insertions(+), 67 deletions(-) create mode 100644 gcc/ada/a-crdlli.adb create mode 100644 gcc/ada/a-crdlli.ads create mode 100644 gcc/ada/s-dsaser.ads diff --git a/gcc/ada/a-crdlli.adb b/gcc/ada/a-crdlli.adb new file mode 100644 index 0000000..1e99800 --- /dev/null +++ b/gcc/ada/a-crdlli.adb @@ -0,0 +1,1505 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . -- +-- R E S R I C T E D _ D O U B L Y _ L I N K E D _ L I S T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2006, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Restricted_Doubly_Linked_Lists is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List'Class; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Free + (Container : in out List'Class; + X : Count_Type); + + procedure Insert_Internal + (Container : in out List'Class; + Before : Count_Type; + New_Node : Count_Type); + + function Vet (Position : Cursor) return Boolean; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + LN : Node_Array renames Left.Nodes; + RN : Node_Array renames Right.Nodes; + + LI : Count_Type := Left.First; + RI : Count_Type := Right.First; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + for J in 1 .. Left.Length loop + if LN (LI).Element /= RN (RI).Element then + return False; + end if; + + LI := LN (LI).Next; + RI := RN (RI).Next; + end loop; + + return True; + end "="; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Container : in out List'Class; + New_Item : Element_Type; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + N (New_Node).Element := New_Item; + Container.Free := N (New_Node).Next; + + else + New_Node := abs Container.Free; + N (New_Node).Element := New_Item; + Container.Free := Container.Free - 1; + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Constraint_Error; -- ??? + end if; + + Clear (Target); + + declare + N : Node_Array renames Source.Nodes; + J : Count_Type := Source.First; + + begin + while J /= 0 loop + Append (Target, N (J).Element); + J := N (J).Next; + end loop; + end; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); +-- pragma Assert (Container.Busy = 0); +-- pragma Assert (Container.Lock = 0); + return; + end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + while Container.Length > 1 loop + X := Container.First; + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + + X := Container.First; + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container, X); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; + + if Count = 0 then + Position := No_Element; + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container, X); + return; + end if; + + Position.Node := N (X).Next; + + N (N (X).Next).Prev := N (X).Prev; + N (N (X).Prev).Next := N (X).Next; + + Free (Container, X); + end loop; + + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + for I in 1 .. Count loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + for I in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + declare + N : Node_Array renames Position.Container.Nodes; + begin + return N (Position.Node).Element; + end; + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type := Position.Node; + + begin + if Node = 0 then + Node := Container.First; + + else + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); + end if; + + while Node /= 0 loop + if Nodes (Node).Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Nodes (Node).Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + N : Node_Array renames Container.Nodes; + + begin + if Container.First = 0 then + raise Constraint_Error; + end if; + + return N (Container.First).Element; + end First_Element; + + ---------- + -- Free -- + ---------- + + procedure Free + (Container : in out List'Class; + X : Count_Type) + is + pragma Assert (X > 0); + pragma Assert (X <= Container.Capacity); + + N : Node_Array renames Container.Nodes; + + begin + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Container.Free >= 0 then + N (X).Next := Container.Free; + Container.Free := X; + + elsif X + 1 = abs Container.Free then + N (X).Next := 0; -- Not strictly necessary, but marginally safer + Container.Free := Container.Free + 1; + + else + Container.Free := abs Container.Free; + + if Container.Free > Container.Capacity then + Container.Free := 0; + + else + for I in Container.Free .. Container.Capacity - 1 loop + N (I).Next := I + 1; + end loop; + + N (Container.Capacity).Next := 0; + end if; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type := Container.First; + + begin + for I in 2 .. Container.Length loop + if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then + return False; + end if; + + Node := Nodes (Node).Next; + end loop; + + return True; + end Is_Sorted; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + N : Node_Array renames Container.Nodes; + + procedure Partition (Pivot, Back : Count_Type); + procedure Sort (Front, Back : Count_Type); + + --------------- + -- Partition -- + --------------- + + procedure Partition (Pivot, Back : Count_Type) is + Node : Count_Type := N (Pivot).Next; + + begin + while Node /= Back loop + if N (Node).Element < N (Pivot).Element then + declare + Prev : constant Count_Type := N (Node).Prev; + Next : constant Count_Type := N (Node).Next; + + begin + N (Prev).Next := Next; + + if Next = 0 then + Container.Last := Prev; + else + N (Next).Prev := Prev; + end if; + + N (Node).Next := Pivot; + N (Node).Prev := N (Pivot).Prev; + + N (Pivot).Prev := Node; + + if N (Node).Prev = 0 then + Container.First := Node; + else + N (N (Node).Prev).Next := Node; + end if; + + Node := Next; + end; + + else + Node := N (Node).Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Count_Type) is + Pivot : Count_Type; + + begin + if Front = 0 then + Pivot := Container.First; + else + Pivot := N (Front).Next; + end if; + + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Sort + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + Sort (Front => 0, Back => 0); + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Sort; + + end Generic_Sorting; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= 0; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + J : Count_Type; + + begin + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Container.Length > Container.Capacity - Count then + raise Constraint_Error; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + Position := Cursor'(Container'Unrestricted_Access, Node => J); + + for Index in 2 .. Count loop + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Do we need to reinit node ??? + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List'Class; + Before : Count_Type; + New_Node : Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + + Container.First := New_Node; + Container.Last := New_Node; + + N (Container.First).Prev := 0; + N (Container.Last).Next := 0; + + elsif Before = 0 then + pragma Assert (N (Container.Last).Next = 0); + + N (Container.Last).Next := New_Node; + N (New_Node).Prev := Container.Last; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + elsif Before = Container.First then + pragma Assert (N (Container.First).Prev = 0); + + N (Container.First).Prev := New_Node; + N (New_Node).Next := Container.First; + + Container.First := New_Node; + N (Container.First).Prev := 0; + + else + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + N (New_Node).Next := Before; + N (New_Node).Prev := N (Before).Prev; + + N (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + C : List renames Container'Unrestricted_Access.all; + N : Node_Array renames C.Nodes; +-- B : Natural renames C.Busy; + + Node : Count_Type := Container.First; + + Index : Count_Type := 0; + Index_Max : constant Count_Type := Container.Length; + + begin + if Index_Max = 0 then + pragma Assert (Node = 0); + return; + end if; + + loop + pragma Assert (Node /= 0); + + Process (Cursor'(C'Unchecked_Access, Node)); + pragma Assert (Container.Length = Index_Max); + pragma Assert (N (Node).Prev /= -1); + + Node := N (Node).Next; + Index := Index + 1; + + if Index = Index_Max then + pragma Assert (Node = 0); + return; + end if; + end loop; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + N : Node_Array renames Container.Nodes; + + begin + if Container.Last = 0 then + raise Constraint_Error; + end if; + + return N (Container.Last).Element; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Next; + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Previous"); + + declare + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Prev; + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + N : Node_Type renames C.Nodes (Position.Node); + + begin + Process (N.Element); + pragma Assert (N.Prev >= 0); + end; + end Query_Element; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + +-- if Container.Lock > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + declare + N : Node_Array renames Container.Nodes; + begin + N (Position.Node).Element := New_Item; + end; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + N : Node_Array renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; + + procedure Swap (L, R : Count_Type); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; + + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := N (J).Next; + exit when I = J; + + I := N (I).Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := N (I).Next; + exit when I = J; + + J := N (J).Prev; + exit when I = J; + end loop; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + N : Node_Array renames Container.Nodes; + Node : Count_Type := Position.Node; + + begin + if Node = 0 then + Node := Container.Last; + + else + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; + + while Node /= 0 loop + if N (Node).Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := N (Node).Prev; + end loop; + + return No_Element; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + C : List renames Container'Unrestricted_Access.all; + N : Node_Array renames C.Nodes; +-- B : Natural renames C.Busy; + + Node : Count_Type := Container.Last; + + Index : Count_Type := 0; + Index_Max : constant Count_Type := Container.Length; + + begin + if Index_Max = 0 then + pragma Assert (Node = 0); + return; + end if; + + loop + pragma Assert (Node > 0); + + Process (Cursor'(C'Unchecked_Access, Node)); + pragma Assert (Container.Length = Index_Max); + pragma Assert (N (Node).Prev /= -1); + + Node := N (Node).Prev; + Index := Index + 1; + + if Index = Index_Max then + pragma Assert (Node = 0); + return; + end if; + end loop; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : in out Cursor) + is + N : Node_Array renames Container.Nodes; + + begin + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Position.Node = 0 then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; + + Container.Last := Position.Node; + N (Container.Last).Next := 0; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.First).Prev := Position.Node; + N (Position.Node).Next := Container.First; + + Container.First := Position.Node; + N (Container.First).Prev := 0; + + return; + end if; + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + elsif Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (N (Before.Node).Prev).Next := Position.Node; + N (Position.Node).Prev := N (Before.Node).Prev; + + N (Before.Node).Prev := Position.Node; + N (Position.Node).Next := Before.Node; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = 0 + or else J.Node = 0 + then + raise Constraint_Error; + end if; + + if I.Container /= Container'Unrestricted_Access + or else J.Container /= Container'Unrestricted_Access + then + raise Program_Error; + end if; + + if I.Node = J.Node then + return; + end if; + +-- if Container.Lock > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + declare + N : Node_Array renames Container.Nodes; + + EI : Element_Type renames N (I.Node).Element; + EJ : Element_Type renames N (J.Node).Element; + + EI_Copy : constant Element_Type := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = 0 + or else J.Node = 0 + then + raise Constraint_Error; + end if; + + if I.Container /= Container'Unrestricted_Access + or else I.Container /= J.Container + then + raise Program_Error; + end if; + + if I.Node = J.Node then + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + + declare + I_Next : constant Cursor := Next (I); + J_Copy : Cursor := J; + + begin + if I_Next = J then + Splice (Container, Before => I, Position => J_Copy); + + else + declare + J_Next : constant Cursor := Next (J); + I_Copy : Cursor := I; + + begin + if J_Next = I then + Splice (Container, Before => J, Position => I_Copy); + + else + pragma Assert (Container.Length >= 3); + + Splice (Container, Before => I_Next, Position => J_Copy); + Splice (Container, Before => J_Next, Position => I_Copy); + end if; + end; + end if; + end; + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + + begin + Process (N.Element); + pragma Assert (N.Prev >= 0); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + declare + L : List renames Position.Container.all; + N : Node_Array renames L.Nodes; + + begin + if L.Length = 0 then + return False; + end if; + + if L.First = 0 then + return False; + end if; + + if L.Last = 0 then + return False; + end if; + + if Position.Node > L.Capacity then + return False; + end if; + + if N (Position.Node).Prev < 0 + or else N (Position.Node).Prev > L.Capacity + then + return False; + end if; + + if N (Position.Node).Next > L.Capacity then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 + and then Position.Node /= L.First + then + return False; + end if; + + if N (Position.Node).Next = 0 + and then Position.Node /= L.Last + then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if N (Position.Node).Next = 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 then + return False; + end if; + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if N (L.First).Next /= Position.Node then + return False; + end if; + + if N (L.Last).Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + +end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/gcc/ada/a-crdlli.ads b/gcc/ada/a-crdlli.ads new file mode 100644 index 0000000..0e768a4 --- /dev/null +++ b/gcc/ada/a-crdlli.ads @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . -- +-- R E S R I C T E D _ D O U B L Y _ L I N K E D _ L I S T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2006, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Restricted_Doubly_Linked_Lists is + pragma Pure; + + type List (Capacity : Count_Type) is tagged limited private; + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + function "=" (Left, Right : List) return Boolean; + + procedure Assign (Target : in out List; Source : List); + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out List); + + procedure Swap + (Container : in out List; + I, J : Cursor); + + procedure Swap_Links + (Container : in out List; + I, J : Cursor); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : in out Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + end Generic_Sorting; + +private + + type Node_Type is limited record + Prev : Count_Type'Base; + Next : Count_Type; + Element : Element_Type; + end record; + + type Node_Array is array (Count_Type range <>) of Node_Type; + + type List (Capacity : Count_Type) is tagged limited record + Nodes : Node_Array (1 .. Capacity) := (others => <>); + Free : Count_Type'Base := -1; + First : Count_Type := 0; + Last : Count_Type := 0; + Length : Count_Type := 0; + end record; + + Empty_List : constant List := (0, others => <>); + + type List_Access is access all List; + for List_Access'Storage_Size use 0; + + type Cursor is + record + Container : List_Access; + Node : Count_Type := 0; + end record; + + No_Element : constant Cursor := (null, 0); + +end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/gcc/ada/a-wtenio.adb b/gcc/ada/a-wtenio.adb index 33e5970..f5725fa 100644 --- a/gcc/ada/a-wtenio.adb +++ b/gcc/ada/a-wtenio.adb @@ -44,11 +44,9 @@ package body Ada.Wide_Text_IO.Enumeration_IO is procedure Get (File : File_Type; Item : out Enum) is Buf : Wide_String (1 .. Enum'Width); Buflen : Natural; - begin Aux.Get_Enum_Lit (File, Buf, Buflen); Item := Enum'Wide_Value (Buf (1 .. Buflen)); - exception when Constraint_Error => raise Data_Error; end Get; @@ -64,11 +62,9 @@ package body Ada.Wide_Text_IO.Enumeration_IO is Last : out Positive) is Start : Natural; - begin Aux.Scan_Enum_Lit (From, Start, Last); Item := Enum'Wide_Value (From (Start .. Last)); - exception when Constraint_Error => raise Data_Error; end Get; @@ -84,7 +80,6 @@ package body Ada.Wide_Text_IO.Enumeration_IO is Set : Type_Set := Default_Setting) is Image : constant Wide_String := Enum'Wide_Image (Item); - begin Aux.Put (File, Image, Width, Set); end Put; @@ -104,7 +99,6 @@ package body Ada.Wide_Text_IO.Enumeration_IO is Set : Type_Set := Default_Setting) is Image : constant Wide_String := Enum'Wide_Image (Item); - begin Aux.Puts (To, Image, Set); end Put; diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index d8fc6ea..0fb616e 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -186,7 +186,6 @@ package body Elists is N : constant Union_Id := Elmts.Table (Elmt).Next; begin - pragma Assert (Elmt /= No_Elmt); Elmts.Increment_Last; @@ -301,11 +300,11 @@ package body Elists is return Elmt = No_Elmt; end No; - ----------- + ---------- -- Node -- - ----------- + ---------- - function Node (Elmt : Elmt_Id) return Node_Id is + function Node (Elmt : Elmt_Id) return Node_Or_Entity_Id is begin if Elmt = No_Elmt then return Empty; diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index 311997d..690ff33 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -172,20 +172,20 @@ package Exp_Tss is procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id); -- This procedure is used to install a newly created TSS. The second - -- argument is the entity for such a new TSS. This entity is placed in - -- the TSS list for the type given as the first argument, replacing an - -- old entry of the same name if one was present. The tree for the body - -- of this TSS, which is not analyzed yet, is placed in the actions field - -- of the freeze node for the type. All such bodies are inserted into the - -- main tree and analyzed at the point at which the freeze node itself is - -- is expanded. + -- argument is the entity for such a new TSS. This entity is placed in the + -- TSS list for the type given as the first argument, replacing an old + -- entry of the same name if one was present. The tree for the body of this + -- TSS, which is not analyzed yet, is placed in the actions field of the + -- freeze node for the type. All such bodies are inserted into the main + -- tree and analyzed at the point at which the freeze node itself is + -- expanded. procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id); -- Given an existing TSS for another type (which is already installed, -- analyzed and expanded), install it as the corresponding TSS for Typ. - -- Note that this just copies a reference, not the tree. This can also - -- be used to initially install a TSS in the case where the subprogram - -- for the TSS has already been created and its declaration processed. + -- Note that this just copies a reference, not the tree. This can also be + -- used to initially install a TSS in the case where the subprogram for the + -- TSS has already been created and its declaration processed. function Init_Proc (Typ : Entity_Id) return Entity_Id; pragma Inline (Init_Proc); diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index 5dc75de..85a30d9 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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/gnatvsn.ads b/gcc/ada/gnatvsn.ads index f17343e..009dbee 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -45,7 +45,7 @@ package Gnatvsn is -- Static string identifying this version, that can be used as an argument -- to e.g. pragma Ident. - type Gnat_Build_Type is (FSF, Public, GAP); + type Gnat_Build_Type is (FSF, GPL); -- See Get_Gnat_Build_Type below for the meaning of these values. function Get_Gnat_Build_Type return Gnat_Build_Type; @@ -53,28 +53,25 @@ package Gnatvsn is -- -- FSF -- GNAT FSF version. This version of GNAT is part of a Free Software - -- Foundation release of the GNU Compiler Collection (GCC). The binder - -- will not output informational messages regarding intended use, - -- and the bug box generated by Comperr will give information on - -- how to report bugs and list the "no warranty" information. + -- Foundation release of the GNU Compiler Collection (GCC). The bug + -- box generated by Comperr gives information on how to report bugs + -- and list the "no warranty" information. -- - -- Public - -- GNAT Public version. - -- The binder will output informational messages, and the bug box - -- generated by the package Comperr will give appropriate bug - -- submission instructions. - -- - -- GAP - -- GNAT Academic Program, similar to Public. + -- GPL + -- GNAT GPL Edition. This is a special version of GNAT, released by + -- Ada Core Technologies and intended for academic users, and free + -- software developers. The bug box generated by the package Comperr + -- gives appropriate bug submission instructions that do not reference + -- customer number etc. - Ver_Len_Max : constant := 32; + Ver_Len_Max : constant := 64; -- Longest possible length for Gnat_Version_String in this or any -- other version of GNAT. This is used by the binder to establish -- space to store any possible version string value for checks. This -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. - Library_Version : constant String := "4.2"; + Library_Version : constant String := "4.3"; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. @@ -85,7 +82,7 @@ package Gnatvsn is Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version; -- Version string stored in e.g. ALI files. - ASIS_Version_Number : constant := 5; + ASIS_Version_Number : constant := 6; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees, and an ASIS application that is reading the -- trees. It must be updated (incremented) whenever a change is made to diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads index d7679b4..f14ac7c 100644 --- a/gcc/ada/impunit.ads +++ b/gcc/ada/impunit.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2005, 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/initialize.c b/gcc/ada/initialize.c index 0b86c2f..8da3089 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2005, Free Software Foundation, Inc. * + * Copyright (C) 1992-2006, 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/s-dsaser.ads b/gcc/ada/s-dsaser.ads new file mode 100644 index 0000000..9d5eec4 --- /dev/null +++ b/gcc/ada/s-dsaser.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D S A _ S E R V I C E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 2, or (at your option) any later ver- -- +-- sion. GNARL 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is for distributed system annex services, which require the +-- partition communication sub-system to be initialized before they are used. + +with System.Partition_Interface; +with System.RPC; + +package System.DSA_Services is + + function Get_Active_Partition_ID + (Name : Partition_Interface.Unit_Name) return RPC.Partition_ID + renames Partition_Interface.Get_Active_Partition_ID; + -- Returns the partition ID of the partition in which Name resides + +end System.DSA_Services; diff --git a/gcc/ada/s-imgdec.ads b/gcc/ada/s-imgdec.ads index d1e2768..41762e1 100644 --- a/gcc/ada/s-imgdec.ads +++ b/gcc/ada/s-imgdec.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -39,8 +39,7 @@ package System.Img_Dec is function Image_Decimal (V : Integer; - Scale : Integer) - return String; + Scale : Integer) return String; -- Compute 'Image of V, the integer value (in units of delta) of a decimal -- type whose Scale is as given and return the result. THe image is given -- by the rules in RM 3.5(34) for fixed-point type image functions. diff --git a/gcc/ada/s-osinte-vms.ads b/gcc/ada/s-osinte-vms.ads index a0167ef..2e32161 100644 --- a/gcc/ada/s-osinte-vms.ads +++ b/gcc/ada/s-osinte-vms.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -121,10 +121,10 @@ package System.OS_Interface is procedure Sys_Assign (Status : out Cond_Value_Type; - Devnam : in String; + Devnam : String; Chan : out unsigned_short; Acmode : in unsigned_short := 0; - Mbxnam : in String := String'Null_Parameter; + Mbxnam : String := String'Null_Parameter; Flags : in unsigned_long := 0); pragma Interface (External, Sys_Assign); pragma Import_Valued_Procedure @@ -147,7 +147,7 @@ package System.OS_Interface is -- procedure Sys_Cantim (Status : out Cond_Value_Type; - Reqidt : in Address; + Reqidt : Address; Acmode : in unsigned); pragma Interface (External, Sys_Cantim); pragma Import_Valued_Procedure @@ -173,13 +173,13 @@ package System.OS_Interface is -- procedure Sys_Crembx (Status : out Cond_Value_Type; - Prmflg : in Boolean; + Prmflg : Boolean; Chan : out unsigned_short; Maxmsg : in unsigned_long := 0; Bufquo : in unsigned_long := 0; Promsk : in unsigned_short := 0; Acmode : in unsigned_short := 0; - Lognam : in String; + Lognam : String; Flags : in unsigned_long := 0); pragma Interface (External, Sys_Crembx); pragma Import_Valued_Procedure @@ -212,8 +212,8 @@ package System.OS_Interface is Chan : in unsigned_short; Func : in unsigned_long := 0; Iosb : out IO_Status_Block_Type; - Astadr : in AST_Handler := No_AST_Handler; - Astprm : in Address := Null_Address; + Astadr : AST_Handler := No_AST_Handler; + Astprm : Address := Null_Address; P1 : in unsigned_long := 0; P2 : in unsigned_long := 0; P3 : in unsigned_long := 0; @@ -226,9 +226,9 @@ package System.OS_Interface is EFN : in unsigned_long := 0; Chan : in unsigned_short; Func : in unsigned_long := 0; - Iosb : in Address := Null_Address; - Astadr : in AST_Handler := No_AST_Handler; - Astprm : in Address := Null_Address; + Iosb : Address := Null_Address; + Astadr : AST_Handler := No_AST_Handler; + Astprm : Address := Null_Address; P1 : in unsigned_long := 0; P2 : in unsigned_long := 0; P3 : in unsigned_long := 0; @@ -275,9 +275,9 @@ package System.OS_Interface is procedure Sys_Setimr (Status : out Cond_Value_Type; EFN : in unsigned_long; - Tim : in Long_Integer; - AST : in AST_Handler; - Reqidt : in Address; + Tim : Long_Integer; + AST : AST_Handler; + Reqidt : Address; Flags : in unsigned_long); pragma Interface (External, Sys_Setimr); pragma Import_Valued_Procedure diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index f15601a..288e300 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads index d2b414d..d33c335 100644 --- a/gcc/ada/system-linux-ppc.ads +++ b/gcc/ada/system-linux-ppc.ads @@ -5,9 +5,9 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (GNU-Linux/PPC Version) -- +-- (GNU-Linux/PPC Version) -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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 -- @@ -88,17 +88,18 @@ package System is type Bit_Order is (High_Order_First, Low_Order_First); Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning -- Priority-related Declarations (RM D.1) - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; - Default_Priority : constant Priority := 15; + Default_Priority : constant Priority := 48; private -- 2.7.4