diff options
| author | Richard Kenner <kenner@vlsi1.ultra.nyu.edu> | 2001-10-02 14:18:40 +0000 |
|---|---|---|
| committer | Richard Kenner <kenner@vlsi1.ultra.nyu.edu> | 2001-10-02 14:18:40 +0000 |
| commit | ef1bc253666f505c1a9c2dcd1cd57d51e24b1033 (patch) | |
| tree | 6570bc15069492ca4f53a85c5d09a36d099fd63f | |
| parent | fbc7692d939ce513571e37e9d05dd8d5c4b4dac6 (diff) | |
New Language: Ada
git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@45955 138bc75d-0d04-0410-961f-82ee72b054a4
186 files changed, 82060 insertions, 0 deletions
diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb new file mode 100644 index 00000000000..7811caec00b --- /dev/null +++ b/gcc/ada/g-awk.adb @@ -0,0 +1,1296 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A W K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off alpha ordering check for subprograms, since we cannot +-- Put Finalize and Initialize in alpha order (see comments). + +with Ada.Exceptions; +with Ada.Text_IO; +with Ada.Strings.Unbounded; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with Ada.Unchecked_Deallocation; + +with GNAT.Directory_Operations; +with GNAT.Dynamic_Tables; +with GNAT.OS_Lib; + +package body GNAT.AWK is + + use Ada; + use Ada.Strings.Unbounded; + + ---------------- + -- Split mode -- + ---------------- + + package Split is + + type Mode is abstract tagged null record; + -- This is the main type which is declared abstract. This type must be + -- derived for each split style. + + type Mode_Access is access Mode'Class; + + procedure Current_Line (S : Mode; Session : Session_Type) + is abstract; + -- Split Session's current line using split mode. + + ------------------------ + -- Split on separator -- + ------------------------ + + type Separator (Size : Positive) is new Mode with record + Separators : String (1 .. Size); + end record; + + procedure Current_Line + (S : Separator; + Session : Session_Type); + + --------------------- + -- Split on column -- + --------------------- + + type Column (Size : Positive) is new Mode with record + Columns : Widths_Set (1 .. Size); + end record; + + procedure Current_Line (S : Column; Session : Session_Type); + + end Split; + + procedure Free is new Unchecked_Deallocation + (Split.Mode'Class, Split.Mode_Access); + + ---------------- + -- File_Table -- + ---------------- + + type AWK_File is access String; + + package File_Table is + new Dynamic_Tables (AWK_File, Natural, 1, 5, 50); + -- List of filename associated with a Session. + + procedure Free is new Unchecked_Deallocation (String, AWK_File); + + ----------------- + -- Field_Table -- + ----------------- + + type Field_Slice is record + First : Positive; + Last : Natural; + end record; + -- This is a field slice (First .. Last) in session's current line. + + package Field_Table is + new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100); + -- List of fields for the current line. + + -------------- + -- Patterns -- + -------------- + + -- Define all patterns style : exact string, regular expression, boolean + -- function. + + package Patterns is + + type Pattern is abstract tagged null record; + -- This is the main type which is declared abstract. This type must be + -- derived for each patterns style. + + type Pattern_Access is access Pattern'Class; + + function Match + (P : Pattern; + Session : Session_Type) + return Boolean + is abstract; + -- Returns True if P match for the current session and False otherwise. + + procedure Release (P : in out Pattern); + -- Release memory used by the pattern structure. + + -------------------------- + -- Exact string pattern -- + -------------------------- + + type String_Pattern is new Pattern with record + Str : Unbounded_String; + Rank : Count; + end record; + + function Match + (P : String_Pattern; + Session : Session_Type) + return Boolean; + + -------------------------------- + -- Regular expression pattern -- + -------------------------------- + + type Pattern_Matcher_Access is access Regpat.Pattern_Matcher; + + type Regexp_Pattern is new Pattern with record + Regx : Pattern_Matcher_Access; + Rank : Count; + end record; + + function Match + (P : Regexp_Pattern; + Session : Session_Type) + return Boolean; + + procedure Release (P : in out Regexp_Pattern); + + ------------------------------ + -- Boolean function pattern -- + ------------------------------ + + type Callback_Pattern is new Pattern with record + Pattern : Pattern_Callback; + end record; + + function Match + (P : Callback_Pattern; + Session : Session_Type) + return Boolean; + + end Patterns; + + procedure Free is new Unchecked_Deallocation + (Patterns.Pattern'Class, Patterns.Pattern_Access); + + ------------- + -- Actions -- + ------------- + + -- Define all action style : simple call, call with matches + + package Actions is + + type Action is abstract tagged null record; + -- This is the main type which is declared abstract. This type must be + -- derived for each action style. + + type Action_Access is access Action'Class; + + procedure Call + (A : Action; + Session : Session_Type) + is abstract; + -- Call action A as required. + + ------------------- + -- Simple action -- + ------------------- + + type Simple_Action is new Action with record + Proc : Action_Callback; + end record; + + procedure Call + (A : Simple_Action; + Session : Session_Type); + + ------------------------- + -- Action with matches -- + ------------------------- + + type Match_Action is new Action with record + Proc : Match_Action_Callback; + end record; + + procedure Call + (A : Match_Action; + Session : Session_Type); + + end Actions; + + procedure Free is new Unchecked_Deallocation + (Actions.Action'Class, Actions.Action_Access); + + -------------------------- + -- Pattern/Action table -- + -------------------------- + + type Pattern_Action is record + Pattern : Patterns.Pattern_Access; -- If Pattern is True + Action : Actions.Action_Access; -- Action will be called + end record; + + package Pattern_Action_Table is + new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50); + + ------------------ + -- Session Data -- + ------------------ + + type Session_Data is record + Current_File : Text_IO.File_Type; + Current_Line : Unbounded_String; + Separators : Split.Mode_Access; + Files : File_Table.Instance; + File_Index : Natural := 0; + Fields : Field_Table.Instance; + Filters : Pattern_Action_Table.Instance; + NR : Natural := 0; + FNR : Natural := 0; + Matches : Regpat.Match_Array (0 .. 100); + -- latest matches for the regexp pattern + end record; + + procedure Free is + new Unchecked_Deallocation (Session_Data, Session_Data_Access); + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Session : in out Session_Type) is + begin + Session.Data := new Session_Data; + + -- Initialize separators + + Session.Data.Separators := + new Split.Separator'(Default_Separators'Length, Default_Separators); + + -- Initialize all tables + + File_Table.Init (Session.Data.Files); + Field_Table.Init (Session.Data.Fields); + Pattern_Action_Table.Init (Session.Data.Filters); + end Initialize; + + ----------------------- + -- Session Variables -- + ----------------------- + + -- These must come after the body of Initialize, since they make + -- implicit calls to Initialize at elaboration time. + + Def_Session : Session_Type; + Cur_Session : Session_Type; + + -------------- + -- Finalize -- + -------------- + + -- Note: Finalize must come after Initialize and the definition + -- of the Def_Session and Cur_Session variables, since it references + -- the latter. + + procedure Finalize (Session : in out Session_Type) is + begin + -- We release the session data only if it is not the default session. + + if Session.Data /= Def_Session.Data then + Free (Session.Data); + + -- Since we have closed the current session, set it to point + -- now to the default session. + + Cur_Session.Data := Def_Session.Data; + end if; + end Finalize; + + ---------------------- + -- Private Services -- + ---------------------- + + function Always_True return Boolean; + -- A function that always returns True. + + function Apply_Filters + (Session : Session_Type := Current_Session) + return Boolean; + -- Apply any filters for which the Pattern is True for Session. It returns + -- True if a least one filters has been applied (i.e. associated action + -- callback has been called). + + procedure Open_Next_File + (Session : Session_Type := Current_Session); + pragma Inline (Open_Next_File); + -- Open next file for Session closing current file if needed. It raises + -- End_Error if there is no more file in the table. + + procedure Raise_With_Info + (E : Exceptions.Exception_Id; + Message : String; + Session : Session_Type); + pragma No_Return (Raise_With_Info); + -- Raises exception E with the message prepended with the current line + -- number and the filename if possible. + + procedure Read_Line (Session : Session_Type); + -- Read a line for the Session and set Current_Line. + + procedure Split_Line (Session : Session_Type); + -- Split session's Current_Line according to the session separators and + -- set the Fields table. This procedure can be called at any time. + + ---------------------- + -- Private Packages -- + ---------------------- + + ------------- + -- Actions -- + ------------- + + package body Actions is + + ---------- + -- Call -- + ---------- + + procedure Call + (A : Simple_Action; + Session : Session_Type) + is + begin + A.Proc.all; + end Call; + + ---------- + -- Call -- + ---------- + + procedure Call + (A : Match_Action; + Session : Session_Type) + is + begin + A.Proc (Session.Data.Matches); + end Call; + + end Actions; + + -------------- + -- Patterns -- + -------------- + + package body Patterns is + + ----------- + -- Match -- + ----------- + + function Match + (P : String_Pattern; + Session : Session_Type) + return Boolean + is + begin + return P.Str = Field (P.Rank, Session); + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (P : Regexp_Pattern; + Session : Session_Type) + return Boolean + is + use type Regpat.Match_Location; + + begin + Regpat.Match + (P.Regx.all, Field (P.Rank, Session), Session.Data.Matches); + return Session.Data.Matches (0) /= Regpat.No_Match; + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (P : Callback_Pattern; + Session : Session_Type) + return Boolean + is + begin + return P.Pattern.all; + end Match; + + ------------- + -- Release -- + ------------- + + procedure Release (P : in out Pattern) is + begin + null; + end Release; + + ------------- + -- Release -- + ------------- + + procedure Release (P : in out Regexp_Pattern) is + procedure Free is new Unchecked_Deallocation + (Regpat.Pattern_Matcher, Pattern_Matcher_Access); + + begin + Free (P.Regx); + end Release; + + end Patterns; + + ----------- + -- Split -- + ----------- + + package body Split is + + use Ada.Strings; + + ------------------ + -- Current_Line -- + ------------------ + + procedure Current_Line (S : Separator; Session : Session_Type) is + Line : constant String := To_String (Session.Data.Current_Line); + Fields : Field_Table.Instance renames Session.Data.Fields; + + Start : Positive; + Stop : Natural; + + Seps : Maps.Character_Set := Maps.To_Set (S.Separators); + + begin + -- First field start here + + Start := Line'First; + + -- Record the first field start position which is the first character + -- in the line. + + Field_Table.Increment_Last (Fields); + Fields.Table (Field_Table.Last (Fields)).First := Start; + + loop + -- Look for next separator + + Stop := Fixed.Index + (Source => Line (Start .. Line'Last), + Set => Seps); + + exit when Stop = 0; + + Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1; + + -- if separators are set to the default (space and tab) we skip + -- all spaces and tabs following current field. + + if S.Separators = Default_Separators then + Start := Fixed.Index + (Line (Stop + 1 .. Line'Last), + Maps.To_Set (Default_Separators), + Outside, + Strings.Forward); + else + Start := Stop + 1; + end if; + + -- Record in the field table the start of this new field + + Field_Table.Increment_Last (Fields); + Fields.Table (Field_Table.Last (Fields)).First := Start; + + end loop; + + Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; + end Current_Line; + + ------------------ + -- Current_Line -- + ------------------ + + procedure Current_Line (S : Column; Session : Session_Type) is + Line : constant String := To_String (Session.Data.Current_Line); + Fields : Field_Table.Instance renames Session.Data.Fields; + Start : Positive := Line'First; + + begin + -- Record the first field start position which is the first character + -- in the line. + + for C in 1 .. S.Columns'Length loop + + Field_Table.Increment_Last (Fields); + + Fields.Table (Field_Table.Last (Fields)).First := Start; + + Start := Start + S.Columns (C); + + Fields.Table (Field_Table.Last (Fields)).Last := Start - 1; + + end loop; + + -- If there is some remaining character on the line, add them in a + -- new field. + + if Start - 1 < Line'Length then + + Field_Table.Increment_Last (Fields); + + Fields.Table (Field_Table.Last (Fields)).First := Start; + + Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; + end if; + end Current_Line; + + end Split; + + -------------- + -- Add_File -- + -------------- + + procedure Add_File + (Filename : String; + Session : Session_Type := Current_Session) + is + Files : File_Table.Instance renames Session.Data.Files; + + begin + if OS_Lib.Is_Regular_File (Filename) then + File_Table.Increment_Last (Files); + Files.Table (File_Table.Last (Files)) := new String'(Filename); + else + Raise_With_Info + (File_Error'Identity, + "File " & Filename & " not found.", + Session); + end if; + end Add_File; + + --------------- + -- Add_Files -- + --------------- + + procedure Add_Files + (Directory : String; + Filenames : String; + Number_Of_Files_Added : out Natural; + Session : Session_Type := Current_Session) + is + use Directory_Operations; + + Dir : Dir_Type; + Filename : String (1 .. 200); + Last : Natural; + + begin + Number_Of_Files_Added := 0; + + Open (Dir, Directory); + + loop + Read (Dir, Filename, Last); + exit when Last = 0; + + Add_File (Filename (1 .. Last), Session); + Number_Of_Files_Added := Number_Of_Files_Added + 1; + end loop; + + Close (Dir); + + exception + when others => + Raise_With_Info + (File_Error'Identity, + "Error scaning directory " & Directory + & " for files " & Filenames & '.', + Session); + end Add_Files; + + ----------------- + -- Always_True -- + ----------------- + + function Always_True return Boolean is + begin + return True; + end Always_True; + + ------------------- + -- Apply_Filters -- + ------------------- + + function Apply_Filters + (Session : Session_Type := Current_Session) + return Boolean + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + Results : Boolean := False; + + begin + -- Iterate throught the filters table, if pattern match call action. + + for F in 1 .. Pattern_Action_Table.Last (Filters) loop + if Patterns.Match (Filters.Table (F).Pattern.all, Session) then + Results := True; + Actions.Call (Filters.Table (F).Action.all, Session); + end if; + end loop; + + return Results; + end Apply_Filters; + + ----------- + -- Close -- + ----------- + + procedure Close (Session : Session_Type) is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + Files : File_Table.Instance renames Session.Data.Files; + + begin + -- Close current file if needed + + if Text_IO.Is_Open (Session.Data.Current_File) then + Text_IO.Close (Session.Data.Current_File); + end if; + + -- Release separators + + Free (Session.Data.Separators); + + -- Release Filters table + + for F in 1 .. Pattern_Action_Table.Last (Filters) loop + Patterns.Release (Filters.Table (F).Pattern.all); + Free (Filters.Table (F).Pattern); + Free (Filters.Table (F).Action); + end loop; + + for F in 1 .. File_Table.Last (Files) loop + Free (Files.Table (F)); + end loop; + + File_Table.Set_Last (Session.Data.Files, 0); + Field_Table.Set_Last (Session.Data.Fields, 0); + Pattern_Action_Table.Set_Last (Session.Data.Filters, 0); + + Session.Data.NR := 0; + Session.Data.FNR := 0; + Session.Data.File_Index := 0; + Session.Data.Current_Line := Null_Unbounded_String; + end Close; + + --------------------- + -- Current_Session -- + --------------------- + + function Current_Session return Session_Type is + begin + return Cur_Session; + end Current_Session; + + --------------------- + -- Default_Session -- + --------------------- + + function Default_Session return Session_Type is + begin + return Def_Session; + end Default_Session; + + -------------------- + -- Discrete_Field -- + -------------------- + + function Discrete_Field + (Rank : Count; + Session : Session_Type := Current_Session) + return Discrete + is + begin + return Discrete'Value (Field (Rank, Session)); + end Discrete_Field; + + ----------------- + -- End_Of_Data -- + ----------------- + + function End_Of_Data + (Session : Session_Type := Current_Session) + return Boolean + is + begin + return Session.Data.File_Index = File_Table.Last (Session.Data.Files) + and then End_Of_File (Session); + end End_Of_Data; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File + (Session : Session_Type := Current_Session) + return Boolean + is + begin + return Text_IO.End_Of_File (Session.Data.Current_File); + end End_Of_File; + + ----------- + -- Field -- + ----------- + + function Field + (Rank : Count; + Session : Session_Type := Current_Session) + return String + is + Fields : Field_Table.Instance renames Session.Data.Fields; + + begin + if Rank > Number_Of_Fields (Session) then + Raise_With_Info + (Field_Error'Identity, + "Field number" & Count'Image (Rank) & " does not exist.", + Session); + + elsif Rank = 0 then + + -- Returns the whole line, this is what $0 does under Session_Type. + + return To_String (Session.Data.Current_Line); + + else + return Slice (Session.Data.Current_Line, + Fields.Table (Positive (Rank)).First, + Fields.Table (Positive (Rank)).Last); + end if; + end Field; + + function Field + (Rank : Count; + Session : Session_Type := Current_Session) + return Integer + is + begin + return Integer'Value (Field (Rank, Session)); + + exception + when Constraint_Error => + Raise_With_Info + (Field_Error'Identity, + "Field number" & Count'Image (Rank) + & " cannot be converted to an integer.", + Session); + end Field; + + function Field + (Rank : Count; + Session : Session_Type := Current_Session) + return Float + is + begin + return Float'Value (Field (Rank, Session)); + + exception + when Constraint_Error => + Raise_With_Info + (Field_Error'Identity, + "Field number" & Count'Image (Rank) + & " cannot be converted to a float.", + Session); + end Field; + + ---------- + -- File -- + ---------- + + function File + (Session : Session_Type := Current_Session) + return String + is + Files : File_Table.Instance renames Session.Data.Files; + + begin + if Session.Data.File_Index = 0 then + return "??"; + else + return Files.Table (Session.Data.File_Index).all; + end if; + end File; + + -------------------- + -- For_Every_Line -- + -------------------- + + procedure For_Every_Line + (Separators : String := Use_Current; + Filename : String := Use_Current; + Callbacks : Callback_Mode := None; + Session : Session_Type := Current_Session) + is + Filter_Active : Boolean; + Quit : Boolean; + + begin + Open (Separators, Filename, Session); + + while not End_Of_Data (Session) loop + Read_Line (Session); + Split_Line (Session); + + if Callbacks in Only .. Pass_Through then + Filter_Active := Apply_Filters (Session); + end if; + + if Callbacks /= Only then + Quit := False; + Action (Quit); + exit when Quit; + end if; + end loop; + + Close (Session); + end For_Every_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Callbacks : Callback_Mode := None; + Session : Session_Type := Current_Session) + is + Filter_Active : Boolean; + + begin + if not Text_IO.Is_Open (Session.Data.Current_File) then + raise File_Error; + end if; + + loop + Read_Line (Session); + Split_Line (Session); + + if Callbacks in Only .. Pass_Through then + Filter_Active := Apply_Filters (Session); + end if; + + exit when Callbacks = None + or else Callbacks = Pass_Through + or else (Callbacks = Only and then not Filter_Active); + + end loop; + end Get_Line; + + ---------------------- + -- Number_Of_Fields -- + ---------------------- + + function Number_Of_Fields + (Session : Session_Type := Current_Session) + return Count + is + begin + return Count (Field_Table.Last (Session.Data.Fields)); + end Number_Of_Fields; + + -------------------------- + -- Number_Of_File_Lines -- + -------------------------- + + function Number_Of_File_Lines + (Session : Session_Type := Current_Session) + return Count + is + begin + return Count (Session.Data.FNR); + end Number_Of_File_Lines; + + --------------------- + -- Number_Of_Files -- + --------------------- + + function Number_Of_Files + (Session : Session_Type := Current_Session) + return Natural + is + Files : File_Table.Instance renames Session.Data.Files; + + begin + return File_Table.Last (Files); + end Number_Of_Files; + + --------------------- + -- Number_Of_Lines -- + --------------------- + + function Number_Of_Lines + (Session : Session_Type := Current_Session) + return Count + is + begin + return Count (Session.Data.NR); + end Number_Of_Lines; + + ---------- + -- Open -- + ---------- + + procedure Open + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type := Current_Session) + is + begin + if Text_IO.Is_Open (Session.Data.Current_File) then + raise Session_Error; + end if; + + if Filename /= Use_Current then + File_Table.Init (Session.Data.Files); + Add_File (Filename, Session); + end if; + + if Separators /= Use_Current then + Set_Field_Separators (Separators, Session); + end if; + + Open_Next_File (Session); + + exception + when End_Error => + raise File_Error; + end Open; + + -------------------- + -- Open_Next_File -- + -------------------- + + procedure Open_Next_File + (Session : Session_Type := Current_Session) + is + Files : File_Table.Instance renames Session.Data.Files; + + begin + if Text_IO.Is_Open (Session.Data.Current_File) then + Text_IO.Close (Session.Data.Current_File); + end if; + + Session.Data.File_Index := Session.Data.File_Index + 1; + + -- If there are no mores file in the table, raise End_Error + + if Session.Data.File_Index > File_Table.Last (Files) then + raise End_Error; + end if; + + Text_IO.Open + (File => Session.Data.Current_File, + Name => Files.Table (Session.Data.File_Index).all, + Mode => Text_IO.In_File); + end Open_Next_File; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type := Current_Session) + is + Filter_Active : Boolean; + begin + Open (Separators, Filename, Session); + + while not End_Of_Data (Session) loop + Get_Line (None, Session); + Filter_Active := Apply_Filters (Session); + end loop; + + Close (Session); + end Parse; + + --------------------- + -- Raise_With_Info -- + --------------------- + + procedure Raise_With_Info + (E : Exceptions.Exception_Id; + Message : String; + Session : Session_Type) + is + function Filename return String; + -- Returns current filename and "??" if the informations is not + -- available. + + function Line return String; + -- Returns current line number without the leading space + + -------------- + -- Filename -- + -------------- + + function Filename return String is + File : constant String := AWK.File (Session); + + begin + if File = "" then + return "??"; + else + return File; + end if; + end Filename; + + ---------- + -- Line -- + ---------- + + function Line return String is + L : constant String := Natural'Image (Session.Data.FNR); + + begin + return L (2 .. L'Last); + end Line; + + -- Start of processing for Raise_With_Info + + begin + Exceptions.Raise_Exception + (E, + '[' & Filename & ':' & Line & "] " & Message); + raise Constraint_Error; -- to please GNAT as this is a No_Return proc + end Raise_With_Info; + + --------------- + -- Read_Line -- + --------------- + + procedure Read_Line (Session : Session_Type) is + + function Read_Line return String; + -- Read a line in the current file. This implementation is recursive + -- and does not have a limitation on the line length. + + NR : Natural renames Session.Data.NR; + FNR : Natural renames Session.Data.FNR; + + function Read_Line return String is + Buffer : String (1 .. 1_024); + Last : Natural; + + begin + Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last); + + if Last = Buffer'Last then + return Buffer & Read_Line; + else + return Buffer (1 .. Last); + end if; + end Read_Line; + + -- Start of processing for Read_Line + + begin + if End_Of_File (Session) then + Open_Next_File (Session); + FNR := 0; + end if; + + Session.Data.Current_Line := To_Unbounded_String (Read_Line); + + NR := NR + 1; + FNR := FNR + 1; + end Read_Line; + + -------------- + -- Register -- + -------------- + + procedure Register + (Field : Count; + Pattern : String; + Action : Action_Callback; + Session : Session_Type := Current_Session) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern); + + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.String_Pattern'(U_Pattern, Field), + Action => new Actions.Simple_Action'(Proc => Action)); + end Register; + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Action_Callback; + Session : Session_Type := Current_Session) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + + A_Pattern : Patterns.Pattern_Matcher_Access := + new Regpat.Pattern_Matcher'(Pattern); + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), + Action => new Actions.Simple_Action'(Proc => Action)); + end Register; + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Match_Action_Callback; + Session : Session_Type := Current_Session) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + + A_Pattern : Patterns.Pattern_Matcher_Access := + new Regpat.Pattern_Matcher'(Pattern); + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), + Action => new Actions.Match_Action'(Proc => Action)); + end Register; + + procedure Register + (Pattern : Pattern_Callback; + Action : Action_Callback; + Session : Session_Type := Current_Session) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern), + Action => new Actions.Simple_Action'(Proc => Action)); + end Register; + + procedure Register + (Action : Action_Callback; + Session : Session_Type := Current_Session) + is + begin + Register (Always_True'Access, Action, Session); + end Register; + + ----------------- + -- Set_Current -- + ----------------- + + procedure Set_Current (Session : Session_Type) is + begin + Cur_Session.Data := Session.Data; + end Set_Current; + + -------------------------- + -- Set_Field_Separators -- + -------------------------- + + procedure Set_Field_Separators + (Separators : String := Default_Separators; + Session : Session_Type := Current_Session) + is + begin + Free (Session.Data.Separators); + + Session.Data.Separators := + new Split.Separator'(Separators'Length, Separators); + + -- If there is a current line read, split it according to the new + -- separators. + + if Session.Data.Current_Line /= Null_Unbounded_String then + Split_Line (Session); + end if; + end Set_Field_Separators; + + ---------------------- + -- Set_Field_Widths -- + ---------------------- + + procedure Set_Field_Widths + (Field_Widths : Widths_Set; + Session : Session_Type := Current_Session) is + + begin + Free (Session.Data.Separators); + + Session.Data.Separators := + new Split.Column'(Field_Widths'Length, Field_Widths); + + -- If there is a current line read, split it according to + -- the new separators. + + if Session.Data.Current_Line /= Null_Unbounded_String then + Split_Line (Session); + end if; + end Set_Field_Widths; + + ---------------- + -- Split_Line -- + ---------------- + + procedure Split_Line (Session : Session_Type) is + Fields : Field_Table.Instance renames Session.Data.Fields; + + begin + Field_Table.Init (Fields); + + Split.Current_Line (Session.Data.Separators.all, Session); + end Split_Line; + +begin + -- We have declared two sessions but both should share the same data. + -- The current session must point to the default session as its initial + -- value. So first we release the session data then we set current + -- session data to point to default session data. + + Free (Cur_Session.Data); + Cur_Session.Data := Def_Session.Data; +end GNAT.AWK; diff --git a/gcc/ada/g-awk.ads b/gcc/ada/g-awk.ads new file mode 100644 index 00000000000..9ac484f6e82 --- /dev/null +++ b/gcc/ada/g-awk.ads @@ -0,0 +1,589 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A W K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- This is an AWK-like unit. It provides an easy interface for parsing one +-- or more files containing formatted data. The file can be viewed seen as +-- a database where each record is a line and a field is a data element in +-- this line. In this implementation an AWK record is a line. This means +-- that a record cannot span multiple lines. The operating procedure is to +-- read files line by line, with each line being presented to the user of +-- the package. The interface provides services to access specific fields +-- in the line. Thus it is possible to control actions takn on a line based +-- on values of some fields. This can be achieved directly or by registering +-- callbacks triggered on programmed conditions. +-- +-- The state of an AWK run is recorded in an object of type session. +-- The following is the procedure for using a session to control an +-- AWK run: +-- +-- 1) Specify which session is to be used. It is possible to use the +-- default session or to create a new one by declaring an object of +-- type Session_Type. For example: +-- +-- Computers : Session_Type; +-- +-- 2) Specify how to cut a line into fields. There are two modes: using +-- character fields separators or column width. This is done by using +-- Set_Fields_Separators or Set_Fields_Width. For example by: +-- +-- AWK.Set_Field_Separators (";,", Computers); +-- +-- or by using iterators' Separators parameter. +-- +-- 3) Specify which files to parse. This is done with Add_File/Add_Files +-- services, or by using the iterators' Filename parameter. For +-- example: +-- +-- AWK.Add_File ("myfile.db", Computers); +-- +-- 4) Run the AWK session using one of the provided iterators. +-- +-- Parse +-- This is the most automated iterator. You can gain control on +-- the session only by registering one or more callbacks (see +-- Register). +-- +-- Get_Line/End_Of_Data +-- This is a manual iterator to be used with a loop. You have +-- complete control on the session. You can use callbacks but +-- this is not required. +-- +-- For_Every_Line +-- This provides a mixture of manual/automated iterator action. +-- +-- Examples of these three approaches appear below +-- +-- There is many ways to use this package. The following discussion shows +-- three approaches, using the three iterator forms, to using this package. +-- All examples will use the following file (computer.db): +-- +-- Pluton;Windows-NT;Pentium III +-- Mars;Linux;Pentium Pro +-- Venus;Solaris;Sparc +-- Saturn;OS/2;i486 +-- Jupiter;MacOS;PPC +-- +-- 1) Using Parse iterator +-- +-- Here the first step is to register some action associated to a pattern +-- and then to call the Parse iterator (this is the simplest way to use +-- this unit). The default session is used here. For example to output the +-- second field (the OS) of computer "Saturn". +-- +-- procedure Action is +-- begin +-- Put_Line (AWK.Field (2)); +-- end Action; +-- +-- begin +-- AWK.Register (1, "Saturn", Action'Access); +-- AWK.Parse (";", "computer.db"); +-- +-- +-- 2) Using the Get_Line/End_Of_Data iterator +-- +-- Here you have full control. For example to do the same as +-- above but using a specific session, you could write: +-- +-- Computer_File : Session_Type; +-- +-- begin +-- AWK.Set_Current (Computer_File); +-- AWK.Open (Separators => ";", +-- Filename => "computer.db"); +-- +-- -- Display Saturn OS +-- +-- while not AWK.End_Of_File loop +-- AWK.Get_Line; +-- +-- if AWK.Field (1) = "Saturn" then +-- Put_Line (AWK.Field (2)); +-- end if; +-- end loop; +-- +-- AWK.Close (Computer_File); +-- +-- +-- 3) Using For_Every_Line iterator +-- +-- In this case you use a provided iterator and you pass the procedure +-- that must be called for each record. You could code the previous +-- example could be coded as follows (using the iterator quick interface +-- but without using the current session): +-- +-- Computer_File : Session_Type; +-- +-- procedure Action (Quit : in out Boolean) is +-- begin +-- if AWK.Field (1, Computer_File) = "Saturn" then +-- Put_Line (AWK.Field (2, Computer_File)); +-- end if; +-- end Action; +-- +-- procedure Look_For_Saturn is +-- new AWK.For_Every_Line (Action); +-- +-- begin +-- Look_For_Saturn (Separators => ";", +-- Filename => "computer.db", +-- Session => Computer_File); +-- +-- Integer_Text_IO.Put +-- (Integer (AWK.NR (Session => Computer_File))); +-- Put_Line (" line(s) have been processed."); +-- +-- You can also use a regular expression for the pattern. Let us output +-- the computer name for all computer for which the OS has a character +-- O in its name. +-- +-- Regexp : String := ".*O.*"; +-- +-- Matcher : Regpat.Pattern_Matcher := Regpat.Compile (Regexp); +-- +-- procedure Action is +-- begin +-- Text_IO.Put_Line (AWK.Field (2)); +-- end Action; +-- +-- begin +-- AWK.Register (2, Matcher, Action'Unrestricted_Access); +-- AWK.Parse (";", "computer.db"); +-- + +with Ada.Finalization; +with GNAT.Regpat; + +package GNAT.AWK is + + Session_Error : exception; + -- Raised when a Session is reused but is not closed. + + File_Error : exception; + -- Raised when there is a file problem (see below). + + End_Error : exception; + -- Raised when an attempt is made to read beyond the end of the last + -- file of a session. + + Field_Error : exception; + -- Raised when accessing a field value which does not exist. + + Data_Error : exception; + -- Raised when it is not possible to convert a field value to a specific + -- type. + + type Count is new Natural; + + type Widths_Set is array (Positive range <>) of Positive; + -- Used to store a set of columns widths. + + Default_Separators : constant String := " " & ASCII.HT; + + Use_Current : constant String := ""; + -- Value used when no separator or filename is specified in iterators. + + type Session_Type is limited private; + -- This is the main exported type. A session is used to keep the state of + -- a full AWK run. The state comprises a list of files, the current file, + -- the number of line processed, the current line, the number of fields in + -- the current line... A default session is provided (see Set_Current, + -- Current_Session and Default_Session above). + + ---------------------------- + -- Package initialization -- + ---------------------------- + + -- To be thread safe it is not possible to use the default provided + -- session. Each task must used a specific session and specify it + -- explicitly for every services. + + procedure Set_Current (Session : Session_Type); + -- Set the session to be used by default. This file will be used when the + -- Session parameter in following services is not specified. + + function Current_Session return Session_Type; + -- Returns the session used by default by all services. This is the + -- latest session specified by Set_Current service or the session + -- provided by default with this implementation. + + function Default_Session return Session_Type; + -- Returns the default session provided by this package. Note that this is + -- the session return by Current_Session if Set_Current has not been used. + + procedure Set_Field_Separators + (Separators : String := Default_Separators; + Session : Session_Type := Current_Session); + -- Set the field separators. Each character in the string is a field + -- separator. When a line is read it will be split by field using the + -- separators set here. Separators can be changed at any point and in this + -- case the current line is split according to the new separators. In the + -- special case that Separators is a space and a tabulation + -- (Default_Separators), fields are separated by runs of spaces and/or + -- tabs. + + procedure Set_FS + (Separators : String := Default_Separators; + Session : Session_Type := Current_Session) + renames Set_Field_Separators; + -- FS is the AWK abbreviation for above service. + + procedure Set_Field_Widths + (Field_Widths : Widths_Set; + Session : Session_Type := Current_Session); + -- This is another way to split a line by giving the length (in number of + -- characters) of each field in a line. Field widths can be changed at any + -- point and in this case the current line is split according to the new + -- field lengths. A line split with this method must have a length equal or + -- greater to the total of the field widths. All characters remaining on + -- the line after the latest field are added to a new automatically + -- created field. + + procedure Add_File + (Filename : String; + Session : Session_Type := Current_Session); + -- Add Filename to the list of file to be processed. There is no limit on + -- the number of files that can be added. Files are processed in the order + -- they have been added (i.e. the filename list is FIFO). If Filename does + -- not exist or if it is not readable, File_Error is raised. + + procedure Add_Files + (Directory : String; + Filenames : String; + Number_Of_Files_Added : out Natural; + Session : Session_Type := Current_Session); + -- Add all files matching the regular expression Filenames in the specified + -- directory to the list of file to be processed. There is no limit on + -- the number of files that can be added. Each file is processed in + -- the same order they have been added (i.e. the filename list is FIFO). + -- The number of files (possibly 0) added is returned in + -- Number_Of_Files_Added. + + ------------------------------------- + -- Information about current state -- + ------------------------------------- + + function Number_Of_Fields + (Session : Session_Type := Current_Session) + return Count; + -- Returns the number of fields in the current record. It returns 0 when + -- no file is being processed. + + function NF + (Session : Session_Type := Current_Session) + return Count + renames Number_Of_Fields; + -- AWK abbreviation for above service. + + function Number_Of_File_Lines + (Session : Session_Type := Current_Session) + return Count; + -- Returns the current line number in the processed file. It returns 0 when + -- no file is being processed. + + function FNR + (Session : Session_Type := Current_Session) + return Count renames Number_Of_File_Lines; + -- AWK abbreviation for above service. + + function Number_Of_Lines + (Session : Session_Type := Current_Session) + return Count; + -- Returns the number of line processed until now. This is equal to number + -- of line in each already processed file plus FNR. It returns 0 when + -- no file is being processed. + + function NR + (Session : Session_Type := Current_Session) + return Count + renames Number_Of_Lines; + -- AWK abbreviation for above service. + + function Number_Of_Files + (Session : Session_Type := Current_Session) + return Natural; + -- Returns the number of files associated with Session. This is the total + -- number of files added with Add_File and Add_Files services. + + function File + (Session : Session_Type := Current_Session) + return String; + -- Returns the name of the file being processed. It returns the empty + -- string when no file is being processed. + + --------------------- + -- Field accessors -- + --------------------- + + function Field + (Rank : Count; + Session : Session_Type := Current_Session) + return String; + -- Returns field number Rank value of the current record. If Rank = 0 it + -- returns the current record (i.e. the line as read in the file). It + -- raises Field_Error if Rank > NF or if Session is not open. + + function Field + (Rank : Count; + Session : Session_Type := Current_Session) + return Integer; + -- Returns field number Rank value of the current record as an integer. It + -- raises Field_Error if Rank > NF or if Session is not open. It + -- raises Data_Error if the field value cannot be converted to an integer. + + function Field + (Rank : Count; + Session : Session_Type := Current_Session) + return Float; + -- Returns field number Rank value of the current record as a float. It + -- raises Field_Error if Rank > NF or if Session is not open. It + -- raises Data_Error if the field value cannot be converted to a float. + + generic + type Discrete is (<>); + function Discrete_Field + (Rank : Count; + Session : Session_Type := Current_Session) + return Discrete; + -- Returns field number Rank value of the current record as a type + -- Discrete. It raises Field_Error if Rank > NF. It raises Data_Error if + -- the field value cannot be converted to type Discrete. + + -------------------- + -- Pattern/Action -- + -------------------- + + -- AWK defines rules like "PATTERN { ACTION }". Which means that ACTION + -- will be executed if PATTERN match. A pattern in this implementation can + -- be a simple string (match function is equality), a regular expression, + -- a function returning a boolean. An action is associated to a pattern + -- using the Register services. + -- + -- Each procedure Register will add a rule to the set of rules for the + -- session. Rules are examined in the order they have been added. + + type Pattern_Callback is access function return Boolean; + -- This is a pattern function pointer. When it returns True the associated + -- action will be called. + + type Action_Callback is access procedure; + -- A simple action pointer + + type Match_Action_Callback is + access procedure (Matches : GNAT.Regpat.Match_Array); + -- An advanced action pointer used with a regular expression pattern. It + -- returns an array of all the matches. See GNAT.Regpat for further + -- information. + + procedure Register + (Field : Count; + Pattern : String; + Action : Action_Callback; + Session : Session_Type := Current_Session); + -- Register an Action associated with a Pattern. The pattern here is a + -- simple string that must match exactly the field number specified. + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Action_Callback; + Session : Session_Type := Current_Session); + -- Register an Action associated with a Pattern. The pattern here is a + -- simple regular expression which must match the field number specified. + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Match_Action_Callback; + Session : Session_Type := Current_Session); + -- Same as above but it pass the set of matches to the action + -- procedure. This is useful to analyse further why and where a regular + -- expression did match. + + procedure Register + (Pattern : Pattern_Callback; + Action : Action_Callback; + Session : Session_Type := Current_Session); + -- Register an Action associated with a Pattern. The pattern here is a + -- function that must return a boolean. Action callback will be called if + -- the pattern callback returns True and nothing will happen if it is + -- False. This version is more general, the two other register services + -- trigger an action based on the value of a single field only. + + procedure Register + (Action : Action_Callback; + Session : Session_Type := Current_Session); + -- Register an Action that will be called for every line. This is + -- equivalent to a Pattern_Callback function always returning True. + + -------------------- + -- Parse iterator -- + -------------------- + + procedure Parse + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type := Current_Session); + -- Launch the iterator, it will read every line in all specified + -- session's files. Registered callbacks are then called if the associated + -- pattern match. It is possible to specify a filename and a set of + -- separators directly. This offer a quick way to parse a single + -- file. These parameters will override those specified by Set_FS and + -- Add_File. The Session will be opened and closed automatically. + -- File_Error is raised if there is no file associated with Session, or if + -- a file associated with Session is not longer readable. It raises + -- Session_Error is Session is already open. + + ----------------------------------- + -- Get_Line/End_Of_Data Iterator -- + ----------------------------------- + + type Callback_Mode is (None, Only, Pass_Through); + -- These mode are used for Get_Line/End_Of_Data and For_Every_Line + -- iterators. The associated semantic is: + -- + -- None + -- callbacks are not active. This is the default mode for + -- Get_Line/End_Of_Data and For_Every_Line iterators. + -- + -- Only + -- callbacks are active, if at least one pattern match, the associated + -- action is called and this line will not be passed to the user. In + -- the Get_Line case the next line will be read (if there is some + -- line remaining), in the For_Every_Line case Action will + -- not be called for this line. + -- + -- Pass_Through + -- callbacks are active, for patterns which match the associated + -- action is called. Then the line is passed to the user. It means + -- that Action procedure is called in the For_Every_Line case and + -- that Get_Line returns with the current line active. + -- + + procedure Open + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type := Current_Session); + -- Open the first file and initialize the unit. This must be called once + -- before using Get_Line. It is possible to specify a filename and a set of + -- separators directly. This offer a quick way to parse a single file. + -- These parameters will override those specified by Set_FS and Add_File. + -- File_Error is raised if there is no file associated with Session, or if + -- the first file associated with Session is no longer readable. It raises + -- Session_Error is Session is already open. + + procedure Get_Line + (Callbacks : Callback_Mode := None; + Session : Session_Type := Current_Session); + -- Read a line from the current input file. If the file index is at the + -- end of the current input file (i.e. End_Of_File is True) then the + -- following file is opened. If there is no more file to be processed, + -- exception End_Error will be raised. File_Error will be raised if Open + -- has not been called. Next call to Get_Line will return the following + -- line in the file. By default the registered callbacks are not called by + -- Get_Line, this can activated by setting Callbacks (see Callback_Mode + -- description above). File_Error may be raised if a file associated with + -- Session is not readable. + -- + -- When Callbacks is not None, it is possible to exhaust all the lines + -- of all the files associated with Session. In this case, File_Error + -- is not raised. + -- + -- This procedure can be used from a subprogram called by procedure Parse + -- or by an instantiation of For_Every_Line (see below). + + + function End_Of_Data + (Session : Session_Type := Current_Session) + return Boolean; + -- Returns True if there is no more data to be processed in Session. It + -- means that the latest session's file is being processed and that + -- there is no more data to be read in this file (End_Of_File is True). + + function End_Of_File + (Session : Session_Type := Current_Session) + return Boolean; + -- Returns True when there is no more data to be processed on the current + -- session's file. + + procedure Close (Session : Session_Type); + -- Release all associated data with Session. All memory allocated will + -- be freed, the current file will be closed if needed, the callbacks + -- will be unregistered. Close is convenient in reestablishing a session + -- for new use. Get_Line is no longer usable (will raise File_Error) + -- except after a successful call to Open, Parse or an instantiation + -- of For_Every_Line. + + ----------------------------- + -- For_Every_Line iterator -- + ----------------------------- + + generic + with procedure Action (Quit : in out Boolean); + procedure For_Every_Line + (Separators : String := Use_Current; + Filename : String := Use_Current; + Callbacks : Callback_Mode := None; + Session : Session_Type := Current_Session); + -- This is another iterator. Action will be called for each new + -- record. The iterator's termination can be controlled by setting Quit + -- to True. It is by default set to False. It is possible to specify a + -- filename and a set of separators directly. This offer a quick way to + -- parse a single file. These parameters will override those specified by + -- Set_FS and Add_File. By default the registered callbacks are not called + -- by For_Every_Line, this can activated by setting Callbacks (see + -- Callback_Mode description above). The Session will be opened and + -- closed automatically. File_Error is raised if there is no file + -- associated with Session. It raises Session_Error is Session is already + -- open. + +private + pragma Inline (End_Of_File); + pragma Inline (End_Of_Data); + pragma Inline (Number_Of_Fields); + pragma Inline (Number_Of_Lines); + pragma Inline (Number_Of_Files); + pragma Inline (Number_Of_File_Lines); + + type Session_Data; + type Session_Data_Access is access Session_Data; + + type Session_Type is new Ada.Finalization.Limited_Controlled with record + Data : Session_Data_Access; + end record; + + procedure Initialize (Session : in out Session_Type); + procedure Finalize (Session : in out Session_Type); + +end GNAT.AWK; diff --git a/gcc/ada/g-busora.adb b/gcc/ada/g-busora.adb new file mode 100644 index 00000000000..9c6c539c06f --- /dev/null +++ b/gcc/ada/g-busora.adb @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ A -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- Copyright (C) 1995-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Bubble_Sort_A is + + ---------- + -- Sort -- + ---------- + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is + Switched : Boolean; + + begin + loop + Switched := False; + + for J in 1 .. N - 1 loop + if Lt (J + 1, J) then + Move (J, 0); + Move (J + 1, J); + Move (0, J + 1); + Switched := True; + end if; + end loop; + + exit when not Switched; + end loop; + end Sort; + +end GNAT.Bubble_Sort_A; diff --git a/gcc/ada/g-busora.ads b/gcc/ada/g-busora.ads new file mode 100644 index 00000000000..6c693c89ef3 --- /dev/null +++ b/gcc/ada/g-busora.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ A -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 1995-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Bubblesort using access to procedure parameters + +-- This package provides a bubblesort routine that works with access to +-- subprogram parameters, so that it can be used with different types with +-- shared sorting code. See also GNAT.Bubble_Sort_G, the generic version +-- which is a little more efficient, but does not allow code sharing. +-- The generic version is also Pure, while the access version can +-- only be Preelaborate. + +package GNAT.Bubble_Sort_A is +pragma Preelaborate (Bubble_Sort_A); + + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + type Move_Procedure is access procedure (From : Natural; To : Natural); + -- A pointer to a procedure that moves the data item with index From to + -- the data item with index To. An index value of zero is used for moves + -- from and to the single temporary location used by the sort. + + type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; + -- A pointer to a function that compares two items and returns True if + -- the item with index Op1 is less than the item with index Op2, and False + -- if the Op2 item is greater than or equal to the Op1 item. + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is not + -- stable, i.e. the order of equal elements in the input is not preserved. + +end GNAT.Bubble_Sort_A; diff --git a/gcc/ada/g-busorg.adb b/gcc/ada/g-busorg.adb new file mode 100644 index 00000000000..f16b6ef488b --- /dev/null +++ b/gcc/ada/g-busorg.adb @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1995-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Bubble_Sort_G is + + ---------- + -- Sort -- + ---------- + + procedure Sort (N : Natural) is + Switched : Boolean; + + begin + loop + Switched := False; + + for J in 1 .. N - 1 loop + if Lt (J + 1, J) then + Move (J, 0); + Move (J + 1, J); + Move (0, J + 1); + Switched := True; + end if; + end loop; + + exit when not Switched; + end loop; + end Sort; + +end GNAT.Bubble_Sort_G; diff --git a/gcc/ada/g-busorg.ads b/gcc/ada/g-busorg.ads new file mode 100644 index 00000000000..54183a724da --- /dev/null +++ b/gcc/ada/g-busorg.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1995-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Bubblesort generic package using formal procedures + +-- This package provides a generic bubble sort routine that can be used with +-- different types of data. See also GNAT.Bubble_Sort_A, a version that works +-- with subprogram parameters, allowing code sharing. The generic version +-- is slightly more efficient but does not allow code sharing. The generic +-- version is also Pure, while the access version can only be Preelaborate. + +generic + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + with procedure Move (From : Natural; To : Natural); + -- A procedure that moves the data item with index From to the data item + -- with Index To. An index value of zero is used for moves from and to a + -- single temporary location used by the sort. + + with function Lt (Op1, Op2 : Natural) return Boolean; + -- A function that compares two items and returns True if the item with + -- index Op1 is less than the item with Index Op2, and False if the Op2 + -- item is greater than or equal to the Op1 item. + +package GNAT.Bubble_Sort_G is +pragma Pure (Bubble_Sort_G); + + procedure Sort (N : Natural); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is not + -- stable, i.e. the order of equal elements in the input is not preserved. + +end GNAT.Bubble_Sort_G; diff --git a/gcc/ada/g-calend.adb b/gcc/ada/g-calend.adb new file mode 100644 index 00000000000..76252ad7dbf --- /dev/null +++ b/gcc/ada/g-calend.adb @@ -0,0 +1,319 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Calendar is + + use Ada.Calendar; + use Interfaces; + + ----------------- + -- Day_In_Year -- + ----------------- + + function Day_In_Year (Date : Time) return Day_In_Year_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Dsecs : Day_Duration; + + begin + Split (Date, Year, Month, Day, Dsecs); + + return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1; + end Day_In_Year; + + ----------------- + -- Day_Of_Week -- + ----------------- + + function Day_Of_Week (Date : Time) return Day_Name is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Dsecs : Day_Duration; + + begin + Split (Date, Year, Month, Day, Dsecs); + + return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7); + end Day_Of_Week; + + ---------- + -- Hour -- + ---------- + + function Hour (Date : Time) return Hour_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Hour; + end Hour; + + ---------------- + -- Julian_Day -- + ---------------- + + -- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note + -- that this implementation is not expensive. + + function Julian_Day + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number) + return Integer + is + Internal_Year : Integer; + Internal_Month : Integer; + Internal_Day : Integer; + Julian_Date : Integer; + C : Integer; + Ya : Integer; + + begin + Internal_Year := Integer (Year); + Internal_Month := Integer (Month); + Internal_Day := Integer (Day); + + if Internal_Month > 2 then + Internal_Month := Internal_Month - 3; + else + Internal_Month := Internal_Month + 9; + Internal_Year := Internal_Year - 1; + end if; + + C := Internal_Year / 100; + Ya := Internal_Year - (100 * C); + + Julian_Date := (146_097 * C) / 4 + + (1_461 * Ya) / 4 + + (153 * Internal_Month + 2) / 5 + + Internal_Day + 1_721_119; + + return Julian_Date; + end Julian_Day; + + ------------ + -- Minute -- + ------------ + + function Minute (Date : Time) return Minute_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Minute; + end Minute; + + ------------ + -- Second -- + ------------ + + function Second (Date : Time) return Second_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Second; + end Second; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration) + is + Dsecs : Day_Duration; + Secs : Natural; + + begin + Split (Date, Year, Month, Day, Dsecs); + + if Dsecs = 0.0 then + Secs := 0; + else + Secs := Natural (Dsecs - 0.5); + end if; + + Sub_Second := Second_Duration (Dsecs - Day_Duration (Secs)); + Hour := Hour_Number (Secs / 3600); + Secs := Secs mod 3600; + Minute := Minute_Number (Secs / 60); + Second := Second_Number (Secs mod 60); + end Split; + + ---------------- + -- Sub_Second -- + ---------------- + + function Sub_Second (Date : Time) return Second_Duration is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Sub_Second; + end Sub_Second; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0) + return Time + is + Dsecs : constant Day_Duration := + Day_Duration (Hour * 3600 + Minute * 60 + Second) + + Sub_Second; + begin + return Time_Of (Year, Month, Day, Dsecs); + end Time_Of; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : access timeval) return Duration is + + procedure timeval_to_duration + (T : access timeval; + sec : access C.long; + usec : access C.long); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased C.long; + usec : aliased C.long; + + + begin + timeval_to_duration (T, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end To_Duration; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return timeval is + + procedure duration_to_timeval (Sec, Usec : C.long; T : access timeval); + pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval"); + + Micro : constant := 10**6; + Result : aliased timeval; + sec : C.long; + usec : C.long; + + begin + if D = 0.0 then + sec := 0; + usec := 0; + else + sec := C.long (D - 0.5); + usec := C.long ((D - Duration (sec)) * Micro - 0.5); + end if; + + duration_to_timeval (sec, usec, Result'Access); + + return Result; + end To_Timeval; + + ------------------ + -- Week_In_Year -- + ------------------ + + function Week_In_Year + (Date : Ada.Calendar.Time) + return Week_In_Year_Number + is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + Offset : Natural; + + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + + -- Day offset number for the first week of the year. + + Offset := Julian_Day (Year, 1, 1) mod 7; + + return 1 + ((Day_In_Year (Date) - 1) + Offset) / 7; + end Week_In_Year; + +end GNAT.Calendar; diff --git a/gcc/ada/g-calend.ads b/gcc/ada/g-calend.ads new file mode 100644 index 00000000000..16548db3706 --- /dev/null +++ b/gcc/ada/g-calend.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1999-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package extends Ada.Calendar to handle Hour, Minute, Second, +-- Second_Duration and Day_Of_Week and Day_In_Year from Calendar.Time. +-- Second_Duration precision depends on the target clock precision. +-- +-- GNAT.Calendar provides the same kind of abstraction found in +-- Ada.Calendar. It provides Split and Time_Of to build and split a Time +-- data. And it provides accessor functions to get only one of Hour, Minute, +-- Second, Second_Duration. Other functions are to access more advanced +-- valueas like Day_Of_Week, Day_In_Year and Week_In_Year. + +with Ada.Calendar; +with Interfaces.C; + +package GNAT.Calendar is + + type Day_Name is + (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); + + subtype Hour_Number is Natural range 0 .. 23; + subtype Minute_Number is Natural range 0 .. 59; + subtype Second_Number is Natural range 0 .. 59; + subtype Second_Duration is Ada.Calendar.Day_Duration range 0.0 .. 1.0; + subtype Day_In_Year_Number is Positive range 1 .. 366; + subtype Week_In_Year_Number is Positive range 1 .. 53; + + function Hour (Date : Ada.Calendar.Time) return Hour_Number; + function Minute (Date : Ada.Calendar.Time) return Minute_Number; + function Second (Date : Ada.Calendar.Time) return Second_Number; + function Sub_Second (Date : Ada.Calendar.Time) return Second_Duration; + -- Hour, Minute, Sedond and Sub_Second returns the complete time data for + -- the Date (H:M:S.SS). See Ada.Calendar for Year, Month, Day accessors. + -- Second_Duration precision depends on the target clock precision. + + function Day_Of_Week (Date : Ada.Calendar.Time) return Day_Name; + -- Return the day name. + + function Day_In_Year (Date : Ada.Calendar.Time) return Day_In_Year_Number; + -- Returns the day number in the year. (1st January is day 1 and 31st + -- December is day 365 or 366 for leap year). + + function Week_In_Year (Date : Ada.Calendar.Time) return Week_In_Year_Number; + -- Returns the week number in the year with Monday as first day of week + + procedure Split + (Date : Ada.Calendar.Time; + Year : out Ada.Calendar.Year_Number; + Month : out Ada.Calendar.Month_Number; + Day : out Ada.Calendar.Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration); + -- Split the standard Ada.Calendar.Time data in date data (Year, Month, + -- Day) and Time data (Hour, Minute, Second, Sub_Second) + + function Time_Of + (Year : Ada.Calendar.Year_Number; + Month : Ada.Calendar.Month_Number; + Day : Ada.Calendar.Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0) + return Ada.Calendar.Time; + -- Returns an Ada.Calendar.Time data built from the date and time values. + + -- C timeval conversion + + -- C timeval represent a duration (used in Select for example). This + -- structure is composed of a number of seconds and a number of micro + -- seconds. The timeval structure is not exposed here because its + -- definition is target dependent. Interface to C programs is done via a + -- pointer to timeval structure. + + type timeval is private; + + function To_Duration (T : access timeval) return Duration; + function To_Timeval (D : Duration) return timeval; + +private + -- This is a dummy declaration that should be the largest possible timeval + -- structure of all supported targets. + + type timeval is array (1 .. 2) of Interfaces.C.long; + + function Julian_Day + (Year : Ada.Calendar.Year_Number; + Month : Ada.Calendar.Month_Number; + Day : Ada.Calendar.Day_Number) + return Integer; + -- Compute Julian day number. + -- + -- The code of this function is a modified version of algorithm + -- 199 from the Collected Algorithms of the ACM. + -- The author of algorithm 199 is Robert G. Tantzen. +end GNAT.Calendar; diff --git a/gcc/ada/g-casuti.adb b/gcc/ada/g-casuti.adb new file mode 100644 index 00000000000..dcedebecb43 --- /dev/null +++ b/gcc/ada/g-casuti.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . C A S E _ U T I L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1995-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Case_Util is + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); + + begin + if A in 'A' .. 'Z' + or else A_Val in 16#C0# .. 16#D6# + or else A_Val in 16#D8# .. 16#DE# + then + return Character'Val (A_Val + 16#20#); + else + return A; + end if; + end To_Lower; + + procedure To_Lower (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Lower (A (J)); + end loop; + end To_Lower; + + -------------- + -- To_Mixed -- + -------------- + + procedure To_Mixed (A : in out String) is + Ucase : Boolean := True; + + begin + for J in A'Range loop + if Ucase then + A (J) := To_Upper (A (J)); + else + A (J) := To_Lower (A (J)); + end if; + + Ucase := A (J) = '_'; + end loop; + end To_Mixed; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); + + begin + if A in 'a' .. 'z' + or else A_Val in 16#E0# .. 16#F6# + or else A_Val in 16#F8# .. 16#FE# + then + return Character'Val (A_Val - 16#20#); + else + return A; + end if; + end To_Upper; + + procedure To_Upper (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Upper (A (J)); + end loop; + end To_Upper; + +end GNAT.Case_Util; diff --git a/gcc/ada/g-casuti.ads b/gcc/ada/g-casuti.ads new file mode 100644 index 00000000000..fb0959a6fcc --- /dev/null +++ b/gcc/ada/g-casuti.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . C A S E _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1995-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Simple casing functions + +-- This package provides simple casing functions that do not require the +-- overhead of the full casing tables found in Ada.Characters.Handling. + +package GNAT.Case_Util is +pragma Pure (Case_Util); + + -- Note: all the following functions handle the full Latin-1 set + + function To_Upper (A : Character) return Character; + -- Converts A to upper case if it is a lower case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Upper (A : in out String); + -- Folds all characters of string A to upper csae + + function To_Lower (A : Character) return Character; + -- Converts A to lower case if it is an upper case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Lower (A : in out String); + -- Folds all characters of string A to lower case + + procedure To_Mixed (A : in out String); + -- Converts A to mixed case (i.e. lower case, except for initial + -- character and any character after an underscore, which are + -- converted to upper case. + +end GNAT.Case_Util; diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb new file mode 100644 index 00000000000..8f52cc3e8e1 --- /dev/null +++ b/gcc/ada/g-catiio.adb @@ -0,0 +1,465 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R . T I M E _ I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; use Ada.Calendar; +with Ada.Characters.Handling; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Text_IO; + +package body GNAT.Calendar.Time_IO is + + type Month_Name is + (January, + Febuary, + March, + April, + May, + June, + July, + August, + September, + October, + November, + December); + + type Padding_Mode is (None, Zero, Space); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Am_Pm (H : Natural) return String; + -- return AM or PM depending on the hour H + + function Hour_12 (H : Natural) return Positive; + -- Convert a 1-24h format to a 0-12 hour format. + + function Image (Str : String; Length : Natural := 0) return String; + -- Return Str capitalized and cut to length number of characters. If + -- length is set to 0 it does not cut it. + + function Image + (N : Long_Integer; + Padding : Padding_Mode := Zero; + Length : Natural := 0) + return String; + -- Return image of N. This number is eventually padded with zeros or + -- spaces depending of the length required. If length is 0 then no padding + -- occurs. + + function Image + (N : Integer; + Padding : Padding_Mode := Zero; + Length : Natural := 0) + return String; + -- As above with N provided in Integer format. + + ----------- + -- Am_Pm -- + ----------- + + function Am_Pm (H : Natural) return String is + begin + if H = 0 or else H > 12 then + return "PM"; + else + return "AM"; + end if; + end Am_Pm; + + ------------- + -- Hour_12 -- + ------------- + + function Hour_12 (H : Natural) return Positive is + begin + if H = 0 then + return 12; + elsif H <= 12 then + return H; + else -- H > 12 + return H - 12; + end if; + end Hour_12; + + ----------- + -- Image -- + ----------- + + function Image + (Str : String; + Length : Natural := 0) + return String + is + use Ada.Characters.Handling; + Local : String := To_Upper (Str (1)) & To_Lower (Str (2 .. Str'Last)); + + begin + if Length = 0 then + return Local; + else + return Local (1 .. Length); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (N : Integer; + Padding : Padding_Mode := Zero; + Length : Natural := 0) + return String + is + begin + return Image (Long_Integer (N), Padding, Length); + end Image; + + function Image + (N : Long_Integer; + Padding : Padding_Mode := Zero; + Length : Natural := 0) + return String + is + function Pad_Char return String; + + function Pad_Char return String is + begin + case Padding is + when None => return ""; + when Zero => return "00"; + when Space => return " "; + end case; + end Pad_Char; + + NI : constant String := Long_Integer'Image (N); + NIP : constant String := Pad_Char & NI (2 .. NI'Last); + + -- Start of processing for Image + + begin + if Length = 0 or else Padding = None then + return NI (2 .. NI'Last); + + else + return NIP (NIP'Last - Length + 1 .. NIP'Last); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (Date : Ada.Calendar.Time; + Picture : Picture_String) + return String + is + Padding : Padding_Mode := Zero; + -- Padding is set for one directive + + Result : Unbounded_String; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + + P : Positive := Picture'First; + + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + + loop + -- A directive has the following format "%[-_]." + + if Picture (P) = '%' then + + Padding := Zero; + + if P = Picture'Last then + raise Picture_Error; + end if; + + -- Check for GNU extension to change the padding + + if Picture (P + 1) = '-' then + Padding := None; + P := P + 1; + elsif Picture (P + 1) = '_' then + Padding := Space; + P := P + 1; + end if; + + if P = Picture'Last then + raise Picture_Error; + end if; + + case Picture (P + 1) is + + -- Literal % + + when '%' => + Result := Result & '%'; + + -- A newline + + when 'n' => + Result := Result & ASCII.LF; + + -- A horizontal tab + + when 't' => + Result := Result & ASCII.HT; + + -- Hour (00..23) + + when 'H' => + Result := Result & Image (Hour, Padding, 2); + + -- Hour (01..12) + + when 'I' => + Result := Result & Image (Hour_12 (Hour), Padding, 2); + + -- Hour ( 0..23) + + when 'k' => + Result := Result & Image (Hour, Space, 2); + + -- Hour ( 1..12) + + when 'l' => + Result := Result & Image (Hour_12 (Hour), Space, 2); + + -- Minute (00..59) + + when 'M' => + Result := Result & Image (Minute, Padding, 2); + + -- AM/PM + + when 'p' => + Result := Result & Am_Pm (Hour); + + -- Time, 12-hour (hh:mm:ss [AP]M) + + when 'r' => + Result := Result & + Image (Hour_12 (Hour), Padding, Length => 2) & ':' & + Image (Minute, Padding, Length => 2) & ':' & + Image (Second, Padding, Length => 2) & ' ' & + Am_Pm (Hour); + + -- Seconds since 1970-01-01 00:00:00 UTC + -- (a nonstandard extension) + + when 's' => + declare + Sec : constant Long_Integer := + Long_Integer + ((Julian_Day (Year, Month, Day) - + Julian_Day (1970, 1, 1)) * 86_400 + + Hour * 3_600 + Minute * 60 + Second); + + begin + Result := Result & Image (Sec, None); + end; + + -- Second (00..59) + + when 'S' => + Result := Result & Image (Second, Padding, Length => 2); + + -- Time, 24-hour (hh:mm:ss) + + when 'T' => + Result := Result & + Image (Hour, Padding, Length => 2) & ':' & + Image (Minute, Padding, Length => 2) & ':' & + Image (Second, Padding, Length => 2); + + -- Locale's abbreviated weekday name (Sun..Sat) + + when 'a' => + Result := Result & + Image (Day_Name'Image (Day_Of_Week (Date)), 3); + + -- Locale's full weekday name, variable length + -- (Sunday..Saturday) + + when 'A' => + Result := Result & + Image (Day_Name'Image (Day_Of_Week (Date))); + + -- Locale's abbreviated month name (Jan..Dec) + + when 'b' | 'h' => + Result := Result & + Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3); + + -- Locale's full month name, variable length + -- (January..December) + + when 'B' => + Result := Result & + Image (Month_Name'Image (Month_Name'Val (Month - 1))); + + -- Locale's date and time (Sat Nov 04 12:02:33 EST 1989) + + when 'c' => + case Padding is + when Zero => + Result := Result & Image (Date, "%a %b %d %T %Y"); + when Space => + Result := Result & Image (Date, "%a %b %_d %_T %Y"); + when None => + Result := Result & Image (Date, "%a %b %-d %-T %Y"); + end case; + + -- Day of month (01..31) + + when 'd' => + Result := Result & Image (Day, Padding, 2); + + -- Date (mm/dd/yy) + + when 'D' | 'x' => + Result := Result & + Image (Month, Padding, 2) & '/' & + Image (Day, Padding, 2) & '/' & + Image (Year, Padding, 2); + + -- Day of year (001..366) + + when 'j' => + Result := Result & Image (Day_In_Year (Date), Padding, 3); + + -- Month (01..12) + + when 'm' => + Result := Result & Image (Month, Padding, 2); + + -- Week number of year with Sunday as first day of week + -- (00..53) + + when 'U' => + declare + Offset : constant Natural := + (Julian_Day (Year, 1, 1) + 1) mod 7; + + Week : constant Natural := + 1 + ((Day_In_Year (Date) - 1) + Offset) / 7; + + begin + Result := Result & Image (Week, Padding, 2); + end; + + -- Day of week (0..6) with 0 corresponding to Sunday + + when 'w' => + declare + DOW : Natural range 0 .. 6; + + begin + if Day_Of_Week (Date) = Sunday then + DOW := 0; + else + DOW := Day_Name'Pos (Day_Of_Week (Date)); + end if; + + Result := Result & Image (DOW, Length => 1); + end; + + -- Week number of year with Monday as first day of week + -- (00..53) + + when 'W' => + Result := Result & Image (Week_In_Year (Date), Padding, 2); + + -- Last two digits of year (00..99) + + when 'y' => + declare + Y : constant Natural := Year - (Year / 100) * 100; + + begin + Result := Result & Image (Y, Padding, 2); + end; + + -- Year (1970...) + + when 'Y' => + Result := Result & Image (Year, None, 4); + + when others => + raise Picture_Error; + end case; + + P := P + 2; + + else + Result := Result & Picture (P); + P := P + 1; + end if; + + exit when P > Picture'Last; + + end loop; + + return To_String (Result); + end Image; + + -------------- + -- Put_Time -- + -------------- + + procedure Put_Time + (Date : Ada.Calendar.Time; + Picture : Picture_String) + is + begin + Ada.Text_IO.Put (Image (Date, Picture)); + end Put_Time; + +end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/g-catiio.ads b/gcc/ada/g-catiio.ads new file mode 100644 index 00000000000..59f0520becc --- /dev/null +++ b/gcc/ada/g-catiio.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R . T I M E _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package augments standard Ada.Text_IO with facilities for input +-- and output of time values in standardized format. + +package GNAT.Calendar.Time_IO is + + Picture_Error : exception; + + type Picture_String is new String; + + -- This is a string to describe date and time output format. The string is + -- a set of standard character and special tag that are replaced by the + -- corresponding values. It follows the GNU Date specification. Here are + -- the recognized directives : + -- + -- % a literal % + -- n a newline + -- t a horizontal tab + -- + -- Time fields: + -- + -- %H hour (00..23) + -- %I hour (01..12) + -- %k hour ( 0..23) + -- %l hour ( 1..12) + -- %M minute (00..59) + -- %p locale's AM or PM + -- %r time, 12-hour (hh:mm:ss [AP]M) + -- %s seconds since 1970-01-01 00:00:00 UTC + -- (a nonstandard extension) + -- %S second (00..59) + -- %T time, 24-hour (hh:mm:ss) + -- + -- Date fields: + -- + -- %a locale's abbreviated weekday name (Sun..Sat) + -- %A locale's full weekday name, variable length + -- (Sunday..Saturday) + -- %b locale's abbreviated month name (Jan..Dec) + -- %B locale's full month name, variable length + -- (January..December) + -- %c locale's date and time (Sat Nov 04 12:02:33 EST 1989) + -- %d day of month (01..31) + -- %D date (mm/dd/yy) + -- %h same as %b + -- %j day of year (001..366) + -- %m month (01..12) + -- %U week number of year with Sunday as first day of week + -- (00..53) + -- %w day of week (0..6) with 0 corresponding to Sunday + -- %W week number of year with Monday as first day of week + -- (00..53) + -- %x locale's date representation (mm/dd/yy) + -- %y last two digits of year (00..99) + -- %Y year (1970...) + -- + -- By default, date pads numeric fields with zeroes. GNU date + -- recognizes the following nonstandard numeric modifiers: + -- + -- - (hyphen) do not pad the field + -- _ (underscore) pad the field with spaces + + ISO_Date : constant Picture_String; + -- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD", + -- four digits year, month and day number separated by minus. + + US_Date : constant Picture_String; + -- This format is the common US date format: "MM/DD/YY", + -- month and day number, two digits year separated by slashes. + + European_Date : constant Picture_String; + -- This format is the common European date format: "DD/MM/YY", + -- day and month number, two digits year separated by slashes. + + function Image + (Date : Ada.Calendar.Time; + Picture : Picture_String) + return String; + -- Return Date as a string with format Picture. + -- raise Picture_Error if picture string is wrong + + procedure Put_Time + (Date : Ada.Calendar.Time; + Picture : Picture_String); + -- Put Date with format Picture. + -- raise Picture_Error if picture string is wrong + +private + ISO_Date : constant Picture_String := "%Y-%m-%d"; + US_Date : constant Picture_String := "%m/%d/%y"; + European_Date : constant Picture_String := "%d/%m/%y"; + +end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/g-cgi.adb b/gcc/ada/g-cgi.adb new file mode 100644 index 00000000000..1cd910028dc --- /dev/null +++ b/gcc/ada/g-cgi.adb @@ -0,0 +1,491 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; +with Ada.Strings.Fixed; +with Ada.Characters.Handling; +with Ada.Strings.Maps; + +with GNAT.OS_Lib; +with GNAT.Table; + +package body GNAT.CGI is + + use Ada; + + Valid_Environment : Boolean := True; + -- This boolean will be set to False if the initialization was not + -- completed correctly. It must be set to true there because the + -- Initialize routine (called during elaboration) will use some of the + -- services exported by this unit. + + Current_Method : Method_Type; + -- This is the current method used to pass CGI parameters. + + Header_Sent : Boolean := False; + -- Will be set to True when the header will be sent. + + -- Key/Value table declaration + + type String_Access is access String; + + type Key_Value is record + Key : String_Access; + Value : String_Access; + end record; + + package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Check_Environment; + pragma Inline (Check_Environment); + -- This procedure will raise Data_Error if Valid_Environment is False. + + procedure Initialize; + -- Initialize CGI package by reading the runtime environment. This + -- procedure is called during elaboration. All exceptions raised during + -- this procedure are deferred. + + -------------------- + -- Argument_Count -- + -------------------- + + function Argument_Count return Natural is + begin + Check_Environment; + return Key_Value_Table.Last; + end Argument_Count; + + ----------------------- + -- Check_Environment -- + ----------------------- + + procedure Check_Environment is + begin + if not Valid_Environment then + raise Data_Error; + end if; + end Check_Environment; + + ------------ + -- Decode -- + ------------ + + function Decode (S : String) return String is + Result : String (S'Range); + K : Positive := S'First; + J : Positive := Result'First; + + begin + while K <= S'Last loop + if K + 2 <= S'Last + and then S (K) = '%' + and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1)) + and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2)) + then + -- Here we have '%HH' which is an encoded character where 'HH' is + -- the character number in hexadecimal. + + Result (J) := Character'Val + (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#')); + K := K + 3; + + else + Result (J) := S (K); + K := K + 1; + end if; + + J := J + 1; + end loop; + + return Result (Result'First .. J - 1); + end Decode; + + ------------------------- + -- For_Every_Parameter -- + ------------------------- + + procedure For_Every_Parameter is + Quit : Boolean; + + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + + Quit := False; + + Action (Key_Value_Table.Table (K).Key.all, + Key_Value_Table.Table (K).Value.all, + K, + Quit); + + exit when Quit; + + end loop; + end For_Every_Parameter; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + + Request_Method : constant String := + Characters.Handling.To_Upper + (Metavariable (CGI.Request_Method)); + + procedure Initialize_GET; + -- Read CGI parameters for a GET method. In this case the parameters + -- are passed into QUERY_STRING environment variable. + + procedure Initialize_POST; + -- Read CGI parameters for a POST method. In this case the parameters + -- are passed with the standard input. The total number of characters + -- for the data is passed in CONTENT_LENGTH environment variable. + + procedure Set_Parameter_Table (Data : String); + -- Parse the parameter data and set the parameter table. + + -------------------- + -- Initialize_GET -- + -------------------- + + procedure Initialize_GET is + Data : constant String := Metavariable (Query_String); + begin + Current_Method := Get; + if Data /= "" then + Set_Parameter_Table (Data); + end if; + end Initialize_GET; + + --------------------- + -- Initialize_POST -- + --------------------- + + procedure Initialize_POST is + Content_Length : constant Natural := + Natural'Value (Metavariable (CGI.Content_Length)); + Data : String (1 .. Content_Length); + + begin + Current_Method := Post; + + if Content_Length /= 0 then + Text_IO.Get (Data); + Set_Parameter_Table (Data); + end if; + end Initialize_POST; + + ------------------------- + -- Set_Parameter_Table -- + ------------------------- + + procedure Set_Parameter_Table (Data : String) is + + procedure Add_Parameter (K : Positive; P : String); + -- Add a single parameter into the table at index K. The parameter + -- format is "key=value". + + Count : constant Positive := + 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&")); + -- Count is the number of parameters in the string. Parameters are + -- separated by ampersand character. + + Index : Positive := Data'First; + Amp : Natural; + + ------------------- + -- Add_Parameter -- + ------------------- + + procedure Add_Parameter (K : Positive; P : String) is + Equal : constant Natural := Strings.Fixed.Index (P, "="); + + begin + if Equal = 0 then + raise Data_Error; + + else + Key_Value_Table.Table (K) := + Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), + new String'(Decode (P (Equal + 1 .. P'Last)))); + end if; + end Add_Parameter; + + -- Start of processing for Set_Parameter_Table + + begin + Key_Value_Table.Set_Last (Count); + + for K in 1 .. Count - 1 loop + Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&"); + + Add_Parameter (K, Data (Index .. Amp - 1)); + + Index := Amp + 1; + end loop; + + -- add last parameter + + Add_Parameter (Count, Data (Index .. Data'Last)); + end Set_Parameter_Table; + + -- Start of processing for Initialize + + begin + if Request_Method = "GET" then + Initialize_GET; + + elsif Request_Method = "POST" then + Initialize_POST; + + else + Valid_Environment := False; + end if; + + exception + when others => + + -- If we have an exception during initialization of this unit we + -- just declare it invalid. + + Valid_Environment := False; + end Initialize; + + --------- + -- Key -- + --------- + + function Key (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Key.all; + else + raise Parameter_Not_Found; + end if; + end Key; + + ---------------- + -- Key_Exists -- + ---------------- + + function Key_Exists (Key : String) return Boolean is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return True; + end if; + end loop; + + return False; + end Key_Exists; + + ------------------ + -- Metavariable -- + ------------------ + + function Metavariable + (Name : Metavariable_Name; + Required : Boolean := False) return String + is + function Get_Environment (Variable_Name : String) return String; + -- Returns the environment variable content. + + --------------------- + -- Get_Environment -- + --------------------- + + function Get_Environment (Variable_Name : String) return String is + Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name); + Result : constant String := Value.all; + + begin + OS_Lib.Free (Value); + return Result; + end Get_Environment; + + Result : constant String := + Get_Environment (Metavariable_Name'Image (Name)); + + -- Start of processing for Metavariable + + begin + Check_Environment; + + if Result = "" and then Required then + raise Parameter_Not_Found; + else + return Result; + end if; + end Metavariable; + + ------------------------- + -- Metavariable_Exists -- + ------------------------- + + function Metavariable_Exists (Name : Metavariable_Name) return Boolean is + begin + Check_Environment; + + if Metavariable (Name) = "" then + return False; + else + return True; + end if; + end Metavariable_Exists; + + ------------ + -- Method -- + ------------ + + function Method return Method_Type is + begin + Check_Environment; + return Current_Method; + end Method; + + -------- + -- Ok -- + -------- + + function Ok return Boolean is + begin + return Valid_Environment; + end Ok; + + ---------------- + -- Put_Header -- + ---------------- + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False) + is + begin + if Header_Sent = False or else Force then + Check_Environment; + Text_IO.Put_Line (Header); + Text_IO.New_Line; + Header_Sent := True; + end if; + end Put_Header; + + --------- + -- URL -- + --------- + + function URL return String is + + function Exists_And_Not_80 (Server_Port : String) return String; + -- Returns ':' & Server_Port if Server_Port is not "80" and the empty + -- string otherwise (80 is the default sever port). + + ----------------------- + -- Exists_And_Not_80 -- + ----------------------- + + function Exists_And_Not_80 (Server_Port : String) return String is + begin + if Server_Port = "80" then + return ""; + else + return ':' & Server_Port; + end if; + end Exists_And_Not_80; + + -- Start of processing for URL + + begin + Check_Environment; + + return "http://" + & Metavariable (Server_Name) + & Exists_And_Not_80 (Metavariable (Server_Port)) + & Metavariable (Script_Name); + end URL; + + ----------- + -- Value -- + ----------- + + function Value + (Key : String; + Required : Boolean := False) + return String + is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return Key_Value_Table.Table (K).Value.all; + end if; + end loop; + + if Required then + raise Parameter_Not_Found; + else + return ""; + end if; + end Value; + + ----------- + -- Value -- + ----------- + + function Value (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Value.all; + else + raise Parameter_Not_Found; + end if; + end Value; + +begin + + Initialize; + +end GNAT.CGI; diff --git a/gcc/ada/g-cgi.ads b/gcc/ada/g-cgi.ads new file mode 100644 index 00000000000..10e4907d6e5 --- /dev/null +++ b/gcc/ada/g-cgi.ads @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a package to interface a GNAT program with a Web server via the +-- Common Gateway Interface (CGI). + +-- Other related packages are: + +-- GNAT.CGI.Cookie which deal with Web HTTP Cookies. +-- GNAT.CGI.Debug which output complete CGI runtime environment + +-- Basically this package parse the CGI parameter which are a set of key/value +-- pairs. It builds a table whose index is the key and provides some services +-- to deal with this table. + +-- Example: + +-- Consider the following simple HTML form to capture a client name: + +-- <!DOCTYPE HTML PUBLIC "-//W3C//DTD W3 HTML 3.2//EN"> +-- <html> +-- <head> +-- <title>My Web Page</title> +-- </head> + +-- <body> +-- <form action="/cgi-bin/new_client" method="POST"> +-- <input type=text name=client_name> +-- <input type=submit name="Enter"> +-- </form> +-- </body> +-- </html> + +-- The following program will retrieve the client's name: + +-- with GNAT.CGI; + +-- procedure New_Client is +-- use GNAT; + +-- procedure Add_Client_To_Database (Name : in String) is +-- begin +-- ... +-- end Add_Client_To_Database; + +-- begin +-- -- Check that we have 2 arguments (there is two inputs tag in +-- -- the HTML form) and that one of them is called "client_name". + +-- if CGI.Argument_Count = 2 +-- and the CGI.Key_Exists ("client_name") +-- then +-- Add_Client_To_Database (CGI.Value ("client_name")); +-- end if; + +-- ... + +-- CGI.Put_Header; +-- Text_IO.Put_Line ("<html><body>< ... Ok ... >"); + +-- exception +-- when CGI.Data_Error => +-- CGI.Put_Header ("Location: /htdocs/error.html"); +-- -- This returns the address of a Web page to be displayed +-- -- using a "Location:" header style. +-- end New_Client; + +-- Note that the names in this package interface have been designed so that +-- they read nicely with the CGI prefix. The recommended style is to avoid +-- a use clause for GNAT.CGI, but to include a use clause for GNAT. + +-- This package builds up a table of CGI parameters whose memory is not +-- released. A CGI program is expected to be a short lived program and +-- so it is adequate to have the underlying OS free the program on exit. + +package GNAT.CGI is + + Data_Error : exception; + -- This is raised when there is a problem with the CGI protocol. Either + -- the data could not be retrieved or the CGI environment is invalid. + -- + -- The package will initialize itself by parsing the runtime CGI + -- environment during elaboration but we do not want to raise an + -- exception at this time, so the exception Data_Error is deferred + -- and will be raised when calling any services below (except for Ok). + + Parameter_Not_Found : exception; + -- This exception is raised when a specific parameter is not found. + + Default_Header : constant String := "Content-type: text/html"; + -- This is the default header returned by Put_Header. If the CGI program + -- returned data is not an HTML page, this header must be change to a + -- valid MIME type. + + type Method_Type is (Get, Post); + -- The method used to pass parameter from the Web client to the + -- server. With the GET method parameters are passed via the command + -- line, with the POST method parameters are passed via environment + -- variables. Others methods are not supported by this implementation. + + type Metavariable_Name is + (Auth_Type, + Content_Length, + Content_Type, + Document_Root, -- Web server dependant + Gateway_Interface, + HTTP_Accept, + HTTP_Accept_Encoding, + HTTP_Accept_Language, + HTTP_Connection, + HTTP_Cookie, + HTTP_Extension, + HTTP_From, + HTTP_Host, + HTTP_Referer, + HTTP_User_Agent, + Path, + Path_Info, + Path_Translated, + Query_String, + Remote_Addr, + Remote_Host, + Remote_Port, -- Web server dependant + Remote_Ident, + Remote_User, + Request_Method, + Request_URI, -- Web server dependant + Script_Filename, -- Web server dependant + Script_Name, + Server_Addr, -- Web server dependant + Server_Admin, -- Web server dependant + Server_Name, + Server_Port, + Server_Protocol, + Server_Signature, -- Web server dependant + Server_Software); + -- CGI metavariables that are set by the Web server during program + -- execution. All these variables are part of the restricted CGI runtime + -- environment and can be read using Metavariable service. The detailed + -- meanings of these metavariables are out of the scope of this + -- description. Please refer to http://www.w3.org/CGI/ for a description + -- of the CGI specification. Some metavariables are Web server dependant + -- and are not described in the cited document. + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False); + -- Output standard CGI header by default. The header string is followed by + -- an empty line. This header must be the first answer sent back to the + -- server. Do nothing if this function has already been called and Force + -- is False. + + function Ok return Boolean; + -- Returns True if the CGI environment is valid and False otherwise. + -- Every service used when the CGI environment is not valid will raise + -- the exception Data_Error. + + function Method return Method_Type; + -- Returns the method used to call the CGI. + + function Metavariable + (Name : Metavariable_Name; + Required : Boolean := False) + return String; + -- Returns parameter Name value. Returns the null string if Name + -- environment variable is not defined or raises Data_Error if + -- Required is set to True. + + function Metavariable_Exists (Name : Metavariable_Name) return Boolean; + -- Returns True if the environment variable Name is defined in + -- the CGI runtime environment and False otherwise. + + function URL return String; + -- Returns the URL used to call this script without the parameters. + -- The URL form is: http://<server_name>[:<server_port>]<script_name> + + function Argument_Count return Natural; + -- Returns the number of parameters passed to the client. This is the + -- number of input tags in a form or the number of parameters passed to + -- the CGI via the command line. + + --------------------------------------------------- + -- Services to retrieve key/value CGI parameters -- + --------------------------------------------------- + + function Value + (Key : String; + Required : Boolean := False) + return String; + -- Returns the parameter value associated to the parameter named Key. + -- If parameter does not exist, returns an empty string if Required + -- is False and raises the exception Parameter_Not_Found otherwise. + + function Value (Position : Positive) return String; + -- Returns the parameter value associated with the CGI parameter number + -- Position. Raises Parameter_Not_Found if there is no such parameter + -- (i.e. Position > Argument_Count) + + function Key_Exists (Key : String) return Boolean; + -- Returns True if the parameter named Key existx and False otherwise. + + function Key (Position : Positive) return String; + -- Returns the parameter key associated with the CGI parameter number + -- Position. Raises the exception Parameter_Not_Found if there is no + -- such parameter (i.e. Position > Argument_Count) + + generic + with procedure + Action + (Key : String; + Value : String; + Position : Positive; + Quit : in out Boolean); + procedure For_Every_Parameter; + -- Iterate through all existing key/value pairs and call the Action + -- supplied procedure. The Key and Value are set appropriately, Position + -- is the parameter order in the list, Quit is set to True by default. + -- Quit can be set to False to control the iterator termination. + +private + + function Decode (S : String) return String; + -- Decode Web string S. A string when passed to a CGI is encoded, + -- this function will decode the string to return the original + -- string's content. Every triplet of the form %HH (where H is an + -- hexadecimal number) is translated into the character such that: + -- Hex (Character'Pos (C)) = HH. + +end GNAT.CGI; diff --git a/gcc/ada/g-cgicoo.adb b/gcc/ada/g-cgicoo.adb new file mode 100644 index 00000000000..f28832a0d36 --- /dev/null +++ b/gcc/ada/g-cgicoo.adb @@ -0,0 +1,405 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . C O O K I E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with Ada.Text_IO; +with Ada.Integer_Text_IO; + +with GNAT.Table; + +package body GNAT.CGI.Cookie is + + use Ada; + + Valid_Environment : Boolean := False; + -- This boolean will be set to True if the initialization was fine. + + Header_Sent : Boolean := False; + -- Will be set to True when the header will be sent. + + -- Cookie data that have been added. + + type String_Access is access String; + + type Cookie_Data is record + Key : String_Access; + Value : String_Access; + Comment : String_Access; + Domain : String_Access; + Max_Age : Natural; + Path : String_Access; + Secure : Boolean := False; + end record; + + type Key_Value is record + Key, Value : String_Access; + end record; + + package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50); + -- This is the table to keep all cookies to be sent back to the server. + + package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); + -- This is the table to keep all cookies received from the server. + + procedure Check_Environment; + pragma Inline (Check_Environment); + -- This procedure will raise Data_Error if Valid_Environment is False. + + procedure Initialize; + -- Initialize CGI package by reading the runtime environment. This + -- procedure is called during elaboration. All exceptions raised during + -- this procedure are deferred. + + ----------------------- + -- Check_Environment -- + ----------------------- + + procedure Check_Environment is + begin + if not Valid_Environment then + raise Data_Error; + end if; + end Check_Environment; + + ----------- + -- Count -- + ----------- + + function Count return Natural is + begin + return Key_Value_Table.Last; + end Count; + + ------------ + -- Exists -- + ------------ + + function Exists (Key : String) return Boolean is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return True; + end if; + end loop; + + return False; + end Exists; + + ---------------------- + -- For_Every_Cookie -- + ---------------------- + + procedure For_Every_Cookie is + Quit : Boolean; + + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + Quit := False; + + Action (Key_Value_Table.Table (K).Key.all, + Key_Value_Table.Table (K).Value.all, + K, + Quit); + + exit when Quit; + end loop; + end For_Every_Cookie; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + + HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie); + + procedure Set_Parameter_Table (Data : String); + -- Parse Data and insert information in Key_Value_Table. + + ------------------------- + -- Set_Parameter_Table -- + ------------------------- + + procedure Set_Parameter_Table (Data : String) is + + procedure Add_Parameter (K : Positive; P : String); + -- Add a single parameter into the table at index K. The parameter + -- format is "key=value". + + Count : constant Positive + := 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";")); + -- Count is the number of parameters in the string. Parameters are + -- separated by ampersand character. + + Index : Positive := Data'First; + Sep : Natural; + + ------------------- + -- Add_Parameter -- + ------------------- + + procedure Add_Parameter (K : Positive; P : String) is + Equal : constant Natural := Strings.Fixed.Index (P, "="); + begin + if Equal = 0 then + raise Data_Error; + else + Key_Value_Table.Table (K) := + Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), + new String'(Decode (P (Equal + 1 .. P'Last)))); + end if; + end Add_Parameter; + + begin + Key_Value_Table.Set_Last (Count); + + for K in 1 .. Count - 1 loop + Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";"); + + Add_Parameter (K, Data (Index .. Sep - 1)); + + Index := Sep + 2; + end loop; + + -- add last parameter + + Add_Parameter (Count, Data (Index .. Data'Last)); + end Set_Parameter_Table; + + begin + if HTTP_COOKIE /= "" then + Set_Parameter_Table (HTTP_COOKIE); + end if; + + Valid_Environment := True; + + exception + when others => + Valid_Environment := False; + end Initialize; + + --------- + -- Key -- + --------- + + function Key (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Key.all; + else + raise Cookie_Not_Found; + end if; + end Key; + + -------- + -- Ok -- + -------- + + function Ok return Boolean is + begin + return Valid_Environment; + end Ok; + + ---------------- + -- Put_Header -- + ---------------- + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False) + is + + procedure Output_Cookies; + -- Iterate through the list of cookies to be sent to the server + -- and output them. + + -------------------- + -- Output_Cookies -- + -------------------- + + procedure Output_Cookies is + + procedure Output_One_Cookie + (Key : String; + Value : String; + Comment : String; + Domain : String; + Max_Age : Natural; + Path : String; + Secure : Boolean); + -- Output one cookie in the CGI header. + + ----------------------- + -- Output_One_Cookie -- + ----------------------- + + procedure Output_One_Cookie + (Key : String; + Value : String; + Comment : String; + Domain : String; + Max_Age : Natural; + Path : String; + Secure : Boolean) + is + begin + Text_IO.Put ("Set-Cookie: "); + Text_IO.Put (Key & '=' & Value); + + if Comment /= "" then + Text_IO.Put ("; Comment=" & Comment); + end if; + + if Domain /= "" then + Text_IO.Put ("; Domain=" & Domain); + end if; + + if Max_Age /= Natural'Last then + Text_IO.Put ("; Max-Age="); + Integer_Text_IO.Put (Max_Age, Width => 0); + end if; + + if Path /= "" then + Text_IO.Put ("; Path=" & Path); + end if; + + if Secure then + Text_IO.Put ("; Secure"); + end if; + + Text_IO.New_Line; + end Output_One_Cookie; + + -- Start of processing for Output_Cookies + + begin + for C in 1 .. Cookie_Table.Last loop + Output_One_Cookie (Cookie_Table.Table (C).Key.all, + Cookie_Table.Table (C).Value.all, + Cookie_Table.Table (C).Comment.all, + Cookie_Table.Table (C).Domain.all, + Cookie_Table.Table (C).Max_Age, + Cookie_Table.Table (C).Path.all, + Cookie_Table.Table (C).Secure); + end loop; + end Output_Cookies; + + -- Start of processing for Put_Header + + begin + if Header_Sent = False or else Force then + Check_Environment; + Text_IO.Put_Line (Header); + Output_Cookies; + Text_IO.New_Line; + Header_Sent := True; + end if; + end Put_Header; + + --------- + -- Set -- + --------- + + procedure Set + (Key : String; + Value : String; + Comment : String := ""; + Domain : String := ""; + Max_Age : Natural := Natural'Last; + Path : String := "/"; + Secure : Boolean := False) is + begin + Cookie_Table.Increment_Last; + + Cookie_Table.Table (Cookie_Table.Last) := + Cookie_Data'(new String'(Key), + new String'(Value), + new String'(Comment), + new String'(Domain), + Max_Age, + new String'(Path), + Secure); + end Set; + + ----------- + -- Value -- + ----------- + + function Value + (Key : String; + Required : Boolean := False) + return String + is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return Key_Value_Table.Table (K).Value.all; + end if; + end loop; + + if Required then + raise Cookie_Not_Found; + else + return ""; + end if; + end Value; + + function Value (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Value.all; + else + raise Cookie_Not_Found; + end if; + end Value; + +-- Elaboration code for package + +begin + -- Initialize unit by reading the HTTP_COOKIE metavariable and fill + -- Key_Value_Table structure. + + Initialize; +end GNAT.CGI.Cookie; diff --git a/gcc/ada/g-cgicoo.ads b/gcc/ada/g-cgicoo.ads new file mode 100644 index 00000000000..3d4d1b4bf5e --- /dev/null +++ b/gcc/ada/g-cgicoo.ads @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . C O O K I E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a package to interface a GNAT program with a Web server via the +-- Common Gateway Interface (CGI). It exports services to deal with Web +-- cookies (piece of information kept in the Web client software). + +-- The complete CGI Cookie specification can be found in the RFC2109 at: +-- http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt + +-- This package builds up data tables whose memory is not released. +-- A CGI program is expected to be a short lived program and so it +-- is adequate to have the underlying OS free the program on exit. + +package GNAT.CGI.Cookie is + + -- The package will initialize itself by parsing the HTTP_Cookie runtime + -- CGI environment variable during elaboration but we do not want to raise + -- an exception at this time, so the exception Data_Error is deferred and + -- will be raised when calling any services below (except for Ok). + + Cookie_Not_Found : exception; + -- This exception is raised when a specific parameter is not found. + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False); + -- Output standard CGI header by default. This header must be returned + -- back to the server at the very beginning and will be output only for + -- the first call to Put_Header if Force is set to False. This procedure + -- also outputs the Cookies that have been defined. If the program uses + -- the GNAT.CGI.Put_Header service, cookies will not be set. + -- + -- Cookies are passed back to the server in the header, the format is: + -- + -- Set-Cookie: <key>=<value>; comment=<comment>; domain=<domain>; + -- max_age=<max_age>; path=<path>[; secured] + + function Ok return Boolean; + -- Returns True if the CGI cookie environment is valid and False + -- otherwise. Every service used when the CGI environment is not valid + -- will raise the exception Data_Error. + + function Count return Natural; + -- Returns the number of cookies received by the CGI. + + function Value + (Key : String; + Required : Boolean := False) + return String; + -- Returns the cookie value associated with the cookie named Key. If + -- cookie does not exist, returns an empty string if Required is + -- False and raises the exception Cookie_Not_Found otherwise. + + function Value (Position : Positive) return String; + -- Returns the value associated with the cookie number Position + -- of the CGI. It raises Cookie_Not_Found if there is no such + -- cookie (i.e. Position > Count) + + function Exists (Key : String) return Boolean; + -- Returns True if the cookie named Key exist and False otherwise. + + function Key (Position : Positive) return String; + -- Returns the key associated with the cookie number Position of + -- the CGI. It raises Cookie_Not_Found if there is no such cookie + -- (i.e. Position > Count) + + procedure Set + (Key : String; + Value : String; + Comment : String := ""; + Domain : String := ""; + Max_Age : Natural := Natural'Last; + Path : String := "/"; + Secure : Boolean := False); + -- Add a cookie to the list of cookies. This will be sent back + -- to the server by the Put_Header service above. + + generic + with procedure + Action + (Key : String; + Value : String; + Position : Positive; + Quit : in out Boolean); + procedure For_Every_Cookie; + -- Iterate through all cookies received from the server and call + -- the Action supplied procedure. The Key, Value parameters are set + -- appropriately, Position is the cookie order in the list, Quit is set to + -- True by default. Quit can be set to False to control the iterator + -- termination. + +end GNAT.CGI.Cookie; diff --git a/gcc/ada/g-cgideb.adb b/gcc/ada/g-cgideb.adb new file mode 100644 index 00000000000..fb4ad490b27 --- /dev/null +++ b/gcc/ada/g-cgideb.adb @@ -0,0 +1,332 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . D E B U G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded; + +package body GNAT.CGI.Debug is + + use Ada.Strings.Unbounded; + + -- + -- Define the abstract type which act as a template for all debug IO mode. + -- To create a new IO mode you must: + -- 1. create a new package spec + -- 2. create a new type derived from IO.Format + -- 3. implement all the abstract rountines in IO + -- + + package IO is + + type Format is abstract tagged null record; + + function Output (Mode : in Format'Class) return String; + + function Variable + (Mode : Format; + Name : String; + Value : String) + return String + is abstract; + -- Returns variable Name and its associated value. + + function New_Line + (Mode : Format) + return String + is abstract; + -- Returns a new line such as this concatenated between two strings + -- will display the strings on two lines. + + function Title + (Mode : Format; + Str : String) + return String + is abstract; + -- Returns Str as a Title. A title must be alone and centered on a + -- line. Next output will be on the following line. + + function Header + (Mode : Format; + Str : String) + return String + is abstract; + -- Returns Str as an Header. An header must be alone on its line. Next + -- output will be on the following line. + + end IO; + + -- + -- IO for HTML mode + -- + + package HTML_IO is + + -- see IO for comments about these routines. + + type Format is new IO.Format with null record; + + function Variable + (IO : Format; + Name : String; + Value : String) + return String; + + function New_Line (IO : in Format) return String; + + function Title (IO : in Format; Str : in String) return String; + + function Header (IO : in Format; Str : in String) return String; + + end HTML_IO; + + -- + -- IO for plain text mode + -- + + package Text_IO is + + -- See IO for comments about these routines + + type Format is new IO.Format with null record; + + function Variable + (IO : Format; + Name : String; + Value : String) + return String; + + function New_Line (IO : in Format) return String; + + function Title (IO : in Format; Str : in String) return String; + + function Header (IO : in Format; Str : in String) return String; + + end Text_IO; + + -------------- + -- Debug_IO -- + -------------- + + package body IO is + + ------------ + -- Output -- + ------------ + + function Output (Mode : in Format'Class) return String is + Result : Unbounded_String; + + begin + Result := Result + & Title (Mode, "CGI complete runtime environment"); + + Result := Result + & Header (Mode, "CGI parameters:") + & New_Line (Mode); + + for K in 1 .. Argument_Count loop + Result := Result + & Variable (Mode, Key (K), Value (K)) + & New_Line (Mode); + end loop; + + Result := Result + & New_Line (Mode) + & Header (Mode, "CGI environment variables (Metavariables):") + & New_Line (Mode); + + for P in Metavariable_Name'Range loop + if Metavariable_Exists (P) then + Result := Result + & Variable (Mode, + Metavariable_Name'Image (P), + Metavariable (P)) + & New_Line (Mode); + end if; + end loop; + + return To_String (Result); + end Output; + + end IO; + + ------------- + -- HTML_IO -- + ------------- + + package body HTML_IO is + + NL : constant String := (1 => ASCII.LF); + + function Bold (S : in String) return String; + -- Returns S as an HTML bold string. + + function Italic (S : in String) return String; + -- Returns S as an HTML italic string. + + ---------- + -- Bold -- + ---------- + + function Bold (S : in String) return String is + begin + return "<b>" & S & "</b>"; + end Bold; + + ------------ + -- Header -- + ------------ + + function Header (IO : in Format; Str : in String) return String is + begin + return "<h2>" & Str & "</h2>" & NL; + end Header; + + ------------ + -- Italic -- + ------------ + + function Italic (S : in String) return String is + begin + return "<i>" & S & "</i>"; + end Italic; + + -------------- + -- New_Line -- + -------------- + + function New_Line (IO : in Format) return String is + begin + return "<br>" & NL; + end New_Line; + + ----------- + -- Title -- + ----------- + + function Title (IO : in Format; Str : in String) return String is + begin + return "<p align=center><font size=+2>" & Str & "</font></p>" & NL; + end Title; + + -------------- + -- Variable -- + -------------- + + function Variable + (IO : Format; + Name : String; + Value : String) + return String + is + begin + return Bold (Name) & " = " & Italic (Value); + end Variable; + + end HTML_IO; + + ------------- + -- Text_IO -- + ------------- + + package body Text_IO is + + ------------ + -- Header -- + ------------ + + function Header (IO : in Format; Str : in String) return String is + begin + return "*** " & Str & New_Line (IO); + end Header; + + -------------- + -- New_Line -- + -------------- + + function New_Line (IO : in Format) return String is + begin + return String'(1 => ASCII.LF); + end New_Line; + + ----------- + -- Title -- + ----------- + + function Title (IO : in Format; Str : in String) return String is + Spaces : constant Natural := (80 - Str'Length) / 2; + Indent : constant String (1 .. Spaces) := (others => ' '); + + begin + return Indent & Str & New_Line (IO); + end Title; + + -------------- + -- Variable -- + -------------- + + function Variable + (IO : Format; + Name : String; + Value : String) + return String + is + begin + return " " & Name & " = " & Value; + end Variable; + + end Text_IO; + + ----------------- + -- HTML_Output -- + ----------------- + + function HTML_Output return String is + HTML : HTML_IO.Format; + + begin + return IO.Output (Mode => HTML); + end HTML_Output; + + ----------------- + -- Text_Output -- + ----------------- + + function Text_Output return String is + Text : Text_IO.Format; + + begin + return IO.Output (Mode => Text); + end Text_Output; + +end GNAT.CGI.Debug; diff --git a/gcc/ada/g-cgideb.ads b/gcc/ada/g-cgideb.ads new file mode 100644 index 00000000000..5c5c5e8f82c --- /dev/null +++ b/gcc/ada/g-cgideb.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . D E B U G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a package to help debugging CGI (Common Gateway Interface) +-- programs written in Ada. + +package GNAT.CGI.Debug is + + -- Both functions below output all possible CGI parameters set. These + -- are the form field and all CGI environment variables which make the + -- CGI environment at runtime. + + function Text_Output return String; + -- Returns a plain text version of the CGI runtime environment + + function HTML_Output return String; + -- Returns an HTML version of the CGI runtime environment + +end GNAT.CGI.Debug; diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb new file mode 100644 index 00000000000..f2ee9b8a054 --- /dev/null +++ b/gcc/ada/g-comlin.adb @@ -0,0 +1,612 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M M A N D _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1999-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Command_Line; + +package body GNAT.Command_Line is + + package CL renames Ada.Command_Line; + + type Section_Number is new Natural range 0 .. 65534; + for Section_Number'Size use 16; + + type Parameter_Type is + record + Arg_Num : Positive; + First : Positive; + Last : Positive; + end record; + The_Parameter : Parameter_Type; + The_Switch : Parameter_Type; + -- This type and this variable are provided to store the current switch + -- and parameter + + type Is_Switch_Type is array (1 .. CL.Argument_Count) of Boolean; + pragma Pack (Is_Switch_Type); + + Is_Switch : Is_Switch_Type := (others => False); + -- Indicates wich arguments on the command line are considered not be + -- switches or parameters to switches (this leaves e.g. the filenames...) + + type Section_Type is array (1 .. CL.Argument_Count + 1) of Section_Number; + pragma Pack (Section_Type); + Section : Section_Type := (others => 1); + -- Contains the number of the section associated with the current + -- switch. If this number is 0, then it is a section delimiter, which + -- is never returns by GetOpt. + -- The last element of this array is set to 0 to avoid the need to test for + -- if we have reached the end of the command line in loops. + + Current_Argument : Natural := 1; + -- Number of the current argument parsed on the command line + + Current_Index : Natural := 1; + -- Index in the current argument of the character to be processed + + Current_Section : Section_Number := 1; + + Expansion_It : aliased Expansion_Iterator; + -- When Get_Argument is expanding a file name, this is the iterator used + + In_Expansion : Boolean := False; + -- True if we are expanding a file + + Switch_Character : Character := '-'; + -- The character at the beginning of the command line arguments, + -- indicating the beginning of a switch + + Stop_At_First : Boolean := False; + -- If it is True then Getopt stops at the first non-switch argument + + procedure Set_Parameter + (Variable : out Parameter_Type; + Arg_Num : Positive; + First : Positive; + Last : Positive); + pragma Inline (Set_Parameter); + -- Set the parameter that will be returned by Parameter below + + function Goto_Next_Argument_In_Section return Boolean; + -- Go to the next argument on the command line. If we are at the end + -- of the current section, we want to make sure there is no other + -- identical section on the command line (there might be multiple + -- instances of -largs). + -- Return True if there as another argument, False otherwise + + --------------- + -- Expansion -- + --------------- + + function Expansion (Iterator : Expansion_Iterator) return String is + use GNAT.Directory_Operations; + type Pointer is access all Expansion_Iterator; + + S : String (1 .. 1024); + Last : Natural; + It : Pointer := Iterator'Unrestricted_Access; + + begin + loop + Read (It.Dir, S, Last); + + if Last = 0 then + Close (It.Dir); + return String'(1 .. 0 => ' '); + end if; + + if GNAT.Regexp.Match (S (1 .. Last), Iterator.Regexp) then + return S (1 .. Last); + end if; + + end loop; + + return String'(1 .. 0 => ' '); + end Expansion; + + ----------------- + -- Full_Switch -- + ----------------- + + function Full_Switch return String is + begin + return CL.Argument (The_Switch.Arg_Num) + (The_Switch.First .. The_Switch.Last); + end Full_Switch; + + ------------------ + -- Get_Argument -- + ------------------ + + function Get_Argument (Do_Expansion : Boolean := False) return String is + Total : constant Natural := CL.Argument_Count; + + begin + if In_Expansion then + declare + S : String := Expansion (Expansion_It); + begin + if S'Length /= 0 then + return S; + else + In_Expansion := False; + end if; + + end; + end if; + + if Current_Argument > Total then + + -- If this is the first time this function is called + + if Current_Index = 1 then + Current_Argument := 1; + while Current_Argument <= CL.Argument_Count + and then Section (Current_Argument) /= Current_Section + loop + Current_Argument := Current_Argument + 1; + end loop; + else + return String'(1 .. 0 => ' '); + end if; + + elsif Section (Current_Argument) = 0 then + while Current_Argument <= CL.Argument_Count + and then Section (Current_Argument) /= Current_Section + loop + Current_Argument := Current_Argument + 1; + end loop; + end if; + + Current_Index := 2; + + while Current_Argument <= Total + and then Is_Switch (Current_Argument) + loop + Current_Argument := Current_Argument + 1; + end loop; + + if Current_Argument > Total then + return String'(1 .. 0 => ' '); + end if; + + if Section (Current_Argument) = 0 then + return Get_Argument (Do_Expansion); + end if; + + Current_Argument := Current_Argument + 1; + + -- Could it be a file name with wild cards to expand ? + + if Do_Expansion then + declare + Arg : String renames CL.Argument (Current_Argument - 1); + Index : Positive := Arg'First; + + begin + while Index <= Arg'Last loop + + if Arg (Index) = '*' + or else Arg (Index) = '?' + or else Arg (Index) = '[' + then + In_Expansion := True; + Start_Expansion (Expansion_It, Arg); + return Get_Argument (Do_Expansion); + end if; + + Index := Index + 1; + end loop; + end; + end if; + + return CL.Argument (Current_Argument - 1); + end Get_Argument; + + ------------ + -- Getopt -- + ------------ + + function Getopt (Switches : String) return Character is + Dummy : Boolean; + + begin + -- If we have finished to parse the current command line item (there + -- might be multiple switches in a single item), then go to the next + -- element + + if Current_Argument > CL.Argument_Count + or else (Current_Index > CL.Argument (Current_Argument)'Last + and then not Goto_Next_Argument_In_Section) + then + return ASCII.NUL; + end if; + + -- If we are on a new item, test if this might be a switch + + if Current_Index = 1 then + if CL.Argument (Current_Argument)(1) /= Switch_Character then + if Switches (Switches'First) = '*' then + Set_Parameter (The_Switch, + Arg_Num => Current_Argument, + First => 1, + Last => CL.Argument (Current_Argument)'Last); + Is_Switch (Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section; + return '*'; + end if; + + if Stop_At_First then + Current_Argument := Positive'Last; + return ASCII.NUL; + + elsif not Goto_Next_Argument_In_Section then + return ASCII.NUL; + + else + return Getopt (Switches); + end if; + end if; + + Current_Index := 2; + Is_Switch (Current_Argument) := True; + end if; + + declare + Arg : String renames CL.Argument (Current_Argument); + Index_Switches : Natural := 0; + Max_Length : Natural := 0; + Index : Natural := Switches'First; + Length : Natural := 1; + End_Index : Natural; + + begin + while Index <= Switches'Last loop + + -- Search the length of the parameter at this position in Switches + + Length := Index; + while Length <= Switches'Last + and then Switches (Length) /= ' ' + loop + Length := Length + 1; + end loop; + + if (Switches (Length - 1) = ':' + or else Switches (Length - 1) = '?' + or else Switches (Length - 1) = '!') + and then Length > Index + 1 + then + Length := Length - 1; + end if; + + -- If it is the one we searched, it may be a candidate + + if Current_Index + Length - 1 - Index <= Arg'Last + and then + Switches (Index .. Length - 1) = + Arg (Current_Index .. Current_Index + Length - 1 - Index) + and then Length - Index > Max_Length + then + Index_Switches := Index; + Max_Length := Length - Index; + end if; + + -- Look for the next switch in Switches + while Index <= Switches'Last + and then Switches (Index) /= ' ' loop + Index := Index + 1; + end loop; + Index := Index + 1; + + end loop; + + End_Index := Current_Index + Max_Length - 1; + + -- If the switch is not accepted, skip it, unless we had a '*' in + -- Switches + + if Index_Switches = 0 then + if Switches (Switches'First) = '*' then + Set_Parameter (The_Switch, + Arg_Num => Current_Argument, + First => 1, + Last => CL.Argument (Current_Argument)'Last); + Is_Switch (Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section; + return '*'; + end if; + + Set_Parameter (The_Switch, + Arg_Num => Current_Argument, + First => Current_Index, + Last => Current_Index); + Current_Index := Current_Index + 1; + raise Invalid_Switch; + end if; + + Set_Parameter (The_Switch, + Arg_Num => Current_Argument, + First => Current_Index, + Last => End_Index); + + -- If switch needs an argument + + if Index_Switches + Max_Length <= Switches'Last then + + case Switches (Index_Switches + Max_Length) is + + when ':' => + + if End_Index < Arg'Last then + Set_Parameter (The_Parameter, + Arg_Num => Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section; + + elsif Section (Current_Argument + 1) /= 0 then + Set_Parameter + (The_Parameter, + Arg_Num => Current_Argument + 1, + First => 1, + Last => CL.Argument (Current_Argument + 1)'Last); + Current_Argument := Current_Argument + 1; + Is_Switch (Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section; + + else + Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when '!' => + + if End_Index < Arg'Last then + Set_Parameter (The_Parameter, + Arg_Num => Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section; + + else + Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when '?' => + + if End_Index < Arg'Last then + Set_Parameter (The_Parameter, + Arg_Num => Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + + else + Set_Parameter (The_Parameter, + Arg_Num => Current_Argument, + First => 2, + Last => 1); + end if; + Dummy := Goto_Next_Argument_In_Section; + + when others => + + Current_Index := End_Index + 1; + + end case; + else + Current_Index := End_Index + 1; + end if; + + return Switches (Index_Switches); + end; + end Getopt; + + ----------------------------------- + -- Goto_Next_Argument_In_Section -- + ----------------------------------- + + function Goto_Next_Argument_In_Section return Boolean is + begin + Current_Index := 1; + Current_Argument := Current_Argument + 1; + + if Section (Current_Argument) = 0 then + loop + if Current_Argument > CL.Argument_Count then + return False; + end if; + Current_Argument := Current_Argument + 1; + exit when Section (Current_Argument) = Current_Section; + end loop; + end if; + return True; + end Goto_Next_Argument_In_Section; + + ------------------ + -- Goto_Section -- + ------------------ + + procedure Goto_Section (Name : String := "") is + Index : Integer := 1; + + begin + In_Expansion := False; + + if Name = "" then + Current_Argument := 1; + Current_Index := 1; + Current_Section := 1; + return; + end if; + + while Index <= CL.Argument_Count loop + + if Section (Index) = 0 + and then CL.Argument (Index) = Switch_Character & Name + then + Current_Argument := Index + 1; + Current_Index := 1; + if Current_Argument <= CL.Argument_Count then + Current_Section := Section (Current_Argument); + end if; + return; + end if; + + Index := Index + 1; + end loop; + Current_Argument := Positive'Last; + Current_Index := 2; -- so that Get_Argument returns nothing + end Goto_Section; + + ---------------------------- + -- Initialize_Option_Scan -- + ---------------------------- + + procedure Initialize_Option_Scan + (Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := "") + is + Section_Num : Section_Number := 1; + Section_Index : Integer := Section_Delimiters'First; + Last : Integer; + Delimiter_Found : Boolean; + + begin + Current_Argument := 0; + Current_Index := 0; + In_Expansion := False; + Switch_Character := Switch_Char; + Stop_At_First := Stop_At_First_Non_Switch; + + -- If we are using sections, we have to preprocess the command line + -- to delimit them. A section can be repeated, so we just give each + -- item on the command line a section number + + while Section_Index <= Section_Delimiters'Last loop + + Last := Section_Index; + while Last <= Section_Delimiters'Last + and then Section_Delimiters (Last) /= ' ' + loop + Last := Last + 1; + end loop; + + Delimiter_Found := False; + Section_Num := Section_Num + 1; + + for Index in 1 .. CL.Argument_Count loop + if CL.Argument (Index)(1) = Switch_Character + and then CL.Argument (Index) = Switch_Character + & Section_Delimiters (Section_Index .. Last - 1) + then + Section (Index) := 0; + Delimiter_Found := True; + + elsif Section (Index) = 0 then + Delimiter_Found := False; + + elsif Delimiter_Found then + Section (Index) := Section_Num; + end if; + end loop; + + Section_Index := Last + 1; + while Section_Index <= Section_Delimiters'Last + and then Section_Delimiters (Section_Index) = ' ' + loop + Section_Index := Section_Index + 1; + end loop; + end loop; + + Delimiter_Found := Goto_Next_Argument_In_Section; + end Initialize_Option_Scan; + + --------------- + -- Parameter -- + --------------- + + function Parameter return String is + begin + if The_Parameter.First > The_Parameter.Last then + return String'(1 .. 0 => ' '); + else + return CL.Argument (The_Parameter.Arg_Num) + (The_Parameter.First .. The_Parameter.Last); + end if; + end Parameter; + + ------------------- + -- Set_Parameter -- + ------------------- + + procedure Set_Parameter + (Variable : out Parameter_Type; + Arg_Num : Positive; + First : Positive; + Last : Positive) is + begin + Variable.Arg_Num := Arg_Num; + Variable.First := First; + Variable.Last := Last; + end Set_Parameter; + + --------------------- + -- Start_Expansion -- + --------------------- + + procedure Start_Expansion + (Iterator : out Expansion_Iterator; + Pattern : String; + Directory : String := ""; + Basic_Regexp : Boolean := True) + is + Directory_Separator : Character; + pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + + begin + if Directory = "" then + GNAT.Directory_Operations.Open + (Iterator.Dir, "." & Directory_Separator); + else + GNAT.Directory_Operations.Open (Iterator.Dir, Directory); + end if; + + Iterator.Regexp := GNAT.Regexp.Compile (Pattern, Basic_Regexp, True); + end Start_Expansion; + +begin + Section (CL.Argument_Count + 1) := 0; +end GNAT.Command_Line; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads new file mode 100644 index 00000000000..dedaefe8819 --- /dev/null +++ b/gcc/ada/g-comlin.ads @@ -0,0 +1,272 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M M A N D _ L I N E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.24 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- High level package for command line parsing + +-- This package provides an interface to Ada.Command_Line, to do the +-- parsing of command line arguments. Here is a small usage example: +-- +-- begin +-- loop +-- case Getopt ("a b: ad") is -- Accepts '-a', '-ad', or '-b argument' +-- when ASCII.NUL => exit; +-- +-- when 'a' => +-- if Full_Switch = "a" then +-- Put_Line ("Got a"); +-- else +-- Put_Line ("Got ad"); +-- end if; +-- +-- when 'b' => +-- Put_Line ("Got b + " & Parameter); +-- +-- when others => +-- raise Program_Error; -- cannot occur! +-- end case; +-- end loop; +-- +-- loop +-- declare +-- S : constant String := Get_Argument (Do_Expansion => True); + +-- begin +-- exit when S'Length = 0; +-- Put_Line ("Got " & S); +-- end; +-- end loop; +-- +-- exception +-- when Invalid_Switch => Put_Line ("Invalid Switch " & Full_Switch); +-- when Invalid_Parameter => Put_Line ("No parameter for " & Full_Switch); +-- end; +-- +-- A more complicated example would involve the use of sections for the +-- switches, as for instance in gnatmake. These sections are separated by +-- special switches, chosen by the programer. Each section act as a +-- command line of its own. +-- +-- begin +-- Initialize_Option_Scan ('-', False, "largs bargs cargs"); +-- loop +-- -- same loop as above to get switches and arguments +-- end loop; +-- +-- Goto_Section ("bargs"); +-- loop +-- -- same loop as above to get switches and arguments +-- -- The supports switches in Get_Opt might be different +-- end loop; +-- +-- Goto_Section ("cargs"); +-- loop +-- -- same loop as above to get switches and arguments +-- -- The supports switches in Get_Opt might be different +-- end loop; +-- end; + + +with GNAT.Directory_Operations; +with GNAT.Regexp; + +package GNAT.Command_Line is + + procedure Initialize_Option_Scan + (Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := ""); + -- This procedure resets the internal state of the package to prepare + -- to rescan the parameters. It need not (but may be) called before the + -- first use of Getopt, but it must be called if you want to start + -- rescanning the command line parameters from the start. The optional + -- parameter Switch_Char can be used to reset the switch character, + -- e.g. to '/' for use in DOS-like systems. The optional parameter + -- Stop_At_First_Non_Switch indicates if Getopt is to look for switches + -- on the whole command line, or if it has to stop as soon as a + -- non-switch argument is found. + -- + -- Example: + -- + -- Arguments: my_application file1 -c + -- + -- if Stop_At_First_Non_Switch is False, then -c will be considered + -- as a switch (returned by getopt), otherwise it will be considered + -- as a normal argument (returned by Get_Argument). + -- + -- if SECTION_DELIMITERS is set, then every following subprogram + -- (Getopt and Get_Argument) will only operate within a section, which + -- is delimited by any of these delimiters or the end of the command line. + -- + -- Example: + -- Initialize_Option_Scan ("largs bargs cargs"); + -- + -- Arguments on command line : my_application -c -bargs -d -e -largs -f + -- This line is made of three section, the first one is the default one + -- and includes only the '-c' switch, the second one is between -bargs + -- and -largs and includes '-d -e' and the last one includes '-f' + + procedure Goto_Section (Name : String := ""); + -- Change the current section. The next Getopt of Get_Argument will + -- start looking at the beginning of the section. An empty name ("") + -- refers to the first section between the program name and the first + -- section delimiter. + -- If the section does not exist, then Invalid_Section is raised. + + function Full_Switch return String; + -- Returns the full name of the last switch found (Getopt only returns + -- the first character) + + function Getopt (Switches : String) return Character; + -- This function moves to the next switch on the command line (defined + -- as a switch character followed by a character within Switches, + -- casing being significant). The result returned is the first + -- character of the particular switch located. If there are no more + -- switches in the current section, returns ASCII.NUL. The switches + -- need not be separated by spaces (they can be concatenated if they do + -- not require an argument, e.g. -ab is the same as two separate + -- arguments -a -b). + -- + -- Switches is a string of all the possible switches, separated by a + -- space. A switch can be followed by one of the following characters : + -- + -- ':' The switch requires a parameter. There can optionally be a space + -- on the command line between the switch and its parameter + -- '!' The switch requires a parameter, but there can be no space on the + -- command line between the switch and its parameter + -- '?' The switch may have an optional parameter. There can no space + -- between the switch and its argument + -- ex/ if Switches has the following value : "a? b" + -- The command line can be : + -- -afoo : -a switch with 'foo' parameter + -- -a foo : -a switch and another element on the + -- command line 'foo', returned by Get_Argument + -- + -- Example: if Switches is "-a: -aO:", you can have the following + -- command lines : + -- -aarg : 'a' switch with 'arg' parameter + -- -a arg : 'a' switch with 'arg' parameter + -- -aOarg : 'aO' switch with 'arg' parameter + -- -aO arg : 'aO' switch with 'arg' parameter + -- + -- Example: + -- + -- Getopt ("a b: ac ad?") + -- + -- accept either 'a' or 'ac' with no argument, + -- accept 'b' with a required argument + -- accept 'ad' with an optional argument + -- + -- If the first item in switches is '*', then Getopt will catch + -- every element on the command line that was not caught by any other + -- switch. The character returned by GetOpt is '*' + -- + -- Example + -- Getopt ("* a b") + -- If the command line is '-a -c toto.o -b', GetOpt will return + -- successively 'a', '*', '*' and 'b'. When '*' is returnd, + -- Full_Switch returns the corresponding item on the command line. + -- + -- + -- When Getopt encounters an invalid switch, it raises the exception + -- Invalid_Switch and sets Full_Switch to return the invalid switch. + -- When Getopt can not find the parameter associated with a switch, it + -- raises Invalid_Parameter, and sets Full_Switch to return the invalid + -- switch character. + -- + -- Note: in case of ambiguity, e.g. switches a ab abc, then the longest + -- matching switch is returned. + -- + -- Arbitrary characters are allowed for switches, although it is + -- strongly recommanded to use only letters and digits for portability + -- reasons. + + function Get_Argument (Do_Expansion : Boolean := False) return String; + -- Returns the next element in the command line which is not a switch. + -- This function should not be called before Getopt has returned + -- ASCII.NUL. + -- + -- If Expansion is True, then the parameter on the command + -- line will considered as filename with wild cards, and will be + -- expanded. The matching file names will be returned one at a time. + -- When there are no more arguments on the command line, this function + -- returns an empty string. This is useful in non-Unix systems for + -- obtaining normal expansion of wild card references. + + function Parameter return String; + -- Returns parameter associated with the last switch returned by Getopt. + -- If no parameter was associated with the last switch, or no previous + -- call has been made to Get_Argument, raises Invalid_Parameter. + -- If the last switch was associated with an optionnal argument and this + -- argument was not found on the command line, Parameter returns an empty + -- string + + type Expansion_Iterator is limited private; + -- Type used during expansion of file names + + procedure Start_Expansion + (Iterator : out Expansion_Iterator; + Pattern : String; + Directory : String := ""; + Basic_Regexp : Boolean := True); + -- Initialize an wild card expansion. The next calls to Expansion will + -- return the next file name in Directory which match Pattern (Pattern + -- is a regular expression, using only the Unix shell and DOS syntax if + -- Basic_Regexp is True. When Directory is an empty string, the current + -- directory is searched. + + function Expansion (Iterator : Expansion_Iterator) return String; + -- Return the next file in the directory matching the parameters given + -- to Start_Expansion and updates Iterator to point to the next entry. + -- Returns an empty string when there are no more files in the directory. + -- If Expansion is called again after an empty string has been returned, + -- then the exception GNAT.Directory_Operations.Directory_Error is raised. + + Invalid_Section : exception; + -- Raised when an invalid section is selected by Goto_Section + + Invalid_Switch : exception; + -- Raised when an invalid switch is detected in the command line + + Invalid_Parameter : exception; + -- Raised when a parameter is missing, or an attempt is made to obtain + -- a parameter for a switch that does not allow a parameter + +private + + type Expansion_Iterator is limited record + Dir : GNAT.Directory_Operations.Dir_Type; + Regexp : GNAT.Regexp.Regexp; + end record; + +end GNAT.Command_Line; diff --git a/gcc/ada/g-curexc.ads b/gcc/ada/g-curexc.ads new file mode 100644 index 00000000000..712da9640e5 --- /dev/null +++ b/gcc/ada/g-curexc.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . C U R R E N T _ E X C E P T I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1996-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines for obtaining the current exception +-- information in Ada 83 style. In Ada 83, there was no official method +-- for obtaining exception information, but a number of vendors supplied +-- routines for this purpose, and this package closely approximates the +-- interfaces supplied by DEC Ada 83 and VADS Ada. + +-- The routines in this package are associated with a particular exception +-- handler, and can only be called from within an exception handler. See +-- also the package GNAT.Most_Recent_Exception, which provides access to +-- the most recently raised exception, and is not limited to static calls +-- from an exception handler. + +package GNAT.Current_Exception is +pragma Pure (Current_Exception); + + ----------------- + -- Subprograms -- + ----------------- + + function Exception_Information return String; + -- Returns the result of calling Ada.Exceptions.Exception_Information + -- with an argument that is the Exception_Occurrence corresponding to + -- the current exception. Returns the null string if called from outside + -- an exception handler. + + function Exception_Message return String; + -- Returns the result of calling Ada.Exceptions.Exception_Message with + -- an argument that is the Exception_Occurrence corresponding to the + -- current exception. Returns the null string if called from outside an + -- exception handler. + + function Exception_Name return String; + -- Returns the result of calling Ada.Exceptions.Exception_Name with + -- an argument that is the Exception_Occurrence corresponding to the + -- current exception. Returns the null string if called from outside + -- an exception handler. + + -- Note: all these functions return useful information only if + -- called statically from within an exception handler, and they + -- return information about the exception corresponding to the + -- handler in which they appear. This is NOT the same as the most + -- recently raised exception. Consider the example: + + -- exception + -- when Constraint_Error => + -- begin + -- ... + -- exception + -- when Tasking_Error => ... + -- end; + -- + -- -- Exception_xxx at this point returns the information about + -- -- the constraint error, not about any exception raised within + -- -- the nested block since it is the static nesting that counts. + + ----------------------------------- + -- Use of Library Level Renaming -- + ----------------------------------- + + -- For greater compatibility with existing legacy software, library + -- level renaming may be used to create a function with a name matching + -- one that is in use. For example, some versions of VADS Ada provided + -- a functin called Current_Exception whose semantics was identical to + -- that of GNAT. The following library level renaming declaration: + + -- with GNAT.Current_Exception; + -- function Current_Exception + -- renames GNAT.Current_Exception.Exception_Name; + + -- placed in a file called current_exception.ads and compiled into the + -- application compilation environment, will make the function available + -- in a manner exactly compatible with that in VADS Ada 83. + +private + pragma Import (Intrinsic, Exception_Information); + pragma Import (intrinsic, Exception_Message); + pragma Import (Intrinsic, Exception_Name); + +end GNAT.Current_Exception; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb new file mode 100644 index 00000000000..d3d2e7468f8 --- /dev/null +++ b/gcc/ada/g-debpoo.adb @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D E B U G _ P O O L S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Unchecked_Conversion; +with GNAT.HTable; +with System.Memory; + +pragma Elaborate_All (GNAT.HTable); + +package body GNAT.Debug_Pools is + use System; + use System.Memory; + use System.Storage_Elements; + + -- Definition of a H-table storing the status of each storage chunck + -- used by this pool + + type State is (Not_Allocated, Deallocated, Allocated); + + type Header is range 1 .. 1023; + function H (F : Address) return Header; + + package Table is new GNAT.HTable.Simple_HTable ( + Header_Num => Header, + Element => State, + No_Element => Not_Allocated, + Key => Address, + Hash => H, + Equal => "="); + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Debug_Pool; + Storage_Address : out Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) is + begin + Storage_Address := Alloc (size_t (Size_In_Storage_Elements)); + + if Storage_Address = Null_Address then + raise Storage_Error; + else + Table.Set (Storage_Address, Allocated); + Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements; + + if Pool.Allocated - Pool.Deallocated > Pool.High_Water then + Pool.High_Water := Pool.Allocated - Pool.Deallocated; + end if; + end if; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + procedure Free (Address : System.Address; Siz : Storage_Count); + -- Faked free, that reset all the deallocated storage to "DEADBEEF" + + procedure Free (Address : System.Address; Siz : Storage_Count) is + DB1 : constant Integer := 16#DEAD#; + DB2 : constant Integer := 16#BEEF#; + + type Dead_Memory is array (1 .. Siz / 4) of Integer; + type Mem_Ptr is access all Dead_Memory; + + function From_Ptr is + new Unchecked_Conversion (System.Address, Mem_Ptr); + + J : Storage_Offset; + + begin + J := Dead_Memory'First; + while J < Dead_Memory'Last loop + From_Ptr (Address) (J) := DB1; + From_Ptr (Address) (J + 1) := DB2; + J := J + 2; + end loop; + + if J = Dead_Memory'Last then + From_Ptr (Address) (J) := DB1; + end if; + end Free; + + S : State := Table.Get (Storage_Address); + + -- Start of processing for Deallocate + + begin + case S is + when Not_Allocated => + raise Freeing_Not_Allocated_Storage; + + when Deallocated => + raise Freeing_Deallocated_Storage; + + when Allocated => + Free (Storage_Address, Size_In_Storage_Elements); + Table.Set (Storage_Address, Deallocated); + Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements; + end case; + end Deallocate; + + ----------------- + -- Dereference -- + ----------------- + + procedure Dereference + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + S : State := Table.Get (Storage_Address); + Max_Dim : constant := 3; + Dim : Integer := 1; + + begin + + -- If this is not a known address, maybe it is because is is an + -- unconstained array. In which case, the bounds have used the + -- 2 first words (per dimension) of the allocated spot. + + while S = Not_Allocated and then Dim <= Max_Dim loop + S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4)); + Dim := Dim + 1; + end loop; + + case S is + when Not_Allocated => + raise Accessing_Not_Allocated_Storage; + + when Deallocated => + raise Accessing_Deallocated_Storage; + + when Allocated => + null; + end case; + end Dereference; + + ------- + -- H -- + ------- + + function H (F : Address) return Header is + begin + return + Header (1 + (To_Integer (F) mod Integer_Address (Header'Last))); + end H; + + ---------------- + -- Print_Info -- + ---------------- + + procedure Print_Info (Pool : Debug_Pool) is + use System.Storage_Elements; + + begin + Put_Line ("Debug Pool info:"); + Put_Line (" Total allocated bytes : " + & Storage_Offset'Image (Pool.Allocated)); + + Put_Line (" Total deallocated bytes : " + & Storage_Offset'Image (Pool.Deallocated)); + + Put_Line (" Current Water Mark: " + & Storage_Offset'Image (Pool.Allocated - Pool.Deallocated)); + + Put_Line (" High Water Mark: " + & Storage_Offset'Image (Pool.High_Water)); + Put_Line (""); + end Print_Info; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size (Pool : Debug_Pool) return Storage_Count is + begin + return Storage_Count'Last; + end Storage_Size; + +end GNAT.Debug_Pools; diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads new file mode 100644 index 00000000000..bd61e77768c --- /dev/null +++ b/gcc/ada/g-debpoo.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D E B U G _ P O O L S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; +with System.Checked_Pools; + +package GNAT.Debug_Pools is + + -- The debug pool is used to track down memory corruption due to use of + -- deallocated memory or incorrect unchecked conversions. Allocation + -- strategy : + + -- - allocation: . memory is normally allocated with malloc + -- . the allocated address is noted in a table + + -- - deallocation: . memory is filled with "DEAD_BEEF" patterns + -- . memory is not freed + -- . exceptions are raised if the memory was not + -- allocated or was already deallocated + + -- - dereference: . exceptions are raised if the memory was not + -- allocated or was already deallocated + + Accessing_Not_Allocated_Storage : exception; + Accessing_Deallocated_Storage : exception; + Freeing_Not_Allocated_Storage : exception; + Freeing_Deallocated_Storage : exception; + + type Debug_Pool is + new System.Checked_Pools.Checked_Pool with private; + + procedure Allocate + (Pool : in out Debug_Pool; + Storage_Address : out Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count); + + procedure Deallocate + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count); + + function Storage_Size + (Pool : Debug_Pool) + return System.Storage_Elements.Storage_Count; + + procedure Dereference + (Pool : in out Debug_Pool; + Storage_Address : System.Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count); + + generic + with procedure Put_Line (S : String); + procedure Print_Info (Pool : Debug_Pool); + -- Print out information about the High Water Mark, the current and + -- total number of bytes allocated and the total number of bytes + -- deallocated. + +private + type Debug_Pool is new System.Checked_Pools.Checked_Pool with record + Allocated : Storage_Count := 0; + -- Total number of bytes allocated in this pool + + Deallocated : Storage_Count := 0; + -- Total number of bytes deallocated in this pool + + High_Water : Storage_Count := 0; + -- Maximum of during the time of Allocated - Deallocated + end record; +end GNAT.Debug_Pools; diff --git a/gcc/ada/g-debuti.adb b/gcc/ada/g-debuti.adb new file mode 100644 index 00000000000..f92cffa4792 --- /dev/null +++ b/gcc/ada/g-debuti.adb @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . D E B U G _ U T I L I T I E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1997-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +package body GNAT.Debug_Utilities is + + -------------------------- + -- Image (address case) -- + -------------------------- + + function Image (A : Address) return String is + S : String (1 .. Address_Image_Length); + P : Natural := S'Last - 1; + N : Integer_Address := To_Integer (A); + U : Natural := 0; + + H : array (Integer range 0 .. 15) of Character := "0123456789ABCDEF"; + + begin + S (S'Last) := '#'; + + while P > 3 loop + if U = 4 then + S (P) := '_'; + P := P - 1; + U := 1; + + else + U := U + 1; + end if; + + S (P) := H (Integer (N mod 16)); + P := P - 1; + N := N / 16; + end loop; + + S (1 .. 3) := "16#"; + return S; + end Image; + + ------------------------- + -- Image (string case) -- + ------------------------- + + function Image (S : String) return String is + W : String (1 .. 2 * S'Length + 2); + P : Positive := 1; + + begin + W (1) := '"'; + + for J in S'Range loop + if S (J) = '"' then + P := P + 1; + W (P) := '"'; + end if; + + P := P + 1; + W (P) := S (J); + end loop; + + P := P + 1; + W (P) := '"'; + return W (1 .. P); + end Image; + + ----------- + -- Value -- + ----------- + + function Value (S : String) return System.Address is + N : constant Integer_Address := Integer_Address'Value (S); + + begin + return To_Address (N); + end Value; + +end GNAT.Debug_Utilities; diff --git a/gcc/ada/g-debuti.ads b/gcc/ada/g-debuti.ads new file mode 100644 index 00000000000..4a3d862faa1 --- /dev/null +++ b/gcc/ada/g-debuti.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . D E B U G _ U T I L I T I E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1995-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Debugging utilities + +-- This package provides some useful utility subprograms for use in writing +-- routines that generate debugging output. + +with System; + +package GNAT.Debug_Utilities is +pragma Pure (Debug_Utilities); + + function Image (S : String) return String; + -- Returns a string image of S, obtained by prepending and appending + -- quote (") characters and doubling any quote characters in the string. + -- The maximum length of the result is thus 2 ** S'Length + 2. + + Address_Image_Length : constant := + 13 + 10 * Boolean'Pos (Standard'Address_Size > 32); + -- Length of string returned by Image function + + function Image (A : System.Address) return String; + -- Returns a string of the form 16#xxxx_xxxx# for 32-bit addresses + -- or 16#xxxx_xxxx_xxxx_xxxx# for 64-bit addresses. Hex characters + -- are in upper case. + + function Value (S : String) return System.Address; + -- Given a valid integer literal in any form, including the form returned + -- by the Image function in this package, yields the corresponding address. + +end GNAT.Debug_Utilities; diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb new file mode 100644 index 00000000000..d73d9a02005 --- /dev/null +++ b/gcc/ada/g-dirope.adb @@ -0,0 +1,981 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; +with Ada.Strings.Fixed; +with Ada.Strings.Unbounded; +with Ada.Strings.Maps; +with Unchecked_Deallocation; +with Unchecked_Conversion; +with System; use System; + +with GNAT.Regexp; +with GNAT.OS_Lib; + +package body GNAT.Directory_Operations is + + use Ada; + + type Dir_Type_Value is new System.Address; + -- This is the low-level address directory structure as returned by the C + -- opendir routine. + + Dir_Seps : constant Strings.Maps.Character_Set := + Strings.Maps.To_Set ("/\"); + -- UNIX and DOS style directory separators. + + procedure Free is new + Unchecked_Deallocation (Dir_Type_Value, Dir_Type); + + --------------- + -- Base_Name -- + --------------- + + function Base_Name + (Path : Path_Name; + Suffix : String := "") + return String + is + function Get_File_Names_Case_Sensitive return Integer; + pragma Import + (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + Case_Sensitive_File_Name : constant Boolean := + Get_File_Names_Case_Sensitive = 1; + + function Basename + (Path : Path_Name; + Suffix : String := "") + return String; + -- This function does the job. The only difference between Basename + -- and Base_Name (the parent function) is that the former is case + -- sensitive, while the latter is not. Path and Suffix are adjusted + -- appropriately before calling Basename under platforms where the + -- file system is not case sensitive. + + -------------- + -- Basename -- + -------------- + + function Basename + (Path : Path_Name; + Suffix : String := "") + return String + is + Cut_Start : Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + Cut_End : Natural; + + begin + -- Cut_Start point to the first basename character + + if Cut_Start = 0 then + Cut_Start := Path'First; + + else + Cut_Start := Cut_Start + 1; + end if; + + -- Cut_End point to the last basename character. + + Cut_End := Path'Last; + + -- If basename ends with Suffix, adjust Cut_End. + + if Suffix /= "" + and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix + then + Cut_End := Path'Last - Suffix'Length; + end if; + + Check_For_Standard_Dirs : declare + BN : constant String := Base_Name.Path (Cut_Start .. Cut_End); + + begin + if BN = "." or else BN = ".." then + return ""; + + elsif BN'Length > 2 + and then Characters.Handling.Is_Letter (BN (BN'First)) + and then BN (BN'First + 1) = ':' + then + -- We have a DOS drive letter prefix, remove it + + return BN (BN'First + 2 .. BN'Last); + + else + return BN; + end if; + end Check_For_Standard_Dirs; + end Basename; + + -- Start processing for Base_Name + + begin + if Case_Sensitive_File_Name then + return Basename (Path, Suffix); + + else + return Basename + (Characters.Handling.To_Lower (Path), + Characters.Handling.To_Lower (Suffix)); + end if; + end Base_Name; + + ---------------- + -- Change_Dir -- + ---------------- + + procedure Change_Dir (Dir_Name : Dir_Name_Str) is + C_Dir_Name : String := Dir_Name & ASCII.NUL; + + function chdir (Dir_Name : String) return Integer; + pragma Import (C, chdir, "chdir"); + + begin + if chdir (C_Dir_Name) /= 0 then + raise Directory_Error; + end if; + end Change_Dir; + + ----------- + -- Close -- + ----------- + + procedure Close (Dir : in out Dir_Type) is + + function closedir (Directory : System.Address) return Integer; + pragma Import (C, closedir, "closedir"); + + Discard : Integer; + + begin + if not Is_Open (Dir) then + raise Directory_Error; + end if; + + Discard := closedir (System.Address (Dir.all)); + Free (Dir); + end Close; + + -------------- + -- Dir_Name -- + -------------- + + function Dir_Name (Path : Path_Name) return Dir_Name_Str is + Last_DS : constant Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + + begin + if Last_DS = 0 then + + -- There is no directory separator, returns current working directory + + return "." & Dir_Separator; + + else + return Path (Path'First .. Last_DS); + end if; + end Dir_Name; + + ----------------- + -- Expand_Path -- + ----------------- + + function Expand_Path (Path : Path_Name) return String is + use Ada.Strings.Unbounded; + + procedure Read (K : in out Positive); + -- Update Result while reading current Path starting at position K. If + -- a variable is found, call Var below. + + procedure Var (K : in out Positive); + -- Translate variable name starting at position K with the associated + -- environement value. + + procedure Free is + new Unchecked_Deallocation (String, OS_Lib.String_Access); + + Result : Unbounded_String; + + ---------- + -- Read -- + ---------- + + procedure Read (K : in out Positive) is + begin + For_All_Characters : loop + if Path (K) = '$' then + + -- Could be a variable + + if K < Path'Last then + + if Path (K + 1) = '$' then + + -- Not a variable after all, this is a double $, just + -- insert one in the result string. + + Append (Result, '$'); + K := K + 1; + + else + -- Let's parse the variable + + K := K + 1; + Var (K); + end if; + + else + -- We have an ending $ sign + + Append (Result, '$'); + end if; + + else + -- This is a standard character, just add it to the result + + Append (Result, Path (K)); + end if; + + -- Skip to next character + + K := K + 1; + + exit For_All_Characters when K > Path'Last; + end loop For_All_Characters; + end Read; + + --------- + -- Var -- + --------- + + procedure Var (K : in out Positive) is + E : Positive; + + begin + if Path (K) = '{' then + + -- Look for closing } (curly bracket). + + E := K; + + loop + E := E + 1; + exit when Path (E) = '}' or else E = Path'Last; + end loop; + + if Path (E) = '}' then + + -- OK found, translate with environement value + + declare + Env : OS_Lib.String_Access := + OS_Lib.Getenv (Path (K + 1 .. E - 1)); + + begin + Append (Result, Env.all); + Free (Env); + end; + + else + -- No closing curly bracket, not a variable after all or a + -- syntax error, ignore it, insert string as-is. + + Append (Result, '$' & Path (K .. E)); + end if; + + else + -- The variable name is everything from current position to first + -- non letter/digit character. + + E := K; + + -- Check that first chartacter is a letter + + if Characters.Handling.Is_Letter (Path (E)) then + E := E + 1; + + Var_Name : loop + exit Var_Name when E = Path'Last; + + if Characters.Handling.Is_Letter (Path (E)) + or else Characters.Handling.Is_Digit (Path (E)) + then + E := E + 1; + else + E := E - 1; + exit Var_Name; + end if; + end loop Var_Name; + + declare + Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E)); + + begin + Append (Result, Env.all); + Free (Env); + end; + + else + -- This is not a variable after all + + Append (Result, '$' & Path (E)); + end if; + + end if; + + K := E; + end Var; + + -- Start of processing for Expand_Path + + begin + declare + K : Positive := Path'First; + + begin + Read (K); + return To_String (Result); + end; + end Expand_Path; + + -------------------- + -- File_Extension -- + -------------------- + + function File_Extension (Path : Path_Name) return String is + First : Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + + Dot : Natural; + + begin + if First = 0 then + First := Path'First; + end if; + + Dot := Strings.Fixed.Index (Path (First .. Path'Last), + ".", + Going => Strings.Backward); + + if Dot = 0 or else Dot = Path'Last then + return ""; + else + return Path (Dot .. Path'Last); + end if; + end File_Extension; + + --------------- + -- File_Name -- + --------------- + + function File_Name (Path : Path_Name) return String is + begin + return Base_Name (Path); + end File_Name; + + ---------- + -- Find -- + ---------- + + procedure Find + (Root_Directory : Dir_Name_Str; + File_Pattern : String) + is + File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern); + Index : Natural := 0; + + procedure Read_Directory (Directory : Dir_Name_Str); + -- Open Directory and read all entries. This routine is called + -- recursively for each sub-directories. + + function Make_Pathname (Dir, File : String) return String; + -- Returns the pathname for File by adding Dir as prefix. + + ------------------- + -- Make_Pathname -- + ------------------- + + function Make_Pathname (Dir, File : String) return String is + begin + if Dir (Dir'Last) = '/' or else Dir (Dir'Last) = '\' then + return Dir & File; + else + return Dir & Dir_Separator & File; + end if; + end Make_Pathname; + + -------------------- + -- Read_Directory -- + -------------------- + + procedure Read_Directory (Directory : Dir_Name_Str) is + Dir : Dir_Type; + Buffer : String (1 .. 2_048); + Last : Natural; + Quit : Boolean; + + begin + Open (Dir, Directory); + + loop + Read (Dir, Buffer, Last); + exit when Last = 0; + + declare + Dir_Entry : constant String := Buffer (1 .. Last); + Pathname : constant String + := Make_Pathname (Directory, Dir_Entry); + begin + if Regexp.Match (Dir_Entry, File_Regexp) then + Quit := False; + Index := Index + 1; + + begin + Action (Pathname, Index, Quit); + exception + when others => + Close (Dir); + raise; + end; + + exit when Quit; + end if; + + -- Recursively call for sub-directories, except for . and .. + + if not (Dir_Entry = "." or else Dir_Entry = "..") + and then OS_Lib.Is_Directory (Pathname) + then + Read_Directory (Pathname); + end if; + end; + end loop; + + Close (Dir); + end Read_Directory; + + begin + Read_Directory (Root_Directory); + end Find; + + --------------------- + -- Get_Current_Dir -- + --------------------- + + Max_Path : Integer; + pragma Import (C, Max_Path, "max_path_len"); + + function Get_Current_Dir return Dir_Name_Str is + Current_Dir : String (1 .. Max_Path + 1); + Last : Natural; + + begin + Get_Current_Dir (Current_Dir, Last); + return Current_Dir (1 .. Last); + end Get_Current_Dir; + + procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is + Path_Len : Natural := Max_Path; + Buffer : String (Dir'First .. Dir'First + Max_Path + 1); + + procedure Local_Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); + + begin + Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Dir'Length > Path_Len then + Last := Dir'First + Path_Len - 1; + else + Last := Dir'Last; + end if; + + Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); + end Get_Current_Dir; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (Dir : Dir_Type) return Boolean is + begin + return Dir /= Null_Dir + and then System.Address (Dir.all) /= System.Null_Address; + end Is_Open; + + -------------- + -- Make_Dir -- + -------------- + + procedure Make_Dir (Dir_Name : Dir_Name_Str) is + C_Dir_Name : String := Dir_Name & ASCII.NUL; + + function mkdir (Dir_Name : String) return Integer; + pragma Import (C, mkdir, "__gnat_mkdir"); + + begin + if mkdir (C_Dir_Name) /= 0 then + raise Directory_Error; + end if; + end Make_Dir; + + ------------------------ + -- Normalize_Pathname -- + ------------------------ + + function Normalize_Pathname + (Path : Path_Name; + Style : Path_Style := System_Default) + return String + is + N_Path : String := Path; + K : Positive := N_Path'First; + Prev_Dirsep : Boolean := False; + + begin + for J in Path'Range loop + + if Strings.Maps.Is_In (Path (J), Dir_Seps) then + if not Prev_Dirsep then + + case Style is + when UNIX => N_Path (K) := '/'; + when DOS => N_Path (K) := '\'; + when System_Default => N_Path (K) := Dir_Separator; + end case; + + K := K + 1; + end if; + + Prev_Dirsep := True; + + else + N_Path (K) := Path (J); + K := K + 1; + Prev_Dirsep := False; + end if; + end loop; + + return N_Path (N_Path'First .. K - 1); + end Normalize_Pathname; + + ---------- + -- Open -- + ---------- + + procedure Open + (Dir : out Dir_Type; + Dir_Name : Dir_Name_Str) + is + C_File_Name : String := Dir_Name & ASCII.NUL; + + function opendir + (File_Name : String) + return Dir_Type_Value; + pragma Import (C, opendir, "opendir"); + + begin + Dir := new Dir_Type_Value'(opendir (C_File_Name)); + + if not Is_Open (Dir) then + Free (Dir); + Dir := Null_Dir; + raise Directory_Error; + end if; + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (Dir : in out Dir_Type; + Str : out String; + Last : out Natural) + is + Filename_Addr : Address; + Filename_Len : Integer; + + Buffer : array (0 .. 1024) of Character; + -- 1024 is the value of FILENAME_MAX in stdio.h + + function readdir_gnat + (Directory : System.Address; + Buffer : System.Address) + return System.Address; + pragma Import (C, readdir_gnat, "__gnat_readdir"); + + function strlen (S : Address) return Integer; + pragma Import (C, strlen, "strlen"); + + begin + if not Is_Open (Dir) then + raise Directory_Error; + end if; + + Filename_Addr := + readdir_gnat (System.Address (Dir.all), Buffer'Address); + + if Filename_Addr = System.Null_Address then + Last := 0; + return; + end if; + + Filename_Len := strlen (Filename_Addr); + + if Str'Length > Filename_Len then + Last := Str'First + Filename_Len - 1; + else + Last := Str'Last; + end if; + + declare + subtype Path_String is String (1 .. Filename_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Unchecked_Conversion + (Source => Address, + Target => Path_String_Access); + + Path_Access : Path_String_Access := Address_To_Access (Filename_Addr); + + begin + for J in Str'First .. Last loop + Str (J) := Path_Access (J - Str'First + 1); + end loop; + end; + end Read; + + ------------------------- + -- Read_Is_Thread_Sage -- + ------------------------- + + function Read_Is_Thread_Safe return Boolean is + + function readdir_is_thread_safe return Integer; + pragma Import + (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe"); + + begin + return (readdir_is_thread_safe /= 0); + end Read_Is_Thread_Safe; + + ---------------- + -- Remove_Dir -- + ---------------- + + procedure Remove_Dir (Dir_Name : Dir_Name_Str) is + C_Dir_Name : String := Dir_Name & ASCII.NUL; + + procedure rmdir (Dir_Name : String); + pragma Import (C, rmdir, "rmdir"); + + begin + rmdir (C_Dir_Name); + end Remove_Dir; + + ----------------------- + -- Wildcard_Iterator -- + ----------------------- + + procedure Wildcard_Iterator (Path : Path_Name) is + + Index : Natural := 0; + + procedure Read + (Directory : String; + File_Pattern : String; + Suffix_Pattern : String); + -- Read entries in Directory and call user's callback if the entry + -- match File_Pattern and Suffix_Pattern is empty otherwise it will go + -- down one more directory level by calling Next_Level routine above. + + procedure Next_Level + (Current_Path : String; + Suffix_Path : String); + -- Extract next File_Pattern from Suffix_Path and call Read routine + -- above. + + ---------------- + -- Next_Level -- + ---------------- + + procedure Next_Level + (Current_Path : String; + Suffix_Path : String) + is + DS : Natural; + SP : String renames Suffix_Path; + + begin + if SP'Length > 2 + and then SP (SP'First) = '.' + and then Strings.Maps.Is_In (SP (SP'First + 1), Dir_Seps) + then + -- Starting with "./" + + DS := Strings.Fixed.Index + (SP (SP'First + 2 .. SP'Last), + Dir_Seps); + + if DS = 0 then + + -- We have "./" + + Read (Current_Path & ".", "*", ""); + + else + -- We have "./dir" + + Read (Current_Path & ".", + SP (SP'First + 2 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + elsif SP'Length > 3 + and then SP (SP'First .. SP'First + 1) = ".." + and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps) + then + -- Starting with "../" + + DS := Strings.Fixed.Index + (SP (SP'First + 3 .. SP'Last), + Dir_Seps); + + if DS = 0 then + + -- We have "../" + + Read (Current_Path & "..", "*", ""); + + else + -- We have "../dir" + + Read (Current_Path & "..", + SP (SP'First + 4 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + elsif Current_Path = "" + and then SP'Length > 1 + and then Characters.Handling.Is_Letter (SP (SP'First)) + and then SP (SP'First + 1) = ':' + then + -- Starting with "<drive>:" + + if SP'Length > 2 + and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps) + then + -- Starting with "<drive>:\" + + DS := Strings.Fixed.Index + (SP (SP'First + 3 .. SP'Last), Dir_Seps); + + if DS = 0 then + + -- Se have "<drive>:\dir" + + Read (SP (SP'First .. SP'First + 1), + SP (SP'First + 3 .. SP'Last), + ""); + + else + -- We have "<drive>:\dir\kkk" + + Read (SP (SP'First .. SP'First + 1), + SP (SP'First + 3 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + else + -- Starting with "<drive>:" + + DS := Strings.Fixed.Index + (SP (SP'First + 2 .. SP'Last), Dir_Seps); + + if DS = 0 then + + -- We have "<drive>:dir" + + Read (SP (SP'First .. SP'First + 1), + SP (SP'First + 2 .. SP'Last), + ""); + + else + -- We have "<drive>:dir/kkk" + + Read (SP (SP'First .. SP'First + 1), + SP (SP'First + 2 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + end if; + + elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then + + -- Starting with a / + + DS := Strings.Fixed.Index + (SP (SP'First + 1 .. SP'Last), + Dir_Seps); + + if DS = 0 then + + -- We have "/dir" + + Read (Current_Path, + SP (SP'First + 1 .. SP'Last), + ""); + else + -- We have "/dir/kkk" + + Read (Current_Path, + SP (SP'First + 1 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + else + -- Starting with a name + + DS := Strings.Fixed.Index (SP, Dir_Seps); + + if DS = 0 then + + -- We have "dir" + + Read (Current_Path & '.', + SP, + ""); + else + -- We have "dir/kkk" + + Read (Current_Path & '.', + SP (SP'First .. DS - 1), + SP (DS .. SP'Last)); + end if; + + end if; + end Next_Level; + + ---------- + -- Read -- + ---------- + + Quit : Boolean := False; + -- Global state to be able to exit all recursive calls. + + procedure Read + (Directory : String; + File_Pattern : String; + Suffix_Pattern : String) + is + File_Regexp : constant Regexp.Regexp := + Regexp.Compile (File_Pattern, Glob => True); + Dir : Dir_Type; + Buffer : String (1 .. 2_048); + Last : Natural; + + begin + if OS_Lib.Is_Directory (Directory) then + Open (Dir, Directory); + + Dir_Iterator : loop + Read (Dir, Buffer, Last); + exit Dir_Iterator when Last = 0; + + declare + Dir_Entry : constant String := Buffer (1 .. Last); + Pathname : constant String := + Directory & Dir_Separator & Dir_Entry; + begin + -- Handle "." and ".." only if explicit use in the + -- File_Pattern. + + if not + ((Dir_Entry = "." and then File_Pattern /= ".") + or else + (Dir_Entry = ".." and then File_Pattern /= "..")) + then + if Regexp.Match (Dir_Entry, File_Regexp) then + + if Suffix_Pattern = "" then + + -- No more matching needed, call user's callback + + Index := Index + 1; + + begin + Action (Pathname, Index, Quit); + + exception + when others => + Close (Dir); + raise; + end; + + exit Dir_Iterator when Quit; + + else + -- Down one level + + Next_Level + (Directory & Dir_Separator & Dir_Entry, + Suffix_Pattern); + end if; + end if; + end if; + end; + + exit Dir_Iterator when Quit; + + end loop Dir_Iterator; + + Close (Dir); + end if; + end Read; + + begin + Next_Level ("", Path); + end Wildcard_Iterator; + +end GNAT.Directory_Operations; diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads new file mode 100644 index 00000000000..8e6d005405e --- /dev/null +++ b/gcc/ada/g-dirope.ads @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Directory operations + +-- This package provides routines for manipulating directories. A directory +-- can be treated as a file, using open and close routines, and a scanning +-- routine is provided for iterating through the entries in a directory. + +package GNAT.Directory_Operations is + + subtype Dir_Name_Str is String; + -- A subtype used in this package to represent string values that are + -- directory names. A directory name is a prefix for files that appear + -- with in the directory. This means that for UNIX systems, the string + -- includes a final '/', and for DOS-like systems, it includes a final + -- '\' character. It can also include drive letters if the operating + -- system provides for this. The final '/' or '\' in a Dir_Name_Str is + -- optional when passed as a procedure or function in parameter. + + type Dir_Type is limited private; + -- A value used to reference a directory. Conceptually this value includes + -- the identity of the directory, and a sequential position within it. + + Null_Dir : constant Dir_Type; + -- Represent the value for an uninitialized or closed directory + + Directory_Error : exception; + -- Exception raised if the directory cannot be opened, read, closed, + -- created or if it is not possible to change the current execution + -- environment directory. + + Dir_Separator : constant Character; + -- Running system default directory separator + + -------------------------------- + -- Basic Directory operations -- + -------------------------------- + + procedure Change_Dir (Dir_Name : Dir_Name_Str); + -- Changes the working directory of the current execution environment + -- to the directory named by Dir_Name. Raises Directory_Error if Dir_Name + -- does not exist. + + procedure Make_Dir (Dir_Name : Dir_Name_Str); + -- Create a new directory named Dir_Name. Raises Directory_Error if + -- Dir_Name cannot be created. + + procedure Remove_Dir (Dir_Name : Dir_Name_Str); + -- Remove the directory named Dir_Name. Raises Directory_Error if Dir_Name + -- cannot be removed. + + function Get_Current_Dir return Dir_Name_Str; + -- Returns the current working directory for the execution environment. + + procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural); + -- Returns the current working directory for the execution environment + -- The name is returned in Dir_Name. Last is the index in Dir_Name such + -- that Dir_Name (Last) is the last character written. If Dir_Name is + -- too small for the directory name, the name will be truncated before + -- being copied to Dir_Name. + + ------------------------- + -- Pathname Operations -- + ------------------------- + + subtype Path_Name is String; + -- All routines using Path_Name handle both styles (UNIX and DOS) of + -- directory separators (either slash or back slash). + + function Dir_Name (Path : Path_Name) return Dir_Name_Str; + -- Returns directory name for Path. This is similar to the UNIX dirname + -- command. Everything after the last directory separator is removed. If + -- there is no directory separator the current working directory is + -- returned. + + function Base_Name + (Path : Path_Name; + Suffix : String := "") + return String; + -- Any directory prefix is removed. If Suffix is non-empty and is a + -- suffix of Path, it is removed. This is equivalent to the UNIX basename + -- command. The following rule is always true: + -- + -- 'Path' and 'Dir_Name (Path) & Directory_Separator & Base_Name (Path)' + -- represent the same file. + -- + -- This function is not case-sensitive on systems that have a non + -- case-sensitive file system like Windows, OS/2 and VMS. + + function File_Extension (Path : Path_Name) return String; + -- Return the file extension. This is the string after the last dot + -- character in File_Name (Path). It returns the empty string if no + -- extension is found. The returned value does contains the file + -- extension separator (dot character). + + function File_Name (Path : Path_Name) return String; + -- Returns the file name and the file extension if present. It removes all + -- path information. This is equivalent to Base_Name with default Extension + -- value. + + type Path_Style is (UNIX, DOS, System_Default); + + function Normalize_Pathname + (Path : Path_Name; + Style : Path_Style := System_Default) + return Path_Name; + -- Removes all double directory separator and converts all '\' to '/' if + -- Style is UNIX and converts all '/' to '\' if Style is set to DOS. This + -- function will help to provide a consistent naming scheme running for + -- different environments. If style is set to System_Default the routine + -- will use the default directory separator on the running environment. + + function Expand_Path (Path : Path_Name) return Path_Name; + -- Returns Path with environment variables (string preceded by a dollar + -- sign) replaced by the current environment variable value. For example, + -- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment + -- variable is set to /home/joe. The variable can be surrounded by the + -- characters '{' and '}' (curly bracket) if needed as in ${HOME}/mydir. + -- If an environment variable does not exists the variable will be replaced + -- by the empty string. Two dollar signs are replaced by a single dollar + -- sign. Note that a variable must start with a letter. If there is no + -- closing curly bracket for an opening one there is no translation done, + -- so for example ${VAR/toto is returned as ${VAR/toto. + + --------------- + -- Iterators -- + --------------- + + procedure Open (Dir : out Dir_Type; Dir_Name : Dir_Name_Str); + -- Opens the directory named by Dir_Name and returns a Dir_Type value + -- that refers to this directory, and is positioned at the first entry. + -- Raises Directory_Error if Dir_Name cannot be accessed. In that case + -- Dir will be set to Null_Dir. + + procedure Close (Dir : in out Dir_Type); + -- Closes the directory stream refered to by Dir. After calling Close + -- Is_Open will return False. Dir will be set to Null_Dir. + -- Raises Directory_Error if Dir has not be opened (Dir = Null_Dir). + + function Is_Open (Dir : Dir_Type) return Boolean; + -- Returns True if Dir is open, or False otherwise. + + procedure Read + (Dir : in out Dir_Type; + Str : out String; + Last : out Natural); + -- Reads the next entry from the directory and sets Str to the name + -- of that entry. Last is the index in Str such that Str (Last) is the + -- last character written. Last is 0 when there are no more files in the + -- directory. If Str is too small for the file name, the file name will + -- be truncated before being copied to Str. The list of files returned + -- includes directories in systems providing a hierarchical directory + -- structure, including . (the current directory) and .. (the parent + -- directory) in systems providing these entries. The directory is + -- returned in target-OS form. Raises Directory_Error if Dir has not + -- be opened (Dir = Null_Dir). + + generic + with procedure Action + (Item : String; + Index : Positive; + Quit : in out Boolean); + procedure Wildcard_Iterator (Path : Path_Name); + -- Calls Action for each path matching Path. Path can include wildcards '*' + -- and '?' and [...]. The rules are: + -- + -- * can be replaced by any sequence of characters + -- ? can be replaced by a single character + -- [a-z] match one character in the range 'a' through 'z' + -- [abc] match either character 'a', 'b' or 'c' + -- + -- Item is the filename that has been matched. Index is set to one for the + -- first call and is incremented by one at each call. The iterator's + -- termination can be controlled by setting Quit to True. It is by default + -- set to False. + -- + -- For example, if we have the following directory structure: + -- /boo/ + -- foo.ads + -- /sed/ + -- foo.ads + -- file/ + -- foo.ads + -- /sid/ + -- foo.ads + -- file/ + -- foo.ads + -- /life/ + -- + -- A call with expression "/s*/file/*" will call Action for the following + -- items: + -- /sed/file/foo.ads + -- /sid/file/foo.ads + + generic + with procedure Action + (Item : String; + Index : Positive; + Quit : in out Boolean); + procedure Find + (Root_Directory : Dir_Name_Str; + File_Pattern : String); + -- Recursively searches the directory structure rooted at Root_Directory. + -- This provides functionality similar to the UNIX 'find' command. + -- Action will be called for every item matching the regular expression + -- File_Pattern (see GNAT.Regexp). Item is the full pathname to the file + -- starting with Root_Directory that has been matched. Index is set to one + -- for the first call and is incremented by one at each call. The iterator + -- will pass in the value False on each call to Action. The iterator will + -- terminate after passing the last matched path to Action or after + -- returning from a call to Action which sets Quit to True. + -- Raises GNAT.Regexp.Error_In_Regexp if File_Pattern is ill formed. + + function Read_Is_Thread_Safe return Boolean; + -- Indicates if procedure Read is thread safe. On systems where the + -- target system supports this functionality, Read is thread safe, + -- and this function returns True (e.g. this will be the case on any + -- UNIX or UNIX-like system providing a correct implementation of the + -- function readdir_r). If the system cannot provide a thread safe + -- implementation of Read, then this function returns False. + +private + + type Dir_Type_Value; + type Dir_Type is access Dir_Type_Value; + + Null_Dir : constant Dir_Type := null; + + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + +end GNAT.Directory_Operations; diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb new file mode 100644 index 00000000000..02c1bc19636 --- /dev/null +++ b/gcc/ada/g-dyntab.adb @@ -0,0 +1,246 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ T A B L E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; + +package body GNAT.Dynamic_Tables is + + Min : constant Integer := Integer (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + type size_t is new Integer; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate (T : in out Instance); + -- Reallocate the existing table according to the current value stored + -- in Max. Works correctly to do an initial allocation if the table + -- is currently null. + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (T : in out Instance; + Num : Integer := 1) + is + begin + T.P.Last_Val := T.P.Last_Val + Num; + + if T.P.Last_Val > T.P.Max then + Reallocate (T); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (T : in out Instance; New_Val : Table_Component_Type) is + begin + Increment_Last (T); + T.Table (Table_Index_Type (T.P.Last_Val)) := New_Val; + end Append; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last (T : in out Instance) is + begin + T.P.Last_Val := T.P.Last_Val - 1; + end Decrement_Last; + + ---------- + -- Free -- + ---------- + + procedure Free (T : in out Instance) is + procedure free (T : Table_Ptr); + pragma Import (C, free); + + begin + free (T.Table); + T.Table := null; + T.P.Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last (T : in out Instance) is + begin + T.P.Last_Val := T.P.Last_Val + 1; + + if T.P.Last_Val > T.P.Max then + Reallocate (T); + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init (T : in out Instance) is + Old_Length : constant Integer := T.P.Length; + + begin + T.P.Last_Val := Min - 1; + T.P.Max := Min + Table_Initial - 1; + T.P.Length := T.P.Max - Min + 1; + + -- If table is same size as before (happens when table is never + -- expanded which is a common case), then simply reuse it. Note + -- that this also means that an explicit Init call right after + -- the implicit one in the package body is harmless. + + if Old_Length = T.P.Length then + return; + + -- Otherwise we can use Reallocate to get a table of the right size. + -- Note that Reallocate works fine to allocate a table of the right + -- initial size when it is first allocated. + + else + Reallocate (T); + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last (T : in Instance) return Table_Index_Type is + begin + return Table_Index_Type (T.P.Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate (T : in out Instance) is + + function realloc + (memblock : Table_Ptr; + size : size_t) + return Table_Ptr; + pragma Import (C, realloc); + + function malloc + (size : size_t) + return Table_Ptr; + pragma Import (C, malloc); + + New_Size : size_t; + + begin + if T.P.Max < T.P.Last_Val then + while T.P.Max < T.P.Last_Val loop + T.P.Length := T.P.Length * (100 + Table_Increment) / 100; + T.P.Max := Min + T.P.Length - 1; + end loop; + end if; + + New_Size := + size_t ((T.P.Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + if T.Table = null then + T.Table := malloc (New_Size); + + elsif New_Size > 0 then + T.Table := + realloc + (memblock => T.Table, + size => New_Size); + end if; + + if T.P.Length /= 0 and then T.Table = null then + raise Storage_Error; + end if; + + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release (T : in out Instance) is + begin + T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1; + T.P.Max := T.P.Last_Val; + Reallocate (T); + end Release; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (T : in out Instance; + Index : Table_Index_Type; + Item : Table_Component_Type) + is + begin + if Integer (Index) > T.P.Max then + Set_Last (T, Index); + end if; + + T.Table (Index) := Item; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is + begin + if Integer (New_Val) < T.P.Last_Val then + T.P.Last_Val := Integer (New_Val); + + else + T.P.Last_Val := Integer (New_Val); + + if T.P.Last_Val > T.P.Max then + Reallocate (T); + end if; + end if; + end Set_Last; + +end GNAT.Dynamic_Tables; diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads new file mode 100644 index 00000000000..65a25e75884 --- /dev/null +++ b/gcc/ada/g-dyntab.ads @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ T A B L E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Resizable one dimensional array support + +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- This package provides a facility similar to that of GNAT.Table, except +-- that this package declares a type that can be used to define dynamic +-- instances of the table, while an instantiation of GNAT.Table creates a +-- single instance of the table type. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Table and the GNAT compiler source unit Table to keep as much +-- coherency as possible between these three related units. + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + Table_Increment : Natural; + +package GNAT.Dynamic_Tables is + + -- Table_Component_Type and Table_Index_Type specify the type of the + -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- integer type. The effect is roughly to declare: + + -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; + + -- Table_Component_Type may be any Ada type, except that controlled + -- types are not supported. Note however that default initialization + -- will NOT occur for array components. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init + -- call. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: we do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained + -- with the maximum possible range bound. This means that the pointer + -- is a thin pointer, which is more efficient. Since subscript checks + -- in any case must be on the logical, rather than physical bounds, + -- safety is not compromised by this approach. + + type Table_Ptr is access all Big_Table_Type; + -- The table is actually represented as a pointer to allow + -- reallocation. + + type Table_Private is private; + -- table private data that is not exported in Instance. + + type Instance is record + Table : aliased Table_Ptr := null; + -- The table itself. The lower bound is the value of Low_Bound. + -- Logically the upper bound is the current value of Last (although + -- the actual size of the allocated table may be larger than this). + -- The program may only access and modify Table entries in the + -- range First .. Last. + + P : Table_Private; + end record; + + procedure Init (T : in out Instance); + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). Init must be called before using + -- the table. Init is convenient in reestablishing a table for new use. + + function Last (T : in Instance) return Table_Index_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, + -- which can then be used as a subscript for Table. Note that the + -- only way to modify Last is to call the Set_Last procedure. Last + -- must always be used to determine the logically last entry. + + procedure Release (T : in out Instance); + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. A call to Release releases all + -- storage that is allocated, but is not logically part of the current + -- array value. Current array values are not affected by this call. + + procedure Free (T : in out Instance); + -- Free all allocated memory for the table. A call to init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the + -- table is reallocated to accomodate the new value (i.e. on return + -- the allocated table has an upper bound of at least Last). If + -- Set_Last reduces the size of the table, then logically entries are + -- removed from the table. If Set_Last increases the size of the + -- table, then new entries are logically added to the table. + + procedure Increment_Last (T : in out Instance); + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1). + + procedure Decrement_Last (T : in out Instance); + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1). + + procedure Append (T : in out Instance; New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- Increment_Last (T); + -- T.Table (T.Last) := New_Val; + -- i.e. the table size is increased by one, and the given new item + -- stored in the newly created table element. + + procedure Set_Item + (T : in out Instance; + Index : Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. The table is expanded if + -- current table length is less than Index and in that case Last is set to + -- Index. Item will replace any value already present in the table at this + -- position. + + procedure Allocate (T : in out Instance; Num : Integer := 1); + pragma Inline (Allocate); + -- Adds Num to Last. + +private + + type Table_Private is record + Max : Integer; + -- Subscript of the maximum entry in the currently allocated table + + Length : Integer := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + Last_Val : Integer; + -- Current value of Last. + end record; + +end GNAT.Dynamic_Tables; diff --git a/gcc/ada/g-except.ads b/gcc/ada/g-except.ads new file mode 100644 index 00000000000..b4c107c6a12 --- /dev/null +++ b/gcc/ada/g-except.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface for raising predefined exceptions +-- with an exception message. It can be used from Pure units. This unit +-- is for internal use only, it is not generally available to applications. + +package GNAT.Exceptions is +pragma Pure (Exceptions); + + type Exception_Type is limited null record; + -- Type used to specify which exception to raise. + + -- Really Exception_Type is Exception_Id, but Exception_Id can't be + -- used directly since it is declared in the non-pure unit Ada.Exceptions, + + -- Exception_Id is in fact simply a pointer to the type Exception_Data + -- declared in System.Standard_Library (which is also non-pure). So what + -- we do is to define it here as a by reference type (any by reference + -- type would do), and then Import the definitions from Standard_Library. + -- Since this is a by reference type, these will be passed by reference, + -- which has the same effect as passing a pointer. + + -- This type is not private because keeping it by reference would require + -- defining it in a way (e.g a tagged type) that would drag other run time + -- files, which is unwanted in the case of e.g ravenscar where we want to + -- minimize the number of run time files needed by default. + + CE : constant Exception_Type; -- Constraint_Error + PE : constant Exception_Type; -- Program_Error + SE : constant Exception_Type; -- Storage_Error + TE : constant Exception_Type; -- Tasking_Error + -- One of these constants is used in the call to specify the exception + + procedure Raise_Exception (E : Exception_Type; Message : String); + pragma Import (Ada, Raise_Exception, "__gnat_raise_exception"); + pragma No_Return (Raise_Exception); + -- Raise specified exception with specified message + +private + pragma Import (C, CE, "constraint_error"); + pragma Import (C, PE, "program_error"); + pragma Import (C, SE, "storage_error"); + pragma Import (C, TE, "tasking_error"); + -- References to the exception structures in the standard library + +end GNAT.Exceptions; diff --git a/gcc/ada/g-exctra.adb b/gcc/ada/g-exctra.adb new file mode 100644 index 00000000000..fb34ce223c7 --- /dev/null +++ b/gcc/ada/g-exctra.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N _ T R A C E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Standard_Library; use System.Standard_Library; +with System.Soft_Links; use System.Soft_Links; + +package body GNAT.Exception_Traces is + + -- Calling the decorator directly from where it is needed would require + -- introducing nasty dependencies upon the spec of this package (typically + -- in a-except.adb). We also have to deal with the fact that the traceback + -- array within an exception occurrence and the one the decorator shall + -- accept are of different types. These are two reasons for which a wrapper + -- with a System.Address argument is indeed used to call the decorator + -- provided by the user of this package. This wrapper is called via a + -- soft-link, which either is null when no decorator is in place or "points + -- to" the following function otherwise. + + function Decorator_Wrapper + (Traceback : System.Address; + Len : Natural) + return String; + -- The wrapper to be called when a decorator is in place for exception + -- backtraces. + -- + -- Traceback is the address of the call chain array as stored in the + -- exception occurrence and Len is the number of significant addresses + -- contained in this array. + + Current_Decorator : Traceback_Decorator := null; + -- The decorator to be called by the wrapper when it is not null, as set + -- by Set_Trace_Decorator. When this access is null, the wrapper is null + -- also and shall then not be called. + + ----------------------- + -- Decorator_Wrapper -- + ----------------------- + + function Decorator_Wrapper + (Traceback : System.Address; + Len : Natural) + return String + is + Decorator_Traceback : Tracebacks_Array (1 .. Len); + for Decorator_Traceback'Address use Traceback; + + -- Handle the "transition" from the array stored in the exception + -- occurrence to the array expected by the decorator. + + pragma Import (Ada, Decorator_Traceback); + + begin + return Current_Decorator.all (Decorator_Traceback); + end Decorator_Wrapper; + + ------------------------- + -- Set_Trace_Decorator -- + ------------------------- + + procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is + begin + Current_Decorator := Decorator; + + if Current_Decorator /= null then + Traceback_Decorator_Wrapper := Decorator_Wrapper'Access; + else + Traceback_Decorator_Wrapper := null; + end if; + end Set_Trace_Decorator; + + -- Trace_On/Trace_Off control the kind of automatic output to occur + -- by way of the global Exception_Trace variable. + + --------------- + -- Trace_Off -- + --------------- + + procedure Trace_Off is + begin + Exception_Trace := RM_Convention; + end Trace_Off; + + -------------- + -- Trace_On -- + -------------- + + procedure Trace_On (Kind : in Trace_Kind) is + begin + case Kind is + when Every_Raise => + Exception_Trace := Every_Raise; + when Unhandled_Raise => + Exception_Trace := Unhandled_Raise; + end case; + end Trace_On; + +end GNAT.Exception_Traces; diff --git a/gcc/ada/g-exctra.ads b/gcc/ada/g-exctra.ads new file mode 100644 index 00000000000..854ff9d8a60 --- /dev/null +++ b/gcc/ada/g-exctra.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N _ T R A C E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface allowing to control *automatic* output +-- to standard error upon exception occurrences (as opposed to explicit +-- generation of traceback information using GNAT.Traceback). +-- +-- This output includes the basic information associated with the exception +-- (name, message) as well as a backtrace of the call chain at the point +-- where the exception occured. This backtrace is only output if the call +-- chain information is available, depending if the binder switch dedicated +-- to that purpose has been used or not. +-- +-- The default backtrace is in the form of absolute code locations which may +-- be converted to corresponding source locations using the addr2line utility +-- or from within GDB. Please refer to GNAT.Traceback for information about +-- what is necessary to be able to exploit thisg possibility. +-- +-- The backtrace output can also be customized by way of a "decorator" which +-- may return any string output in association with a provided call chain. + +with GNAT.Traceback; use GNAT.Traceback; + +package GNAT.Exception_Traces is + + -- The following defines the exact situations in which raises will + -- cause automatic output of trace information. + + type Trace_Kind is + (Every_Raise, + -- Denotes the initial raise event for any exception occurrence, either + -- explicit or due to a specific language rule, within the context of a + -- task or not. + + Unhandled_Raise + -- Denotes the raise events corresponding to exceptions for which there + -- is no user defined handler, in particular, when a task dies due to an + -- unhandled exception. + ); + + -- The following procedures can be used to activate and deactivate + -- traces identified by the above trace kind values. + + procedure Trace_On (Kind : in Trace_Kind); + -- Activate the traces denoted by Kind. + + procedure Trace_Off; + -- Stop the tracing requested by the last call to Trace_On. + -- Has no effect if no such call has ever occurred. + + -- The following provide the backtrace decorating facilities + + type Traceback_Decorator is access + function (Traceback : Tracebacks_Array) return String; + -- A backtrace decorator is a function which returns the string to be + -- output for a call chain provided by way of a tracebacks array. + + procedure Set_Trace_Decorator (Decorator : Traceback_Decorator); + -- Set the decorator to be used for future automatic outputs. Restore + -- the default behavior (output of raw addresses) if the provided + -- access value is null. + +end GNAT.Exception_Traces; diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb new file mode 100644 index 00000000000..651b6201483 --- /dev/null +++ b/gcc/ada/g-expect.adb @@ -0,0 +1,1177 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.IO; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Regpat; use GNAT.Regpat; +with System; use System; +with Unchecked_Conversion; +with Unchecked_Deallocation; +with Ada.Calendar; use Ada.Calendar; + +package body GNAT.Expect is + + function To_Pid is new + Unchecked_Conversion (OS_Lib.Process_Id, Process_Id); + + type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean); + -- Internal function used to read from the process Descriptor. + -- + -- Three outputs are possible: + -- Result=Expect_Timeout, if no output was available before the timeout + -- expired. + -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters + -- had to be discarded from the internal buffer of Descriptor. + -- Result=<integer>, indicates how many characters were added to the + -- internal buffer. These characters are from indexes + -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index + -- Process_Died is raised if the process is no longer valid. + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class); + -- Reinitialize the internal buffer. + -- The buffer is deleted up to the end of the last match. + + procedure Free is new Unchecked_Deallocation + (Pattern_Matcher, Pattern_Matcher_Access); + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type); + -- Call all the filters that have the appropriate type. + -- This function does nothing if the filters are locked + + ------------------------------ + -- Target dependent section -- + ------------------------------ + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2); + + procedure Kill (Pid : Process_Id; Sig_Num : Integer); + pragma Import (C, Kill); + + function Create_Pipe (Pipe : access Pipe_Type) return Integer; + pragma Import (C, Create_Pipe, "__gnat_pipe"); + + function Read + (Fd : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + pragma Import (C, Read, "read"); + -- Read N bytes to address A from file referenced by FD. Returned value + -- is count of bytes actually read, which can be less than N at EOF. + + procedure Close (Fd : File_Descriptor); + pragma Import (C, Close); + -- Close a file given its file descriptor. + + function Write + (Fd : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + pragma Import (C, Write, "write"); + -- Read N bytes to address A from file referenced by FD. Returned value + -- is count of bytes actually read, which can be less than N at EOF. + + function Poll + (Fds : System.Address; + Num_Fds : Integer; + Timeout : Integer; + Is_Set : System.Address) return Integer; + pragma Import (C, Poll, "__gnat_expect_poll"); + -- Check whether there is any data waiting on the file descriptor + -- Out_fd, and wait if there is none, at most Timeout milliseconds + -- Returns -1 in case of error, 0 if the timeout expired before + -- data became available. + -- + -- Out_Is_Set is set to 1 if data was available, 0 otherwise. + + --------- + -- "+" -- + --------- + + function "+" (S : String) return GNAT.OS_Lib.String_Access is + begin + return new String'(S); + end "+"; + + --------- + -- "+" -- + --------- + + function "+" + (P : GNAT.Regpat.Pattern_Matcher) + return Pattern_Matcher_Access + is + begin + return new GNAT.Regpat.Pattern_Matcher'(P); + end "+"; + + ---------------- + -- Add_Filter -- + ---------------- + + procedure Add_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function; + Filter_On : Filter_Type := Output; + User_Data : System.Address := System.Null_Address; + After : Boolean := False) + is + Current : Filter_List := Descriptor.Filters; + + begin + if After then + while Current /= null and then Current.Next /= null loop + Current := Current.Next; + end loop; + + if Current = null then + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + else + Current.Next := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + end if; + + else + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => Descriptor.Filters); + end if; + end Add_Filter; + + ------------------ + -- Call_Filters -- + ------------------ + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type) + is + Current_Filter : Filter_List; + + begin + if Pid.Filters_Lock = 0 then + Current_Filter := Pid.Filters; + + while Current_Filter /= null loop + if Current_Filter.Filter_On = Filter_On then + Current_Filter.Filter + (Pid, Str, Current_Filter.User_Data); + end if; + + Current_Filter := Current_Filter.Next; + end loop; + end if; + end Call_Filters; + + ----------- + -- Close -- + ----------- + + procedure Close (Descriptor : in out Process_Descriptor) is + Success : Boolean; + Pid : OS_Lib.Process_Id; + + begin + Close (Descriptor.Input_Fd); + + if Descriptor.Error_Fd /= Descriptor.Output_Fd then + Close (Descriptor.Error_Fd); + end if; + + Close (Descriptor.Output_Fd); + + -- ??? Should have timeouts for different signals, see ddd + Kill (Descriptor.Pid, 9); + + GNAT.OS_Lib.Free (Descriptor.Buffer); + Descriptor.Buffer_Size := 0; + + Wait_Process (Pid, Success); + Descriptor.Pid := To_Pid (Pid); + end Close; + + ------------ + -- Expect -- + ------------ + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + begin + if Regexp = "" then + Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); + else + Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + begin + pragma Assert (Matched'First = 0); + if Regexp = "" then + Expect + (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); + else + Expect + (Descriptor, Result, Compile (Regexp), Matched, Timeout, + Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + Try_Until : Time := Clock + Duration (Timeout) / 1000.0; + Timeout_Tmp : Integer := Timeout; + + begin + pragma Assert (Matched'First = 0); + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + + -- Else try to read new input + + Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + + -- Calculate the timeout for the next turn. + -- Note that Timeout is, from the caller's perspective, the maximum + -- time until a match, not the maximum time until some output is + -- read, and thus can not be reused as is for Expect_Internal. + + if Timeout /= -1 then + Timeout_Tmp := Integer (Try_Until - Clock) * 1000; + + if Timeout_Tmp < 0 then + Result := Expect_Timeout; + exit; + end if; + end if; + end loop; + + -- Even if we had the general timeout above, we have to test that the + -- last test we read from the external process didn't match. + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + begin + pragma Assert (Matched'First = 0); + + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + if Descriptor.Buffer /= null then + for J in Regexps'Range loop + Match + (Regexps (J).all, + Descriptor.Buffer (1 .. Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end loop; + end if; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + end loop; + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Descriptors'Range loop + Descriptors (J) := Regexps (J).Descriptor; + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end loop; + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + for J in Regexps'Range loop + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end loop; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + end loop; + end Expect; + + --------------------- + -- Expect_Internal -- + --------------------- + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean) + is + Num_Descriptors : Integer; + Buffer_Size : Integer := 0; + + N : Integer; + + type File_Descriptor_Array is + array (Descriptors'Range) of File_Descriptor; + Fds : aliased File_Descriptor_Array; + + type Integer_Array is array (Descriptors'Range) of Integer; + Is_Set : aliased Integer_Array; + + begin + for J in Descriptors'Range loop + Fds (J) := Descriptors (J).Output_Fd; + + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; + end loop; + + declare + Buffer : aliased String (1 .. Buffer_Size); + -- Buffer used for input. This is allocated only once, not for + -- every iteration of the loop + + begin + -- Loop until we match or we have a timeout + + loop + Num_Descriptors := + Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error? + + when -1 => + raise Process_Died; + + -- Timeout? + + when 0 => + Result := Expect_Timeout; + return; + + -- Some input + + when others => + for J in Descriptors'Range loop + if Is_Set (J) = 1 then + Buffer_Size := Descriptors (J).Buffer_Size; + + if Buffer_Size = 0 then + Buffer_Size := 4096; + end if; + + N := Read (Descriptors (J).Output_Fd, Buffer'Address, + Buffer_Size); + + -- Error or End of file + + if N <= 0 then + -- ??? Note that ddd tries again up to three times + -- in that case. See LiterateA.C:174 + raise Process_Died; + + else + -- If there is no limit to the buffer size + + if Descriptors (J).Buffer_Size = 0 then + + declare + Tmp : String_Access := Descriptors (J).Buffer; + + begin + if Tmp /= null then + Descriptors (J).Buffer := + new String (1 .. Tmp'Length + N); + Descriptors (J).Buffer (1 .. Tmp'Length) := + Tmp.all; + Descriptors (J).Buffer + (Tmp'Length + 1 .. Tmp'Length + N) := + Buffer (1 .. N); + Free (Tmp); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer'Last; + + else + Descriptors (J).Buffer := + new String (1 .. N); + Descriptors (J).Buffer.all := + Buffer (1 .. N); + Descriptors (J).Buffer_Index := N; + end if; + end; + + else + -- Add what we read to the buffer + + if Descriptors (J).Buffer_Index + N - 1 > + Descriptors (J).Buffer_Size + then + -- If the user wants to know when we have + -- read more than the buffer can contain. + + if Full_Buffer then + Result := Expect_Full_Buffer; + return; + end if; + + -- Keep as much as possible from the buffer, + -- and forget old characters. + + Descriptors (J).Buffer + (1 .. Descriptors (J).Buffer_Size - N) := + Descriptors (J).Buffer + (N - Descriptors (J).Buffer_Size + + Descriptors (J).Buffer_Index + 1 .. + Descriptors (J).Buffer_Index); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer_Size - N; + end if; + + -- Keep what we read in the buffer. + + Descriptors (J).Buffer + (Descriptors (J).Buffer_Index + 1 .. + Descriptors (J).Buffer_Index + N) := + Buffer (1 .. N); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer_Index + N; + end if; + + -- Call each of the output filter with what we + -- read. + + Call_Filters + (Descriptors (J).all, Buffer (1 .. N), Output); + + Result := Expect_Match (N); + return; + end if; + end if; + end loop; + end case; + end loop; + end; + end Expect_Internal; + + ---------------- + -- Expect_Out -- + ---------------- + + function Expect_Out (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); + end Expect_Out; + + ---------------------- + -- Expect_Out_Match -- + ---------------------- + + function Expect_Out_Match (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer + (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); + end Expect_Out_Match; + + ----------- + -- Flush -- + ----------- + + procedure Flush + (Descriptor : in out Process_Descriptor; + Timeout : Integer := 0) + is + Num_Descriptors : Integer; + N : Integer; + Is_Set : aliased Integer; + Buffer_Size : Integer := 8192; + Buffer : aliased String (1 .. Buffer_Size); + + begin + -- Empty the current buffer + + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + Reinitialize_Buffer (Descriptor); + + -- Read everything from the process to flush its output + + loop + Num_Descriptors := + Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error ? + + when -1 => + raise Process_Died; + + -- Timeout => End of flush + + when 0 => + return; + + -- Some input + + when others => + if Is_Set = 1 then + N := Read (Descriptor.Output_Fd, Buffer'Address, + Buffer_Size); + + if N = -1 then + raise Process_Died; + elsif N = 0 then + return; + end if; + end if; + end case; + end loop; + + end Flush; + + ------------------ + -- Get_Error_Fd -- + ------------------ + + function Get_Error_Fd + (Descriptor : Process_Descriptor) + return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Error_Fd; + end Get_Error_Fd; + + ------------------ + -- Get_Input_Fd -- + ------------------ + + function Get_Input_Fd + (Descriptor : Process_Descriptor) + return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Input_Fd; + end Get_Input_Fd; + + ------------------- + -- Get_Output_Fd -- + ------------------- + + function Get_Output_Fd + (Descriptor : Process_Descriptor) + return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Output_Fd; + end Get_Output_Fd; + + ------------- + -- Get_Pid -- + ------------- + + function Get_Pid + (Descriptor : Process_Descriptor) + return Process_Id + is + begin + return Descriptor.Pid; + end Get_Pid; + + --------------- + -- Interrupt -- + --------------- + + procedure Interrupt (Descriptor : in out Process_Descriptor) is + SIGINT : constant := 2; + + begin + Send_Signal (Descriptor, SIGINT); + end Interrupt; + + ------------------ + -- Lock_Filters -- + ------------------ + + procedure Lock_Filters (Descriptor : in out Process_Descriptor) is + begin + Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; + end Lock_Filters; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + procedure Non_Blocking_Spawn + (Descriptor : out Process_Descriptor'Class; + Command : String; + Args : GNAT.OS_Lib.Argument_List; + Buffer_Size : Natural := 4096; + Err_To_Out : Boolean := False) + is + function Fork return Process_Id; + pragma Import (C, Fork, "__gnat_expect_fork"); + -- Starts a new process if possible. + -- See the Unix command fork for more information. On systems that + -- don't support this capability (Windows...), this command does + -- nothing, and Fork will return Null_Pid. + + Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; + + Arg : String_Access; + Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; + + Command_With_Path : String_Access; + + begin + -- Create the rest of the pipes + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + -- Fork a new process + + Descriptor.Pid := Fork; + + -- Are we now in the child (or, for Windows, still in the common + -- process). + + if Descriptor.Pid = Null_Pid then + + Command_With_Path := Locate_Exec_On_Path (Command); + + -- Prepare an array of arguments to pass to C + Arg := new String (1 .. Command_With_Path'Length + 1); + Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (1) := Arg.all'Address; + + for J in Args'Range loop + Arg := new String (1 .. Args (J)'Length + 1); + Arg (1 .. Args (J)'Length) := Args (J).all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (J + 2 - Args'First) := Arg.all'Address; + end loop; + + Arg_List (Arg_List'Last) := System.Null_Address; + + -- This does not return on Unix systems + + Set_Up_Child_Communications + (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, + Arg_List'Address); + + Free (Command_With_Path); + end if; + + -- Did we have an error when spawning the child ? + + if Descriptor.Pid < Null_Pid then + null; + else + -- We are now in the parent process + + Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); + end if; + + -- Create the buffer + + Descriptor.Buffer_Size := Buffer_Size; + + if Buffer_Size /= 0 then + Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); + end if; + end Non_Blocking_Spawn; + + ------------------------- + -- Reinitialize_Buffer -- + ------------------------- + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class) + is + begin + if Descriptor.Buffer_Size = 0 then + declare + Tmp : String_Access := Descriptor.Buffer; + + begin + Descriptor.Buffer := + new String + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); + + if Tmp /= null then + Descriptor.Buffer.all := Tmp + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + Free (Tmp); + end if; + end; + + Descriptor.Buffer_Index := Descriptor.Buffer'Last; + + else + Descriptor.Buffer + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := + Descriptor.Buffer + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + + if Descriptor.Buffer_Index > Descriptor.Last_Match_End then + Descriptor.Buffer_Index := + Descriptor.Buffer_Index - Descriptor.Last_Match_End; + else + Descriptor.Buffer_Index := 0; + end if; + end if; + + Descriptor.Last_Match_Start := 0; + Descriptor.Last_Match_End := 0; + end Reinitialize_Buffer; + + ------------------- + -- Remove_Filter -- + ------------------- + + procedure Remove_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function) + is + Previous : Filter_List := null; + Current : Filter_List := Descriptor.Filters; + + begin + while Current /= null loop + if Current.Filter = Filter then + if Previous = null then + Descriptor.Filters := Current.Next; + else + Previous.Next := Current.Next; + end if; + end if; + + Previous := Current; + Current := Current.Next; + end loop; + end Remove_Filter; + + ---------- + -- Send -- + ---------- + + procedure Send + (Descriptor : in out Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False) + is + N : Natural; + Full_Str : constant String := Str & ASCII.LF; + Last : Natural; + Result : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + begin + if Empty_Buffer then + + -- Force a read on the process if there is anything waiting. + + Expect_Internal (Descriptors, Result, + Timeout => 0, Full_Buffer => False); + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + + -- Empty the buffer + + Reinitialize_Buffer (Descriptor); + end if; + + if Add_LF then + Last := Full_Str'Last; + else + Last := Full_Str'Last - 1; + end if; + + Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); + + N := Write (Descriptor.Input_Fd, + Full_Str'Address, + Last - Full_Str'First + 1); + end Send; + + ----------------- + -- Send_Signal -- + ----------------- + + procedure Send_Signal + (Descriptor : Process_Descriptor; + Signal : Integer) + is + begin + Kill (Descriptor.Pid, Signal); + -- ??? Need to check process status here. + end Send_Signal; + + --------------------------------- + -- Set_Up_Child_Communications -- + --------------------------------- + + procedure Set_Up_Child_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : in String; + Args : in System.Address) + is + Input, Output, Error : File_Descriptor; + + begin + -- Since Windows does not have a separate fork/exec, we need to + -- perform the following actions: + -- - save stdin, stdout, stderr + -- - replace them by our pipes + -- - create the child with process handle inheritance + -- - revert to the previous stdin, stdout and stderr. + + Input := Dup (GNAT.OS_Lib.Standin); + Output := Dup (GNAT.OS_Lib.Standout); + Error := Dup (GNAT.OS_Lib.Standerr); + + -- Since we are still called from the parent process, there is no way + -- currently we can cleanly close the unneeded ends of the pipes, but + -- this doesn't really matter. + -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input. + + Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); + Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); + Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); + + Portable_Execvp (Cmd & ASCII.Nul, Args); + + -- The following commands are not executed on Unix systems, and are + -- only required for Windows systems. We are now in the parent process. + + -- Restore the old descriptors + + Dup2 (Input, GNAT.OS_Lib.Standin); + Dup2 (Output, GNAT.OS_Lib.Standout); + Dup2 (Error, GNAT.OS_Lib.Standerr); + Close (Input); + Close (Output); + Close (Error); + end Set_Up_Child_Communications; + + --------------------------- + -- Set_Up_Communications -- + --------------------------- + + procedure Set_Up_Communications + (Pid : in out Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type) is + begin + -- Create the pipes + + if Create_Pipe (Pipe1) /= 0 then + return; + end if; + + if Create_Pipe (Pipe2) /= 0 then + return; + end if; + + Pid.Input_Fd := Pipe1.Output; + Pid.Output_Fd := Pipe2.Input; + + if Err_To_Out then + Pipe3.all := Pipe2.all; + else + if Create_Pipe (Pipe3) /= 0 then + return; + end if; + end if; + + Pid.Error_Fd := Pipe3.Input; + end Set_Up_Communications; + + ---------------------------------- + -- Set_Up_Parent_Communications -- + ---------------------------------- + + procedure Set_Up_Parent_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type) + is + begin + Close (Pipe1.Input); + Close (Pipe2.Output); + Close (Pipe3.Output); + end Set_Up_Parent_Communications; + + ------------------ + -- Trace_Filter -- + ------------------ + + procedure Trace_Filter + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address) + is + begin + GNAT.IO.Put (Str); + end Trace_Filter; + + -------------------- + -- Unlock_Filters -- + -------------------- + + procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is + begin + if Descriptor.Filters_Lock > 0 then + Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; + end if; + end Unlock_Filters; + +end GNAT.Expect; diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads new file mode 100644 index 00000000000..5df3e73d43b --- /dev/null +++ b/gcc/ada/g-expect.ads @@ -0,0 +1,589 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 2000-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Currently this package is implemented on all native GNAT ports except +-- for VMS. It is not yet implemented for any of the cross-ports (e.g. it +-- is not available for VxWorks or LynxOS). +-- +-- Usage +-- ===== +-- +-- This package provides a set of subprograms similar to what is available +-- with the standard Tcl Expect tool. + +-- It allows you to easily spawn and communicate with an external process. +-- You can send commands or inputs to the process, and compare the output +-- with some expected regular expression. +-- +-- Usage example: +-- +-- Non_Blocking_Spawn (Fd, "ftp machine@domaine"); +-- Timeout := 10000; -- 10 seconds +-- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"), +-- Timeout); +-- case Result is +-- when 1 => Send (Fd, "my_name"); -- matched "user" +-- when 2 => Send (Fd, "my_passwd"); -- matched "passwd" +-- when Expect_Timeout => null; -- timeout +-- when others => null; +-- end case; +-- Close (Fd); +-- +-- You can also combine multiple regular expressions together, and get the +-- specific string matching a parenthesis pair by doing something like. If you +-- expect either "lang=optional ada" or "lang=ada" from the external process, +-- you can group the two together, which is more efficient, and simply get the +-- name of the language by doing: +-- +-- declare +-- Matched : Regexp_Array (0 .. 2); +-- begin +-- Expect (Fd, Result, "lang=(optional)? ([a-z]+)", Matched); +-- Put_Line ("Seen: " & +-- Expect_Out (Fd) (Matched (2).First .. Matched (2).Last)); +-- end; +-- +-- Alternatively, you might choose to use a lower-level interface to the +-- processes, where you can give your own input and output filters every +-- time characters are read from or written to the process. +-- +-- procedure My_Filter (Descriptor : Process_Descriptor; Str : String) is +-- begin +-- Put_Line (Str); +-- end; +-- +-- Fd := Non_Blocking_Spawn ("tail -f a_file"); +-- Add_Filter (Fd, My_Filter'Access, Output); +-- Expect (Fd, Result, "", 0); -- wait forever +-- +-- The above example should probably be run in a separate task, since it is +-- blocking on the call to Expect. +-- +-- Both examples can be combined, for instance to systematically print the +-- output seen by expect, even though you still want to let Expect do the +-- filtering. You can use the Trace_Filter subprogram for such a filter. +-- +-- If you want to get the output of a simple command, and ignore any previous +-- existing output, it is recommended to do something like: +-- +-- Expect (Fd, Result, ".*", Timeout => 0); +-- -- empty the buffer, by matching everything (after checking +-- -- if there was any input). +-- Send (Fd, "command"); +-- Expect (Fd, Result, ".."); -- match only on the output of command +-- +-- Task Safety +-- =========== +-- +-- This package is not task-safe. However, you can easily make is task safe +-- by encapsulating the type Process_Descriptor in a protected record. +-- There should not be concurrent calls to Expect. + +with System; +with GNAT.OS_Lib; +with GNAT.Regpat; + +package GNAT.Expect is + + type Process_Id is new Integer; + Invalid_Pid : constant Process_Id := -1; + Null_Pid : constant Process_Id := 0; + + type Filter_Type is (Output, Input, Died); + -- The signals that are emitted by the Process_Descriptor upon state + -- changed in the child. One can connect to any of this signal through + -- the Add_Filter subprograms. + -- + -- Output => Every time new characters are read from the process + -- associated with Descriptor, the filter is called with + -- these new characters in argument. + -- + -- Note that output is only generated when the program is + -- blocked in a call to Expect. + -- + -- Input => Every time new characters are written to the process + -- associated with Descriptor, the filter is called with + -- these new characters in argument. + -- Note that input is only generated by calls to Send. + -- + -- Died => The child process has died, or was explicitly killed + + type Process_Descriptor is tagged private; + -- Contains all the components needed to describe a process handled + -- in this package, including a process identifier, file descriptors + -- associated with the standard input, output and error, and the buffer + -- needed to handle the expect calls. + + type Process_Descriptor_Access is access Process_Descriptor'Class; + + ------------------------ + -- Spawning a process -- + ------------------------ + + procedure Non_Blocking_Spawn + (Descriptor : out Process_Descriptor'Class; + Command : String; + Args : GNAT.OS_Lib.Argument_List; + Buffer_Size : Natural := 4096; + Err_To_Out : Boolean := False); + -- This call spawns a new process and allows sending commands to + -- the process and/or automatic parsing of the output. + -- + -- The expect buffer associated with that process can contain at most + -- Buffer_Size characters. Older characters are simply discarded when + -- this buffer is full. Beware that if the buffer is too big, this could + -- slow down the Expect calls if not output is matched, since Expect has + -- to match all the regexp against all the characters in the buffer. + -- If Buffer_Size is 0, there is no limit (ie all the characters are kept + -- till Expect matches), but this is slower. + -- + -- If Err_To_Out is True, then the standard error of the spawned process is + -- connected to the standard output. This is the only way to get the + -- Except subprograms also match on output on standard error. + -- + -- Invalid_Process is raised if the process could not be spawned. + + procedure Close (Descriptor : in out Process_Descriptor); + -- Terminate the process and close the pipes to it. It implicitly + -- does the 'wait' command required to clean up the process table. + -- This also frees the buffer associated with the process id. + + procedure Send_Signal + (Descriptor : Process_Descriptor; + Signal : Integer); + -- Send a given signal to the process. + + procedure Interrupt (Descriptor : in out Process_Descriptor); + -- Interrupt the process (the equivalent of Ctrl-C on unix and windows) + -- and call close if the process dies. + + function Get_Input_Fd + (Descriptor : Process_Descriptor) + return GNAT.OS_Lib.File_Descriptor; + -- Return the input file descriptor associated with Descriptor. + + function Get_Output_Fd + (Descriptor : Process_Descriptor) + return GNAT.OS_Lib.File_Descriptor; + -- Return the output file descriptor associated with Descriptor. + + function Get_Error_Fd + (Descriptor : Process_Descriptor) + return GNAT.OS_Lib.File_Descriptor; + -- Return the error output file descriptor associated with Descriptor. + + function Get_Pid + (Descriptor : Process_Descriptor) + return Process_Id; + -- Return the process id assocated with a given process descriptor. + + -------------------- + -- Adding filters -- + -------------------- + + -- This is a rather low-level interface to subprocesses, since basically + -- the filtering is left entirely to the user. See the Expect subprograms + -- below for higher level functions. + + type Filter_Function is access + procedure + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address); + -- Function called every time new characters are read from or written + -- to the process. + -- + -- Str is a string of all these characters. + -- + -- User_Data, if specified, is a user specific data that will be passed to + -- the filter. Note that no checks are done on this parameter that should + -- be used with cautiousness. + + procedure Add_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function; + Filter_On : Filter_Type := Output; + User_Data : System.Address := System.Null_Address; + After : Boolean := False); + -- Add a new filter for one of the filter type. This filter will be + -- run before all the existing filters, unless After is set True, + -- in which case it will be run after existing filters. User_Data + -- is passed as is to the filter procedure. + + procedure Remove_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function); + -- Remove a filter from the list of filters (whatever the type of the + -- filter). + + procedure Trace_Filter + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address); + -- Function that can be used a filter and that simply outputs Str on + -- Standard_Output. This is mainly used for debugging purposes. + -- User_Data is ignored. + + procedure Lock_Filters (Descriptor : in out Process_Descriptor); + -- Temporarily disables all output and input filters. They will be + -- reactivated only when Unlock_Filters has been called as many times as + -- Lock_Filters; + + procedure Unlock_Filters (Descriptor : in out Process_Descriptor); + -- Unlocks the filters. They are reactivated only if Unlock_Filters + -- has been called as many times as Lock_Filters. + + ------------------ + -- Sending data -- + ------------------ + + procedure Send + (Descriptor : in out Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False); + -- Send a string to the file descriptor. + -- + -- The string is not formatted in any way, except if Add_LF is True, + -- in which case an ASCII.LF is added at the end, so that Str is + -- recognized as a command by the external process. + -- + -- If Empty_Buffer is True, any input waiting from the process (or in the + -- buffer) is first discarded before the command is sent. The output + -- filters are of course called as usual. + + ----------------------------------------------------------- + -- Working on the output (single process, simple regexp) -- + ----------------------------------------------------------- + + type Expect_Match is new Integer; + Expect_Full_Buffer : constant Expect_Match := -1; + -- If the buffer was full and some characters were discarded. + + Expect_Timeout : constant Expect_Match := -2; + -- If not output matching the regexps was found before the timeout. + + function "+" (S : String) return GNAT.OS_Lib.String_Access; + -- Allocate some memory for the string. This is merely a convenience + -- convenience function to help create the array of regexps in the + -- call to Expect. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Wait till a string matching Fd can be read from Fd, and return 1 + -- if a match was found. + -- + -- It consumes all the characters read from Fd until a match found, and + -- then sets the return values for the subprograms Expect_Out and + -- Expect_Out_Match. + -- + -- The empty string "" will never match, and can be used if you only want + -- to match after a specific timeout. Beware that if Timeout is -1 at the + -- time, the current task will be blocked forever. + -- + -- This command times out after Timeout milliseconds (or never if Timeout + -- is -1). In that case, Expect_Timeout is returned. The value returned by + -- Expect_Out and Expect_Out_Match are meaningless in that case. + -- + -- Note that using a timeout of 0ms leads to unpredictable behavior, since + -- the result depends on whether the process has already sent some output + -- the first time Expect checks, and this depends on the operating system. + -- + -- The regular expression must obey the syntax described in GNAT.Regpat. + -- + -- If Full_Buffer is True, then Expect will match if the buffer was too + -- small and some characters were about to be discarded. In that case, + -- Expect_Full_Buffer is returned. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as the previous one, but with a precompiled regular expression. + -- This is more efficient however, especially if you are using this + -- expression multiple times, since this package won't need to recompile + -- the regexp every time. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as above, but it is now possible to get the indexes of the + -- substrings for the parentheses in the regexp (see the example at the + -- top of this package, as well as the documentation in the package + -- GNAT.Regpat). + -- + -- Matched'First should be 0, and this index will contain the indexes for + -- the whole string that was matched. The index 1 will contain the indexes + -- for the first parentheses-pair, and so on. + + ------------ + -- Expect -- + ------------ + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as above, but with a precompiled regular expression. + + ------------------------------------------------------------- + -- Working on the output (single process, multiple regexp) -- + ------------------------------------------------------------- + + type Regexp_Array is array (Positive range <>) of GNAT.OS_Lib.String_Access; + + type Pattern_Matcher_Access is access GNAT.Regpat.Pattern_Matcher; + type Compiled_Regexp_Array is array (Positive range <>) + of Pattern_Matcher_Access; + + function "+" + (P : GNAT.Regpat.Pattern_Matcher) + return Pattern_Matcher_Access; + -- Allocate some memory for the pattern matcher. + -- This is only a convenience function to help create the array of + -- compiled regular expressoins. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Wait till a string matching one of the regular expressions in Regexps + -- is found. This function returns the index of the regexp that matched. + -- This command is blocking, but will timeout after Timeout milliseconds. + -- In that case, Timeout is returned. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as the previous one, but with precompiled regular expressions. + -- This can be much faster if you are using them multiple times. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as above, except that you can also access the parenthesis + -- groups inside the matching regular expression. + -- The first index in Matched must be 0, or Constraint_Error will be + -- raised. The index 0 contains the indexes for the whole string that was + -- matched, the index 1 contains the indexes for the first parentheses + -- pair, and so on. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as above, but with precompiled regular expressions. + -- The first index in Matched must be 0, or Constraint_Error will be + -- raised. + + ------------------------------------------- + -- Working on the output (multi-process) -- + ------------------------------------------- + + type Multiprocess_Regexp is record + Descriptor : Process_Descriptor_Access; + Regexp : Pattern_Matcher_Access; + end record; + type Multiprocess_Regexp_Array is array (Positive range <>) + of Multiprocess_Regexp; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as above, but for multi processes. + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False); + -- Same as the previous one, but for multiple processes. + -- This procedure finds the first regexp that match the associated process. + + ------------------------ + -- Getting the output -- + ------------------------ + + procedure Flush + (Descriptor : in out Process_Descriptor; + Timeout : Integer := 0); + -- Discard all output waiting from the process. + -- + -- This output is simply discarded, and no filter is called. This output + -- will also not be visible by the next call to Expect, nor will any + -- output currently buffered. + -- + -- Timeout is the delay for which we wait for output to be available from + -- the process. If 0, we only get what is immediately available. + + function Expect_Out (Descriptor : Process_Descriptor) return String; + -- Return the string matched by the last Expect call. + -- + -- The returned string is in fact the concatenation of all the strings + -- read from the file descriptor up to, and including, the characters + -- that matched the regular expression. + -- + -- For instance, with an input "philosophic", and a regular expression + -- "hi" in the call to expect, the strings returned the first and second + -- time would be respectively "phi" and "losophi". + + function Expect_Out_Match (Descriptor : Process_Descriptor) return String; + -- Return the string matched by the last Expect call. + -- + -- The returned string includes only the character that matched the + -- specific regular expression. All the characters that came before are + -- simply discarded. + -- + -- For instance, with an input "philosophic", and a regular expression + -- "hi" in the call to expect, the strings returned the first and second + -- time would both be "hi". + + ---------------- + -- Exceptions -- + ---------------- + + Invalid_Process : exception; + -- Raised by most subprograms above when the parameter Descriptor is not a + -- valid process or is a closed process. + + Process_Died : exception; + -- Raised by all the expect subprograms if Descriptor was originally a + -- valid process that died while Expect was executing. It is also raised + -- when Expect receives an end-of-file. + + ------------------------ + -- Internal functions -- + ------------------------ + + -- The following subprograms are provided so that it is easy to write + -- extensions to this package. However, clients should not use these + -- routines directly. + + procedure Portable_Execvp (Cmd : String; Args : System.Address); + -- Executes, in a portable way, the command Cmd (full path must be + -- specified), with the given Args. Note that the first element in Args + -- must be the executable name, and the last element must be a null + -- pointer + +private + type Filter_List_Elem; + type Filter_List is access Filter_List_Elem; + type Filter_List_Elem is record + Filter : Filter_Function; + User_Data : System.Address; + Filter_On : Filter_Type; + Next : Filter_List; + end record; + + type Pipe_Type is record + Input, Output : GNAT.OS_Lib.File_Descriptor; + end record; + -- This type represents a pipe, used to communicate between two processes. + + procedure Set_Up_Communications + (Pid : in out Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type); + -- Set up all the communication pipes and file descriptors prior to + -- spawning the child process. + + procedure Set_Up_Parent_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type); + -- Finish the set up of the pipes while in the parent process + + procedure Set_Up_Child_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : String; + Args : System.Address); + -- Finish the set up of the pipes while in the child process + -- This also spawns the child process (based on Cmd). + -- On systems that support fork, this procedure is executed inside the + -- newly created process. + + type Process_Descriptor is tagged record + Pid : Process_Id := Invalid_Pid; + Input_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; + Output_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; + Error_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; + Filters_Lock : Integer := 0; + + Filters : Filter_List := null; + + Buffer : GNAT.OS_Lib.String_Access := null; + Buffer_Size : Natural := 0; + Buffer_Index : Natural := 0; + + Last_Match_Start : Natural := 0; + Last_Match_End : Natural := 0; + end record; + + pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp"); + +end GNAT.Expect; diff --git a/gcc/ada/g-flocon.ads b/gcc/ada/g-flocon.ads new file mode 100644 index 00000000000..c5d0cb2d03d --- /dev/null +++ b/gcc/ada/g-flocon.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . F L O A T _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Control functions for floating-point unit + +package GNAT.Float_Control is + + procedure Reset; + -- Reset the floating-point processor to the default state needed to get + -- correct Ada semantics for the target. Some third party tools change + -- the settings for the floating-point processor. Reset can be called + -- to reset the floating-point processor into the mode required by GNAT + -- for correct operation. Use this call after a call to foreign code if + -- you suspect incorrect floating-point operation after the call. + -- + -- For example under Windows NT some system DLL calls change the default + -- FPU arithmetic to 64 bit precision mode. However, since in Ada 95 it + -- is required to provide full access to the floating-point types of the + -- architecture, GNAT requires full 80-bit precision mode, and Reset makes + -- sure this mode is established. + -- + -- Similarly on the PPC processor, it is important that overflow and + -- underflow exceptions be disabled. + -- + -- The call to Reset simply has no effect if the target environment + -- does not give rise to such concerns. + +private + pragma Import (C, Reset, "__gnat_init_float"); + +end GNAT.Float_Control; diff --git a/gcc/ada/g-hesora.adb b/gcc/ada/g-hesora.adb new file mode 100644 index 00000000000..6657a975182 --- /dev/null +++ b/gcc/ada/g-hesora.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ A -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- Copyright (C) 1995-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Heap_Sort_A is + + ---------- + -- Sort -- + ---------- + + -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) + -- as described by Knuth ("The Art of Programming", Volume III, first + -- edition, section 5.2.3, p. 145-147) with the modification that is + -- mentioned in exercise 18. For more details on this algorithm, see + -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray + -- Phase Problem". University of Chicago, 1968, which was the first + -- publication of the modification, which reduces the number of compares + -- from 2NlogN to NlogN. + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is + + Max : Natural := N; + -- Current Max index in tree being sifted + + procedure Sift (S : Positive); + -- This procedure sifts up node S, i.e. converts the subtree rooted + -- at node S into a heap, given the precondition that any sons of + -- S are already heaps. On entry, the contents of node S is found + -- in the temporary (index 0), the actual contents of node S on + -- entry are irrelevant. This is just a minor optimization to avoid + -- what would otherwise be two junk moves in phase two of the sort. + + procedure Sift (S : Positive) is + C : Positive := S; + Son : Positive; + Father : Positive; + + begin + -- This is where the optimization is done, normally we would do a + -- comparison at each stage between the current node and the larger + -- of the two sons, and continue the sift only if the current node + -- was less than this maximum. In this modified optimized version, + -- we assume that the current node will be less than the larger + -- son, and unconditionally sift up. Then when we get to the bottom + -- of the tree, we check parents to make sure that we did not make + -- a mistake. This roughly cuts the number of comparisions in half, + -- since it is almost always the case that our assumption is correct. + + -- Loop to pull up larger sons + + loop + Son := 2 * C; + exit when Son > Max; + + if Son < Max and then Lt (Son, Son + 1) then + Son := Son + 1; + end if; + + Move (Son, C); + C := Son; + end loop; + + -- Loop to check fathers + + while C /= S loop + Father := C / 2; + + if Lt (Father, 0) then + Move (Father, C); + C := Father; + else + exit; + end if; + end loop; + + -- Last step is to pop the sifted node into place + + Move (0, C); + end Sift; + + -- Start of processing for Sort + + begin + -- Phase one of heapsort is to build the heap. This is done by + -- sifting nodes N/2 .. 1 in sequence. + + for J in reverse 1 .. N / 2 loop + Move (J, 0); + Sift (J); + end loop; + + -- In phase 2, the largest node is moved to end, reducing the size + -- of the tree by one, and the displaced node is sifted down from + -- the top, so that the largest node is again at the top. + + while Max > 1 loop + Move (Max, 0); + Move (1, Max); + Max := Max - 1; + Sift (1); + end loop; + + end Sort; + +end GNAT.Heap_Sort_A; diff --git a/gcc/ada/g-hesora.ads b/gcc/ada/g-hesora.ads new file mode 100644 index 00000000000..019c0d134ee --- /dev/null +++ b/gcc/ada/g-hesora.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ A -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 1995-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Heapsort using access to procedure parameters + +-- This package provides a heapsort routine that works with access to +-- subprogram parameters, so that it can be used with different types with +-- shared sorting code. See also GNAT.Heap_Sort_G, the generic version, +-- which is a little more efficient but does not allow code sharing. +-- The generic version is also Pure, while the access version can +-- only be Preelaborate. + +package GNAT.Heap_Sort_A is +pragma Preelaborate (Heap_Sort_A); + + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + type Move_Procedure is access procedure (From : Natural; To : Natural); + -- A pointer to a procedure that moves the data item with index From to + -- the data item with index To. An index value of zero is used for moves + -- from and to the single temporary location used by the sort. + + type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; + -- A pointer to a function that compares two items and returns True if + -- the item with index Op1 is less than the item with index Op2, and False + -- if the Op1 item is greater than or equal to the Op2 item. + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is not + -- stable, i.e. the order of equal elements in the input is not preserved. + +end GNAT.Heap_Sort_A; diff --git a/gcc/ada/g-hesorg.adb b/gcc/ada/g-hesorg.adb new file mode 100644 index 00000000000..45fb3d0321d --- /dev/null +++ b/gcc/ada/g-hesorg.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- Copyright (C) 1995-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Heap_Sort_G is + + ---------- + -- Sort -- + ---------- + + -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) + -- as described by Knuth ("The Art of Programming", Volume III, first + -- edition, section 5.2.3, p. 145-147) with the modification that is + -- mentioned in exercise 18. For more details on this algorithm, see + -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray + -- Phase Problem". University of Chicago, 1968, which was the first + -- publication of the modification, which reduces the number of compares + -- from 2NlogN to NlogN. + + procedure Sort (N : Natural) is + + Max : Natural := N; + -- Current Max index in tree being sifted + + procedure Sift (S : Positive); + -- This procedure sifts up node S, i.e. converts the subtree rooted + -- at node S into a heap, given the precondition that any sons of + -- S are already heaps. On entry, the contents of node S is found + -- in the temporary (index 0), the actual contents of node S on + -- entry are irrelevant. This is just a minor optimization to avoid + -- what would otherwise be two junk moves in phase two of the sort. + + procedure Sift (S : Positive) is + C : Positive := S; + Son : Positive; + Father : Positive; + + begin + -- This is where the optimization is done, normally we would do a + -- comparison at each stage between the current node and the larger + -- of the two sons, and continue the sift only if the current node + -- was less than this maximum. In this modified optimized version, + -- we assume that the current node will be less than the larger + -- son, and unconditionally sift up. Then when we get to the bottom + -- of the tree, we check parents to make sure that we did not make + -- a mistake. This roughly cuts the number of comparisions in half, + -- since it is almost always the case that our assumption is correct. + + -- Loop to pull up larger sons + + loop + Son := 2 * C; + exit when Son > Max; + + if Son < Max and then Lt (Son, Son + 1) then + Son := Son + 1; + end if; + + Move (Son, C); + C := Son; + end loop; + + -- Loop to check fathers + + while C /= S loop + Father := C / 2; + + if Lt (Father, 0) then + Move (Father, C); + C := Father; + else + exit; + end if; + end loop; + + -- Last step is to pop the sifted node into place + + Move (0, C); + end Sift; + + -- Start of processing for Sort + + begin + -- Phase one of heapsort is to build the heap. This is done by + -- sifting nodes N/2 .. 1 in sequence. + + for J in reverse 1 .. N / 2 loop + Move (J, 0); + Sift (J); + end loop; + + -- In phase 2, the largest node is moved to end, reducing the size + -- of the tree by one, and the displaced node is sifted down from + -- the top, so that the largest node is again at the top. + + while Max > 1 loop + Move (Max, 0); + Move (1, Max); + Max := Max - 1; + Sift (1); + end loop; + + end Sort; + +end GNAT.Heap_Sort_G; diff --git a/gcc/ada/g-hesorg.ads b/gcc/ada/g-hesorg.ads new file mode 100644 index 00000000000..1611def563b --- /dev/null +++ b/gcc/ada/g-hesorg.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1995-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Heapsort generic package using formal procedures + +-- This package provides a generic heapsort routine that can be used with +-- different types of data. See also GNAT.Heap_Sort_A, a version that works +-- with subprogram parameters, allowing code sharing. The generic version +-- is slightly more efficient but does not allow code sharing. The generic +-- version is also Pure, while the access version can only be Preelaborate. + +generic + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + with procedure Move (From : Natural; To : Natural); + -- A procedure that moves the data item with index From to the data item + -- with Index To. An index value of zero is used for moves from and to a + -- single temporary location used by the sort. + + with function Lt (Op1, Op2 : Natural) return Boolean; + -- A function that compares two items and returns True if the item with + -- index Op1 is less than the item with Index Op2, and False if the Op1 + -- item is greater than or equal to the Op2 item. + +package GNAT.Heap_Sort_G is +pragma Pure (Heap_Sort_G); + + procedure Sort (N : Natural); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is not + -- stable, i.e. the order of equal elements in the input is not preserved. + +end GNAT.Heap_Sort_G; diff --git a/gcc/ada/g-htable.adb b/gcc/ada/g-htable.adb new file mode 100644 index 00000000000..4560049518c --- /dev/null +++ b/gcc/ada/g-htable.adb @@ -0,0 +1,362 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . H T A B L E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1995-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; +package body GNAT.HTable is + + -------------------- + -- Static_HTable -- + -------------------- + + package body Static_HTable is + + Table : array (Header_Num) of Elmt_Ptr; + + Iterator_Index : Header_Num; + Iterator_Ptr : Elmt_Ptr; + Iterator_Started : Boolean := False; + + function Get_Non_Null return Elmt_Ptr; + -- Returns Null_Ptr if Iterator_Started is false of the Table is + -- empty. Returns Iterator_Ptr if non null, or the next non null + -- element in table if any. + + --------- + -- Get -- + --------- + + function Get (K : Key) return Elmt_Ptr is + Elmt : Elmt_Ptr; + + begin + Elmt := Table (Hash (K)); + + loop + if Elmt = Null_Ptr then + return Null_Ptr; + + elsif Equal (Get_Key (Elmt), K) then + return Elmt; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First return Elmt_Ptr is + begin + Iterator_Started := True; + Iterator_Index := Table'First; + Iterator_Ptr := Table (Iterator_Index); + return Get_Non_Null; + end Get_First; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next return Elmt_Ptr is + begin + if not Iterator_Started then + return Null_Ptr; + end if; + + Iterator_Ptr := Next (Iterator_Ptr); + return Get_Non_Null; + end Get_Next; + + ------------------ + -- Get_Non_Null -- + ------------------ + + function Get_Non_Null return Elmt_Ptr is + begin + while Iterator_Ptr = Null_Ptr loop + if Iterator_Index = Table'Last then + Iterator_Started := False; + return Null_Ptr; + end if; + + Iterator_Index := Iterator_Index + 1; + Iterator_Ptr := Table (Iterator_Index); + end loop; + + return Iterator_Ptr; + end Get_Non_Null; + + ------------ + -- Remove -- + ------------ + + procedure Remove (K : Key) is + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr; + Next_Elmt : Elmt_Ptr; + + begin + Elmt := Table (Index); + + if Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Elmt), K) then + Table (Index) := Next (Elmt); + + else + loop + Next_Elmt := Next (Elmt); + + if Next_Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Next_Elmt), K) then + Set_Next (Elmt, Next (Next_Elmt)); + return; + + else + Elmt := Next_Elmt; + end if; + end loop; + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + for J in Table'Range loop + Table (J) := Null_Ptr; + end loop; + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (E : Elmt_Ptr) is + Index : Header_Num; + + begin + Index := Hash (Get_Key (E)); + Set_Next (E, Table (Index)); + Table (Index) := E; + end Set; + + end Static_HTable; + + -------------------- + -- Simple_HTable -- + -------------------- + + package body Simple_HTable is + + type Element_Wrapper; + type Elmt_Ptr is access all Element_Wrapper; + type Element_Wrapper is record + K : Key; + E : Element; + Next : Elmt_Ptr; + end record; + + procedure Free is new + Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + function Next (E : Elmt_Ptr) return Elmt_Ptr; + function Get_Key (E : Elmt_Ptr) return Key; + + package Tab is new Static_HTable ( + Header_Num => Header_Num, + Element => Element_Wrapper, + Elmt_Ptr => Elmt_Ptr, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Key, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + --------- + -- Get -- + --------- + + function Get (K : Key) return Element is + Tmp : constant Elmt_Ptr := Tab.Get (K); + + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First return Element is + Tmp : constant Elmt_Ptr := Tab.Get_First; + + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_First; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Elmt_Ptr) return Key is + begin + return E.K; + end Get_Key; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next return Element is + Tmp : constant Elmt_Ptr := Tab.Get_Next; + + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_Next; + + ---------- + -- Next -- + ---------- + + function Next (E : Elmt_Ptr) return Elmt_Ptr is + begin + return E.Next; + end Next; + + ------------ + -- Remove -- + ------------ + + procedure Remove (K : Key) is + Tmp : Elmt_Ptr; + + begin + Tmp := Tab.Get (K); + + if Tmp /= null then + Tab.Remove (K); + Free (Tmp); + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + E1, E2 : Elmt_Ptr; + + begin + E1 := Tab.Get_First; + while E1 /= null loop + E2 := Tab.Get_Next; + Free (E1); + E1 := E2; + end loop; + + Tab.Reset; + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (K : Key; E : Element) is + Tmp : constant Elmt_Ptr := Tab.Get (K); + + begin + if Tmp = null then + Tab.Set (new Element_Wrapper'(K, E, null)); + else + Tmp.E := E; + end if; + end Set; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is + begin + E.Next := Next; + end Set_Next; + end Simple_HTable; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : String) return Header_Num is + + type Uns is mod 2 ** 32; + + function Rotate_Left (Value : Uns; Amount : Natural) return Uns; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Uns := 0; + + begin + for J in Key'Range loop + Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J)); + end loop; + + return Header_Num'First + + Header_Num'Base (Tmp mod Header_Num'Range_Length); + end Hash; + +end GNAT.HTable; diff --git a/gcc/ada/g-htable.ads b/gcc/ada/g-htable.ads new file mode 100644 index 00000000000..3b93f2ea9e9 --- /dev/null +++ b/gcc/ada/g-htable.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . H T A B L E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 1995-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Hash table searching routines + +-- This package contains two separate packages. The Simple_Htable package +-- provides a very simple abstraction that asosicates one element to one +-- key values and takes care of all allocation automatically using the heap. +-- The Static_Htable package provides a more complex interface that allows +-- complete control over allocation. + +package GNAT.HTable is +pragma Preelaborate (HTable); + + ------------------- + -- Simple_HTable -- + ------------------- + + -- A simple hash table abstraction, easy to instantiate, easy to use. + -- The table associates one element to one key with the procedure Set. + -- Get retrieves the Element stored for a given Key. The efficiency of + -- retrieval is function of the size of the Table parameterized by + -- Header_Num and the hashing function Hash. + + generic + type Header_Num is range <>; + -- An integer type indicating the number and range of hash headers. + + type Element is private; + -- The type of element to be stored + + No_Element : Element; + -- The object that is returned by Get when no element has been set for + -- a given key + + type Key is private; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Simple_HTable is + + procedure Set (K : Key; E : Element); + -- Associates an element with a given key. Overrides any previously + -- associated element. + + procedure Reset; + -- Removes and frees all elements in the table + + function Get (K : Key) return Element; + -- Returns the Element associated with a key or No_Element if the + -- given key has not associated element + + procedure Remove (K : Key); + -- Removes the latest inserted element pointer associated with the + -- given key if any, does nothing if none. + + function Get_First return Element; + -- Returns No_Element if the Htable is empty, otherwise returns one + -- non specified element. There is no guarantee that 2 calls to this + -- function will return the same element. + + function Get_Next return Element; + -- Returns a non-specified element that has not been returned by the + -- same function since the last call to Get_First or No_Element if + -- there is no such element. If there is no call to 'Set' in between + -- Get_Next calls, all the elements of the Htable will be traversed. + end Simple_HTable; + + ------------------- + -- Static_HTable -- + ------------------- + + -- A low-level Hash-Table abstraction, not as easy to instantiate as + -- Simple_HTable but designed to allow complete control over the + -- allocation of necessary data structures. Particularly useful when + -- dynamic allocation is not desired. The model is that each Element + -- contains its own Key that can be retrieved by Get_Key. Furthermore, + -- Element provides a link that can be used by the HTable for linking + -- elements with same hash codes: + + -- Element + + -- +-------------------+ + -- | Key | + -- +-------------------+ + -- : other data : + -- +-------------------+ + -- | Next Elmt | + -- +-------------------+ + + generic + type Header_Num is range <>; + -- An integer type indicating the number and range of hash headers. + + type Element (<>) is limited private; + -- The type of element to be stored + + type Elmt_Ptr is private; + -- The type used to reference an element (will usually be an access + -- type, but could be some other form of type such as an integer type). + + Null_Ptr : Elmt_Ptr; + -- The null value of the Elmt_Ptr type. + + with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + with function Next (E : Elmt_Ptr) return Elmt_Ptr; + -- The type must provide an internal link for the sake of the + -- staticness of the HTable. + + type Key is limited private; + with function Get_Key (E : Elmt_Ptr) return Key; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Static_HTable is + + procedure Reset; + -- Resets the hash table by setting all its elements to Null_Ptr. The + -- effect is to clear the hash table so that it can be reused. For the + -- most common case where Elmt_Ptr is an access type, and Null_Ptr is + -- null, this is only needed if the same table is reused in a new + -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is + -- other than null, then Reset must be called before the first use + -- of the hash table. + + procedure Set (E : Elmt_Ptr); + -- Insert the element pointer in the HTable + + function Get (K : Key) return Elmt_Ptr; + -- Returns the latest inserted element pointer with the given Key + -- or null if none. + + procedure Remove (K : Key); + -- Removes the latest inserted element pointer associated with the + -- given key if any, does nothing if none. + + function Get_First return Elmt_Ptr; + -- Returns Null_Ptr if the Htable is empty, otherwise returns one + -- non specified element. There is no guarantee that 2 calls to this + -- function will return the same element. + + function Get_Next return Elmt_Ptr; + -- Returns a non-specified element that has not been returned by the + -- same function since the last call to Get_First or Null_Ptr if + -- there is no such element or Get_First has bever been called. If + -- there is no call to 'Set' in between Get_Next calls, all the + -- elements of the Htable will be traversed. + + end Static_HTable; + + ---------- + -- Hash -- + ---------- + + -- A generic hashing function working on String keys + + generic + type Header_Num is range <>; + function Hash (Key : String) return Header_Num; + +end GNAT.HTable; diff --git a/gcc/ada/g-io.adb b/gcc/ada/g-io.adb new file mode 100644 index 00000000000..561ebf22e21 --- /dev/null +++ b/gcc/ada/g-io.adb @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1995-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.IO is + + Current_Out : File_Type := Stdout; + pragma Atomic (Current_Out); + -- Current output file (modified by Set_Output) + + --------- + -- Get -- + --------- + + procedure Get (X : out Integer) is + + function Get_Int return Integer; + pragma Import (C, Get_Int, "get_int"); + + begin + X := Get_Int; + end Get; + + procedure Get (C : out Character) is + + function Get_Char return Character; + pragma Import (C, Get_Char, "get_char"); + + begin + C := Get_Char; + end Get; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line (Item : in out String; Last : out Natural) is + C : Character; + + begin + for Nstore in Item'Range loop + Get (C); + + if C = ASCII.LF then + Last := Nstore - 1; + return; + + else + Item (Nstore) := C; + end if; + end loop; + + Last := Item'Last; + end Get_Line; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (File : File_Type; Spacing : Positive := 1) is + begin + for J in 1 .. Spacing loop + Put (File, ASCII.LF); + end loop; + end New_Line; + + procedure New_Line (Spacing : Positive := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + --------- + -- Put -- + --------- + + procedure Put (X : Integer) is + begin + Put (Current_Out, X); + end Put; + + procedure Put (File : File_Type; X : Integer) is + + procedure Put_Int (X : Integer); + pragma Import (C, Put_Int, "put_int"); + + procedure Put_Int_Stderr (X : Integer); + pragma Import (C, Put_Int_Stderr, "put_int_stderr"); + + begin + case File is + when Stdout => Put_Int (X); + when Stderr => Put_Int_Stderr (X); + end case; + end Put; + + procedure Put (C : Character) is + begin + Put (Current_Out, C); + end Put; + + procedure Put (File : in File_Type; C : Character) is + + procedure Put_Char (C : Character); + pragma Import (C, Put_Char, "put_char"); + + procedure Put_Char_Stderr (C : Character); + pragma Import (C, Put_Char_Stderr, "put_char_stderr"); + + begin + case File is + when Stdout => Put_Char (C); + when Stderr => Put_Char_Stderr (C); + end case; + end Put; + + procedure Put (S : String) is + begin + Put (Current_Out, S); + end Put; + + procedure Put (File : File_Type; S : String) is + begin + for J in S'Range loop + Put (File, S (J)); + end loop; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + Put_Line (Current_Out, S); + end Put_Line; + + procedure Put_Line (File : File_Type; S : String) is + begin + Put (File, S); + New_Line (File); + end Put_Line; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : in File_Type) is + begin + Current_Out := File; + end Set_Output; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Stdout; + end Standard_Output; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Stderr; + end Standard_Error; + +end GNAT.IO; diff --git a/gcc/ada/g-io.ads b/gcc/ada/g-io.ads new file mode 100644 index 00000000000..9b91406e864 --- /dev/null +++ b/gcc/ada/g-io.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 1995-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- A simple preelaborable subset of Text_IO capabilities + +-- A simple text I/O package that can be used for simple I/O functions in +-- user programs as required. This package is also preelaborated, unlike +-- Text_Io, and can thus be with'ed by preelaborated library units. + +-- Note that Data_Error is not raised by these subprograms for bad data. +-- If such checks are needed then the regular Text_IO package such be used. + +package GNAT.IO is +pragma Preelaborate (IO); + + type File_Type is limited private; + -- Specifies file to be used (the only possibilities are Standard_Output + -- and Standard_Error). There is no Create or Open facility that would + -- allow more general use of file names. + + function Standard_Output return File_Type; + function Standard_Error return File_Type; + -- These functions are the only way to get File_Type values + + procedure Get (X : out Integer); + procedure Get (C : out Character); + procedure Get_Line (Item : in out String; Last : out Natural); + -- These routines always read from Standard_Input + + procedure Put (File : File_Type; X : Integer); + procedure Put (X : Integer); + -- Output integer to specified file, or to current output file, same + -- output as if Ada.Text_IO.Integer_IO had been instantiated for Integer. + + procedure Put (File : File_Type; C : Character); + procedure Put (C : Character); + -- Output character to specified file, or to current output file + + procedure Put (File : File_Type; S : String); + procedure Put (S : String); + -- Output string to specified file, or to current output file + + procedure Put_Line (File : File_Type; S : String); + procedure Put_Line (S : String); + -- Output string followed by new line to specified file, or to + -- current output file. + + procedure New_Line (File : File_Type; Spacing : Positive := 1); + procedure New_Line (Spacing : Positive := 1); + -- Output new line character to specified file, or to current output file + + procedure Set_Output (File : File_Type); + -- Set current output file, default is Standard_Output if no call to + -- Set_Output is made. + +private + type File_Type is (Stdout, Stderr); + -- Stdout = Standard_Output, Stderr = Standard_Error + + pragma Inline (Standard_Error); + pragma Inline (Standard_Output); + +end GNAT.IO; diff --git a/gcc/ada/g-io_aux.adb b/gcc/ada/g-io_aux.adb new file mode 100644 index 00000000000..95afbc548a2 --- /dev/null +++ b/gcc/ada/g-io_aux.adb @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . I O _ A U X -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1995-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; + +package body GNAT.IO_Aux is + + Buflen : constant := 2000; + -- Buffer length. Works for any non-zero value, larger values take + -- more stack space, smaller values require more recursion. + + ----------------- + -- File_Exists -- + ----------------- + + function File_Exists (Name : String) return Boolean + is + Namestr : aliased String (1 .. Name'Length + 1); + -- Name as given with ASCII.NUL appended + + begin + Namestr (1 .. Name'Length) := Name; + Namestr (Name'Length + 1) := ASCII.NUL; + return file_exists (Namestr'Address) /= 0; + end File_Exists; + + -------------- + -- Get_Line -- + -------------- + + -- Current_Input case + + function Get_Line return String is + Buffer : String (1 .. Buflen); + -- Buffer to read in chunks of remaining line. Will work with any + -- size buffer. We choose a length so that most of the time no + -- recursion will be required. + + Last : Natural; + + begin + Ada.Text_IO.Get_Line (Buffer, Last); + + -- If the buffer is not full, then we are all done + + if Last < Buffer'Last then + return Buffer (1 .. Last); + + -- Otherwise, we still have characters left on the line. Note that + -- as specified by (RM A.10.7(19)) the end of line is not skipped + -- in this case, even if we are right at it now. + + else + return Buffer & GNAT.IO_Aux.Get_Line; + end if; + end Get_Line; + + -- Case of reading from a specified file. Note that we could certainly + -- share code between these two versions, but these are very short + -- routines, and we may as well aim for maximum speed, cutting out an + -- intermediate call (calls returning string may be somewhat slow) + + function Get_Line (File : Ada.Text_IO.File_Type) return String is + Buffer : String (1 .. Buflen); + Last : Natural; + + begin + Ada.Text_IO.Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Buffer & Get_Line (File); + end if; + end Get_Line; + +end GNAT.IO_Aux; diff --git a/gcc/ada/g-io_aux.ads b/gcc/ada/g-io_aux.ads new file mode 100644 index 00000000000..379d84abdf7 --- /dev/null +++ b/gcc/ada/g-io_aux.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . I O _ A U X -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1995-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Auxiliary functions or use with Text_IO + +-- This package provides some auxiliary functions for use with Text_IO, +-- including a test for an existing file, and a Get_Line function which +-- returns a string. + +with Ada.Text_IO; + +package GNAT.IO_Aux is + + function File_Exists (Name : String) return Boolean; + -- Test for existence of a file named Name + + function Get_Line return String; + -- Read Ada.Text_IO.Current_Input and return string that includes all + -- characters from the current character up to the end of the line, + -- with no limit on its length. Raises Ada.IO_Exceptions.End_Error if + -- at end of file. + + function Get_Line (File : Ada.Text_IO.File_Type) return String; + -- Same, but reads from specified file + +end GNAT.IO_Aux; diff --git a/gcc/ada/g-locfil.adb b/gcc/ada/g-locfil.adb new file mode 100644 index 00000000000..3f263f7b654 --- /dev/null +++ b/gcc/ada/g-locfil.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . L O C K _ F I L E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1998-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; + +package body GNAT.Lock_Files is + + Dir_Separator : Character; + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + + --------------- + -- Lock_File -- + --------------- + + procedure Lock_File + (Directory : String; + Lock_File_Name : String; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last) + is + Dir : aliased String := Directory & ASCII.NUL; + File : aliased String := Lock_File_Name & ASCII.NUL; + + function Try_Lock (Dir, File : System.Address) return Integer; + pragma Import (C, Try_Lock, "__gnat_try_lock"); + + begin + for I in 0 .. Retries loop + if Try_Lock (Dir'Address, File'Address) = 1 then + return; + end if; + exit when I = Retries; + delay Wait; + end loop; + raise Lock_Error; + end Lock_File; + + --------------- + -- Lock_File -- + --------------- + + procedure Lock_File + (Lock_File_Name : String; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last) + is + begin + for J in reverse Lock_File_Name'Range loop + if Lock_File_Name (J) = Dir_Separator then + Lock_File + (Lock_File_Name (Lock_File_Name'First .. J - 1), + Lock_File_Name (J + 1 .. Lock_File_Name'Last), + Wait, + Retries); + return; + end if; + end loop; + + Lock_File (".", Lock_File_Name, Wait, Retries); + end Lock_File; + + ----------------- + -- Unlock_File -- + ----------------- + + procedure Unlock_File (Lock_File_Name : String) is + S : aliased String := Lock_File_Name & ASCII.NUL; + + procedure unlink (A : System.Address); + pragma Import (C, unlink, "unlink"); + + begin + unlink (S'Address); + end Unlock_File; + + ----------------- + -- Unlock_File -- + ----------------- + + procedure Unlock_File (Directory : String; Lock_File_Name : String) is + begin + Unlock_File (Directory & Dir_Separator & Lock_File_Name); + end Unlock_File; + +end GNAT.Lock_Files; diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads new file mode 100644 index 00000000000..47715c69bee --- /dev/null +++ b/gcc/ada/g-locfil.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . L O C K _ F I L E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 1995-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + -- This package contains the necessary routines for using files for the + -- purpose of providing realiable system wide locking capability. + +package GNAT.Lock_Files is +pragma Preelaborate; + + Lock_Error : exception; + -- Exception raised if file cannot be locked + + procedure Lock_File + (Directory : String; + Lock_File_Name : String; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last); + -- Create a lock file Lock_File_Name in directory Directory. If the file + -- cannot be locked because someone already owns the lock, this procedure + -- waits Wait seconds and retries at most Retries times. If the file + -- still cannot be locked, Lock_Error is raised. The default is to try + -- every second, almost forever (Natural'Last times). + + procedure Lock_File + (Lock_File_Name : String; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last); + -- See above. The full lock file path is given as one string. + + procedure Unlock_File (Directory : String; Lock_File_Name : String); + -- Unlock a file + + procedure Unlock_File (Lock_File_Name : String); + -- Unlock a file whose full path is given in Lock_File_Name + +end GNAT.Lock_Files; diff --git a/gcc/ada/g-moreex.adb b/gcc/ada/g-moreex.adb new file mode 100644 index 00000000000..35f56015370 --- /dev/null +++ b/gcc/ada/g-moreex.adb @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions.Is_Null_Occurrence; +with System.Soft_Links; + +package body GNAT.Most_Recent_Exception is + + ---------------- + -- Occurrence -- + ---------------- + + function Occurrence + return Ada.Exceptions.Exception_Occurrence + is + EOA : constant Ada.Exceptions.Exception_Occurrence_Access := + GNAT.Most_Recent_Exception.Occurrence_Access; + + use type Ada.Exceptions.Exception_Occurrence_Access; + + begin + if EOA = null then + return Ada.Exceptions.Null_Occurrence; + else + return EOA.all; + end if; + end Occurrence; + + ----------------------- + -- Occurrence_Access -- + ----------------------- + + function Occurrence_Access + return Ada.Exceptions.Exception_Occurrence_Access + is + use Ada.Exceptions; + + EOA : constant Exception_Occurrence_Access := + System.Soft_Links.Get_Current_Excep.all; + + begin + if EOA = null then + return null; + + elsif Is_Null_Occurrence (EOA.all) then + return null; + + else + return EOA; + end if; + end Occurrence_Access; + +end GNAT.Most_Recent_Exception; diff --git a/gcc/ada/g-moreex.ads b/gcc/ada/g-moreex.ads new file mode 100644 index 00000000000..c5216076e0f --- /dev/null +++ b/gcc/ada/g-moreex.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines for accessing the most recently raised +-- exception. This may be useful for certain logging activities. It may +-- also be useful for mimicing implementation dependent capabilities in +-- Ada 83 compilers, but see also GNAT.Current_Exceptions for this usage. + +with Ada.Exceptions; +package GNAT.Most_Recent_Exception is + + ----------------- + -- Subprograms -- + ----------------- + + function Occurrence + return Ada.Exceptions.Exception_Occurrence; + -- Returns the Exception_Occurrence for the most recently raised + -- exception in the current task. If no exception has been raised + -- in the current task prior to the call, returns Null_Occurrence. + + function Occurrence_Access + return Ada.Exceptions.Exception_Occurrence_Access; + -- Similar to the above, but returns an access to the occurrence value. + -- This value is in a task specific location, and may be validly accessed + -- as long as no further exception is raised in the calling task. + + -- Note: unlike the routines in GNAT.Current_Exception, these functions + -- access the most recently raised exception, regardless of where they + -- are called. Consider the following example: + + -- exception + -- when Constraint_Error => + -- begin + -- ... + -- exception + -- when Tasking_Error => ... + -- end; + -- + -- -- Assuming a Tasking_Error was raised in the inner block, + -- -- a call to GNAT.Most_Recent_Exception.Occurrence will + -- -- return information about this Tasking_Error exception, + -- -- not about the Constraint_Error exception being handled + -- -- by the current handler code. + + +end GNAT.Most_Recent_Exception; diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb new file mode 100644 index 00000000000..ef7968d9b73 --- /dev/null +++ b/gcc/ada/g-os_lib.adb @@ -0,0 +1,1347 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . O S _ L I B -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.74 $ +-- -- +-- Copyright (C) 1995-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Soft_Links; +with Unchecked_Conversion; +with System; use System; + +package body GNAT.OS_Lib is + + package SSL renames System.Soft_Links; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Args_Length (Args : Argument_List) return Natural; + -- Returns total number of characters needed to create a string + -- of all Args terminated by ASCII.NUL characters + + function C_String_Length (S : Address) return Integer; + -- Returns the length of a C string. Does check for null address + -- (returns 0). + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean); + -- Internal routine to implement the to Spawn (blocking and non blocking) + -- routines. If Blocking is set to True then the spawn is blocking + -- otherwise it is non blocking. In this latter case the Pid contains + -- the process id number. The first three parameters are as in Spawn. + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) + return String_Access; + -- Converts a C String to an Ada String. We could do this making use of + -- Interfaces.C.Strings but we prefer not to import that entire package + + ----------------- + -- Args_Length -- + ----------------- + + function Args_Length (Args : Argument_List) return Natural is + Len : Natural := 0; + + begin + for J in Args'Range loop + Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL + end loop; + + return Len; + end Args_Length; + + ----------------------------- + -- Argument_String_To_List -- + ----------------------------- + + function Argument_String_To_List + (Arg_String : String) + return Argument_List_Access + is + Max_Args : Integer := Arg_String'Length; + New_Argv : Argument_List (1 .. Max_Args); + New_Argc : Natural := 0; + Idx : Integer; + + begin + Idx := Arg_String'First; + + loop + declare + Quoted : Boolean := False; + Backqd : Boolean := False; + Old_Idx : Integer; + + begin + Old_Idx := Idx; + + loop + -- A vanilla space is the end of an argument + + if not Backqd and then not Quoted + and then Arg_String (Idx) = ' ' + then + exit; + + -- Start of a quoted string + + elsif not Backqd and then not Quoted + and then Arg_String (Idx) = '"' + then + Quoted := True; + + -- End of a quoted string and end of an argument + + elsif not Backqd and then Quoted + and then Arg_String (Idx) = '"' + then + Idx := Idx + 1; + exit; + + -- Following character is backquoted + + elsif Arg_String (Idx) = '\' then + Backqd := True; + + -- Turn off backquoting after advancing one character + + elsif Backqd then + Backqd := False; + + end if; + + Idx := Idx + 1; + exit when Idx > Arg_String'Last; + end loop; + + -- Found an argument + + New_Argc := New_Argc + 1; + New_Argv (New_Argc) := + new String'(Arg_String (Old_Idx .. Idx - 1)); + + -- Skip extraneous spaces + + while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop + Idx := Idx + 1; + end loop; + end; + + exit when Idx > Arg_String'Last; + end loop; + + return new Argument_List'(New_Argv (1 .. New_Argc)); + end Argument_String_To_List; + + --------------------- + -- C_String_Length -- + --------------------- + + function C_String_Length (S : Address) return Integer is + function Strlen (S : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + begin + if S = Null_Address then + return 0; + else + return Strlen (S); + end if; + end C_String_Length; + + ----------------- + -- Create_File -- + ----------------- + + function Create_File + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor + is + function C_Create_File + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_open_create"); + + begin + return C_Create_File (Name, Fmode); + end Create_File; + + function Create_File + (Name : String; + Fmode : Mode) + return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_File (C_Name (C_Name'First)'Address, Fmode); + end Create_File; + + --------------------- + -- Create_New_File -- + --------------------- + + function Create_New_File + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor + is + function C_Create_New_File + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + pragma Import (C, C_Create_New_File, "__gnat_open_new"); + + begin + return C_Create_New_File (Name, Fmode); + end Create_New_File; + + function Create_New_File + (Name : String; + Fmode : Mode) + return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_New_File (C_Name (C_Name'First)'Address, Fmode); + end Create_New_File; + + ---------------------- + -- Create_Temp_File -- + ---------------------- + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Temp_File_Name) + is + function Open_New_Temp + (Name : System.Address; + Fmode : Mode) + return File_Descriptor; + pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); + + begin + FD := Open_New_Temp (Name'Address, Binary); + end Create_Temp_File; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Name : Address; Success : out Boolean) is + R : Integer; + + function unlink (A : Address) return Integer; + pragma Import (C, unlink, "unlink"); + + begin + R := unlink (Name); + Success := (R = 0); + end Delete_File; + + procedure Delete_File (Name : String; Success : out Boolean) is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + + Delete_File (C_Name'Address, Success); + end Delete_File; + + --------------------- + -- File_Time_Stamp -- + --------------------- + + function File_Time_Stamp (FD : File_Descriptor) return OS_Time is + function File_Time (FD : File_Descriptor) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_fd"); + + begin + return File_Time (FD); + end File_Time_Stamp; + + function File_Time_Stamp (Name : C_File_Name) return OS_Time is + function File_Time (Name : Address) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_name"); + + begin + return File_Time (Name); + end File_Time_Stamp; + + function File_Time_Stamp (Name : String) return OS_Time is + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return File_Time_Stamp (F_Name'Address); + end File_Time_Stamp; + + --------------------------- + -- Get_Debuggable_Suffix -- + --------------------------- + + function Get_Debuggable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Debuggable_Suffix; + + --------------------------- + -- Get_Executable_Suffix -- + --------------------------- + + function Get_Executable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Executable_Suffix; + + ----------------------- + -- Get_Object_Suffix -- + ----------------------- + + function Get_Object_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Object_Suffix; + + ------------ + -- Getenv -- + ------------ + + function Getenv (Name : String) return String_Access is + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Env_Value_Ptr : Address; + Env_Value_Length : Integer; + F_Name : String (1 .. Name'Length + 1); + Result : String_Access; + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + Get_Env_Value_Ptr + (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + Result := new String (1 .. Env_Value_Length); + + if Env_Value_Length > 0 then + Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length); + end if; + + return Result; + end Getenv; + + ------------ + -- GM_Day -- + ------------ + + function GM_Day (Date : OS_Time) return Day_Type is + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return D; + end GM_Day; + + ------------- + -- GM_Hour -- + ------------- + + function GM_Hour (Date : OS_Time) return Hour_Type is + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return H; + end GM_Hour; + + --------------- + -- GM_Minute -- + --------------- + + function GM_Minute (Date : OS_Time) return Minute_Type is + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mn; + end GM_Minute; + + -------------- + -- GM_Month -- + -------------- + + function GM_Month (Date : OS_Time) return Month_Type is + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mo; + end GM_Month; + + --------------- + -- GM_Second -- + --------------- + + function GM_Second (Date : OS_Time) return Second_Type is + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return S; + end GM_Second; + + -------------- + -- GM_Split -- + -------------- + + procedure GM_Split + (Date : OS_Time; + Year : out Year_Type; + Month : out Month_Type; + Day : out Day_Type; + Hour : out Hour_Type; + Minute : out Minute_Type; + Second : out Second_Type) + is + procedure To_GM_Time + (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); + pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); + + T : OS_Time := Date; + Y : Integer; + Mo : Integer; + D : Integer; + H : Integer; + Mn : Integer; + S : Integer; + + begin + -- Use the global lock because To_GM_Time is not thread safe. + + Locked_Processing : begin + SSL.Lock_Task.all; + To_GM_Time + (T'Address, Y'Address, Mo'Address, D'Address, + H'Address, Mn'Address, S'Address); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + Year := Y + 1900; + Month := Mo + 1; + Day := D; + Hour := H; + Minute := Mn; + Second := S; + end GM_Split; + + ------------- + -- GM_Year -- + ------------- + + function GM_Year (Date : OS_Time) return Year_Type is + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Y; + end GM_Year; + + ---------------------- + -- Is_Absolute_Path -- + ---------------------- + + function Is_Absolute_Path (Name : String) return Boolean is + function Is_Absolute_Path (Name : Address) return Integer; + pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); + + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + return Is_Absolute_Path (F_Name'Address) /= 0; + end Is_Absolute_Path; + + ------------------ + -- Is_Directory -- + ------------------ + + function Is_Directory (Name : C_File_Name) return Boolean is + function Is_Directory (Name : Address) return Integer; + pragma Import (C, Is_Directory, "__gnat_is_directory"); + + begin + return Is_Directory (Name) /= 0; + end Is_Directory; + + function Is_Directory (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Directory (F_Name'Address); + end Is_Directory; + + --------------------- + -- Is_Regular_File -- + --------------------- + + function Is_Regular_File (Name : C_File_Name) return Boolean is + function Is_Regular_File (Name : Address) return Integer; + pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); + + begin + return Is_Regular_File (Name) /= 0; + end Is_Regular_File; + + function Is_Regular_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Regular_File (F_Name'Address); + end Is_Regular_File; + + ---------------------- + -- Is_Writable_File -- + ---------------------- + + function Is_Writable_File (Name : C_File_Name) return Boolean is + function Is_Writable_File (Name : Address) return Integer; + pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); + + begin + return Is_Writable_File (Name) /= 0; + end Is_Writable_File; + + function Is_Writable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Writable_File (F_Name'Address); + end Is_Writable_File; + + ------------------------- + -- Locate_Exec_On_Path -- + ------------------------- + + function Locate_Exec_On_Path + (Exec_Name : String) + return String_Access + is + function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; + pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); + + procedure Free (Ptr : System.Address); + pragma Import (C, Free, "free"); + + C_Exec_Name : String (1 .. Exec_Name'Length + 1); + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; + C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; + + Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + Free (Path_Addr); + return Result; + end if; + end Locate_Exec_On_Path; + + ------------------------- + -- Locate_Regular_File -- + ------------------------- + + function Locate_Regular_File + (File_Name : C_File_Name; + Path : C_File_Name) + return String_Access + is + function Locate_Regular_File + (C_File_Name, Path_Val : Address) return Address; + pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); + + procedure Free (Ptr : System.Address); + pragma Import (C, Free, "free"); + + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + Path_Addr := Locate_Regular_File (File_Name, Path); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + Free (Path_Addr); + return Result; + end if; + end Locate_Regular_File; + + function Locate_Regular_File + (File_Name : String; + Path : String) + return String_Access + is + C_File_Name : String (1 .. File_Name'Length + 1); + C_Path : String (1 .. Path'Length + 1); + + begin + C_File_Name (1 .. File_Name'Length) := File_Name; + C_File_Name (C_File_Name'Last) := ASCII.NUL; + + C_Path (1 .. Path'Length) := Path; + C_Path (C_Path'Last) := ASCII.NUL; + + return Locate_Regular_File (C_File_Name'Address, C_Path'Address); + end Locate_Regular_File; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) + return Process_Id + is + Junk : Integer; + Pid : Process_Id; + + begin + Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); + return Pid; + end Non_Blocking_Spawn; + + ------------------------ + -- Normalize_Pathname -- + ------------------------ + + function Normalize_Pathname + (Name : String; + Directory : String := "") + return String + is + Max_Path : Integer; + pragma Import (C, Max_Path, "max_path_len"); + -- Maximum length of a path name + + procedure Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + Path_Buffer : String (1 .. Max_Path + Max_Path + 2); + End_Path : Natural := 0; + Link_Buffer : String (1 .. Max_Path + 2); + Status : Integer; + Last : Positive; + Start : Natural; + Finish : Positive; + + Max_Iterations : constant := 500; + + function Readlink + (Path : System.Address; + Buf : System.Address; + Bufsiz : Integer) + return Integer; + pragma Import (C, Readlink, "__gnat_readlink"); + + function To_Canonical_File_Spec + (Host_File : System.Address) + return System.Address; + pragma Import + (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); + + The_Name : String (1 .. Name'Length + 1); + Canonical_File_Addr : System.Address; + Canonical_File_Len : Integer; + + function Strlen (S : System.Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + function Get_Directory return String; + -- If Directory is not empty, return it, adding a directory separator + -- if not already present, otherwise return current working directory + -- with terminating directory separator. + + ------------------- + -- Get_Directory -- + ------------------- + + function Get_Directory return String is + begin + -- Directory given, add directory separator if needed + + if Directory'Length > 0 then + if Directory (Directory'Length) = Directory_Separator then + return Directory; + else + declare + Result : String (1 .. Directory'Length + 1); + + begin + Result (1 .. Directory'Length) := Directory; + Result (Result'Length) := Directory_Separator; + return Result; + end; + end if; + + -- Directory name not given, get current directory + + else + declare + Buffer : String (1 .. Max_Path + 2); + Path_Len : Natural := Max_Path; + + begin + Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Buffer (Path_Len) /= Directory_Separator then + Path_Len := Path_Len + 1; + Buffer (Path_Len) := Directory_Separator; + end if; + + return Buffer (1 .. Path_Len); + end; + end if; + end Get_Directory; + + Reference_Dir : constant String := Get_Directory; + -- Current directory name specified + + -- Start of processing for Normalize_Pathname + + begin + -- Special case, if name is null, then return null + + if Name'Length = 0 then + return ""; + end if; + + -- First, convert VMS file spec to Unix file spec. + -- If Name is not in VMS syntax, then this is equivalent + -- to put Name at the begining of Path_Buffer. + + VMS_Conversion : begin + The_Name (1 .. Name'Length) := Name; + The_Name (The_Name'Last) := ASCII.NUL; + + Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); + Canonical_File_Len := Strlen (Canonical_File_Addr); + + -- If VMS syntax conversion has failed, return an empty string + -- to indicate the failure. + + if Canonical_File_Len = 0 then + return ""; + end if; + + declare + subtype Path_String is String (1 .. Canonical_File_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Unchecked_Conversion (Source => Address, + Target => Path_String_Access); + + Path_Access : Path_String_Access := + Address_To_Access (Canonical_File_Addr); + + begin + Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all; + End_Path := Canonical_File_Len; + Last := 1; + end; + end VMS_Conversion; + + -- Replace all '/' by Directory Separators (this is for Windows) + + if Directory_Separator /= '/' then + for Index in 1 .. End_Path loop + if Path_Buffer (Index) = '/' then + Path_Buffer (Index) := Directory_Separator; + end if; + end loop; + end if; + + -- Start the conversions + + -- If this is not finished after Max_Iterations, give up and + -- return an empty string. + + for J in 1 .. Max_Iterations loop + + -- If we don't have an absolute pathname, prepend + -- the directory Reference_Dir. + + if Last = 1 + and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) + then + Path_Buffer + (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) := + Path_Buffer (1 .. End_Path); + End_Path := Reference_Dir'Length + End_Path; + Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir; + Last := Reference_Dir'Length; + end if; + + Start := Last + 1; + Finish := Last; + + -- If we have traversed the full pathname, return it + + if Start > End_Path then + return Path_Buffer (1 .. End_Path); + end if; + + -- Remove duplicate directory separators + + while Path_Buffer (Start) = Directory_Separator loop + if Start = End_Path then + return Path_Buffer (1 .. End_Path - 1); + + else + Path_Buffer (Start .. End_Path - 1) := + Path_Buffer (Start + 1 .. End_Path); + End_Path := End_Path - 1; + end if; + end loop; + + -- Find the end of the current field: last character + -- or the one preceding the next directory separator. + + while Finish < End_Path + and then Path_Buffer (Finish + 1) /= Directory_Separator + loop + Finish := Finish + 1; + end loop; + + -- Remove "." field + + if Start = Finish and then Path_Buffer (Start) = '.' then + if Start = End_Path then + if Last = 1 then + return (1 => Directory_Separator); + else + return Path_Buffer (1 .. Last - 1); + end if; + + else + Path_Buffer (Last + 1 .. End_Path - 2) := + Path_Buffer (Last + 3 .. End_Path); + End_Path := End_Path - 2; + end if; + + -- Remove ".." fields + + elsif Finish = Start + 1 + and then Path_Buffer (Start .. Finish) = ".." + then + Start := Last; + loop + Start := Start - 1; + exit when Start < 1 or else + Path_Buffer (Start) = Directory_Separator; + end loop; + + if Start <= 1 then + if Finish = End_Path then + return (1 => Directory_Separator); + + else + Path_Buffer (1 .. End_Path - Finish) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish; + Last := 1; + end if; + + else + if Finish = End_Path then + return Path_Buffer (1 .. Start - 1); + + else + Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := + Path_Buffer (Finish + 2 .. End_Path); + End_Path := Start + End_Path - Finish - 1; + Last := Start; + end if; + end if; + + -- Check if current field is a symbolic link + + else + declare + Saved : Character := Path_Buffer (Finish + 1); + + begin + Path_Buffer (Finish + 1) := ASCII.NUL; + Status := Readlink (Path_Buffer'Address, + Link_Buffer'Address, + Link_Buffer'Length); + Path_Buffer (Finish + 1) := Saved; + end; + + -- Not a symbolic link, move to the next field, if any + + if Status <= 0 then + Last := Finish + 1; + + -- Replace symbolic link with its value. + + else + if Is_Absolute_Path (Link_Buffer (1 .. Status)) then + Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - (Finish - Status); + Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); + Last := 1; + + else + Path_Buffer + (Last + Status + 1 .. End_Path - Finish + Last + Status) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish + Last + Status; + Path_Buffer (Last + 1 .. Last + Status) := + Link_Buffer (1 .. Status); + end if; + end if; + end if; + end loop; + + -- Too many iterations: give up + + -- This can happen when there is a circularity in the symbolic links: + -- A is a symbolic link for B, which itself is a symbolic link, and + -- the target of B or of another symbolic link target of B is A. + -- In this case, we return an empty string to indicate failure to + -- resolve. + + return ""; + end Normalize_Pathname; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor + is + function C_Open_Read + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + pragma Import (C, C_Open_Read, "__gnat_open_read"); + + begin + return C_Open_Read (Name, Fmode); + end Open_Read; + + function Open_Read + (Name : String; + Fmode : Mode) + return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read (C_Name (C_Name'First)'Address, Fmode); + end Open_Read; + + --------------------- + -- Open_Read_Write -- + --------------------- + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor + is + function C_Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); + + begin + return C_Open_Read_Write (Name, Fmode); + end Open_Read_Write; + + function Open_Read_Write + (Name : String; + Fmode : Mode) + return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); + end Open_Read_Write; + + ----------------- + -- Rename_File -- + ----------------- + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean) + is + function rename (From, To : Address) return Integer; + pragma Import (C, rename, "rename"); + + R : Integer; + + begin + R := rename (Old_Name, New_Name); + Success := (R = 0); + end Rename_File; + + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean) + is + C_Old_Name : String (1 .. Old_Name'Length + 1); + C_New_Name : String (1 .. New_Name'Length + 1); + + begin + C_Old_Name (1 .. Old_Name'Length) := Old_Name; + C_Old_Name (C_Old_Name'Last) := ASCII.NUL; + + C_New_Name (1 .. New_Name'Length) := New_Name; + C_New_Name (C_New_Name'Last) := ASCII.NUL; + + Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); + end Rename_File; + + ------------ + -- Setenv -- + ------------ + + procedure Setenv (Name : String; Value : String) is + F_Name : String (1 .. Name'Length + 1); + F_Value : String (1 .. Value'Length + 1); + + procedure Set_Env_Value (Name, Value : System.Address); + pragma Import (C, Set_Env_Value, "__gnat_set_env_value"); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + F_Value (1 .. Value'Length) := Value; + F_Value (F_Value'Last) := ASCII.NUL; + + Set_Env_Value (F_Name'Address, F_Value'Address); + end Setenv; + + ----------- + -- Spawn -- + ----------- + + function Spawn + (Program_Name : String; + Args : Argument_List) + return Integer + is + Junk : Process_Id; + Result : Integer; + + begin + Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); + return Result; + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Success : out Boolean) + is + begin + Success := (Spawn (Program_Name, Args) = 0); + end Spawn; + + -------------------- + -- Spawn_Internal -- + -------------------- + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean) + is + type Chars is array (Positive range <>) of aliased Character; + type Char_Ptr is access constant Character; + + Command_Len : constant Positive := Program_Name'Length + 1 + + Args_Length (Args); + Command_Last : Natural := 0; + Command : aliased Chars (1 .. Command_Len); + -- Command contains all characters of the Program_Name and Args, + -- all terminated by ASCII.NUL characters + + Arg_List_Len : constant Positive := Args'Length + 2; + Arg_List_Last : Natural := 0; + Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; + -- List with pointers to NUL-terminated strings of the + -- Program_Name and the Args and terminated with a null pointer. + -- We rely on the default initialization for the last null pointer. + + procedure Add_To_Command (S : String); + -- Add S and a NUL character to Command, updating Last + + function Portable_Spawn (Args : Address) return Integer; + pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); + + function Portable_No_Block_Spawn (Args : Address) return Process_Id; + pragma Import + (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); + + -------------------- + -- Add_To_Command -- + -------------------- + + procedure Add_To_Command (S : String) is + First : constant Natural := Command_Last + 1; + + begin + Command_Last := Command_Last + S'Length; + Command (First .. Command_Last) := Chars (S); + + Command_Last := Command_Last + 1; + Command (Command_Last) := ASCII.NUL; + + Arg_List_Last := Arg_List_Last + 1; + Arg_List (Arg_List_Last) := Command (First)'Access; + end Add_To_Command; + + -- Start of processing for Spawn_Internal + + begin + Add_To_Command (Program_Name); + + for J in Args'Range loop + Add_To_Command (Args (J).all); + end loop; + + if Blocking then + Pid := Invalid_Pid; + Result := Portable_Spawn (Arg_List'Address); + else + Pid := Portable_No_Block_Spawn (Arg_List'Address); + Result := Boolean'Pos (Pid /= Invalid_Pid); + end if; + + end Spawn_Internal; + + --------------------------- + -- To_Path_String_Access -- + --------------------------- + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) + return String_Access + is + subtype Path_String is String (1 .. Path_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Unchecked_Conversion (Source => Address, + Target => Path_String_Access); + + Path_Access : Path_String_Access := Address_To_Access (Path_Addr); + + Return_Val : String_Access; + + begin + Return_Val := new String (1 .. Path_Len); + + for J in 1 .. Path_Len loop + Return_Val (J) := Path_Access (J); + end loop; + + return Return_Val; + end To_Path_String_Access; + + ------------------ + -- Wait_Process -- + ------------------ + + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is + Status : Integer; + + function Portable_Wait (S : Address) return Process_Id; + pragma Import (C, Portable_Wait, "__gnat_portable_wait"); + + begin + Pid := Portable_Wait (Status'Address); + Success := (Status = 0); + end Wait_Process; + +end GNAT.OS_Lib; diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads new file mode 100644 index 00000000000..07fd8f1b83f --- /dev/null +++ b/gcc/ada/g-os_lib.ads @@ -0,0 +1,512 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . O S _ L I B -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.79 $ +-- -- +-- Copyright (C) 1995-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Operating system interface facilities + +-- This package contains types and procedures for interfacing to the +-- underlying OS. It is used by the GNAT compiler and by tools associated +-- with the GNAT compiler, and therefore works for the various operating +-- systems to which GNAT has been ported. This package will undoubtedly +-- grow as new services are needed by various tools. + +-- This package tends to use fairly low-level Ada in order to not bring +-- in large portions of the RTL. For example, functions return access +-- to string as part of avoiding functions returning unconstrained types; +-- types related to dates are defined here instead of using the types +-- from Calendar, since use of Calendar forces linking in of tasking code. + +-- Except where specifically noted, these routines are portable across +-- all GNAT implementations on all supported operating systems. + +with System; +with Unchecked_Deallocation; + +package GNAT.OS_Lib is +pragma Elaborate_Body (OS_Lib); + + type String_Access is access all String; + + procedure Free is new Unchecked_Deallocation + (Object => String, Name => String_Access); + + --------------------- + -- Time/Date Stuff -- + --------------------- + + -- The OS's notion of time is represented by the private type OS_Time. + -- This is the type returned by the File_Time_Stamp functions to obtain + -- the time stamp of a specified file. Functions and a procedure (modeled + -- after the similar subprograms in package Calendar) are provided for + -- extracting information from a value of this type. Although these are + -- called GM, the intention is not that they provide GMT times in all + -- cases but rather the actual (time-zone independent) time stamp of the + -- file (of course in Unix systems, this *is* in GMT form). + + type OS_Time is private; + + subtype Year_Type is Integer range 1900 .. 2099; + subtype Month_Type is Integer range 1 .. 12; + subtype Day_Type is Integer range 1 .. 31; + subtype Hour_Type is Integer range 0 .. 23; + subtype Minute_Type is Integer range 0 .. 59; + subtype Second_Type is Integer range 0 .. 59; + + function GM_Year (Date : OS_Time) return Year_Type; + function GM_Month (Date : OS_Time) return Month_Type; + function GM_Day (Date : OS_Time) return Day_Type; + function GM_Hour (Date : OS_Time) return Hour_Type; + function GM_Minute (Date : OS_Time) return Minute_Type; + function GM_Second (Date : OS_Time) return Second_Type; + + procedure GM_Split + (Date : OS_Time; + Year : out Year_Type; + Month : out Month_Type; + Day : out Day_Type; + Hour : out Hour_Type; + Minute : out Minute_Type; + Second : out Second_Type); + + ---------------- + -- File Stuff -- + ---------------- + + -- These routines give access to the open/creat/close/read/write level + -- of I/O routines in the typical C library (these functions are not + -- part of the ANSI C standard, but are typically available in all + -- systems). See also package Interfaces.C_Streams for access to the + -- stream level routines. + + -- Note on file names. If a file name is passed as type String in any + -- of the following specifications, then the name is a normal Ada string + -- and need not be NUL-terminated. However, a trailing NUL character is + -- permitted, and will be ignored (more accurately, the NUL and any + -- characters that follow it will be ignored). + + type File_Descriptor is private; + -- Corresponds to the int file handle values used in the C routines, + + Standin : constant File_Descriptor; + Standout : constant File_Descriptor; + Standerr : constant File_Descriptor; + -- File descriptors for standard input output files + + Invalid_FD : constant File_Descriptor; + -- File descriptor returned when error in opening/creating file; + + type Mode is (Binary, Text); + for Mode'Size use Integer'Size; + for Mode use (Binary => 0, Text => 1); + -- Used in all the Open and Create calls to specify if the file is to be + -- opened in binary mode or text mode. In systems like Unix, this has no + -- effect, but in systems capable of text mode translation, the use of + -- Text as the mode parameter causes the system to do CR/LF translation + -- and also to recognize the DOS end of file character on input. The use + -- of Text where appropriate allows programs to take a portable Unix view + -- of DOs-format files and process them appropriately. + + function Open_Read + (Name : String; + Fmode : Mode) + return File_Descriptor; + -- Open file Name for reading, returning file descriptor File descriptor + -- returned is Invalid_FD if file cannot be opened. + + function Open_Read_Write + (Name : String; + Fmode : Mode) + return File_Descriptor; + -- Open file Name for both reading and writing, returning file + -- descriptor. File descriptor returned is Invalid_FD if file cannot be + -- opened. + + function Create_File + (Name : String; + Fmode : Mode) + return File_Descriptor; + -- Creates new file with given name for writing, returning file descriptor + -- for subsequent use in Write calls. File descriptor returned is + -- Invalid_FD if file cannot be successfully created + + function Create_New_File + (Name : String; + Fmode : Mode) + return File_Descriptor; + -- Create new file with given name for writing, returning file descriptor + -- for subsequent use in Write calls. This differs from Create_File in + -- that it fails if the file already exists. File descriptor returned is + -- Invalid_FD if the file exists or cannot be created. + + Temp_File_Len : constant Integer := 12; + -- Length of name returned by Create_Temp_File call (GNAT-XXXXXX & NUL) + + subtype Temp_File_Name is String (1 .. Temp_File_Len); + -- String subtype set by Create_Temp_File + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Temp_File_Name); + -- Create and open for writing a temporary file. The name of the + -- file and the File Descriptor are returned. The File Descriptor + -- returned is Invalid_FD in the case of failure. No mode parameter + -- is provided. Since this is a temporary file, there is no point in + -- doing text translation on it. + + procedure Close (FD : File_Descriptor); + pragma Import (C, Close, "close"); + -- Close file referenced by FD + + procedure Delete_File (Name : String; Success : out Boolean); + -- Deletes file. Success is set True or False indicating if the delete is + -- successful. + + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean); + -- Rename a file. Successis set True or False indicating if the rename is + -- successful. + + function Read + (FD : File_Descriptor; + A : System.Address; + N : Integer) + return Integer; + pragma Import (C, Read, "read"); + -- Read N bytes to address A from file referenced by FD. Returned value + -- is count of bytes actually read, which can be less than N at EOF. + + function Write + (FD : File_Descriptor; + A : System.Address; + N : Integer) + return Integer; + pragma Import (C, Write, "write"); + -- Write N bytes from address A to file referenced by FD. The returned + -- value is the number of bytes written, which can be less than N if + -- a disk full condition was detected. + + Seek_Cur : constant := 1; + Seek_End : constant := 2; + Seek_Set : constant := 0; + -- Used to indicate origin for Lseek call + + procedure Lseek + (FD : File_Descriptor; + offset : Long_Integer; + origin : Integer); + pragma Import (C, Lseek, "lseek"); + -- Sets the current file pointer to the indicated offset value, + -- relative to the current position (origin = SEEK_CUR), end of + -- file (origin = SEEK_END), or start of file (origin = SEEK_SET). + + function File_Length (FD : File_Descriptor) return Long_Integer; + pragma Import (C, File_Length, "__gnat_file_length"); + -- Get length of file from file descriptor FD + + function File_Time_Stamp (Name : String) return OS_Time; + -- Given the name of a file or directory, Name, obtains and returns the + -- time stamp. This function can be used for an unopend file. + + function File_Time_Stamp (FD : File_Descriptor) return OS_Time; + -- Get time stamp of file from file descriptor FD + + function Normalize_Pathname + (Name : String; + Directory : String := "") + return String; + -- Returns a file name as an absolute path name, resolving all relative + -- directories, and symbolic links. The parameter Directory is a fully + -- resolved path name for a directory, or the empty string (the default). + -- Name is the name of a file, which is either relative to the given + -- directory name, if Directory is non-null, or to the current working + -- directory if Directory is null. The result returned is the normalized + -- name of the file. For most cases, if two file names designate the same + -- file through different paths, Normalize_Pathname will return the same + -- canonical name in both cases. However, there are cases when this is + -- not true; for example, this is not true in Unix for two hard links + -- designating the same file. + -- + -- If Name cannot be resolved or is null on entry (for example if there is + -- a circularity in symbolic links: A is a symbolic link for B, while B is + -- a symbolic link for A), then Normalize_Pathname returns an empty string. + -- + -- In VMS, if Name follows the VMS syntax file specification, it is first + -- converted into Unix syntax. If the conversion fails, Normalize_Pathname + -- returns an empty string. + + function Is_Absolute_Path (Name : String) return Boolean; + -- Returns True if Name is an absolute path name, i.e. it designates + -- a directory absolutely, rather than relative to another directory. + + function Is_Regular_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing + -- regular file. Returns True if so, False otherwise. + + function Is_Directory (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of a directory. + -- Returns True if so, False otherwise. + + function Is_Writable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing + -- file that is writable. Returns True if so, False otherwise. + + function Locate_Exec_On_Path + (Exec_Name : String) + return String_Access; + -- Try to locate an executable whose name is given by Exec_Name in the + -- directories listed in the environment Path. If the Exec_Name doesn't + -- have the executable suffix, it will be appended before the search. + -- Otherwise works like Locate_Regular_File below. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. + + function Locate_Regular_File + (File_Name : String; + Path : String) + return String_Access; + -- Try to locate a regular file whose name is given by File_Name in the + -- directories listed in Path. If a file is found, its full pathname is + -- returned; otherwise, a null pointer is returned. If the File_Name given + -- is an absolute pathname, then Locate_Regular_File just checks that the + -- file exists and is a regular file. Otherwise, the Path argument is + -- parsed according to OS conventions, and for each directory in the Path + -- a check is made if File_Name is a relative pathname of a regular file + -- from that directory. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. + + function Get_Debuggable_Suffix return String_Access; + -- Return the debuggable suffix convention. Usually this is the same as + -- the convention for Get_Executable_Suffix. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. + + function Get_Executable_Suffix return String_Access; + -- Return the executable suffix convention. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. + + function Get_Object_Suffix return String_Access; + -- Return the object suffix convention. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. + + -- The following section contains low-level routines using addresses to + -- pass file name and executable name. In each routine the name must be + -- Nul-Terminated. For complete documentation refer to the equivalent + -- routine (but using string) defined above. + + subtype C_File_Name is System.Address; + -- This subtype is used to document that a parameter is the address + -- of a null-terminated string containing the name of a file. + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + + function Create_File + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + + function Create_New_File + (Name : C_File_Name; + Fmode : Mode) + return File_Descriptor; + + procedure Delete_File (Name : C_File_Name; Success : out Boolean); + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean); + + function File_Time_Stamp (Name : C_File_Name) return OS_Time; + + function Is_Regular_File (Name : C_File_Name) return Boolean; + + function Is_Directory (Name : C_File_Name) return Boolean; + + function Is_Writable_File (Name : C_File_Name) return Boolean; + + function Locate_Regular_File + (File_Name : C_File_Name; + Path : C_File_Name) + return String_Access; + + ------------------ + -- Subprocesses -- + ------------------ + + type Argument_List is array (Positive range <>) of String_Access; + -- Type used for argument list in call to Spawn. The lower bound + -- of the array should be 1, and the length of the array indicates + -- the number of arguments. + + type Argument_List_Access is access all Argument_List; + -- Type used to return an Argument_List without dragging in secondary + -- stack. + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Success : out Boolean); + -- The first parameter of function Spawn is the name of the executable. + -- The second parameter contains the arguments to be passed to the + -- program. Success is False if the named program could not be spawned + -- or its execution completed unsuccessfully. Note that the caller will + -- be blocked until the execution of the spawned program is complete. + -- For maximum portability, use a full path name for the Program_Name + -- argument. On some systems (notably Unix systems) a simple file + -- name may also work (if the executable can be located in the path). + -- + -- Note: Arguments that contain spaces and/or quotes such as + -- "--GCC=gcc -v" or "--GCC=""gcc-v""" are not portable + -- across OSes. They may or may not have the desired effect. + + function Spawn + (Program_Name : String; + Args : Argument_List) + return Integer; + -- Like above, but as function returning the exact exit status + + type Process_Id is private; + -- A private type used to identify a process activated by the following + -- non-blocking call. The only meaningful operation on this type is a + -- comparison for equality. + + Invalid_Pid : constant Process_Id; + -- A special value used to indicate errors, as described below. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) + return Process_Id; + -- This is a non blocking call. The Process_Id of the spawned process + -- is returned. Parameters are to be used as in Spawn. If Invalid_Id + -- is returned the program could not be spawned. + + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); + -- Wait for the completion of any of the processes created by previous + -- calls to Non_Blocking_Spawn. The caller will be suspended until one + -- of these processes terminates (normally or abnormally). If any of + -- these subprocesses terminates prior to the call to Wait_Process (and + -- has not been returned by a previous call to Wait_Process), then the + -- call to Wait_Process is immediate. Pid identifies the process that + -- has terminated (matching the value returned from Non_Blocking_Spawn). + -- Success is set to True if this sub-process terminated successfully. + -- If Pid = Invalid_Id, there were no subprocesses left to wait on. + + function Argument_String_To_List + (Arg_String : String) + return Argument_List_Access; + -- Take a string that is a program and it's arguments and parse it into + -- an Argument_List. + + ------------------- + -- Miscellaneous -- + ------------------- + + function Getenv (Name : String) return String_Access; + -- Get the value of the environment variable. Returns an access + -- to the empty string if the environment variable does not exist + -- or has an explicit null value (in some operating systems these + -- are distinct cases, in others they are not; this interface + -- abstracts away that difference. + + procedure Setenv (Name : String; Value : String); + -- Set the value of the environment variable Name to Value. This call + -- modifies the current environment, but does not modify the parent + -- process environment. After a call to Setenv, Getenv (Name) will + -- always return a String_Access referencing the same String as Value. + -- This is true also for the null string case (the actual effect may + -- be to either set an explicit null as the value, or to remove the + -- entry, this is operating system dependent). Note that any following + -- calls to Spawn will pass an environment to the spawned process that + -- includes the changes made by Setenv calls. This procedure is not + -- available under VMS. + + procedure OS_Exit (Status : Integer); + pragma Import (C, OS_Exit, "__gnat_os_exit"); + -- Exit to OS with given status code (program is terminated) + + procedure OS_Abort; + pragma Import (C, OS_Abort, "abort"); + -- Exit to OS signalling an abort (traceback or other appropriate + -- diagnostic information should be given if possible, or entry made + -- to the debugger if that is possible). + + function Errno return Integer; + pragma Import (C, Errno, "__get_errno"); + -- Return the task-safe last error number. + + procedure Set_Errno (Errno : Integer); + pragma Import (C, Set_Errno, "__set_errno"); + -- Set the task-safe error number. + + Directory_Separator : constant Character; + -- The character that is used to separate parts of a pathname. + + Path_Separator : constant Character; + -- The character to separate paths in an environment variable value. + +private + pragma Import (C, Path_Separator, "__gnat_path_separator"); + pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + + type OS_Time is new Integer; + + type File_Descriptor is new Integer; + + Standin : constant File_Descriptor := 0; + Standout : constant File_Descriptor := 1; + Standerr : constant File_Descriptor := 2; + Invalid_FD : constant File_Descriptor := -1; + + type Process_Id is new Integer; + Invalid_Pid : constant Process_Id := -1; + +end GNAT.OS_Lib; diff --git a/gcc/ada/g-regexp.adb b/gcc/ada/g-regexp.adb new file mode 100644 index 00000000000..302b63a7832 --- /dev/null +++ b/gcc/ada/g-regexp.adb @@ -0,0 +1,1477 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G E X P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; +with Unchecked_Deallocation; +with Ada.Exceptions; +with GNAT.Case_Util; + +package body GNAT.Regexp is + + Open_Paren : constant Character := '('; + Close_Paren : constant Character := ')'; + Open_Bracket : constant Character := '['; + Close_Bracket : constant Character := ']'; + + type State_Index is new Natural; + type Column_Index is new Natural; + + type Regexp_Array is array + (State_Index range <>, Column_Index range <>) of State_Index; + -- First index is for the state number + -- Second index is for the character type + -- Contents is the new State + + type Regexp_Array_Access is access Regexp_Array; + -- Use this type through the functions Set below, so that it + -- can grow dynamically depending on the needs. + + type Mapping is array (Character'Range) of Column_Index; + -- Mapping between characters and column in the Regexp_Array + + type Boolean_Array is array (State_Index range <>) of Boolean; + + type Regexp_Value + (Alphabet_Size : Column_Index; + Num_States : State_Index) is + record + Map : Mapping; + States : Regexp_Array (1 .. Num_States, 0 .. Alphabet_Size); + Is_Final : Boolean_Array (1 .. Num_States); + Case_Sensitive : Boolean; + end record; + -- Deterministic finite-state machine + + Debug : constant Boolean := False; + -- When True, the primary and secondary tables will be printed. + -- Gnat does not generate any code if this variable is False; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set + (Table : in out Regexp_Array_Access; + State : State_Index; + Column : Column_Index; + Value : State_Index); + -- Sets a value in the table. If the table is too small, reallocate it + -- dynamically so that (State, Column) is a valid index in it. + + function Get + (Table : Regexp_Array_Access; + State : State_Index; + Column : Column_Index) + return State_Index; + -- Returns the value in the table at (State, Column). + -- If this index does not exist in the table, returns 0 + + procedure Free is new Unchecked_Deallocation + (Regexp_Array, Regexp_Array_Access); + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (R : in out Regexp) is + Tmp : Regexp_Access; + + begin + Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size, + Num_States => R.R.Num_States); + Tmp.all := R.R.all; + R.R := Tmp; + end Adjust; + + ------------- + -- Compile -- + ------------- + + function Compile + (Pattern : String; + Glob : Boolean := False; + Case_Sensitive : Boolean := True) + return Regexp + is + S : String := Pattern; + -- The pattern which is really compiled (when the pattern is case + -- insensitive, we convert this string to lower-cases + + Map : Mapping := (others => 0); + -- Mapping between characters and columns in the tables + + Alphabet_Size : Column_Index := 0; + -- Number of significant characters in the regular expression. + -- This total does not include special operators, such as *, (, ... + + procedure Create_Mapping; + -- Creates a mapping between characters in the regexp and columns + -- in the tables representing the regexp. Test that the regexp is + -- well-formed Modifies Alphabet_Size and Map + + procedure Create_Primary_Table + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index); + -- Creates the first version of the regexp (this is a non determinist + -- finite state machine, which is unadapted for a fast pattern + -- matching algorithm). We use a recursive algorithm to process the + -- parenthesis sub-expressions. + -- + -- Table : at the end of the procedure : Column 0 is for any character + -- ('.') and the last columns are for no character (closure) + -- Num_States is set to the number of states in the table + -- Start_State is the number of the starting state in the regexp + -- End_State is the number of the final state when the regexp matches + + procedure Create_Primary_Table_Glob + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index); + -- Same function as above, but it deals with the second possible + -- grammar for 'globbing pattern', which is a kind of subset of the + -- whole regular expression grammar. + + function Create_Secondary_Table + (First_Table : Regexp_Array_Access; + Num_States : State_Index; + Start_State : State_Index; + End_State : State_Index) + return Regexp; + -- Creates the definitive table representing the regular expression + -- This is actually a transformation of the primary table First_Table, + -- where every state is grouped with the states in its 'no-character' + -- columns. The transitions between the new states are then recalculated + -- and if necessary some new states are created. + -- + -- Note that the resulting finite-state machine is not optimized in + -- terms of the number of states : it would be more time-consuming to + -- add a third pass to reduce the number of states in the machine, with + -- no speed improvement... + + procedure Raise_Exception + (M : String; + Index : Integer); + pragma No_Return (Raise_Exception); + -- Raise an exception, indicating an error at character Index in S. + + procedure Print_Table + (Table : Regexp_Array; + Num_States : State_Index; + Is_Primary : Boolean := True); + -- Print a table for debugging purposes + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping is + + procedure Add_In_Map (C : Character); + -- Add a character in the mapping, if it is not already defined + + ----------------- + -- Add_In_Map -- + ----------------- + + procedure Add_In_Map (C : Character) is + begin + if Map (C) = 0 then + Alphabet_Size := Alphabet_Size + 1; + Map (C) := Alphabet_Size; + end if; + end Add_In_Map; + + J : Integer := S'First; + Parenthesis_Level : Integer := 0; + Curly_Level : Integer := 0; + + -- Start of processing for Create_Mapping + + begin + while J <= S'Last loop + case S (J) is + when Open_Bracket => + J := J + 1; + + if S (J) = '^' then + J := J + 1; + end if; + + if S (J) = ']' or S (J) = '-' then + J := J + 1; + end if; + + -- The first character never has a special meaning + + loop + if J > S'Last then + Raise_Exception + ("Ran out of characters while parsing ", J); + end if; + + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= Close_Bracket + then + declare + Start : constant Integer := J - 1; + + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Add_In_Map (Char); + end loop; + end; + else + if S (J) = '\' then + J := J + 1; + end if; + + Add_In_Map (S (J)); + end if; + + J := J + 1; + end loop; + + -- A close bracket must follow a open_bracket, + -- and cannot be found alone on the line + + when Close_Bracket => + Raise_Exception + ("Incorrect character ']' in regular expression", J); + + when '\' => + if J < S'Last then + J := J + 1; + Add_In_Map (S (J)); + + else + -- \ not allowed at the end of the regexp + + Raise_Exception + ("Incorrect character '\' in regular expression", J); + end if; + + when Open_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level + 1; + else + Add_In_Map (Open_Paren); + end if; + + when Close_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level - 1; + + if Parenthesis_Level < 0 then + Raise_Exception + ("')' is not associated with '(' in regular " + & "expression", J); + end if; + + if S (J - 1) = Open_Paren then + Raise_Exception + ("Empty parenthesis not allowed in regular " + & "expression", J); + end if; + + else + Add_In_Map (Close_Paren); + end if; + + when '.' => + if Glob then + Add_In_Map ('.'); + end if; + + when '{' => + if not Glob then + Add_In_Map (S (J)); + else + Curly_Level := Curly_Level + 1; + end if; + + when '}' => + if not Glob then + Add_In_Map (S (J)); + else + Curly_Level := Curly_Level - 1; + end if; + + when '*' | '?' => + if not Glob then + if J = S'First then + Raise_Exception + ("'*', '+', '?' and '|' operators can not be in " + & "first position in regular expression", J); + end if; + end if; + + when '|' | '+' => + if not Glob then + if J = S'First then + + -- These operators must apply to a sub-expression, + -- and cannot be found at the beginning of the line + + Raise_Exception + ("'*', '+', '?' and '|' operators can not be in " + & "first position in regular expression", J); + end if; + + else + Add_In_Map (S (J)); + end if; + + when others => + Add_In_Map (S (J)); + end case; + + J := J + 1; + end loop; + + -- A closing parenthesis must follow an open parenthesis + + if Parenthesis_Level /= 0 then + Raise_Exception + ("'(' must always be associated with a ')'", J); + end if; + + if Curly_Level /= 0 then + Raise_Exception + ("'{' must always be associated with a '}'", J); + end if; + end Create_Mapping; + + -------------------------- + -- Create_Primary_Table -- + -------------------------- + + procedure Create_Primary_Table + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index) + is + Empty_Char : constant Column_Index := Alphabet_Size + 1; + + Current_State : State_Index := 0; + -- Index of the last created state + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index); + -- Add a empty-character transition from State to To_State. + + procedure Create_Repetition + (Repetition : Character; + Start_Prev : State_Index; + End_Prev : State_Index; + New_Start : out State_Index; + New_End : in out State_Index); + -- Create the table in case we have a '*', '+' or '?'. + -- Start_Prev .. End_Prev should indicate respectively the start and + -- end index of the previous expression, to which '*', '+' or '?' is + -- applied. + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index); + -- Fill the table for the regexp Simple. + -- This is the recursive procedure called to handle () expressions + -- If End_State = 0, then the call to Create_Simple creates an + -- independent regexp, not a concatenation + -- Start_Index .. End_Index is the starting index in the string S. + -- + -- Warning: it may look like we are creating too many empty-string + -- transitions, but they are needed to get the correct regexp. + -- The table is filled as follow ( s means start-state, e means + -- end-state) : + -- + -- regexp state_num | a b * empty_string + -- ------- --------------------------------------- + -- a 1 (s) | 2 - - - + -- 2 (e) | - - - - + -- + -- ab 1 (s) | 2 - - - + -- 2 | - - - 3 + -- 3 | - 4 - - + -- 4 (e) | - - - - + -- + -- a|b 1 | 2 - - - + -- 2 | - - - 6 + -- 3 | - 4 - - + -- 4 | - - - 6 + -- 5 (s) | - - - 1,3 + -- 6 (e) | - - - - + -- + -- a* 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1,4 + -- 4 (e) | - - - 3 + -- + -- (a) 1 (s) | 2 - - - + -- 2 (e) | - - - - + -- + -- a+ 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1 + -- 4 (e) | - - - 3 + -- + -- a? 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1,4 + -- 4 (e) | - - - - + -- + -- . 1 (s) | 2 2 2 - + -- 2 (e) | - - - - + + function Next_Sub_Expression + (Start_Index : Integer; + End_Index : Integer) + return Integer; + -- Returns the index of the last character of the next sub-expression + -- in Simple. Index can not be greater than End_Index + + -------------------- + -- Add_Empty_Char -- + -------------------- + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index) + is + J : Column_Index := Empty_Char; + + begin + while Get (Table, State, J) /= 0 loop + J := J + 1; + end loop; + + Set (Table, State, J, To_State); + end Add_Empty_Char; + + ----------------------- + -- Create_Repetition -- + ----------------------- + + procedure Create_Repetition + (Repetition : Character; + Start_Prev : State_Index; + End_Prev : State_Index; + New_Start : out State_Index; + New_End : in out State_Index) + is + begin + New_Start := Current_State + 1; + + if New_End /= 0 then + Add_Empty_Char (New_End, New_Start); + end if; + + Current_State := Current_State + 2; + New_End := Current_State; + + Add_Empty_Char (End_Prev, New_End); + Add_Empty_Char (New_Start, Start_Prev); + + if Repetition /= '+' then + Add_Empty_Char (New_Start, New_End); + end if; + + if Repetition /= '?' then + Add_Empty_Char (New_End, New_Start); + end if; + end Create_Repetition; + + ------------------- + -- Create_Simple -- + ------------------- + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index) + is + J : Integer := Start_Index; + Last_Start : State_Index := 0; + + begin + Start_State := 0; + End_State := 0; + while J <= End_Index loop + case S (J) is + when Open_Paren => + declare + J_Start : Integer := J + 1; + Next_Start : State_Index; + Next_End : State_Index; + + begin + J := Next_Sub_Expression (J, End_Index); + Create_Simple (J_Start, J - 1, Next_Start, Next_End); + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Next_Start, + Next_End, + Last_Start, + End_State); + + else + Last_Start := Next_Start; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Next_End; + end if; + end; + + when '|' => + declare + Start_Prev : State_Index := Start_State; + End_Prev : State_Index := End_State; + Start_Next : State_Index := 0; + End_Next : State_Index := 0; + Start_J : Integer := J + 1; + + begin + J := Next_Sub_Expression (J, End_Index); + + -- Create a new state for the start of the alternative + + Current_State := Current_State + 1; + Last_Start := Current_State; + Start_State := Last_Start; + + -- Create the tree for the second part of alternative + + Create_Simple (Start_J, J, Start_Next, End_Next); + + -- Create the end state + + Add_Empty_Char (Last_Start, Start_Next); + Add_Empty_Char (Last_Start, Start_Prev); + Current_State := Current_State + 1; + End_State := Current_State; + Add_Empty_Char (End_Prev, End_State); + Add_Empty_Char (End_Next, End_State); + end; + + when Open_Bracket => + Current_State := Current_State + 1; + + declare + Next_State : State_Index := Current_State + 1; + + begin + J := J + 1; + + if S (J) = '^' then + J := J + 1; + + Next_State := 0; + + for Column in 0 .. Alphabet_Size loop + Set (Table, Current_State, Column, + Value => Current_State + 1); + end loop; + end if; + + -- Automatically add the first character + + if S (J) = '-' or S (J) = ']' then + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + J := J + 1; + end if; + + -- Loop till closing bracket found + + loop + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= ']' + then + declare + Start : constant Integer := J - 1; + + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Set (Table, Current_State, Map (Char), + Value => Next_State); + end loop; + end; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + end if; + J := J + 1; + end loop; + end; + + Current_State := Current_State + 1; + + -- If the next symbol is a special symbol + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Current_State - 1, + Current_State, + Last_Start, + End_State); + + else + Last_Start := Current_State - 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + end if; + + when '*' | '+' | '?' | Close_Paren | Close_Bracket => + Raise_Exception + ("Incorrect character in regular expression :", J); + + when others => + Current_State := Current_State + 1; + + -- Create the state for the symbol S (J) + + if S (J) = '.' then + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Current_State + 1); + end if; + + Current_State := Current_State + 1; + + -- If the next symbol is a special symbol + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Current_State - 1, + Current_State, + Last_Start, + End_State); + + else + Last_Start := Current_State - 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + end if; + + end case; + + if Start_State = 0 then + Start_State := Last_Start; + end if; + + J := J + 1; + end loop; + end Create_Simple; + + ------------------------- + -- Next_Sub_Expression -- + ------------------------- + + function Next_Sub_Expression + (Start_Index : Integer; + End_Index : Integer) + return Integer + is + J : Integer := Start_Index; + Start_On_Alter : Boolean := False; + + begin + if S (J) = '|' then + Start_On_Alter := True; + end if; + + loop + exit when J = End_Index; + J := J + 1; + + case S (J) is + when '\' => + J := J + 1; + + when Open_Bracket => + loop + J := J + 1; + exit when S (J) = Close_Bracket; + + if S (J) = '\' then + J := J + 1; + end if; + end loop; + + when Open_Paren => + J := Next_Sub_Expression (J, End_Index); + + when Close_Paren => + return J; + + when '|' => + if Start_On_Alter then + return J - 1; + end if; + + when others => + null; + end case; + end loop; + + return J; + end Next_Sub_Expression; + + -- Start of Create_Primary_Table + + begin + Table.all := (others => (others => 0)); + Create_Simple (S'First, S'Last, Start_State, End_State); + Num_States := Current_State; + end Create_Primary_Table; + + ------------------------------- + -- Create_Primary_Table_Glob -- + ------------------------------- + + procedure Create_Primary_Table_Glob + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index) + is + Empty_Char : constant Column_Index := Alphabet_Size + 1; + + Current_State : State_Index := 0; + -- Index of the last created state + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index); + -- Add a empty-character transition from State to To_State. + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index); + -- Fill the table for the S (Start_Index .. End_Index). + -- This is the recursive procedure called to handle () expressions + + -------------------- + -- Add_Empty_Char -- + -------------------- + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index) + is + J : Column_Index := Empty_Char; + + begin + while Get (Table, State, J) /= 0 loop + J := J + 1; + end loop; + + Set (Table, State, J, + Value => To_State); + end Add_Empty_Char; + + ------------------- + -- Create_Simple -- + ------------------- + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index) + is + J : Integer := Start_Index; + Last_Start : State_Index := 0; + + begin + Start_State := 0; + End_State := 0; + + while J <= End_Index loop + case S (J) is + + when Open_Bracket => + Current_State := Current_State + 1; + + declare + Next_State : State_Index := Current_State + 1; + + begin + J := J + 1; + + if S (J) = '^' then + J := J + 1; + Next_State := 0; + + for Column in 0 .. Alphabet_Size loop + Set (Table, Current_State, Column, + Value => Current_State + 1); + end loop; + end if; + + -- Automatically add the first character + + if S (J) = '-' or S (J) = ']' then + Set (Table, Current_State, Map (S (J)), + Value => Current_State); + J := J + 1; + end if; + + -- Loop till closing bracket found + + loop + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= ']' + then + declare + Start : constant Integer := J - 1; + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Set (Table, Current_State, Map (Char), + Value => Next_State); + end loop; + end; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + end if; + J := J + 1; + end loop; + end; + + Last_Start := Current_State; + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + + when '{' => + declare + End_Sub : Integer; + Start_Regexp_Sub : State_Index; + End_Regexp_Sub : State_Index; + Create_Start : State_Index := 0; + + Create_End : State_Index := 0; + -- Initialized to avoid junk warning + + begin + while S (J) /= '}' loop + + -- First step : find sub pattern + + End_Sub := J + 1; + while S (End_Sub) /= ',' + and then S (End_Sub) /= '}' + loop + End_Sub := End_Sub + 1; + end loop; + + -- Second step : create a sub pattern + + Create_Simple + (J + 1, + End_Sub - 1, + Start_Regexp_Sub, + End_Regexp_Sub); + + J := End_Sub; + + -- Third step : create an alternative + + if Create_Start = 0 then + Current_State := Current_State + 1; + Create_Start := Current_State; + Add_Empty_Char (Create_Start, Start_Regexp_Sub); + Current_State := Current_State + 1; + Create_End := Current_State; + Add_Empty_Char (End_Regexp_Sub, Create_End); + + else + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Create_Start); + Create_Start := Current_State; + Add_Empty_Char (Create_Start, Start_Regexp_Sub); + Add_Empty_Char (End_Regexp_Sub, Create_End); + end if; + end loop; + + if End_State /= 0 then + Add_Empty_Char (End_State, Create_Start); + end if; + + End_State := Create_End; + Last_Start := Create_Start; + end; + + when '*' => + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Current_State); + end if; + + Add_Empty_Char (Current_State, Current_State + 1); + Add_Empty_Char (Current_State, Current_State + 3); + Last_Start := Current_State; + + Current_State := Current_State + 1; + + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Current_State + 1); + + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Last_Start); + End_State := Current_State; + + when others => + Current_State := Current_State + 1; + + if S (J) = '?' then + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + else + if S (J) = '\' then + J := J + 1; + end if; + + -- Create the state for the symbol S (J) + + Set (Table, Current_State, Map (S (J)), + Value => Current_State + 1); + end if; + + Last_Start := Current_State; + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + + end case; + + if Start_State = 0 then + Start_State := Last_Start; + end if; + + J := J + 1; + end loop; + end Create_Simple; + + -- Start of processing for Create_Primary_Table_Glob + + begin + Table.all := (others => (others => 0)); + Create_Simple (S'First, S'Last, Start_State, End_State); + Num_States := Current_State; + end Create_Primary_Table_Glob; + + ---------------------------- + -- Create_Secondary_Table -- + ---------------------------- + + function Create_Secondary_Table + (First_Table : Regexp_Array_Access; + Num_States : State_Index; + Start_State : State_Index; + End_State : State_Index) + return Regexp + is + Last_Index : constant State_Index := First_Table'Last (1); + type Meta_State is array (1 .. Last_Index) of Boolean; + + Table : Regexp_Array (1 .. Last_Index, 0 .. Alphabet_Size) := + (others => (others => 0)); + + Meta_States : array (1 .. Last_Index + 1) of Meta_State := + (others => (others => False)); + + Temp_State_Not_Null : Boolean; + + Is_Final : Boolean_Array (1 .. Last_Index) := (others => False); + + Current_State : State_Index := 1; + Nb_State : State_Index := 1; + + procedure Closure + (State : in out Meta_State; + Item : State_Index); + -- Compute the closure of the state (that is every other state which + -- has a empty-character transition) and add it to the state + + ------------- + -- Closure -- + ------------- + + procedure Closure + (State : in out Meta_State; + Item : State_Index) + is + begin + if State (Item) then + return; + end if; + + State (Item) := True; + + for Column in Alphabet_Size + 1 .. First_Table'Last (2) loop + if First_Table (Item, Column) = 0 then + return; + end if; + + Closure (State, First_Table (Item, Column)); + end loop; + end Closure; + + -- Start of procesing for Create_Secondary_Table + + begin + -- Create a new state + + Closure (Meta_States (Current_State), Start_State); + + while Current_State <= Nb_State loop + + -- If this new meta-state includes the primary table end state, + -- then this meta-state will be a final state in the regexp + + if Meta_States (Current_State)(End_State) then + Is_Final (Current_State) := True; + end if; + + -- For every character in the regexp, calculate the possible + -- transitions from Current_State + + for Column in 0 .. Alphabet_Size loop + Meta_States (Nb_State + 1) := (others => False); + Temp_State_Not_Null := False; + + for K in Meta_States (Current_State)'Range loop + if Meta_States (Current_State)(K) + and then First_Table (K, Column) /= 0 + then + Closure + (Meta_States (Nb_State + 1), First_Table (K, Column)); + Temp_State_Not_Null := True; + end if; + end loop; + + -- If at least one transition existed + + if Temp_State_Not_Null then + + -- Check if this new state corresponds to an old one + + for K in 1 .. Nb_State loop + if Meta_States (K) = Meta_States (Nb_State + 1) then + Table (Current_State, Column) := K; + exit; + end if; + end loop; + + -- If not, create a new state + + if Table (Current_State, Column) = 0 then + Nb_State := Nb_State + 1; + Table (Current_State, Column) := Nb_State; + end if; + end if; + end loop; + + Current_State := Current_State + 1; + end loop; + + -- Returns the regexp + + declare + R : Regexp_Access; + + begin + R := new Regexp_Value (Alphabet_Size => Alphabet_Size, + Num_States => Nb_State); + R.Map := Map; + R.Is_Final := Is_Final (1 .. Nb_State); + R.Case_Sensitive := Case_Sensitive; + + for State in 1 .. Nb_State loop + for K in 0 .. Alphabet_Size loop + R.States (State, K) := Table (State, K); + end loop; + end loop; + + if Debug then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put_Line ("Secondary table : "); + Print_Table (R.States, Nb_State, False); + end if; + + return (Ada.Finalization.Controlled with R => R); + end; + end Create_Secondary_Table; + + ----------------- + -- Print_Table -- + ----------------- + + procedure Print_Table + (Table : Regexp_Array; + Num_States : State_Index; + Is_Primary : Boolean := True) + is + function Reverse_Mapping (N : Column_Index) return Character; + -- Return the character corresponding to a column in the mapping + + --------------------- + -- Reverse_Mapping -- + --------------------- + + function Reverse_Mapping (N : Column_Index) return Character is + begin + for Column in Map'Range loop + if Map (Column) = N then + return Column; + end if; + end loop; + + return ' '; + end Reverse_Mapping; + + -- Start of processing for Print_Table + + begin + -- Print the header line + + Ada.Text_IO.Put (" [*] "); + + for Column in 1 .. Alphabet_Size loop + Ada.Text_IO.Put (String'(1 .. 1 => Reverse_Mapping (Column)) + & " "); + end loop; + + if Is_Primary then + Ada.Text_IO.Put ("closure...."); + end if; + + Ada.Text_IO.New_Line; + + -- Print every line + + for State in 1 .. Num_States loop + Ada.Text_IO.Put (State'Img); + + for K in 1 .. 3 - State'Img'Length loop + Ada.Text_IO.Put (" "); + end loop; + + for K in 0 .. Alphabet_Size loop + Ada.Text_IO.Put (Table (State, K)'Img & " "); + end loop; + + for K in Alphabet_Size + 1 .. Table'Last (2) loop + if Table (State, K) /= 0 then + Ada.Text_IO.Put (Table (State, K)'Img & ","); + end if; + end loop; + + Ada.Text_IO.New_Line; + end loop; + + end Print_Table; + + --------------------- + -- Raise_Exception -- + --------------------- + + procedure Raise_Exception + (M : String; + Index : Integer) + is + begin + Ada.Exceptions.Raise_Exception + (Error_In_Regexp'Identity, M & " at offset " & Index'Img); + end Raise_Exception; + + -- Start of processing for Compile + + begin + if not Case_Sensitive then + GNAT.Case_Util.To_Lower (S); + end if; + + Create_Mapping; + + -- Creates the primary table + + declare + Table : Regexp_Array_Access; + Num_States : State_Index; + Start_State : State_Index; + End_State : State_Index; + R : Regexp; + + begin + Table := new Regexp_Array (1 .. 100, + 0 .. Alphabet_Size + 10); + if not Glob then + Create_Primary_Table (Table, Num_States, Start_State, End_State); + else + Create_Primary_Table_Glob + (Table, Num_States, Start_State, End_State); + end if; + + if Debug then + Print_Table (Table.all, Num_States); + Ada.Text_IO.Put_Line ("Start_State : " & Start_State'Img); + Ada.Text_IO.Put_Line ("End_State : " & End_State'Img); + end if; + + -- Creates the secondary table + + R := Create_Secondary_Table + (Table, Num_States, Start_State, End_State); + Free (Table); + return R; + end; + end Compile; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (R : in out Regexp) is + procedure Free is new + Unchecked_Deallocation (Regexp_Value, Regexp_Access); + + begin + Free (R.R); + end Finalize; + + --------- + -- Get -- + --------- + + function Get + (Table : Regexp_Array_Access; + State : State_Index; + Column : Column_Index) + return State_Index + is + begin + if State <= Table'Last (1) + and then Column <= Table'Last (2) + then + return Table (State, Column); + else + return 0; + end if; + end Get; + + ----------- + -- Match -- + ----------- + + function Match (S : String; R : Regexp) return Boolean is + Current_State : State_Index := 1; + + begin + if R.R = null then + raise Constraint_Error; + end if; + + for Char in S'Range loop + + if R.R.Case_Sensitive then + Current_State := R.R.States (Current_State, R.R.Map (S (Char))); + else + Current_State := + R.R.States (Current_State, + R.R.Map (GNAT.Case_Util.To_Lower (S (Char)))); + end if; + + if Current_State = 0 then + return False; + end if; + + end loop; + + return R.R.Is_Final (Current_State); + end Match; + + --------- + -- Set -- + --------- + + procedure Set + (Table : in out Regexp_Array_Access; + State : State_Index; + Column : Column_Index; + Value : State_Index) + is + New_Lines : State_Index; + New_Columns : Column_Index; + New_Table : Regexp_Array_Access; + + begin + if State <= Table'Last (1) + and then Column <= Table'Last (2) + then + Table (State, Column) := Value; + else + -- Doubles the size of the table until it is big enough that + -- (State, Column) is a valid index + + New_Lines := Table'Last (1) * (State / Table'Last (1) + 1); + New_Columns := Table'Last (2) * (Column / Table'Last (2) + 1); + New_Table := new Regexp_Array (Table'First (1) .. New_Lines, + Table'First (2) .. New_Columns); + New_Table.all := (others => (others => 0)); + + if Debug then + Ada.Text_IO.Put_Line ("Reallocating table: Lines from " + & State_Index'Image (Table'Last (1)) & " to " + & State_Index'Image (New_Lines)); + Ada.Text_IO.Put_Line (" and columns from " + & Column_Index'Image (Table'Last (2)) + & " to " + & Column_Index'Image (New_Columns)); + end if; + + for J in Table'Range (1) loop + for K in Table'Range (2) loop + New_Table (J, K) := Table (J, K); + end loop; + end loop; + + Free (Table); + Table := New_Table; + Table (State, Column) := Value; + end if; + end Set; + +end GNAT.Regexp; diff --git a/gcc/ada/g-regexp.ads b/gcc/ada/g-regexp.ads new file mode 100644 index 00000000000..7e45e0eab67 --- /dev/null +++ b/gcc/ada/g-regexp.ads @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G E X P -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1998-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Simple Regular expression matching + +-- This package provides a simple implementation of a regular expression +-- pattern matching algorithm, using a subset of the syntax of regular +-- expressions copied from familiar Unix style utilities. + +------------------------------------------------------------ +-- Summary of Pattern Matching Packages in GNAT Hierarchy -- +------------------------------------------------------------ + +-- There are three related packages that perform pattern maching functions. +-- the following is an outline of these packages, to help you determine +-- which is best for your needs. + +-- GNAT.Regexp (files g-regexp.ads/g-regexp.adb) +-- This is a simple package providing Unix-style regular expression +-- matching with the restriction that it matches entire strings. It +-- is particularly useful for file name matching, and in particular +-- it provides "globbing patterns" that are useful in implementing +-- unix or DOS style wild card matching for file names. + +-- GNAT.Regpat (files g-regpat.ads/g-regpat.adb) +-- This is a more complete implementation of Unix-style regular +-- expressions, copied from the original V7 style regular expression +-- library written in C by Henry Spencer. It is functionally the +-- same as this library, and uses the same internal data structures +-- stored in a binary compatible manner. + +-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) +-- This is a completely general patterm matching package based on the +-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern +-- language is modeled on context free grammars, with context sensitive +-- extensions that provide full (type 0) computational capabilities. + +with Ada.Finalization; + +package GNAT.Regexp is + + -- The regular expression must first be compiled, using the Compile + -- function, which creates a finite state matching table, allowing + -- very fast matching once the expression has been compiled. + + -- The following is the form of a regular expression, expressed in Ada + -- reference manual style BNF is as follows + + -- regexp ::= term + + -- regexp ::= term | term -- alternation (term or term ...) + + -- term ::= item + + -- term ::= item item ... -- concatenation (item then item) + + -- item ::= elmt -- match elmt + -- item ::= elmt * -- zero or more elmt's + -- item ::= elmt + -- one or more elmt's + -- item ::= elmt ? -- matches elmt or nothing + + -- elmt ::= nchr -- matches given character + -- elmt ::= [nchr nchr ...] -- matches any character listed + -- elmt ::= [^ nchr nchr ...] -- matches any character not listed + -- elmt ::= [char - char] -- matches chars in given range + -- elmt ::= . -- matches any single character + -- elmt ::= ( regexp ) -- parens used for grouping + + -- char ::= any character, including special characters + -- nchr ::= any character except \()[].*+?^ or \char to match char + -- ... is used to indication repetition (one or more terms) + + -- See also regexp(1) man page on Unix systems for further details + + -- A second kind of regular expressions is provided. This one is more + -- like the wild card patterns used in file names by the Unix shell (or + -- DOS prompt) command lines. The grammar is the following: + + -- regexp ::= term + + -- term ::= elmt + + -- term ::= elmt elmt ... -- concatenation (elmt then elmt) + -- term ::= * -- any string of 0 or more characters + -- term ::= ? -- matches any character + -- term ::= [char char ...] -- matches any character listed + -- term ::= [char - char] -- matches any character in given range + -- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt) + + -- Important note : This package was mainly intended to match regular + -- expressions against file names. The whole string has to match the + -- regular expression. If only a substring matches, then the function + -- Match will return False. + + type Regexp is private; + -- Private type used to represent a regular expression + + Error_In_Regexp : exception; + -- Exception raised when an error is found in the regular expression + + function Compile + (Pattern : String; + Glob : Boolean := False; + Case_Sensitive : Boolean := True) + return Regexp; + -- Compiles a regular expression S. If the syntax of the given + -- expression is invalid (does not match above grammar, Error_In_Regexp + -- is raised. If Glob is True, the pattern is considered as a 'globbing + -- pattern', that is a pattern as given by the second grammar above + + function Match (S : String; R : Regexp) return Boolean; + -- True if S matches R, otherwise False. Raises Constraint_Error if + -- R is an uninitialized regular expression value. + +private + type Regexp_Value; + + type Regexp_Access is access Regexp_Value; + + type Regexp is new Ada.Finalization.Controlled with record + R : Regexp_Access := null; + end record; + + pragma Finalize_Storage_Only (Regexp); + + procedure Finalize (R : in out Regexp); + -- Free the memory occupied by R + + procedure Adjust (R : in out Regexp); + -- Called after an assignment (do a copy of the Regexp_Access.all) + +end GNAT.Regexp; diff --git a/gcc/ada/g-regist.adb b/gcc/ada/g-regist.adb new file mode 100644 index 00000000000..97e58fbc24e --- /dev/null +++ b/gcc/ada/g-regist.adb @@ -0,0 +1,434 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G I S T R Y -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Interfaces.C; +with System; + +package body GNAT.Registry is + + use Ada; + use System; + + ------------------------------ + -- Binding to the Win32 API -- + ------------------------------ + + subtype LONG is Interfaces.C.long; + subtype ULONG is Interfaces.C.unsigned_long; + subtype DWORD is ULONG; + + type PULONG is access all ULONG; + subtype PDWORD is PULONG; + subtype LPDWORD is PDWORD; + + subtype Error_Code is LONG; + + subtype REGSAM is LONG; + + type PHKEY is access all HKEY; + + ERROR_SUCCESS : constant Error_Code := 0; + + REG_SZ : constant := 1; + + function RegCloseKey (Key : HKEY) return LONG; + pragma Import (Stdcall, RegCloseKey, "RegCloseKey"); + + function RegCreateKeyEx + (Key : HKEY; + lpSubKey : Address; + Reserved : DWORD; + lpClass : Address; + dwOptions : DWORD; + samDesired : REGSAM; + lpSecurityAttributes : Address; + phkResult : PHKEY; + lpdwDisposition : LPDWORD) + return LONG; + pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA"); + + function RegDeleteKey + (Key : HKEY; + lpSubKey : Address) + return LONG; + pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA"); + + function RegDeleteValue + (Key : HKEY; + lpValueName : Address) + return LONG; + pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA"); + + function RegEnumValue + (Key : HKEY; + dwIndex : DWORD; + lpValueName : Address; + lpcbValueName : LPDWORD; + lpReserved : LPDWORD; + lpType : LPDWORD; + lpData : Address; + lpcbData : LPDWORD) + return LONG; + pragma Import (Stdcall, RegEnumValue, "RegEnumValueA"); + + function RegOpenKeyEx + (Key : HKEY; + lpSubKey : Address; + ulOptions : DWORD; + samDesired : REGSAM; + phkResult : PHKEY) + return LONG; + pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA"); + + function RegQueryValueEx + (Key : HKEY; + lpValueName : Address; + lpReserved : LPDWORD; + lpType : LPDWORD; + lpData : Address; + lpcbData : LPDWORD) + return LONG; + pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA"); + + function RegSetValueEx + (Key : HKEY; + lpValueName : Address; + Reserved : DWORD; + dwType : DWORD; + lpData : Address; + cbData : DWORD) + return LONG; + pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_C_Mode (Mode : Key_Mode) return REGSAM; + -- Returns the Win32 mode value for the Key_Mode value. + + procedure Check_Result (Result : LONG; Message : String); + -- Checks value Result and raise the exception Registry_Error if it is not + -- equal to ERROR_SUCCESS. Message and the error value (Result) is added + -- to the exception message. + + ------------------ + -- Check_Result -- + ------------------ + + procedure Check_Result (Result : LONG; Message : String) is + use type LONG; + + begin + if Result /= ERROR_SUCCESS then + Exceptions.Raise_Exception + (Registry_Error'Identity, + Message & " (" & LONG'Image (Result) & ')'); + end if; + end Check_Result; + + --------------- + -- Close_Key -- + --------------- + + procedure Close_Key (Key : HKEY) is + Result : LONG; + + begin + Result := RegCloseKey (Key); + Check_Result (Result, "Close_Key"); + end Close_Key; + + ---------------- + -- Create_Key -- + ---------------- + + function Create_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Write) + return HKEY + is + use type REGSAM; + use type DWORD; + + REG_OPTION_NON_VOLATILE : constant := 16#0#; + + C_Sub_Key : constant String := Sub_Key & ASCII.Nul; + C_Class : constant String := "" & ASCII.Nul; + C_Mode : constant REGSAM := To_C_Mode (Mode); + + New_Key : aliased HKEY; + Result : LONG; + Dispos : aliased DWORD; + + begin + Result := RegCreateKeyEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + 0, + C_Class (C_Class'First)'Address, + REG_OPTION_NON_VOLATILE, + C_Mode, + Null_Address, + New_Key'Unchecked_Access, + Dispos'Unchecked_Access); + + Check_Result (Result, "Create_Key " & Sub_Key); + return New_Key; + end Create_Key; + + ---------------- + -- Delete_Key -- + ---------------- + + procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is + C_Sub_Key : constant String := Sub_Key & ASCII.Nul; + Result : LONG; + + begin + Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); + Check_Result (Result, "Delete_Key " & Sub_Key); + end Delete_Key; + + ------------------ + -- Delete_Value -- + ------------------ + + procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is + C_Sub_Key : constant String := Sub_Key & ASCII.Nul; + Result : LONG; + + begin + Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); + Check_Result (Result, "Delete_Value " & Sub_Key); + end Delete_Value; + + ------------------------- + -- For_Every_Key_Value -- + ------------------------- + + procedure For_Every_Key_Value (From_Key : HKEY) is + use type LONG; + use type ULONG; + + Index : ULONG := 0; + Result : LONG; + + Sub_Key : String (1 .. 100); + pragma Warnings (Off, Sub_Key); + + Value : String (1 .. 100); + pragma Warnings (Off, Value); + + Size_Sub_Key : aliased ULONG; + Size_Value : aliased ULONG; + Type_Sub_Key : aliased DWORD; + + Quit : Boolean; + + begin + loop + Size_Sub_Key := Sub_Key'Length; + Size_Value := Value'Length; + + Result := RegEnumValue + (From_Key, Index, + Sub_Key (1)'Address, + Size_Sub_Key'Unchecked_Access, + null, + Type_Sub_Key'Unchecked_Access, + Value (1)'Address, + Size_Value'Unchecked_Access); + + exit when not (Result = ERROR_SUCCESS); + + if Type_Sub_Key = REG_SZ then + Quit := False; + + Action (Natural (Index) + 1, + Sub_Key (1 .. Integer (Size_Sub_Key)), + Value (1 .. Integer (Size_Value) - 1), + Quit); + + exit when Quit; + + Index := Index + 1; + end if; + + end loop; + end For_Every_Key_Value; + + ---------------- + -- Key_Exists -- + ---------------- + + function Key_Exists + (From_Key : HKEY; + Sub_Key : String) + return Boolean + is + New_Key : HKEY; + + begin + New_Key := Open_Key (From_Key, Sub_Key); + Close_Key (New_Key); + + -- We have been able to open the key so it exists + + return True; + + exception + when Registry_Error => + + -- An error occured, the key was not found + + return False; + end Key_Exists; + + -------------- + -- Open_Key -- + -------------- + + function Open_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Only) + return HKEY + is + use type REGSAM; + + C_Sub_Key : constant String := Sub_Key & ASCII.Nul; + C_Mode : constant REGSAM := To_C_Mode (Mode); + + New_Key : aliased HKEY; + Result : LONG; + + begin + Result := RegOpenKeyEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + 0, + C_Mode, + New_Key'Unchecked_Access); + + Check_Result (Result, "Open_Key " & Sub_Key); + return New_Key; + end Open_Key; + + ----------------- + -- Query_Value -- + ----------------- + + function Query_Value + (From_Key : HKEY; + Sub_Key : String) + return String + is + use type LONG; + use type ULONG; + + Value : String (1 .. 100); + pragma Warnings (Off, Value); + + Size_Value : aliased ULONG; + Type_Value : aliased DWORD; + + C_Sub_Key : constant String := Sub_Key & ASCII.Nul; + Result : LONG; + + begin + Size_Value := Value'Length; + + Result := RegQueryValueEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + null, + Type_Value'Unchecked_Access, + Value (Value'First)'Address, + Size_Value'Unchecked_Access); + + Check_Result (Result, "Query_Value " & Sub_Key & " key"); + + return Value (1 .. Integer (Size_Value - 1)); + end Query_Value; + + --------------- + -- Set_Value -- + --------------- + + procedure Set_Value + (From_Key : HKEY; + Sub_Key : String; + Value : String) + is + C_Sub_Key : constant String := Sub_Key & ASCII.Nul; + C_Value : constant String := Value & ASCII.Nul; + + Result : LONG; + + begin + Result := RegSetValueEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + 0, + REG_SZ, + C_Value (C_Value'First)'Address, + C_Value'Length); + + Check_Result (Result, "Set_Value " & Sub_Key & " key"); + end Set_Value; + + --------------- + -- To_C_Mode -- + --------------- + + function To_C_Mode (Mode : Key_Mode) return REGSAM is + use type REGSAM; + + KEY_READ : constant := 16#20019#; + KEY_WRITE : constant := 16#20006#; + + begin + case Mode is + when Read_Only => + return KEY_READ; + + when Read_Write => + return KEY_READ + KEY_WRITE; + end case; + end To_C_Mode; + +end GNAT.Registry; diff --git a/gcc/ada/g-regist.ads b/gcc/ada/g-regist.ads new file mode 100644 index 00000000000..3cf06a88340 --- /dev/null +++ b/gcc/ada/g-regist.ads @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G I S T R Y -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- The registry is a Windows database to store key/value pair. It is used +-- to keep Windows operation system and applications configuration options. +-- The database is a hierarchal set of key and for each key a value can +-- be associated. This package provides high level routines to deal with +-- the Windows registry. For full registry API, but at a lower level of +-- abstraction, refer to the Win32.Winreg package provided with the +-- Win32Ada binding. For example this binding handle only key values of +-- type Standard.String. + +-- This package is specific to the NT version of GNAT, and is not available +-- on any other platforms. + +package GNAT.Registry is + + type HKEY is private; + -- HKEY is a handle to a registry key, including standard registry keys: + -- HKEY_CLASSES_ROOT, HKEY_CURRENT_CONFIG, HKEY_CURRENT_USER, + -- HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA. + + HKEY_CLASSES_ROOT : constant HKEY; + HKEY_CURRENT_USER : constant HKEY; + HKEY_CURRENT_CONFIG : constant HKEY; + HKEY_LOCAL_MACHINE : constant HKEY; + HKEY_USERS : constant HKEY; + HKEY_PERFORMANCE_DATA : constant HKEY; + + type Key_Mode is (Read_Only, Read_Write); + -- Access mode for the registry key. + + Registry_Error : exception; + -- Registry_Error is raises by all routines below if a problem occurs + -- (key cannot be opened, key cannot be found etc). + + function Create_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Write) + return HKEY; + -- Open or create a key (named Sub_Key) in the Windows registry database. + -- The key will be created under key From_Key. It returns the key handle. + -- From_Key must be a valid handle to an already opened key or one of + -- the standard keys identified by HKEY declarations above. + + function Open_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Only) + return HKEY; + -- Return a registry key handle for key named Sub_Key opened under key + -- From_Key. It is possible to open a key at any level in the registry + -- tree in a single call to Open_Key. + + procedure Close_Key (Key : HKEY); + -- Close registry key handle. All resources used by Key are released. + + function Key_Exists (From_Key : HKEY; Sub_Key : String) return Boolean; + -- Returns True if Sub_Key is defined under From_Key in the registry. + + function Query_Value (From_Key : HKEY; Sub_Key : String) return String; + -- Returns the registry key's value associated with Sub_Key in From_Key + -- registry key. + + procedure Set_Value (From_Key : HKEY; Sub_Key : String; Value : String); + -- Add the pair (Sub_Key, Value) into From_Key registry key. + + procedure Delete_Key (From_Key : HKEY; Sub_Key : String); + -- Remove Sub_Key from the registry key From_Key. + + procedure Delete_Value (From_Key : HKEY; Sub_Key : String); + -- Remove the named value Sub_Key from the registry key From_Key. + + generic + with procedure Action + (Index : Positive; + Sub_Key : String; + Value : String; + Quit : in out Boolean); + procedure For_Every_Key_Value (From_Key : HKEY); + -- Iterates over all the pairs (Sub_Key, Value) registered under + -- From_Key. Index will be set to 1 for the first key and will be + -- incremented by one in each iteration. Quit can be set to True to + -- stop iteration; its initial value is False. + -- + -- Key value that are not of type string are skipped. In this case, the + -- iterator behaves exactly as if the key was not present. Note that you + -- must use the Win32.Winreg API to deal with this case. + +private + + type HKEY is mod 2 ** Integer'Size; + + HKEY_CLASSES_ROOT : constant HKEY := 16#80000000#; + HKEY_CURRENT_USER : constant HKEY := 16#80000001#; + HKEY_LOCAL_MACHINE : constant HKEY := 16#80000002#; + HKEY_USERS : constant HKEY := 16#80000003#; + HKEY_PERFORMANCE_DATA : constant HKEY := 16#80000004#; + HKEY_CURRENT_CONFIG : constant HKEY := 16#80000005#; + +end GNAT.Registry; diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb new file mode 100644 index 00000000000..f36d5bf9ffc --- /dev/null +++ b/gcc/ada/g-regpat.adb @@ -0,0 +1,3545 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . R E G P A T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.31 $ +-- -- +-- Copyright (C) 1986 by University of Toronto. -- +-- Copyright (C) 1996-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is an altered Ada 95 version of the original V8 style regular +-- expression library written in C by Henry Spencer. Apart from the +-- translation to Ada, the interface has been considerably changed to +-- use the Ada String type instead of C-style nul-terminated strings. + +-- Beware that some of this code is subtly aware of the way operator +-- precedence is structured in regular expressions. Serious changes in +-- regular-expression syntax might require a total rethink. + +with System.IO; use System.IO; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Unchecked_Conversion; + +package body GNAT.Regpat is + + MAGIC : constant Character := Character'Val (10#0234#); + -- The first byte of the regexp internal "program" is actually + -- this magic number; the start node begins in the second byte. + -- + -- This is used to make sure that a regular expression was correctly + -- compiled. + + ---------------------------- + -- Implementation details -- + ---------------------------- + + -- This is essentially a linear encoding of a nondeterministic + -- finite-state machine, also known as syntax charts or + -- "railroad normal form" in parsing technology. + + -- Each node is an opcode plus a "next" pointer, possibly plus an + -- operand. "Next" pointers of all nodes except BRANCH implement + -- concatenation; a "next" pointer with a BRANCH on both ends of it + -- is connecting two alternatives. + + -- The operand of some types of node is a literal string; for others, + -- it is a node leading into a sub-FSM. In particular, the operand of + -- a BRANCH node is the first node of the branch. + -- (NB this is *not* a tree structure: the tail of the branch connects + -- to the thing following the set of BRANCHes). + + -- You can see the exact byte-compiled version by using the Dump + -- subprogram. However, here are a few examples: + + -- (a|b): 1 : MAGIC + -- 2 : BRANCH (next at 10) + -- 5 : EXACT (next at 18) operand=a + -- 10 : BRANCH (next at 18) + -- 13 : EXACT (next at 18) operand=b + -- 18 : EOP (next at 0) + -- + -- (ab)*: 1 : MAGIC + -- 2 : CURLYX (next at 26) { 0, 32767} + -- 9 : OPEN 1 (next at 13) + -- 13 : EXACT (next at 19) operand=ab + -- 19 : CLOSE 1 (next at 23) + -- 23 : WHILEM (next at 0) + -- 26 : NOTHING (next at 29) + -- 29 : EOP (next at 0) + + -- The opcodes are: + + type Opcode is + + -- Name Operand? Meaning + + (EOP, -- no End of program + MINMOD, -- no Next operator is not greedy + + -- Classes of characters + + ANY, -- no Match any one character except newline + SANY, -- no Match any character, including new line + ANYOF, -- class Match any character in this class + EXACT, -- str Match this string exactly + EXACTF, -- str Match this string (case-folding is one) + NOTHING, -- no Match empty string + SPACE, -- no Match any whitespace character + NSPACE, -- no Match any non-whitespace character + DIGIT, -- no Match any numeric character + NDIGIT, -- no Match any non-numeric character + ALNUM, -- no Match any alphanumeric character + NALNUM, -- no Match any non-alphanumeric character + + -- Branches + + BRANCH, -- node Match this alternative, or the next + + -- Simple loops (when the following node is one character in length) + + STAR, -- node Match this simple thing 0 or more times + PLUS, -- node Match this simple thing 1 or more times + CURLY, -- 2num node Match this simple thing between n and m times. + + -- Complex loops + + CURLYX, -- 2num node Match this complex thing {n,m} times + -- The nums are coded on two characters each. + + WHILEM, -- no Do curly processing and see if rest matches + + -- Matches after or before a word + + BOL, -- no Match "" at beginning of line + MBOL, -- no Same, assuming mutiline (match after \n) + SBOL, -- no Same, assuming single line (don't match at \n) + EOL, -- no Match "" at end of line + MEOL, -- no Same, assuming mutiline (match before \n) + SEOL, -- no Same, assuming single line (don't match at \n) + + BOUND, -- no Match "" at any word boundary + NBOUND, -- no Match "" at any word non-boundary + + -- Parenthesis groups handling + + REFF, -- num Match some already matched string, folded + OPEN, -- num Mark this point in input as start of #n + CLOSE); -- num Analogous to OPEN + + for Opcode'Size use 8; + + -- Opcode notes: + + -- BRANCH + -- The set of branches constituting a single choice are hooked + -- together with their "next" pointers, since precedence prevents + -- anything being concatenated to any individual branch. The + -- "next" pointer of the last BRANCH in a choice points to the + -- thing following the whole choice. This is also where the + -- final "next" pointer of each individual branch points; each + -- branch starts with the operand node of a BRANCH node. + + -- STAR,PLUS + -- '?', and complex '*' and '+', are implemented with CURLYX. + -- branches. Simple cases (one character per match) are implemented with + -- STAR and PLUS for speed and to minimize recursive plunges. + + -- OPEN,CLOSE + -- ...are numbered at compile time. + + -- EXACT, EXACTF + -- There are in fact two arguments, the first one is the length (minus + -- one of the string argument), coded on one character, the second + -- argument is the string itself, coded on length + 1 characters. + + -- A node is one char of opcode followed by two chars of "next" pointer. + -- "Next" pointers are stored as two 8-bit pieces, high order first. The + -- value is a positive offset from the opcode of the node containing it. + -- An operand, if any, simply follows the node. (Note that much of the + -- code generation knows about this implicit relationship.) + + -- Using two bytes for the "next" pointer is vast overkill for most + -- things, but allows patterns to get big without disasters. + + ----------------------- + -- Character classes -- + ----------------------- + -- This is the implementation for character classes ([...]) in the + -- syntax for regular expressions. Each character (0..256) has an + -- entry into the table. This makes for a very fast matching + -- algorithm. + + type Class_Byte is mod 256; + type Character_Class is array (Class_Byte range 0 .. 31) of Class_Byte; + + type Bit_Conversion_Array is array (Class_Byte range 0 .. 7) of Class_Byte; + Bit_Conversion : constant Bit_Conversion_Array := + (1, 2, 4, 8, 16, 32, 64, 128); + + type Std_Class is (ANYOF_NONE, + ANYOF_ALNUM, -- Alphanumeric class [a-zA-Z0-9] + ANYOF_NALNUM, + ANYOF_SPACE, -- Space class [ \t\n\r\f] + ANYOF_NSPACE, + ANYOF_DIGIT, -- Digit class [0-9] + ANYOF_NDIGIT, + ANYOF_ALNUMC, -- Alphanumeric class [a-zA-Z0-9] + ANYOF_NALNUMC, + ANYOF_ALPHA, -- Alpha class [a-zA-Z] + ANYOF_NALPHA, + ANYOF_ASCII, -- Ascii class (7 bits) 0..127 + ANYOF_NASCII, + ANYOF_CNTRL, -- Control class + ANYOF_NCNTRL, + ANYOF_GRAPH, -- Graphic class + ANYOF_NGRAPH, + ANYOF_LOWER, -- Lower case class [a-z] + ANYOF_NLOWER, + ANYOF_PRINT, -- printable class + ANYOF_NPRINT, + ANYOF_PUNCT, -- + ANYOF_NPUNCT, + ANYOF_UPPER, -- Upper case class [A-Z] + ANYOF_NUPPER, + ANYOF_XDIGIT, -- Hexadecimal digit + ANYOF_NXDIGIT + ); + + procedure Set_In_Class + (Bitmap : in out Character_Class; + C : Character); + -- Set the entry to True for C in the class Bitmap. + + function Get_From_Class + (Bitmap : Character_Class; + C : Character) + return Boolean; + -- Return True if the entry is set for C in the class Bitmap. + + procedure Reset_Class (Bitmap : in out Character_Class); + -- Clear all the entries in the class Bitmap. + + pragma Inline_Always (Set_In_Class); + pragma Inline_Always (Get_From_Class); + pragma Inline_Always (Reset_Class); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "+" (Left : Opcode; Right : Integer) return Opcode; + function "-" (Left : Opcode; Right : Opcode) return Integer; + function "=" (Left : Character; Right : Opcode) return Boolean; + + function Is_Alnum (C : Character) return Boolean; + -- Return True if C is an alphanum character or an underscore ('_') + + function Is_Space (C : Character) return Boolean; + -- Return True if C is a whitespace character + + function Is_Printable (C : Character) return Boolean; + -- Return True if C is a printable character + + function Operand (P : Pointer) return Pointer; + -- Return a pointer to the first operand of the node at P + + function String_Length + (Program : Program_Data; + P : Pointer) + return Program_Size; + -- Return the length of the string argument of the node at P + + function String_Operand (P : Pointer) return Pointer; + -- Return a pointer to the string argument of the node at P + + procedure Bitmap_Operand + (Program : Program_Data; + P : Pointer; + Op : out Character_Class); + -- Return a pointer to the string argument of the node at P + + function Get_Next_Offset + (Program : Program_Data; + IP : Pointer) + return Pointer; + -- Get the offset field of a node. Used by Get_Next. + + function Get_Next + (Program : Program_Data; + IP : Pointer) + return Pointer; + -- Dig the next instruction pointer out of a node + + procedure Optimize (Self : in out Pattern_Matcher); + -- Optimize a Pattern_Matcher by noting certain special cases + + function Read_Natural + (Program : Program_Data; + IP : Pointer) + return Natural; + -- Return the 2-byte natural coded at position IP. + + -- All of the subprograms above are tiny and should be inlined + + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline ("="); + pragma Inline (Is_Alnum); + pragma Inline (Is_Space); + pragma Inline (Get_Next); + pragma Inline (Get_Next_Offset); + pragma Inline (Operand); + pragma Inline (Read_Natural); + pragma Inline (String_Length); + pragma Inline (String_Operand); + + type Expression_Flags is record + Has_Width, -- Known never to match null string + Simple, -- Simple enough to be STAR/PLUS operand + SP_Start : Boolean; -- Starts with * or + + end record; + + Worst_Expression : constant Expression_Flags := (others => False); + -- Worst case + + --------- + -- "+" -- + --------- + + function "+" (Left : Opcode; Right : Integer) return Opcode is + begin + return Opcode'Val (Opcode'Pos (Left) + Right); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Opcode; Right : Opcode) return Integer is + begin + return Opcode'Pos (Left) - Opcode'Pos (Right); + end "-"; + + --------- + -- "=" -- + --------- + + function "=" (Left : Character; Right : Opcode) return Boolean is + begin + return Character'Pos (Left) = Opcode'Pos (Right); + end "="; + + -------------------- + -- Bitmap_Operand -- + -------------------- + + procedure Bitmap_Operand + (Program : Program_Data; + P : Pointer; + Op : out Character_Class) + is + function Convert is new Unchecked_Conversion + (Program_Data, Character_Class); + + begin + Op (0 .. 31) := Convert (Program (P + 3 .. P + 34)); + end Bitmap_Operand; + + ------------- + -- Compile -- + ------------- + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Final_Code_Size : out Program_Size; + Flags : Regexp_Flags := No_Flags) + is + -- We can't allocate space until we know how big the compiled form + -- will be, but we can't compile it (and thus know how big it is) + -- until we've got a place to put the code. So we cheat: we compile + -- it twice, once with code generation turned off and size counting + -- turned on, and once "for real". + + -- This also means that we don't allocate space until we are sure + -- that the thing really will compile successfully, and we never + -- have to move the code and thus invalidate pointers into it. + + -- Beware that the optimization-preparation code in here knows + -- about some of the structure of the compiled regexp. + + PM : Pattern_Matcher renames Matcher; + Program : Program_Data renames PM.Program; + + Emit_Code : constant Boolean := PM.Size > 0; + Emit_Ptr : Pointer := Program_First; + + Parse_Pos : Natural := Expression'First; -- Input-scan pointer + Parse_End : Natural := Expression'Last; + + ---------------------------- + -- Subprograms for Create -- + ---------------------------- + + procedure Emit (B : Character); + -- Output the Character to the Program. + -- If code-generation is disables, simply increments the program + -- counter. + + function Emit_Node (Op : Opcode) return Pointer; + -- If code-generation is enabled, Emit_Node outputs the + -- opcode and reserves space for a pointer to the next node. + -- Return value is the location of new opcode, ie old Emit_Ptr. + + procedure Emit_Natural (IP : Pointer; N : Natural); + -- Split N on two characters at position IP. + + procedure Emit_Class (Bitmap : Character_Class); + -- Emits a character class. + + procedure Case_Emit (C : Character); + -- Emit C, after converting is to lower-case if the regular + -- expression is case insensitive. + + procedure Parse + (Parenthesized : Boolean; + Flags : in out Expression_Flags; + IP : out Pointer); + -- Parse regular expression, i.e. main body or parenthesized thing + -- Caller must absorb opening parenthesis. + + procedure Parse_Branch + (Flags : in out Expression_Flags; + First : Boolean; + IP : out Pointer); + -- Implements the concatenation operator and handles '|' + -- First should be true if this is the first item of the alternative. + + procedure Parse_Piece + (Expr_Flags : in out Expression_Flags; IP : out Pointer); + -- Parse something followed by possible [*+?] + + procedure Parse_Atom + (Expr_Flags : in out Expression_Flags; IP : out Pointer); + -- Parse_Atom is the lowest level parse procedure. + -- Optimization: gobbles an entire sequence of ordinary characters + -- so that it can turn them into a single node, which is smaller to + -- store and faster to run. Backslashed characters are exceptions, + -- each becoming a separate node; the code is simpler that way and + -- it's not worth fixing. + + procedure Insert_Operator + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean := True); + -- Insert_Operator inserts an operator in front of an + -- already-emitted operand and relocates the operand. + -- This applies to PLUS and STAR. + -- If Minmod is True, then the operator is non-greedy. + + procedure Insert_Curly_Operator + (Op : Opcode; + Min : Natural; + Max : Natural; + Operand : Pointer; + Greedy : Boolean := True); + -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}). + -- If Minmod is True, then the operator is non-greedy. + + procedure Link_Tail (P, Val : Pointer); + -- Link_Tail sets the next-pointer at the end of a node chain + + procedure Link_Operand_Tail (P, Val : Pointer); + -- Link_Tail on operand of first argument; nop if operandless + + function Next_Instruction (P : Pointer) return Pointer; + -- Dig the "next" pointer out of a node + + procedure Fail (M : in String); + -- Fail with a diagnostic message, if possible + + function Is_Curly_Operator (IP : Natural) return Boolean; + -- Return True if IP is looking at a '{' that is the beginning + -- of a curly operator, ie it matches {\d+,?\d*} + + function Is_Mult (IP : Natural) return Boolean; + -- Return True if C is a regexp multiplier: '+', '*' or '?' + + procedure Get_Curly_Arguments + (IP : Natural; + Min : out Natural; + Max : out Natural; + Greedy : out Boolean); + -- Parse the argument list for a curly operator. + -- It is assumed that IP is indeed pointing at a valid operator. + + procedure Parse_Character_Class (IP : out Pointer); + -- Parse a character class. + -- The calling subprogram should consume the opening '[' before. + + procedure Parse_Literal (Expr_Flags : in out Expression_Flags; + IP : out Pointer); + -- Parse_Literal encodes a string of characters + -- to be matched exactly. + + function Parse_Posix_Character_Class return Std_Class; + -- Parse a posic character class, like [:alpha:] or [:^alpha:]. + -- The called is suppoed to absorbe the opening [. + + pragma Inline_Always (Is_Mult); + pragma Inline_Always (Emit_Natural); + pragma Inline_Always (Parse_Character_Class); -- since used only once + + --------------- + -- Case_Emit -- + --------------- + + procedure Case_Emit (C : Character) is + begin + if (Flags and Case_Insensitive) /= 0 then + Emit (To_Lower (C)); + + else + -- Dump current character + + Emit (C); + end if; + end Case_Emit; + + ---------- + -- Emit -- + ---------- + + procedure Emit (B : Character) is + begin + if Emit_Code then + Program (Emit_Ptr) := B; + end if; + + Emit_Ptr := Emit_Ptr + 1; + end Emit; + + ---------------- + -- Emit_Class -- + ---------------- + + procedure Emit_Class (Bitmap : Character_Class) is + subtype Program31 is Program_Data (0 .. 31); + + function Convert is new Unchecked_Conversion + (Character_Class, Program31); + + begin + if Emit_Code then + Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); + end if; + + Emit_Ptr := Emit_Ptr + 32; + end Emit_Class; + + ------------------ + -- Emit_Natural -- + ------------------ + + procedure Emit_Natural (IP : Pointer; N : Natural) is + begin + if Emit_Code then + Program (IP + 1) := Character'Val (N / 256); + Program (IP) := Character'Val (N mod 256); + end if; + end Emit_Natural; + + --------------- + -- Emit_Node -- + --------------- + + function Emit_Node (Op : Opcode) return Pointer is + Result : constant Pointer := Emit_Ptr; + + begin + if Emit_Code then + Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); + Program (Emit_Ptr + 1) := ASCII.NUL; + Program (Emit_Ptr + 2) := ASCII.NUL; + end if; + + Emit_Ptr := Emit_Ptr + 3; + return Result; + end Emit_Node; + + ---------- + -- Fail -- + ---------- + + procedure Fail (M : in String) is + begin + raise Expression_Error; + end Fail; + + ------------------------- + -- Get_Curly_Arguments -- + ------------------------- + + procedure Get_Curly_Arguments + (IP : Natural; + Min : out Natural; + Max : out Natural; + Greedy : out Boolean) + is + Save_Pos : Natural := Parse_Pos + 1; + + begin + Min := 0; + Max := Max_Curly_Repeat; + + while Expression (Parse_Pos) /= '}' + and then Expression (Parse_Pos) /= ',' + loop + Parse_Pos := Parse_Pos + 1; + end loop; + + Min := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); + + if Expression (Parse_Pos) = ',' then + Save_Pos := Parse_Pos + 1; + while Expression (Parse_Pos) /= '}' loop + Parse_Pos := Parse_Pos + 1; + end loop; + + if Save_Pos /= Parse_Pos then + Max := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); + end if; + + else + Max := Min; + end if; + + if Parse_Pos < Expression'Last + and then Expression (Parse_Pos + 1) = '?' + then + Greedy := False; + Parse_Pos := Parse_Pos + 1; + + else + Greedy := True; + end if; + end Get_Curly_Arguments; + + --------------------------- + -- Insert_Curly_Operator -- + --------------------------- + + procedure Insert_Curly_Operator + (Op : Opcode; + Min : Natural; + Max : Natural; + Operand : Pointer; + Greedy : Boolean := True) + is + Dest : constant Pointer := Emit_Ptr; + Old : Pointer; + Size : Pointer := 7; + + begin + -- If the operand is not greedy, insert an extra operand before it + + if not Greedy then + Size := Size + 3; + end if; + + -- Move the operand in the byte-compilation, so that we can insert + -- the operator before it. + + if Emit_Code then + Program (Operand + Size .. Emit_Ptr + Size) := + Program (Operand .. Emit_Ptr); + end if; + + -- Insert the operator at the position previously occupied by the + -- operand. + + Emit_Ptr := Operand; + + if not Greedy then + Old := Emit_Node (MINMOD); + Link_Tail (Old, Old + 3); + end if; + + Old := Emit_Node (Op); + Emit_Natural (Old + 3, Min); + Emit_Natural (Old + 5, Max); + + Emit_Ptr := Dest + Size; + end Insert_Curly_Operator; + + --------------------- + -- Insert_Operator -- + --------------------- + + procedure Insert_Operator + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean := True) + is + Dest : constant Pointer := Emit_Ptr; + Old : Pointer; + Size : Pointer := 3; + + begin + -- If not greedy, we have to emit another opcode first + + if not Greedy then + Size := Size + 3; + end if; + + -- Move the operand in the byte-compilation, so that we can insert + -- the operator before it. + + if Emit_Code then + Program (Operand + Size .. Emit_Ptr + Size) + := Program (Operand .. Emit_Ptr); + end if; + + -- Insert the operator at the position previously occupied by the + -- operand. + + Emit_Ptr := Operand; + + if not Greedy then + Old := Emit_Node (MINMOD); + Link_Tail (Old, Old + 3); + end if; + + Old := Emit_Node (Op); + Emit_Ptr := Dest + Size; + end Insert_Operator; + + ----------------------- + -- Is_Curly_Operator -- + ----------------------- + + function Is_Curly_Operator (IP : Natural) return Boolean is + Scan : Natural := IP; + + begin + if Expression (Scan) /= '{' + or else Scan + 2 > Expression'Last + or else not Is_Digit (Expression (Scan + 1)) + then + return False; + end if; + + Scan := Scan + 1; + + -- The first digit + + loop + Scan := Scan + 1; + + if Scan > Expression'Last then + return False; + end if; + + exit when not Is_Digit (Expression (Scan)); + end loop; + + if Expression (Scan) = ',' then + loop + Scan := Scan + 1; + + if Scan > Expression'Last then + return False; + end if; + + exit when not Is_Digit (Expression (Scan)); + end loop; + end if; + + return Expression (Scan) = '}'; + end Is_Curly_Operator; + + ------------- + -- Is_Mult -- + ------------- + + function Is_Mult (IP : Natural) return Boolean is + C : constant Character := Expression (IP); + + begin + return C = '*' + or else C = '+' + or else C = '?' + or else (C = '{' and then Is_Curly_Operator (IP)); + end Is_Mult; + + ----------------------- + -- Link_Operand_Tail -- + ----------------------- + + procedure Link_Operand_Tail (P, Val : Pointer) is + begin + if Emit_Code and then Program (P) = BRANCH then + Link_Tail (Operand (P), Val); + end if; + end Link_Operand_Tail; + + --------------- + -- Link_Tail -- + --------------- + + procedure Link_Tail (P, Val : Pointer) is + Scan : Pointer; + Temp : Pointer; + Offset : Pointer; + + begin + if not Emit_Code then + return; + end if; + + -- Find last node + + Scan := P; + loop + Temp := Next_Instruction (Scan); + exit when Temp = 0; + Scan := Temp; + end loop; + + Offset := Val - Scan; + + Emit_Natural (Scan + 1, Natural (Offset)); + end Link_Tail; + + ---------------------- + -- Next_Instruction -- + ---------------------- + + function Next_Instruction (P : Pointer) return Pointer is + Offset : Pointer; + + begin + if not Emit_Code then + return 0; + end if; + + Offset := Get_Next_Offset (Program, P); + + if Offset = 0 then + return 0; + end if; + + return P + Offset; + end Next_Instruction; + + ----------- + -- Parse -- + ----------- + + -- Combining parenthesis handling with the base level + -- of regular expression is a trifle forced, but the + -- need to tie the tails of the branches to what follows + -- makes it hard to avoid. + + procedure Parse + (Parenthesized : in Boolean; + Flags : in out Expression_Flags; + IP : out Pointer) + is + E : String renames Expression; + Br : Pointer; + Ender : Pointer; + Par_No : Natural; + New_Flags : Expression_Flags; + Have_Branch : Boolean := False; + + begin + Flags := (Has_Width => True, others => False); -- Tentatively + + -- Make an OPEN node, if parenthesized + + if Parenthesized then + if Matcher.Paren_Count > Max_Paren_Count then + Fail ("too many ()"); + end if; + + Par_No := Matcher.Paren_Count + 1; + Matcher.Paren_Count := Matcher.Paren_Count + 1; + IP := Emit_Node (OPEN); + Emit (Character'Val (Par_No)); + + else + IP := 0; + end if; + + -- Pick up the branches, linking them together + + Parse_Branch (New_Flags, True, Br); + + if Br = 0 then + IP := 0; + return; + end if; + + if Parse_Pos <= Parse_End + and then E (Parse_Pos) = '|' + then + Insert_Operator (BRANCH, Br); + Have_Branch := True; + end if; + + if IP /= 0 then + Link_Tail (IP, Br); -- OPEN -> first + else + IP := Br; + end if; + + if not New_Flags.Has_Width then + Flags.Has_Width := False; + end if; + + Flags.SP_Start := Flags.SP_Start or New_Flags.SP_Start; + + while Parse_Pos <= Parse_End + and then (E (Parse_Pos) = '|') + loop + Parse_Pos := Parse_Pos + 1; + Parse_Branch (New_Flags, False, Br); + + if Br = 0 then + IP := 0; + return; + end if; + + Link_Tail (IP, Br); -- BRANCH -> BRANCH + + if not New_Flags.Has_Width then + Flags.Has_Width := False; + end if; + + Flags.SP_Start := Flags.SP_Start or New_Flags.SP_Start; + end loop; + + -- Make a closing node, and hook it on the end + + if Parenthesized then + Ender := Emit_Node (CLOSE); + Emit (Character'Val (Par_No)); + else + Ender := Emit_Node (EOP); + end if; + + Link_Tail (IP, Ender); + + if Have_Branch then + + -- Hook the tails of the branches to the closing node + + Br := IP; + loop + exit when Br = 0; + Link_Operand_Tail (Br, Ender); + Br := Next_Instruction (Br); + end loop; + end if; + + -- Check for proper termination + + if Parenthesized then + if Parse_Pos > Parse_End or else E (Parse_Pos) /= ')' then + Fail ("unmatched ()"); + end if; + + Parse_Pos := Parse_Pos + 1; + + elsif Parse_Pos <= Parse_End then + if E (Parse_Pos) = ')' then + Fail ("unmatched ()"); + else + Fail ("junk on end"); -- "Can't happen" + end if; + end if; + end Parse; + + ---------------- + -- Parse_Atom -- + ---------------- + + procedure Parse_Atom + (Expr_Flags : in out Expression_Flags; + IP : out Pointer) + is + C : Character; + + begin + -- Tentatively set worst expression case + + Expr_Flags := Worst_Expression; + + C := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + case (C) is + when '^' => + if (Flags and Multiple_Lines) /= 0 then + IP := Emit_Node (MBOL); + elsif (Flags and Single_Line) /= 0 then + IP := Emit_Node (SBOL); + else + IP := Emit_Node (BOL); + end if; + + when '$' => + if (Flags and Multiple_Lines) /= 0 then + IP := Emit_Node (MEOL); + elsif (Flags and Single_Line) /= 0 then + IP := Emit_Node (SEOL); + else + IP := Emit_Node (EOL); + end if; + + when '.' => + if (Flags and Single_Line) /= 0 then + IP := Emit_Node (SANY); + else + IP := Emit_Node (ANY); + end if; + Expr_Flags.Has_Width := True; + Expr_Flags.Simple := True; + + when '[' => + Parse_Character_Class (IP); + Expr_Flags.Has_Width := True; + Expr_Flags.Simple := True; + + when '(' => + declare + New_Flags : Expression_Flags; + + begin + Parse (True, New_Flags, IP); + + if IP = 0 then + return; + end if; + + Expr_Flags.Has_Width := + Expr_Flags.Has_Width or New_Flags.Has_Width; + Expr_Flags.SP_Start := + Expr_Flags.SP_Start or New_Flags.SP_Start; + end; + + when '|' | ASCII.LF | ')' => + Fail ("internal urp"); -- Supposed to be caught earlier + + when '?' | '+' | '*' | '{' => + Fail ("?+*{ follows nothing"); + + when '\' => + if Parse_Pos > Parse_End then + Fail ("trailing \"); + end if; + + Parse_Pos := Parse_Pos + 1; + + case Expression (Parse_Pos - 1) is + when 'b' => + IP := Emit_Node (BOUND); + + when 'B' => + IP := Emit_Node (NBOUND); + + when 's' => + IP := Emit_Node (SPACE); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'S' => + IP := Emit_Node (NSPACE); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'd' => + IP := Emit_Node (DIGIT); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'D' => + IP := Emit_Node (NDIGIT); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'w' => + IP := Emit_Node (ALNUM); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'W' => + IP := Emit_Node (NALNUM); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'A' => + IP := Emit_Node (SBOL); + + when 'G' => + IP := Emit_Node (SEOL); + + when '0' .. '9' => + IP := Emit_Node (REFF); + + declare + Save : Natural := Parse_Pos - 1; + + begin + while Parse_Pos <= Expression'Last + and then Is_Digit (Expression (Parse_Pos)) + loop + Parse_Pos := Parse_Pos + 1; + end loop; + + Emit (Character'Val (Natural'Value + (Expression (Save .. Parse_Pos - 1)))); + end; + + when others => + Parse_Pos := Parse_Pos - 1; + Parse_Literal (Expr_Flags, IP); + end case; + + when others => Parse_Literal (Expr_Flags, IP); + end case; + end Parse_Atom; + + ------------------ + -- Parse_Branch -- + ------------------ + + procedure Parse_Branch + (Flags : in out Expression_Flags; + First : Boolean; + IP : out Pointer) + is + E : String renames Expression; + Chain : Pointer; + Last : Pointer; + New_Flags : Expression_Flags; + Dummy : Pointer; + + begin + Flags := Worst_Expression; -- Tentatively + + if First then + IP := Emit_Ptr; + else + IP := Emit_Node (BRANCH); + end if; + + Chain := 0; + + while Parse_Pos <= Parse_End + and then E (Parse_Pos) /= ')' + and then E (Parse_Pos) /= ASCII.LF + and then E (Parse_Pos) /= '|' + loop + Parse_Piece (New_Flags, Last); + + if Last = 0 then + IP := 0; + return; + end if; + + Flags.Has_Width := Flags.Has_Width or New_Flags.Has_Width; + + if Chain = 0 then -- First piece + Flags.SP_Start := Flags.SP_Start or New_Flags.SP_Start; + else + Link_Tail (Chain, Last); + end if; + + Chain := Last; + end loop; + + if Chain = 0 then -- Loop ran zero CURLY + Dummy := Emit_Node (NOTHING); + end if; + + end Parse_Branch; + + --------------------------- + -- Parse_Character_Class -- + --------------------------- + + procedure Parse_Character_Class (IP : out Pointer) is + Bitmap : Character_Class; + Invert : Boolean := False; + In_Range : Boolean := False; + Named_Class : Std_Class := ANYOF_NONE; + Value : Character; + Last_Value : Character := ASCII.Nul; + + begin + Reset_Class (Bitmap); + + -- Do we have an invert character class ? + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = '^' + then + Invert := True; + Parse_Pos := Parse_Pos + 1; + end if; + + -- First character can be ] or -, without closing the class. + + if Parse_Pos <= Parse_End + and then (Expression (Parse_Pos) = ']' + or else Expression (Parse_Pos) = '-') + then + Set_In_Class (Bitmap, Expression (Parse_Pos)); + Parse_Pos := Parse_Pos + 1; + end if; + + -- While we don't have the end of the class + + while Parse_Pos <= Parse_End + and then Expression (Parse_Pos) /= ']' + loop + Named_Class := ANYOF_NONE; + Value := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + -- Do we have a Posix character class + if Value = '[' then + Named_Class := Parse_Posix_Character_Class; + + elsif Value = '\' then + if Parse_Pos = Parse_End then + Fail ("Trailing \"); + end if; + Value := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + case Value is + when 'w' => Named_Class := ANYOF_ALNUM; + when 'W' => Named_Class := ANYOF_NALNUM; + when 's' => Named_Class := ANYOF_SPACE; + when 'S' => Named_Class := ANYOF_NSPACE; + when 'd' => Named_Class := ANYOF_DIGIT; + when 'D' => Named_Class := ANYOF_NDIGIT; + when 'n' => Value := ASCII.LF; + when 'r' => Value := ASCII.CR; + when 't' => Value := ASCII.HT; + when 'f' => Value := ASCII.FF; + when 'e' => Value := ASCII.ESC; + when 'a' => Value := ASCII.BEL; + + -- when 'x' => ??? hexadecimal value + -- when 'c' => ??? control character + -- when '0'..'9' => ??? octal character + + when others => null; + end case; + end if; + + -- Do we have a character class? + + if Named_Class /= ANYOF_NONE then + + -- A range like 'a-\d' or 'a-[:digit:] is not a range + + if In_Range then + Set_In_Class (Bitmap, Last_Value); + Set_In_Class (Bitmap, '-'); + In_Range := False; + end if; + + -- Expand the range + + case Named_Class is + when ANYOF_NONE => null; + + when ANYOF_ALNUM | ANYOF_ALNUMC => + for Value in Class_Byte'Range loop + if Is_Alnum (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NALNUM | ANYOF_NALNUMC => + for Value in Class_Byte'Range loop + if not Is_Alnum (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_SPACE => + for Value in Class_Byte'Range loop + if Is_Space (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NSPACE => + for Value in Class_Byte'Range loop + if not Is_Space (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_DIGIT => + for Value in Class_Byte'Range loop + if Is_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NDIGIT => + for Value in Class_Byte'Range loop + if not Is_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_ALPHA => + for Value in Class_Byte'Range loop + if Is_Letter (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NALPHA => + for Value in Class_Byte'Range loop + if not Is_Letter (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_ASCII => + for Value in 0 .. 127 loop + Set_In_Class (Bitmap, Character'Val (Value)); + end loop; + + when ANYOF_NASCII => + for Value in 128 .. 255 loop + Set_In_Class (Bitmap, Character'Val (Value)); + end loop; + + when ANYOF_CNTRL => + for Value in Class_Byte'Range loop + if Is_Control (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NCNTRL => + for Value in Class_Byte'Range loop + if not Is_Control (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_GRAPH => + for Value in Class_Byte'Range loop + if Is_Graphic (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NGRAPH => + for Value in Class_Byte'Range loop + if not Is_Graphic (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_LOWER => + for Value in Class_Byte'Range loop + if Is_Lower (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NLOWER => + for Value in Class_Byte'Range loop + if not Is_Lower (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_PRINT => + for Value in Class_Byte'Range loop + if Is_Printable (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NPRINT => + for Value in Class_Byte'Range loop + if not Is_Printable (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_PUNCT => + for Value in Class_Byte'Range loop + if Is_Printable (Character'Val (Value)) + and then not Is_Space (Character'Val (Value)) + and then not Is_Alnum (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NPUNCT => + for Value in Class_Byte'Range loop + if not Is_Printable (Character'Val (Value)) + or else Is_Space (Character'Val (Value)) + or else Is_Alnum (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_UPPER => + for Value in Class_Byte'Range loop + if Is_Upper (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NUPPER => + for Value in Class_Byte'Range loop + if not Is_Upper (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_XDIGIT => + for Value in Class_Byte'Range loop + if Is_Hexadecimal_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NXDIGIT => + for Value in Class_Byte'Range loop + if not Is_Hexadecimal_Digit + (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + end case; + + -- Not a character range + + elsif not In_Range then + Last_Value := Value; + + if Expression (Parse_Pos) = '-' + and then Parse_Pos < Parse_End + and then Expression (Parse_Pos + 1) /= ']' + then + Parse_Pos := Parse_Pos + 1; + + -- Do we have a range like '\d-a' and '[:space:]-a' + -- which is not a real range + + if Named_Class /= ANYOF_NONE then + Set_In_Class (Bitmap, '-'); + else + In_Range := True; + end if; + + else + Set_In_Class (Bitmap, Value); + + end if; + + -- Else in a character range + + else + if Last_Value > Value then + Fail ("Invalid Range [" & Last_Value'Img + & "-" & Value'Img & "]"); + end if; + + while Last_Value <= Value loop + Set_In_Class (Bitmap, Last_Value); + Last_Value := Character'Succ (Last_Value); + end loop; + + In_Range := False; + + end if; + + end loop; + + -- Optimize case-insensitive ranges (put the upper case or lower + -- case character into the bitmap) + + if (Flags and Case_Insensitive) /= 0 then + for C in Character'Range loop + if Get_From_Class (Bitmap, C) then + Set_In_Class (Bitmap, To_Lower (C)); + Set_In_Class (Bitmap, To_Upper (C)); + end if; + end loop; + end if; + + -- Optimize inverted classes + + if Invert then + for J in Bitmap'Range loop + Bitmap (J) := not Bitmap (J); + end loop; + end if; + + Parse_Pos := Parse_Pos + 1; + + -- Emit the class + + IP := Emit_Node (ANYOF); + Emit_Class (Bitmap); + end Parse_Character_Class; + + ------------------- + -- Parse_Literal -- + ------------------- + + -- This is a bit tricky due to quoted chars and due to + -- the multiplier characters '*', '+', and '?' that + -- take the SINGLE char previous as their operand. + -- + -- On entry, the character at Parse_Pos - 1 is going to go + -- into the string, no matter what it is. It could be + -- following a \ if Parse_Atom was entered from the '\' case. + -- + -- Basic idea is to pick up a good char in C and examine + -- the next char. If Is_Mult (C) then twiddle, if it's a \ + -- then frozzle and if it's another magic char then push C and + -- terminate the string. If none of the above, push C on the + -- string and go around again. + -- + -- Start_Pos is used to remember where "the current character" + -- starts in the string, if due to an Is_Mult we need to back + -- up and put the current char in a separate 1-character string. + -- When Start_Pos is 0, C is the only char in the string; + -- this is used in Is_Mult handling, and in setting the SIMPLE + -- flag at the end. + + procedure Parse_Literal + (Expr_Flags : in out Expression_Flags; + IP : out Pointer) + is + Start_Pos : Natural := 0; + C : Character; + Length_Ptr : Pointer; + + begin + Parse_Pos := Parse_Pos - 1; -- Look at current character + + if (Flags and Case_Insensitive) /= 0 then + IP := Emit_Node (EXACTF); + else + IP := Emit_Node (EXACT); + end if; + + Length_Ptr := Emit_Ptr; + Emit_Ptr := String_Operand (IP); + + Parse_Loop : + loop + + C := Expression (Parse_Pos); -- Get current character + + case C is + when '.' | '[' | '(' | ')' | '|' | ASCII.LF | '$' | '^' => + + if Start_Pos = 0 then + Emit (C); -- First character is always emitted + else + exit Parse_Loop; -- Else we are done + end if; + + when '?' | '+' | '*' | '{' => + + if Start_Pos = 0 then + Emit (C); -- First character is always emitted + + -- Are we looking at an operator, or is this + -- simply a normal character ? + elsif not Is_Mult (Parse_Pos) then + Case_Emit (C); + else + -- We've got something like "abc?d". Mark this as a + -- special case. What we want to emit is a first + -- constant string for "ab", then one for "c" that will + -- ultimately be transformed with a CURLY operator, A + -- special case has to be handled for "a?", since there + -- is no initial string to emit. + Start_Pos := Natural'Last; + exit Parse_Loop; + end if; + + when '\' => + if Parse_Pos = Parse_End then + Fail ("Trailing \"); + else + case Expression (Parse_Pos + 1) is + when 'b' | 'B' | 's' | 'S' | 'd' | 'D' + | 'w' | 'W' | '0' .. '9' | 'G' | 'A' + => exit Parse_Loop; + when 'n' => Emit (ASCII.LF); + when 't' => Emit (ASCII.HT); + when 'r' => Emit (ASCII.CR); + when 'f' => Emit (ASCII.FF); + when 'e' => Emit (ASCII.ESC); + when 'a' => Emit (ASCII.BEL); + when others => Emit (Expression (Parse_Pos + 1)); + end case; + Parse_Pos := Parse_Pos + 1; + end if; + + when others => Case_Emit (C); + end case; + + exit Parse_Loop when Emit_Ptr - Length_Ptr = 254; + + Start_Pos := Parse_Pos; + Parse_Pos := Parse_Pos + 1; + + exit Parse_Loop when Parse_Pos > Parse_End; + end loop Parse_Loop; + + -- Is the string followed by a '*+?{' operator ? If yes, and if there + -- is an initial string to emit, do it now. + + if Start_Pos = Natural'Last + and then Emit_Ptr >= Length_Ptr + 3 + then + Emit_Ptr := Emit_Ptr - 1; + Parse_Pos := Parse_Pos - 1; + end if; + + if Emit_Code then + Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); + end if; + + Expr_Flags.Has_Width := True; + + -- Slight optimization when there is a single character + + if Emit_Ptr = Length_Ptr + 2 then + Expr_Flags.Simple := True; + end if; + end Parse_Literal; + + ----------------- + -- Parse_Piece -- + ----------------- + + -- Note that the branching code sequences used for '?' and the + -- general cases of '*' and + are somewhat optimized: they use + -- the same NOTHING node as both the endmarker for their branch + -- list and the body of the last branch. It might seem that + -- this node could be dispensed with entirely, but the endmarker + -- role is not redundant. + + procedure Parse_Piece + (Expr_Flags : in out Expression_Flags; + IP : out Pointer) + is + Op : Character; + New_Flags : Expression_Flags; + Greedy : Boolean := True; + + begin + Parse_Atom (New_Flags, IP); + + if IP = 0 then + return; + end if; + + if Parse_Pos > Parse_End + or else not Is_Mult (Parse_Pos) + then + Expr_Flags := New_Flags; + return; + end if; + + Op := Expression (Parse_Pos); + + if Op /= '+' then + Expr_Flags := (SP_Start => True, others => False); + else + Expr_Flags := (Has_Width => True, others => False); + end if; + + -- Detect non greedy operators in the easy cases + + if Op /= '{' + and then Parse_Pos + 1 <= Parse_End + and then Expression (Parse_Pos + 1) = '?' + then + Greedy := False; + Parse_Pos := Parse_Pos + 1; + end if; + + -- Generate the byte code + + case Op is + when '*' => + + if New_Flags.Simple then + Insert_Operator (STAR, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator + (CURLYX, 0, Max_Curly_Repeat, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '+' => + + if New_Flags.Simple then + Insert_Operator (PLUS, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator + (CURLYX, 1, Max_Curly_Repeat, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '?' => + if New_Flags.Simple then + Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '{' => + declare + Min, Max : Natural; + + begin + Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy); + + if New_Flags.Simple then + Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + end; + + when others => + null; + end case; + + Parse_Pos := Parse_Pos + 1; + + if Parse_Pos <= Parse_End + and then Is_Mult (Parse_Pos) + then + Fail ("nested *+{"); + end if; + end Parse_Piece; + + --------------------------------- + -- Parse_Posix_Character_Class -- + --------------------------------- + + function Parse_Posix_Character_Class return Std_Class is + Invert : Boolean := False; + Class : Std_Class := ANYOF_NONE; + E : String renames Expression; + + begin + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = ':' + then + Parse_Pos := Parse_Pos + 1; + + -- Do we have something like: [[:^alpha:]] + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = '^' + then + Invert := True; + Parse_Pos := Parse_Pos + 1; + end if; + + -- All classes have 6 characters at least + -- ??? magid constant 6 should have a name! + + if Parse_Pos + 6 <= Parse_End then + + case Expression (Parse_Pos) is + when 'a' => + if E (Parse_Pos .. Parse_Pos + 4) = "alnum:]" then + if Invert then + Class := ANYOF_NALNUMC; + else + Class := ANYOF_ALNUMC; + end if; + + elsif E (Parse_Pos .. Parse_Pos + 6) = "alpha:]" then + if Invert then + Class := ANYOF_NALPHA; + else + Class := ANYOF_ALPHA; + end if; + + elsif E (Parse_Pos .. Parse_Pos + 6) = "ascii:]" then + if Invert then + Class := ANYOF_NASCII; + else + Class := ANYOF_ASCII; + end if; + + end if; + + when 'c' => + if E (Parse_Pos .. Parse_Pos + 6) = "cntrl:]" then + if Invert then + Class := ANYOF_NCNTRL; + else + Class := ANYOF_CNTRL; + end if; + end if; + + when 'd' => + + if E (Parse_Pos .. Parse_Pos + 6) = "digit:]" then + if Invert then + Class := ANYOF_NDIGIT; + else + Class := ANYOF_DIGIT; + end if; + end if; + + when 'g' => + + if E (Parse_Pos .. Parse_Pos + 6) = "graph:]" then + if Invert then + Class := ANYOF_NGRAPH; + else + Class := ANYOF_GRAPH; + end if; + end if; + + when 'l' => + + if E (Parse_Pos .. Parse_Pos + 6) = "lower:]" then + if Invert then + Class := ANYOF_NLOWER; + else + Class := ANYOF_LOWER; + end if; + end if; + + when 'p' => + + if E (Parse_Pos .. Parse_Pos + 6) = "print:]" then + if Invert then + Class := ANYOF_NPRINT; + else + Class := ANYOF_PRINT; + end if; + + elsif E (Parse_Pos .. Parse_Pos + 6) = "punct:]" then + if Invert then + Class := ANYOF_NPUNCT; + else + Class := ANYOF_PUNCT; + end if; + end if; + + when 's' => + + if E (Parse_Pos .. Parse_Pos + 6) = "space:]" then + if Invert then + Class := ANYOF_NSPACE; + else + Class := ANYOF_SPACE; + end if; + end if; + + when 'u' => + + if E (Parse_Pos .. Parse_Pos + 6) = "upper:]" then + if Invert then + Class := ANYOF_NUPPER; + else + Class := ANYOF_UPPER; + end if; + end if; + + when 'w' => + + if E (Parse_Pos .. Parse_Pos + 5) = "word:]" then + if Invert then + Class := ANYOF_NALNUM; + else + Class := ANYOF_ALNUM; + end if; + + Parse_Pos := Parse_Pos - 1; + end if; + + when 'x' => + + if Parse_Pos + 7 <= Parse_End + and then E (Parse_Pos .. Parse_Pos + 7) = "xdigit:]" + then + if Invert then + Class := ANYOF_NXDIGIT; + else + Class := ANYOF_XDIGIT; + end if; + + Parse_Pos := Parse_Pos + 1; + end if; + + when others => + Class := ANYOF_NONE; + + end case; + + if Class /= ANYOF_NONE then + Parse_Pos := Parse_Pos + 7; + end if; + + else + Fail ("Invalid character class"); + end if; + + else + return ANYOF_NONE; + end if; + + return Class; + end Parse_Posix_Character_Class; + + Expr_Flags : Expression_Flags; + Result : Pointer; + + -- Start of processing for Compile + + begin + Emit (MAGIC); + Parse (False, Expr_Flags, Result); + + if Result = 0 then + Fail ("Couldn't compile expression"); + end if; + + Final_Code_Size := Emit_Ptr - 1; + + -- Do we want to actually compile the expression, or simply get the + -- code size ??? + + if Emit_Code then + Optimize (PM); + end if; + + PM.Flags := Flags; + end Compile; + + function Compile + (Expression : String; + Flags : Regexp_Flags := No_Flags) + return Pattern_Matcher + is + Size : Program_Size; + Dummy : Pattern_Matcher (0); + + begin + Compile (Dummy, Expression, Size, Flags); + + declare + Result : Pattern_Matcher (Size); + begin + Compile (Result, Expression, Size, Flags); + return Result; + end; + end Compile; + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Flags : Regexp_Flags := No_Flags) + is + Size : Program_Size; + + begin + Compile (Matcher, Expression, Size, Flags); + end Compile; + + ---------- + -- Dump -- + ---------- + + procedure Dump (Self : Pattern_Matcher) is + + -- Index : Pointer := Program_First + 1; + -- What is the above line for ??? + + Op : Opcode; + Program : Program_Data renames Self.Program; + + procedure Dump_Until + (Start : Pointer; + Till : Pointer; + Indent : Natural := 0); + -- Dump the program until the node Till (not included) is met. + -- Every line is indented with Index spaces at the beginning + -- Dumps till the end if Till is 0. + + ---------------- + -- Dump_Until -- + ---------------- + + procedure Dump_Until + (Start : Pointer; + Till : Pointer; + Indent : Natural := 0) + is + Next : Pointer; + Index : Pointer := Start; + Local_Indent : Natural := Indent; + Length : Pointer; + + begin + while Index < Till loop + + Op := Opcode'Val (Character'Pos ((Self.Program (Index)))); + + if Op = CLOSE then + Local_Indent := Local_Indent - 3; + end if; + + declare + Point : String := Pointer'Image (Index); + + begin + for J in 1 .. 6 - Point'Length loop + Put (' '); + end loop; + + Put (Point + & " : " + & (1 .. Local_Indent => ' ') + & Opcode'Image (Op)); + end; + + -- Print the parenthesis number + + if Op = OPEN or else Op = CLOSE or else Op = REFF then + Put (Natural'Image (Character'Pos (Program (Index + 3)))); + end if; + + Next := Index + Get_Next_Offset (Program, Index); + + if Next = Index then + Put (" (next at 0)"); + else + Put (" (next at " & Pointer'Image (Next) & ")"); + end if; + + case Op is + + -- Character class operand + + when ANYOF => null; + declare + Bitmap : Character_Class; + Last : Character := ASCII.Nul; + Current : Natural := 0; + + Current_Char : Character; + + begin + Bitmap_Operand (Program, Index, Bitmap); + Put (" operand="); + + while Current <= 255 loop + Current_Char := Character'Val (Current); + + -- First item in a range + + if Get_From_Class (Bitmap, Current_Char) then + Last := Current_Char; + + -- Search for the last item in the range + + loop + Current := Current + 1; + exit when Current > 255; + Current_Char := Character'Val (Current); + exit when + not Get_From_Class (Bitmap, Current_Char); + + end loop; + + if Last <= ' ' then + Put (Last'Img); + else + Put (Last); + end if; + + if Character'Succ (Last) /= Current_Char then + Put ("-" & Character'Pred (Current_Char)); + end if; + + else + Current := Current + 1; + end if; + end loop; + + New_Line; + Index := Index + 3 + Bitmap'Length; + end; + + -- string operand + + when EXACT | EXACTF => + Length := String_Length (Program, Index); + Put (" operand (length:" & Program_Size'Image (Length + 1) + & ") =" + & String (Program (String_Operand (Index) + .. String_Operand (Index) + + Length))); + Index := String_Operand (Index) + Length + 1; + New_Line; + + -- Node operand + + when BRANCH => + New_Line; + Dump_Until (Index + 3, Next, Local_Indent + 3); + Index := Next; + + when STAR | PLUS => + New_Line; + + -- Only one instruction + + Dump_Until (Index + 3, Index + 4, Local_Indent + 3); + Index := Next; + + when CURLY | CURLYX => + Put (" {" + & Natural'Image (Read_Natural (Program, Index + 3)) + & "," + & Natural'Image (Read_Natural (Program, Index + 5)) + & "}"); + New_Line; + Dump_Until (Index + 7, Next, Local_Indent + 3); + Index := Next; + + when OPEN => + New_Line; + Index := Index + 4; + Local_Indent := Local_Indent + 3; + + when CLOSE | REFF => + New_Line; + Index := Index + 4; + + when EOP => + Index := Index + 3; + New_Line; + exit; + + -- No operand + + when others => + Index := Index + 3; + New_Line; + end case; + end loop; + end Dump_Until; + + -- Start of processing for Dump + + begin + pragma Assert (Self.Program (Program_First) = MAGIC, + "Corrupted Pattern_Matcher"); + + Put_Line ("Must start with (Self.First) = " + & Character'Image (Self.First)); + + if (Self.Flags and Case_Insensitive) /= 0 then + Put_Line (" Case_Insensitive mode"); + end if; + + if (Self.Flags and Single_Line) /= 0 then + Put_Line (" Single_Line mode"); + end if; + + if (Self.Flags and Multiple_Lines) /= 0 then + Put_Line (" Multiple_Lines mode"); + end if; + + Put_Line (" 1 : MAGIC"); + Dump_Until (Program_First + 1, Self.Program'Last + 1); + end Dump; + + -------------------- + -- Get_From_Class -- + -------------------- + + function Get_From_Class + (Bitmap : Character_Class; + C : Character) + return Boolean + is + Value : constant Class_Byte := Character'Pos (C); + + begin + return (Bitmap (Value / 8) + and Bit_Conversion (Value mod 8)) /= 0; + end Get_From_Class; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is + Offset : constant Pointer := Get_Next_Offset (Program, IP); + + begin + if Offset = 0 then + return 0; + else + return IP + Offset; + end if; + end Get_Next; + + --------------------- + -- Get_Next_Offset -- + --------------------- + + function Get_Next_Offset + (Program : Program_Data; + IP : Pointer) + return Pointer + is + begin + return Pointer (Read_Natural (Program, IP + 1)); + end Get_Next_Offset; + + -------------- + -- Is_Alnum -- + -------------- + + function Is_Alnum (C : Character) return Boolean is + begin + return Is_Alphanumeric (C) or else C = '_'; + end Is_Alnum; + + ------------------ + -- Is_Printable -- + ------------------ + + function Is_Printable (C : Character) return Boolean is + Value : constant Natural := Character'Pos (C); + + begin + return (Value > 32 and then Value < 127) + or else Is_Space (C); + end Is_Printable; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (C : Character) return Boolean is + begin + return C = ' ' + or else C = ASCII.HT + or else C = ASCII.CR + or else C = ASCII.LF + or else C = ASCII.VT + or else C = ASCII.FF; + end Is_Space; + + ----------- + -- Match -- + ----------- + + procedure Match + (Self : Pattern_Matcher; + Data : String; + Matches : out Match_Array) + is + Program : Program_Data renames Self.Program; -- Shorter notation + + -- Global work variables + + Input_Pos : Natural; -- String-input pointer + BOL_Pos : Natural; -- Beginning of input, for ^ check + Matched : Boolean := False; -- Until proven True + + Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count, + Matches'Last)); + -- Stores the value of all the parenthesis pairs. + -- We do not use directly Matches, so that we can also use back + -- references (REFF) even if Matches is too small. + + type Natural_Array is array (Match_Count range <>) of Natural; + Matches_Tmp : Natural_Array (Matches_Full'Range); + -- Save the opening position of parenthesis. + + Last_Paren : Natural := 0; + -- Last parenthesis seen + + Greedy : Boolean := True; + -- True if the next operator should be greedy + + type Current_Curly_Record; + type Current_Curly_Access is access all Current_Curly_Record; + type Current_Curly_Record is record + Paren_Floor : Natural; -- How far back to strip parenthesis data + Cur : Integer; -- How many instances of scan we've matched + Min : Natural; -- Minimal number of scans to match + Max : Natural; -- Maximal number of scans to match + Greedy : Boolean; -- Whether to work our way up or down + Scan : Pointer; -- The thing to match + Next : Pointer; -- What has to match after it + Lastloc : Natural; -- Where we started matching this scan + Old_Cc : Current_Curly_Access; -- Before we started this one + end record; + -- Data used to handle the curly operator and the plus and star + -- operators for complex expressions. + + Current_Curly : Current_Curly_Access := null; + -- The curly currently being processed. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Index (Start : Positive; C : Character) return Natural; + -- Find character C in Data starting at Start and return position + + function Repeat + (IP : Pointer; + Max : Natural := Natural'Last) + return Natural; + -- Repeatedly match something simple, report how many + -- It only matches on things of length 1. + -- Starting from Input_Pos, it matches at most Max CURLY. + + function Try (Pos : in Positive) return Boolean; + -- Try to match at specific point + + function Match (IP : Pointer) return Boolean; + -- This is the main matching routine. Conceptually the strategy + -- is simple: check to see whether the current node matches, + -- call self recursively to see whether the rest matches, + -- and then act accordingly. + -- + -- In practice Match makes some effort to avoid recursion, in + -- particular by going through "ordinary" nodes (that don't + -- need to know whether the rest of the match failed) by + -- using a loop instead of recursion. + + function Match_Whilem (IP : Pointer) return Boolean; + -- Return True if a WHILEM matches + + function Recurse_Match (IP : Pointer; From : Natural) return Boolean; + pragma Inline (Recurse_Match); + -- Calls Match recursively. It saves and restores the parenthesis + -- status and location in the input stream correctly, so that + -- backtracking is possible + + function Match_Simple_Operator + (Op : Opcode; + Scan : Pointer; + Next : Pointer; + Greedy : Boolean) + return Boolean; + -- Return True it the simple operator (possibly non-greedy) matches + + pragma Inline_Always (Index); + pragma Inline_Always (Repeat); + + -- These are two complex functions, but used only once. + pragma Inline_Always (Match_Whilem); + pragma Inline_Always (Match_Simple_Operator); + + ----------- + -- Index -- + ----------- + + function Index + (Start : Positive; + C : Character) + return Natural + is + begin + for J in Start .. Data'Last loop + if Data (J) = C then + return J; + end if; + end loop; + + return 0; + end Index; + + ------------------- + -- Recurse_Match -- + ------------------- + + function Recurse_Match (IP : Pointer; From : Natural) return Boolean is + L : constant Natural := Last_Paren; + Tmp_F : constant Match_Array := + Matches_Full (From + 1 .. Matches_Full'Last); + Start : constant Natural_Array := + Matches_Tmp (From + 1 .. Matches_Tmp'Last); + Input : constant Natural := Input_Pos; + begin + if Match (IP) then + return True; + end if; + Last_Paren := L; + Matches_Full (Tmp_F'Range) := Tmp_F; + Matches_Tmp (Start'Range) := Start; + Input_Pos := Input; + return False; + end Recurse_Match; + + ----------- + -- Match -- + ----------- + + function Match (IP : Pointer) return Boolean is + Scan : Pointer := IP; + Next : Pointer; + Op : Opcode; + + begin + State_Machine : + loop + pragma Assert (Scan /= 0); + + -- Determine current opcode and count its usage in debug mode + + Op := Opcode'Val (Character'Pos (Program (Scan))); + + -- Calculate offset of next instruction. + -- Second character is most significant in Program_Data. + + Next := Get_Next (Program, Scan); + + case Op is + when EOP => + return True; -- Success ! + + when BRANCH => + if Program (Next) /= BRANCH then + Next := Operand (Scan); -- No choice, avoid recursion + + else + loop + if Recurse_Match (Operand (Scan), 0) then + return True; + end if; + + Scan := Get_Next (Program, Scan); + exit when Scan = 0 or Program (Scan) /= BRANCH; + end loop; + + exit State_Machine; + end if; + + when NOTHING => + null; + + when BOL => + exit State_Machine when + Input_Pos /= BOL_Pos + and then ((Self.Flags and Multiple_Lines) = 0 + or else Data (Input_Pos - 1) /= ASCII.LF); + + when MBOL => + exit State_Machine when + Input_Pos /= BOL_Pos + and then Data (Input_Pos - 1) /= ASCII.LF; + + when SBOL => + exit State_Machine when Input_Pos /= BOL_Pos; + + when EOL => + exit State_Machine when + Input_Pos <= Data'Last + and then ((Self.Flags and Multiple_Lines) = 0 + or else Data (Input_Pos) /= ASCII.LF); + + when MEOL => + exit State_Machine when + Input_Pos <= Data'Last + and then Data (Input_Pos) /= ASCII.LF; + + when SEOL => + exit State_Machine when Input_Pos <= Data'Last; + + when BOUND | NBOUND => + + -- Was last char in word ? + + declare + N : Boolean := False; + Ln : Boolean := False; + + begin + if Input_Pos /= Data'First then + N := Is_Alnum (Data (Input_Pos - 1)); + end if; + + if Input_Pos > Data'Last then + Ln := False; + else + Ln := Is_Alnum (Data (Input_Pos)); + end if; + + if Op = BOUND then + if N = Ln then + exit State_Machine; + end if; + else + if N /= Ln then + exit State_Machine; + end if; + end if; + end; + + when SPACE => + exit State_Machine when + Input_Pos > Data'Last + or else not Is_Space (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NSPACE => + exit State_Machine when + Input_Pos > Data'Last + or else Is_Space (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when DIGIT => + exit State_Machine when + Input_Pos > Data'Last + or else not Is_Digit (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NDIGIT => + exit State_Machine when + Input_Pos > Data'Last + or else Is_Digit (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when ALNUM => + exit State_Machine when + Input_Pos > Data'Last + or else not Is_Alnum (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NALNUM => + exit State_Machine when + Input_Pos > Data'Last + or else Is_Alnum (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when ANY => + exit State_Machine when Input_Pos > Data'Last + or else Data (Input_Pos) = ASCII.LF; + Input_Pos := Input_Pos + 1; + + when SANY => + exit State_Machine when Input_Pos > Data'Last; + Input_Pos := Input_Pos + 1; + + when EXACT => + declare + Opnd : Pointer := String_Operand (Scan); + Current : Positive := Input_Pos; + Last : constant Pointer := + Opnd + String_Length (Program, Scan); + + begin + while Opnd <= Last loop + exit State_Machine when Current > Data'Last + or else Program (Opnd) /= Data (Current); + Current := Current + 1; + Opnd := Opnd + 1; + end loop; + + Input_Pos := Current; + end; + + when EXACTF => + declare + Opnd : Pointer := String_Operand (Scan); + Current : Positive := Input_Pos; + Last : constant Pointer := + Opnd + String_Length (Program, Scan); + + begin + while Opnd <= Last loop + exit State_Machine when Current > Data'Last + or else Program (Opnd) /= To_Lower (Data (Current)); + Current := Current + 1; + Opnd := Opnd + 1; + end loop; + + Input_Pos := Current; + end; + + when ANYOF => + declare + Bitmap : Character_Class; + + begin + Bitmap_Operand (Program, Scan, Bitmap); + exit State_Machine when + Input_Pos > Data'Last + or else not Get_From_Class (Bitmap, Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + end; + + when OPEN => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + begin + Matches_Tmp (No) := Input_Pos; + end; + + when CLOSE => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + begin + Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1); + if Last_Paren < No then + Last_Paren := No; + end if; + end; + + when REFF => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + Data_Pos : Natural; + + begin + -- If we haven't seen that parenthesis yet + + if Last_Paren < No then + return False; + end if; + + Data_Pos := Matches_Full (No).First; + while Data_Pos <= Matches_Full (No).Last loop + if Input_Pos > Data'Last + or else Data (Input_Pos) /= Data (Data_Pos) + then + return False; + end if; + + Input_Pos := Input_Pos + 1; + Data_Pos := Data_Pos + 1; + end loop; + end; + + when MINMOD => + Greedy := False; + + when STAR | PLUS | CURLY => + declare + Greed : constant Boolean := Greedy; + begin + Greedy := True; + return Match_Simple_Operator (Op, Scan, Next, Greed); + end; + + when CURLYX => + + -- Looking at something like: + -- 1: CURLYX {n,m} (->4) + -- 2: code for complex thing (->3) + -- 3: WHILEM (->0) + -- 4: NOTHING + + declare + Cc : aliased Current_Curly_Record; + Min : Natural := Read_Natural (Program, Scan + 3); + Max : Natural := Read_Natural (Program, Scan + 5); + + Has_Match : Boolean; + + begin + Cc := (Paren_Floor => Last_Paren, + Cur => -1, + Min => Min, + Max => Max, + Greedy => Greedy, + Scan => Scan + 7, + Next => Next, + Lastloc => 0, + Old_Cc => Current_Curly); + Current_Curly := Cc'Unchecked_Access; + + Has_Match := Match (Next - 3); + + -- Start on the WHILEM + + Current_Curly := Cc.Old_Cc; + return Has_Match; + end; + + when WHILEM => + return Match_Whilem (IP); + + when others => + raise Expression_Error; -- Invalid instruction + end case; + + Scan := Next; + end loop State_Machine; + + -- If we get here, there is no match. + -- For successful matches when EOP is the terminating point. + + return False; + end Match; + + --------------------------- + -- Match_Simple_Operator -- + --------------------------- + + function Match_Simple_Operator + (Op : Opcode; + Scan : Pointer; + Next : Pointer; + Greedy : Boolean) + return Boolean + is + Next_Char : Character := ASCII.Nul; + Next_Char_Known : Boolean := False; + No : Integer; -- Can be negative + Min : Natural; + Max : Natural := Natural'Last; + Operand_Code : Pointer; + Old : Natural; + Last_Pos : Natural; + Save : Natural := Input_Pos; + + begin + -- Lookahead to avoid useless match attempts + -- when we know what character comes next. + + if Program (Next) = EXACT then + Next_Char := Program (String_Operand (Next)); + Next_Char_Known := True; + end if; + + -- Find the minimal and maximal values for the operator + + case Op is + when STAR => + Min := 0; + Operand_Code := Operand (Scan); + + when PLUS => + Min := 1; + Operand_Code := Operand (Scan); + + when others => + Min := Read_Natural (Program, Scan + 3); + Max := Read_Natural (Program, Scan + 5); + Operand_Code := Scan + 7; + end case; + + -- Non greedy operators + + if not Greedy then + -- Test the minimal repetitions + + if Min /= 0 + and then Repeat (Operand_Code, Min) < Min + then + return False; + end if; + + Old := Input_Pos; + + -- Find the place where 'next' could work + + if Next_Char_Known then + -- Last position to check + + Last_Pos := Input_Pos + Max; + + if Last_Pos > Data'Last + or else Max = Natural'Last + then + Last_Pos := Data'Last; + end if; + + -- Look for the first possible opportunity + + loop + -- Find the next possible position + + while Input_Pos <= Last_Pos + and then Data (Input_Pos) /= Next_Char + loop + Input_Pos := Input_Pos + 1; + end loop; + + if Input_Pos > Last_Pos then + return False; + end if; + + -- Check that we still match if we stop + -- at the position we just found. + + declare + Num : constant Natural := Input_Pos - Old; + + begin + Input_Pos := Old; + + if Repeat (Operand_Code, Num) < Num then + return False; + end if; + end; + + -- Input_Pos now points to the new position + + if Match (Get_Next (Program, Scan)) then + return True; + end if; + + Old := Input_Pos; + Input_Pos := Input_Pos + 1; + end loop; + + -- We know what the next character is + + else + while Max >= Min loop + + -- If the next character matches + + if Match (Next) then + return True; + end if; + + Input_Pos := Save + Min; + + -- Could not or did not match -- move forward + + if Repeat (Operand_Code, 1) /= 0 then + Min := Min + 1; + else + return False; + end if; + end loop; + end if; + + return False; + + -- Greedy operators + + else + No := Repeat (Operand_Code, Max); + + -- ??? Perl has some special code here in case the + -- next instruction is of type EOL, since $ and \Z + -- can match before *and* after newline at the end. + + -- ??? Perl has some special code here in case (paren) + -- is True. + + -- Else, if we don't have any parenthesis + + while No >= Min loop + if not Next_Char_Known + or else (Input_Pos <= Data'Last + and then Data (Input_Pos) = Next_Char) + then + if Match (Next) then + return True; + end if; + end if; + + -- Could not or did not work, we back up + + No := No - 1; + Input_Pos := Save + No; + end loop; + return False; + end if; + end Match_Simple_Operator; + + ------------------ + -- Match_Whilem -- + ------------------ + + -- This is really hard to understand, because after we match what we're + -- trying to match, we must make sure the rest of the REx is going to + -- match for sure, and to do that we have to go back UP the parse tree + -- by recursing ever deeper. And if it fails, we have to reset our + -- parent's current state that we can try again after backing off. + + function Match_Whilem (IP : Pointer) return Boolean is + Cc : Current_Curly_Access := Current_Curly; + N : Natural := Cc.Cur + 1; + Ln : Natural; + Lastloc : Natural := Cc.Lastloc; + -- Detection of 0-len. + + begin + -- If degenerate scan matches "", assume scan done. + + if Input_Pos = Cc.Lastloc + and then N >= Cc.Min + then + -- Temporarily restore the old context, and check that we + -- match was comes after CURLYX. + + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Match (Cc.Next) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + return False; + end if; + + -- First, just match a string of min scans. + + if N < Cc.Min then + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Match (Cc.Scan) then + return True; + end if; + + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + return False; + end if; + + -- Prefer next over scan for minimal matching. + + if not Cc.Greedy then + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Recurse_Match (Cc.Next, Cc.Paren_Floor) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + + -- Maximum greed exceeded ? + + if N >= Cc.Max then + return False; + end if; + + -- Try scanning more and see if it helps + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then + return True; + end if; + + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + return False; + end if; + + -- Prefer scan over next for maximal matching + + if N < Cc.Max then -- more greed allowed ? + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then + return True; + end if; + end if; + + -- Failed deeper matches of scan, so see if this one works + + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Match (Cc.Next) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + return False; + end Match_Whilem; + + ------------ + -- Repeat -- + ------------ + + function Repeat + (IP : Pointer; + Max : Natural := Natural'Last) + return Natural + is + Scan : Natural := Input_Pos; + Last : Natural; + Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP))); + Count : Natural; + C : Character; + Is_First : Boolean := True; + Bitmap : Character_Class; + + begin + if Max = Natural'Last or else Scan + Max - 1 > Data'Last then + Last := Data'Last; + else + Last := Scan + Max - 1; + end if; + + case Op is + when ANY => + while Scan <= Last + and then Data (Scan) /= ASCII.LF + loop + Scan := Scan + 1; + end loop; + + when SANY => + Scan := Last + 1; + + when EXACT => + + -- The string has only one character if Repeat was called + + C := Program (String_Operand (IP)); + while Scan <= Last + and then C = Data (Scan) + loop + Scan := Scan + 1; + end loop; + + when EXACTF => + + -- The string has only one character if Repeat was called + + C := Program (String_Operand (IP)); + while Scan <= Last + and then To_Lower (C) = Data (Scan) + loop + Scan := Scan + 1; + end loop; + + when ANYOF => + if Is_First then + Bitmap_Operand (Program, IP, Bitmap); + Is_First := False; + end if; + + while Scan <= Last + and then Get_From_Class (Bitmap, Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when ALNUM => + while Scan <= Last + and then Is_Alnum (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NALNUM => + while Scan <= Last + and then not Is_Alnum (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when SPACE => + while Scan <= Last + and then Is_Space (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NSPACE => + while Scan <= Last + and then not Is_Space (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when DIGIT => + while Scan <= Last + and then Is_Digit (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NDIGIT => + while Scan <= Last + and then not Is_Digit (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when others => + raise Program_Error; + end case; + + Count := Scan - Input_Pos; + Input_Pos := Scan; + return Count; + end Repeat; + + --------- + -- Try -- + --------- + + function Try (Pos : in Positive) return Boolean is + begin + Input_Pos := Pos; + Last_Paren := 0; + Matches_Full := (others => No_Match); + + if Match (Program_First + 1) then + Matches_Full (0) := (Pos, Input_Pos - 1); + return True; + end if; + + return False; + end Try; + + -- Start of processing for Match + + begin + -- Do we have the regexp Never_Match? + + if Self.Size = 0 then + Matches (0) := No_Match; + return; + end if; + + -- Check validity of program + + pragma Assert + (Program (Program_First) = MAGIC, + "Corrupted Pattern_Matcher"); + + -- If there is a "must appear" string, look for it + + if Self.Must_Have_Length > 0 then + declare + First : constant Character := Program (Self.Must_Have); + Must_First : constant Pointer := Self.Must_Have; + Must_Last : constant Pointer := + Must_First + Pointer (Self.Must_Have_Length - 1); + Next_Try : Natural := Index (Data'First, First); + + begin + while Next_Try /= 0 + and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1) + = String (Program (Must_First .. Must_Last)) + loop + Next_Try := Index (Next_Try + 1, First); + end loop; + + if Next_Try = 0 then + Matches_Full := (others => No_Match); + return; -- Not present + end if; + end; + end if; + + -- Mark beginning of line for ^ + + BOL_Pos := Data'First; + + -- Simplest case first: an anchored match need be tried only once + + if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then + Matched := Try (Data'First); + + elsif Self.Anchored then + declare + Next_Try : Natural := Data'First; + begin + -- Test the first position in the buffer + Matched := Try (Next_Try); + + -- Else only test after newlines + + if not Matched then + while Next_Try <= Data'Last loop + while Next_Try <= Data'Last + and then Data (Next_Try) /= ASCII.LF + loop + Next_Try := Next_Try + 1; + end loop; + + Next_Try := Next_Try + 1; + + if Next_Try <= Data'Last then + Matched := Try (Next_Try); + exit when Matched; + end if; + end loop; + end if; + end; + + elsif Self.First /= ASCII.NUL then + + -- We know what char it must start with + + declare + Next_Try : Natural := Index (Data'First, Self.First); + + begin + while Next_Try /= 0 loop + Matched := Try (Next_Try); + exit when Matched; + Next_Try := Index (Next_Try + 1, Self.First); + end loop; + end; + + else + -- Messy cases: try all locations (including for the empty string) + + Matched := Try (Data'First); + + if not Matched then + for S in Data'First + 1 .. Data'Last loop + Matched := Try (S); + exit when Matched; + end loop; + end if; + end if; + + -- Matched has its value + + for J in Last_Paren + 1 .. Matches'Last loop + Matches_Full (J) := No_Match; + end loop; + + Matches := Matches_Full (Matches'Range); + return; + end Match; + + function Match + (Self : Pattern_Matcher; + Data : String) + return Natural + is + Matches : Match_Array (0 .. 0); + + begin + Match (Self, Data, Matches); + if Matches (0) = No_Match then + return Data'First - 1; + else + return Matches (0).First; + end if; + end Match; + + procedure Match + (Expression : String; + Data : String; + Matches : out Match_Array; + Size : Program_Size := 0) + is + PM : Pattern_Matcher (Size); + Finalize_Size : Program_Size; + + begin + if Size = 0 then + Match (Compile (Expression), Data, Matches); + else + Compile (PM, Expression, Finalize_Size); + Match (PM, Data, Matches); + end if; + end Match; + + function Match + (Expression : String; + Data : String; + Size : Program_Size := 0) + return Natural + is + PM : Pattern_Matcher (Size); + Final_Size : Program_Size; -- unused + + begin + if Size = 0 then + return Match (Compile (Expression), Data); + else + Compile (PM, Expression, Final_Size); + return Match (PM, Data); + end if; + end Match; + + function Match + (Expression : String; + Data : String; + Size : Program_Size := 0) + return Boolean + is + Matches : Match_Array (0 .. 0); + PM : Pattern_Matcher (Size); + Final_Size : Program_Size; -- unused + + begin + if Size = 0 then + Match (Compile (Expression), Data, Matches); + else + Compile (PM, Expression, Final_Size); + Match (PM, Data, Matches); + end if; + + return Matches (0).First >= Data'First; + end Match; + + ------------- + -- Operand -- + ------------- + + function Operand (P : Pointer) return Pointer is + begin + return P + 3; + end Operand; + + -------------- + -- Optimize -- + -------------- + + procedure Optimize (Self : in out Pattern_Matcher) is + Max_Length : Program_Size; + This_Length : Program_Size; + Longest : Pointer; + Scan : Pointer; + Program : Program_Data renames Self.Program; + + begin + -- Start with safe defaults (no optimization): + -- * No known first character of match + -- * Does not necessarily start at beginning of line + -- * No string known that has to appear in data + + Self.First := ASCII.NUL; + Self.Anchored := False; + Self.Must_Have := Program'Last + 1; + Self.Must_Have_Length := 0; + + Scan := Program_First + 1; -- First instruction (can be anything) + + if Program (Scan) = EXACT then + Self.First := Program (String_Operand (Scan)); + + elsif Program (Scan) = BOL + or else Program (Scan) = SBOL + or else Program (Scan) = MBOL + then + Self.Anchored := True; + end if; + + -- If there's something expensive in the regexp, find the + -- longest literal string that must appear and make it the + -- regmust. Resolve ties in favor of later strings, since + -- the regstart check works with the beginning of the regexp. + -- and avoiding duplication strengthens checking. Not a + -- strong reason, but sufficient in the absence of others. + + if False then -- if Flags.SP_Start then ??? + Longest := 0; + Max_Length := 0; + while Scan /= 0 loop + if Program (Scan) = EXACT or else Program (Scan) = EXACTF then + This_Length := String_Length (Program, Scan); + + if This_Length >= Max_Length then + Longest := String_Operand (Scan); + Max_Length := This_Length; + end if; + end if; + + Scan := Get_Next (Program, Scan); + end loop; + + Self.Must_Have := Longest; + Self.Must_Have_Length := Natural (Max_Length) + 1; + end if; + end Optimize; + + ----------------- + -- Paren_Count -- + ----------------- + + function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is + begin + return Regexp.Paren_Count; + end Paren_Count; + + ----------- + -- Quote -- + ----------- + + function Quote (Str : String) return String is + S : String (1 .. Str'Length * 2); + Last : Natural := 0; + + begin + for J in Str'Range loop + case Str (J) is + when '^' | '$' | '|' | '*' | '+' | '?' | '{' + | '}' | '[' | ']' | '(' | ')' | '\' => + + S (Last + 1) := '\'; + S (Last + 2) := Str (J); + Last := Last + 2; + + when others => + S (Last + 1) := Str (J); + Last := Last + 1; + end case; + end loop; + + return S (1 .. Last); + end Quote; + + ------------------ + -- Read_Natural -- + ------------------ + + function Read_Natural + (Program : Program_Data; + IP : Pointer) + return Natural + is + begin + return Character'Pos (Program (IP)) + + 256 * Character'Pos (Program (IP + 1)); + end Read_Natural; + + ----------------- + -- Reset_Class -- + ----------------- + + procedure Reset_Class (Bitmap : in out Character_Class) is + begin + Bitmap := (others => 0); + end Reset_Class; + + ------------------ + -- Set_In_Class -- + ------------------ + + procedure Set_In_Class + (Bitmap : in out Character_Class; + C : Character) + is + Value : constant Class_Byte := Character'Pos (C); + + begin + Bitmap (Value / 8) := Bitmap (Value / 8) + or Bit_Conversion (Value mod 8); + end Set_In_Class; + + ------------------- + -- String_Length -- + ------------------- + + function String_Length + (Program : Program_Data; + P : Pointer) + return Program_Size + is + begin + pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); + return Character'Pos (Program (P + 3)); + end String_Length; + + -------------------- + -- String_Operand -- + -------------------- + + function String_Operand (P : Pointer) return Pointer is + begin + return P + 4; + end String_Operand; + +end GNAT.Regpat; diff --git a/gcc/ada/g-regpat.ads b/gcc/ada/g-regpat.ads new file mode 100644 index 00000000000..5d6c4b76499 --- /dev/null +++ b/gcc/ada/g-regpat.ads @@ -0,0 +1,548 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . R E G P A T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1986 by University of Toronto. -- +-- Copyright (C) 1996-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements roughly the same set of regular expressions as +-- are available in the Perl or Python programming languages. + +-- This is an extension of the original V7 style regular expression library +-- written in C by Henry Spencer. Apart from the translation to Ada, the +-- interface has been considerably changed to use the Ada String type +-- instead of C-style nul-terminated strings. + +------------------------------------------------------------ +-- Summary of Pattern Matching Packages in GNAT Hierarchy -- +------------------------------------------------------------ + +-- There are three related packages that perform pattern maching functions. +-- the following is an outline of these packages, to help you determine +-- which is best for your needs. + +-- GNAT.Regexp (files g-regexp.ads/g-regexp.adb) +-- This is a simple package providing Unix-style regular expression +-- matching with the restriction that it matches entire strings. It +-- is particularly useful for file name matching, and in particular +-- it provides "globbing patterns" that are useful in implementing +-- unix or DOS style wild card matching for file names. + +-- GNAT.Regpat (files g-regpat.ads/g-regpat.adb) +-- This is a more complete implementation of Unix-style regular +-- expressions, copied from the Perl regular expression engine, +-- written originally in C by Henry Spencer. It is functionally the +-- same as that library. + +-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) +-- This is a completely general pattern matching package based on the +-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern +-- language is modeled on context free grammars, with context sensitive +-- extensions that provide full (type 0) computational capabilities. + +package GNAT.Regpat is +pragma Preelaborate (Regpat); + + -- The grammar is the following: + + -- regexp ::= expr + -- ::= ^ expr -- anchor at the beginning of string + -- ::= expr $ -- anchor at the end of string + -- expr ::= term + -- ::= term | term -- alternation (term or term ...) + -- term ::= item + -- ::= item item ... -- concatenation (item then item) + -- item ::= elmt -- match elmt + -- ::= elmt * -- zero or more elmt's + -- ::= elmt + -- one or more elmt's + -- ::= elmt ? -- matches elmt or nothing + -- ::= elmt *? -- zero or more times, minimum number + -- ::= elmt +? -- one or more times, minimum number + -- ::= elmt ?? -- zero or one time, minimum number + -- ::= elmt { num } -- matches elmt exactly num times + -- ::= elmt { num , } -- matches elmt at least num times + -- ::= elmt { num , num2 } -- matches between num and num2 times + -- ::= elmt { num }? -- matches elmt exactly num times + -- ::= elmt { num , }? -- matches elmt at least num times + -- non-greedy version + -- ::= elmt { num , num2 }? -- matches between num and num2 times + -- non-greedy version + -- elmt ::= nchr -- matches given character + -- ::= [range range ...] -- matches any character listed + -- ::= [^ range range ...] -- matches any character not listed + -- ::= . -- matches any single character + -- -- except newlines + -- ::= ( expr ) -- parens used for grouping + -- ::= \ num -- reference to num-th parenthesis + -- range ::= char - char -- matches chars in given range + -- ::= nchr + -- ::= [: posix :] -- any character in the POSIX range + -- ::= [:^ posix :] -- not in the POSIX range + -- posix ::= alnum -- alphanumeric characters + -- ::= alpha -- alphabetic characters + -- ::= ascii -- ascii characters (0 .. 127) + -- ::= cntrl -- control chars (0..31, 127..159) + -- ::= digit -- digits ('0' .. '9') + -- ::= graph -- graphic chars (32..126, 160..255) + -- ::= lower -- lower case characters + -- ::= print -- printable characters (32..127) + -- ::= punct -- printable, except alphanumeric + -- ::= space -- space characters + -- ::= upper -- upper case characters + -- ::= word -- alphanumeric characters + -- ::= xdigit -- hexadecimal chars (0..9, a..f) + + -- char ::= any character, including special characters + -- ASCII.NUL is not supported. + -- nchr ::= any character except \()[].*+?^ or \char to match char + -- \n means a newline (ASCII.LF) + -- \t means a tab (ASCII.HT) + -- \r means a return (ASCII.CR) + -- \b matches the empty string at the beginning or end of a + -- word. A word is defined as a set of alphanumerical + -- characters (see \w below). + -- \B matches the empty string only when *not* at the + -- beginning or end of a word. + -- \d matches any digit character ([0-9]) + -- \D matches any non digit character ([^0-9]) + -- \s matches any white space character. This is equivalent + -- to [ \t\n\r\f\v] (tab, form-feed, vertical-tab,... + -- \S matches any non-white space character. + -- \w matches any alphanumeric character or underscore. + -- This include accented letters, as defined in the + -- package Ada.Characters.Handling. + -- \W matches any non-alphanumeric character. + -- \A match the empty string only at the beginning of the + -- string, whatever flags are used for Compile (the + -- behavior of ^ can change, see Regexp_Flags below). + -- \G match the empty string only at the end of the + -- string, whatever flags are used for Compile (the + -- behavior of $ can change, see Regexp_Flags below). + -- ... ::= is used to indication repetition (one or more terms) + + -- Embedded newlines are not matched by the ^ operator. + -- It is possible to retrieve the substring matched a parenthesis + -- expression. Although the depth of parenthesis is not limited in the + -- regexp, only the first 9 substrings can be retrieved. + + -- The highest value possible for the arguments to the curly operator ({}) + -- are given by the constant Max_Curly_Repeat below. + + -- The operators '*', '+', '?' and '{}' always match the longest possible + -- substring. They all have a non-greedy version (with an extra ? after the + -- operator), which matches the shortest possible substring. + + -- For instance: + -- regexp="<.*>" string="<h1>title</h1>" matches="<h1>title</h1>" + -- regexp="<.*?>" string="<h1>title</h1>" matches="<h1>" + -- + -- '{' and '}' are only considered as special characters if they appear + -- in a substring that looks exactly like '{n}', '{n,m}' or '{n,}', where + -- n and m are digits. No space is allowed. In other contexts, the curly + -- braces will simply be treated as normal characters. + + -- Compiling Regular Expressions + -- ============================= + + -- To use this package, you first need to compile the regular expression + -- (a string) into a byte-code program, in a Pattern_Matcher structure. + -- This first step checks that the regexp is valid, and optimizes the + -- matching algorithms of the second step. + + -- Two versions of the Compile subprogram are given: one in which this + -- package will compute itself the best possible size to allocate for the + -- byte code; the other where you must allocate enough memory yourself. An + -- exception is raised if there is not enough memory. + + -- declare + -- Regexp : String := "a|b"; + + -- Matcher : Pattern_Matcher := Compile (Regexp); + -- -- The size for matcher is automatically allocated + + -- Matcher2 : Pattern_Matcher (1000); + -- -- Some space is allocated directly. + + -- begin + -- Compile (Matcher2, Regexp); + -- ... + -- end; + + -- Note that the second version is significantly faster, since with the + -- first version the regular expression has in fact to be compiled twice + -- (first to compute the size, then to generate the byte code). + + -- Note also that you can not use the function version of Compile if you + -- specify the size of the Pattern_Matcher, since the discriminants will + -- most probably be different and you will get a Constraint_Error + + -- Matching Strings + -- ================ + + -- Once the regular expression has been compiled, you can use it as often + -- as needed to match strings. + + -- Several versions of the Match subprogram are provided, with different + -- parameters and return results. + + -- See the description under each of these subprograms. + + -- Here is a short example showing how to get the substring matched by + -- the first parenthesis pair. + + -- declare + -- Matches : Match_Array; + -- Regexp : String := "a(b|c)d"; + -- Str : String := "gacdg"; + + -- begin + -- Match (Compile (Regexp), Str, Matches); + -- return Str (Matches (1).First .. Matches (1).Last); + -- -- returns 'c' + -- end; + + -- String Substitution + -- =================== + + -- No subprogram is currently provided for string substitution. + -- However, this is easy to simulate with the parenthesis groups, as + -- shown below. + + -- This example swaps the first two words of the string: + + -- declare + -- Regexp : String := "([a-z]+) +([a-z]+)"; + -- Str : String := " first second third "; + -- Matches : Match_Array; + + -- begin + -- Match (Compile (Regexp), Str, Matches); + -- return Str (Str'First .. Matches (1).First - 1) + -- & Str (Matches (2).First .. Matches (2).Last) + -- & " " + -- & Str (Matches (1).First .. Matches (1).Last) + -- & Str (Matches (2).Last + 1 .. Str'Last); + -- -- returns " second first third " + -- end; + + --------------- + -- Constants -- + --------------- + + Expression_Error : exception; + -- This exception is raised when trying to compile an invalid + -- regular expression. All subprograms taking an expression + -- as parameter may raise Expression_Error. + + Max_Paren_Count : constant := 255; + -- Maximum number of parenthesis in a regular expression. + -- This is limited by the size of a Character, as found in the + -- byte-compiled version of regular expressions. + + Max_Program_Size : constant := 2**15 - 1; + -- Maximum size that can be allocated for a program. + + Max_Curly_Repeat : constant := 32767; + -- Maximum number of repetition for the curly operator. + -- The digits in the {n}, {n,} and {n,m } operators can not be higher + -- than this constant, since they have to fit on two characters in the + -- byte-compiled version of regular expressions. + + type Program_Size is range 0 .. Max_Program_Size; + for Program_Size'Size use 16; + -- Number of bytes allocated for the byte-compiled version of a regular + -- expression. + + type Regexp_Flags is mod 256; + for Regexp_Flags'Size use 8; + -- Flags that can be given at compile time to specify default + -- properties for the regular expression. + + No_Flags : constant Regexp_Flags; + Case_Insensitive : constant Regexp_Flags; + -- The automaton is optimized so that the matching is done in a case + -- insensitive manner (upper case characters and lower case characters + -- are all treated the same way). + + Single_Line : constant Regexp_Flags; + -- Treat the Data we are matching as a single line. This means that + -- ^ and $ will ignore \n (unless Multiple_Lines is also specified), + -- and that '.' will match \n. + + Multiple_Lines : constant Regexp_Flags; + -- Treat the Data as multiple lines. This means that ^ and $ will also + -- match on internal newlines (ASCII.LF), in addition to the beginning + -- and end of the string. + -- + -- This can be combined with Single_Line. + + ----------------- + -- Match_Array -- + ----------------- + + subtype Match_Count is Natural range 0 .. Max_Paren_Count; + + type Match_Location is record + First : Natural := 0; + Last : Natural := 0; + end record; + + type Match_Array is array (Match_Count range <>) of Match_Location; + -- The substring matching a given pair of parenthesis. + -- Index 0 is the whole substring that matched the full regular + -- expression. + -- + -- For instance, if your regular expression is something like: + -- "a(b*)(c+)", then Match_Array(1) will be the indexes of the + -- substring that matched "b*" and Match_Array(2) will be the substring + -- that matched "c+". + -- + -- The number of parenthesis groups that can be retrieved is unlimited, + -- and all the Match subprograms below can use a Match_Array of any size. + -- Indexes that do not have any matching parenthesis are set to + -- No_Match. + + No_Match : constant Match_Location := (First => 0, Last => 0); + -- The No_Match constant is (0, 0) to differentiate between + -- matching a null string at position 1, which uses (1, 0) + -- and no match at all. + + ------------------------------ + -- Pattern_Matcher Creation -- + ------------------------------ + + type Pattern_Matcher (Size : Program_Size) is private; + -- Type used to represent a regular expression compiled into byte code + + Never_Match : constant Pattern_Matcher; + -- A regular expression that never matches anything + + function Compile + (Expression : String; + Flags : Regexp_Flags := No_Flags) + return Pattern_Matcher; + -- Compile a regular expression into internal code. + -- Raises Expression_Error if Expression is not a legal regular expression. + -- The appropriate size is calculated automatically, but this means that + -- the regular expression has to be compiled twice (the first time to + -- calculate the size, the second time to actually generate the byte code). + -- + -- Flags is the default value to use to set properties for Expression (case + -- sensitivity,...). + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Final_Code_Size : out Program_Size; + Flags : Regexp_Flags := No_Flags); + -- Compile a regular expression into into internal code + -- This procedure is significantly faster than the function + -- Compile, as there is a known maximum size for the matcher. + -- This function raises Storage_Error if Matcher is too small + -- to hold the resulting code, or Expression_Error is Expression + -- is not a legal regular expression. + -- + -- Flags is the default value to use to set properties for Expression (case + -- sensitivity,...). + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Flags : Regexp_Flags := No_Flags); + -- Same procedure as above, expect it does not return the final + -- program size. + + function Paren_Count (Regexp : Pattern_Matcher) return Match_Count; + pragma Inline (Paren_Count); + + -- Return the number of parenthesis pairs in Regexp. + + -- This is the maximum index that will be filled if a Match_Array is + -- used as an argument to Match. + -- + -- Thus, if you want to be sure to get all the parenthesis, you should + -- do something like: + -- + -- declare + -- Regexp : Pattern_Matcher := Compile ("a(b*)(c+)"); + -- Matched : Match_Array (0 .. Paren_Count (Regexp)); + -- begin + -- Match (Regexp, "a string", Matched); + -- end; + + ------------- + -- Quoting -- + ------------- + + function Quote (Str : String) return String; + -- Return a version of Str so that every special character is quoted. + -- The resulting string can be used in a regular expression to match + -- exactly Str, whatever character was present in Str. + + -------------- + -- Matching -- + -------------- + + procedure Match + (Expression : String; + Data : String; + Matches : out Match_Array; + Size : Program_Size := 0); + -- Match Expression against Data and store result in Matches. + -- Function raises Storage_Error if Size is too small for Expression, + -- or Expression_Error if Expression is not a legal regular expression. + -- If Size is 0, then the appropriate size is automatically calculated + -- by this package, but this is slightly slower. + -- + -- At most Matches'Length parenthesis are returned. + + function Match + (Expression : String; + Data : String; + Size : Program_Size := 0) + return Natural; + -- Return the position where Data matches, or (Data'First - 1) if there is + -- no match. + -- Function raises Storage_Error if Size is too small for Expression + -- or Expression_Error if Expression is not a legal regular expression + -- If Size is 0, then the appropriate size is automatically calculated + -- by this package, but this is slightly slower. + + function Match + (Expression : String; + Data : String; + Size : Program_Size := 0) + return Boolean; + -- Return True if Data matches Expression. Match raises Storage_Error + -- if Size is too small for Expression, or Expression_Error if Expression + -- is not a legal regular expression. + -- + -- If Size is 0, then the appropriate size is automatically calculated + -- by this package, but this is slightly slower. + + ------------------------------------------------ + -- Matching a pre-compiled regular expression -- + ------------------------------------------------ + + -- The following functions are significantly faster if you need to reuse + -- the same regular expression multiple times, since you only have to + -- compile it once. + + function Match + (Self : Pattern_Matcher; + Data : String) + return Natural; + -- Return the position where Data matches, or (Data'First - 1) if there is + -- no match. Raises Expression_Error if Expression is not a legal regular + -- expression. + + pragma Inline (Match); + -- All except the last one below. + + procedure Match + (Self : Pattern_Matcher; + Data : String; + Matches : out Match_Array); + -- Match Data using the given pattern matcher and store result in Matches. + -- Raises Expression_Error if Expression is not a legal regular expression. + -- The expression matches if Matches (0) /= No_Match. + -- + -- At most Matches'Length parenthesis are returned. + + ----------- + -- Debug -- + ----------- + + procedure Dump (Self : Pattern_Matcher); + -- Dump the compiled version of the regular expression matched by Self. + +-------------------------- +-- Private Declarations -- +-------------------------- + +private + + subtype Pointer is Program_Size; + -- The Pointer type is used to point into Program_Data + + -- Note that the pointer type is not necessarily 2 bytes + -- although it is stored in the program using 2 bytes + + type Program_Data is array (Pointer range <>) of Character; + + Program_First : constant := 1; + + -- The "internal use only" fields in regexp are present to pass + -- info from compile to execute that permits the execute phase + -- to run lots faster on simple cases. They are: + + -- First character that must begin a match or ASCII.Nul + -- Anchored true iff match must start at beginning of line + -- Must_Have pointer to string that match must include or null + -- Must_Have_Length length of Must_Have string + + -- First and Anchored permit very fast decisions on suitable + -- starting points for a match, cutting down the work a lot. + -- Must_Have permits fast rejection of lines that cannot possibly + -- match. + + -- The Must_Have tests are costly enough that Optimize + -- supplies a Must_Have only if the r.e. contains something potentially + -- expensive (at present, the only such thing detected is * or + + -- at the start of the r.e., which can involve a lot of backup). + -- The length is supplied because the test in Execute needs it + -- and Optimize is computing it anyway. + + -- The initialization is meant to fail-safe in case the user of this + -- package tries to use an uninitialized matcher. This takes advantage + -- of the knowledge that ASCII.Nul translates to the end-of-program (EOP) + -- instruction code of the state machine. + + No_Flags : constant Regexp_Flags := 0; + Case_Insensitive : constant Regexp_Flags := 1; + Single_Line : constant Regexp_Flags := 2; + Multiple_Lines : constant Regexp_Flags := 4; + + type Pattern_Matcher (Size : Pointer) is record + First : Character := ASCII.NUL; -- internal use only + Anchored : Boolean := False; -- internal use only + Must_Have : Pointer := 0; -- internal use only + Must_Have_Length : Natural := 0; -- internal use only + Paren_Count : Natural := 0; -- # paren groups + Flags : Regexp_Flags := No_Flags; + Program : Program_Data (Program_First .. Size) := + (others => ASCII.NUL); + end record; + + Never_Match : constant Pattern_Matcher := + (0, ASCII.NUL, False, 0, 0, 0, No_Flags, (others => ASCII.NUL)); + +end GNAT.Regpat; diff --git a/gcc/ada/g-soccon.ads b/gcc/ada/g-soccon.ads new file mode 100644 index 00000000000..bfa29f55c6e --- /dev/null +++ b/gcc/ada/g-soccon.ads @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the version for Linux + +package GNAT.Sockets.Constants is + + -- Families + + AF_INET : constant := 2; + AF_INET6 : constant := 10; + + -- Modes + + SOCK_STREAM : constant := 1; + SOCK_DGRAM : constant := 2; + + -- Socket Errors + + EBADF : constant := 9; + ENOTSOCK : constant := 88; + ENOTCONN : constant := 107; + ENOBUFS : constant := 105; + EOPNOTSUPP : constant := 95; + EFAULT : constant := 14; + EWOULDBLOCK : constant := 11; + EADDRNOTAVAIL : constant := 99; + EMSGSIZE : constant := 90; + EADDRINUSE : constant := 98; + EINVAL : constant := 22; + EACCES : constant := 13; + EAFNOSUPPORT : constant := 97; + EISCONN : constant := 106; + ETIMEDOUT : constant := 110; + ECONNREFUSED : constant := 111; + ENETUNREACH : constant := 101; + EALREADY : constant := 114; + EINPROGRESS : constant := 115; + ENOPROTOOPT : constant := 92; + EPROTONOSUPPORT : constant := 93; + EINTR : constant := 4; + EIO : constant := 5; + ESOCKTNOSUPPORT : constant := 94; + + -- Host Errors + + HOST_NOT_FOUND : constant := 1; + TRY_AGAIN : constant := 2; + NO_ADDRESS : constant := 4; + NO_RECOVERY : constant := 3; + + -- Control Flags + + FIONBIO : constant := 21537; + FIONREAD : constant := 21531; + + -- Shutdown Modes + + SHUT_RD : constant := 0; + SHUT_WR : constant := 1; + SHUT_RDWR : constant := 2; + + -- Protocol Levels + + SOL_SOCKET : constant := 1; + IPPROTO_IP : constant := 0; + IPPROTO_UDP : constant := 17; + IPPROTO_TCP : constant := 6; + + -- Socket Options + + TCP_NODELAY : constant := 1; + SO_SNDBUF : constant := 7; + SO_RCVBUF : constant := 8; + SO_REUSEADDR : constant := 2; + SO_KEEPALIVE : constant := 9; + SO_LINGER : constant := 13; + SO_ERROR : constant := 4; + SO_BROADCAST : constant := 6; + IP_ADD_MEMBERSHIP : constant := 35; + IP_DROP_MEMBERSHIP : constant := 36; + IP_MULTICAST_TTL : constant := 33; + IP_MULTICAST_LOOP : constant := 34; +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb new file mode 100644 index 00000000000..b58a0dc20c0 --- /dev/null +++ b/gcc/ada/g-socket.adb @@ -0,0 +1,1776 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; + +with Interfaces.C.Strings; + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Sockets.Constants; +with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; +with GNAT.Task_Lock; + +with GNAT.Sockets.Linker_Options; +pragma Warnings (Off, GNAT.Sockets.Linker_Options); +-- Need to include pragma Linker_Options which is platform dependent. + +with System; use System; + +package body GNAT.Sockets is + + use type C.int, System.Address; + + Finalized : Boolean := False; + Initialized : Boolean := False; + + -- Correspondance tables + + Families : constant array (Family_Type) of C.int := + (Family_Inet => Constants.AF_INET, + Family_Inet6 => Constants.AF_INET6); + + Levels : constant array (Level_Type) of C.int := + (Socket_Level => Constants.SOL_SOCKET, + IP_Protocol_For_IP_Level => Constants.IPPROTO_IP, + IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP, + IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP); + + Modes : constant array (Mode_Type) of C.int := + (Socket_Stream => Constants.SOCK_STREAM, + Socket_Datagram => Constants.SOCK_DGRAM); + + Shutmodes : constant array (Shutmode_Type) of C.int := + (Shut_Read => Constants.SHUT_RD, + Shut_Write => Constants.SHUT_WR, + Shut_Read_Write => Constants.SHUT_RDWR); + + Requests : constant array (Request_Name) of C.int := + (Non_Blocking_IO => Constants.FIONBIO, + N_Bytes_To_Read => Constants.FIONREAD); + + Options : constant array (Option_Name) of C.int := + (Keep_Alive => Constants.SO_KEEPALIVE, + Reuse_Address => Constants.SO_REUSEADDR, + Broadcast => Constants.SO_BROADCAST, + Send_Buffer => Constants.SO_SNDBUF, + Receive_Buffer => Constants.SO_RCVBUF, + Linger => Constants.SO_LINGER, + Error => Constants.SO_ERROR, + No_Delay => Constants.TCP_NODELAY, + Add_Membership => Constants.IP_ADD_MEMBERSHIP, + Drop_Membership => Constants.IP_DROP_MEMBERSHIP, + Multicast_TTL => Constants.IP_MULTICAST_TTL, + Multicast_Loop => Constants.IP_MULTICAST_LOOP); + + Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; + Host_Error_Id : constant Exception_Id := Host_Error'Identity; + + Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; + -- Use to print in hexadecimal format + + function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); + function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) + return Error_Type; + -- Associate an enumeration value (error_type) to en error value + -- (errno). From_Errno prevents from mixing h_errno with errno. + + function To_Host_Name (N : String) return Host_Name_Type; + function To_String (HN : Host_Name_Type) return String; + -- Conversion functions + + function Port_To_Network + (Port : C.unsigned_short) + return C.unsigned_short; + pragma Inline (Port_To_Network); + -- Convert a port number into a network port number + + function Network_To_Port + (Net_Port : C.unsigned_short) + return C.unsigned_short + renames Port_To_Network; + -- Symetric operation + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) + return String; + -- Output an array of inet address components either in + -- hexadecimal or in decimal mode. + + function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr; + function To_Inet_Addr (Addr : In_Addr) return Inet_Addr_Type; + -- Conversion functions + + function To_Host_Entry (Host : Hostent) return Host_Entry_Type; + -- Conversion function + + function To_Timeval (Val : Duration) return Timeval; + -- Separate Val in seconds and microseconds + + procedure Raise_Socket_Error (Error : Integer); + -- Raise Socket_Error with an exception message describing + -- the error code. + + procedure Raise_Host_Error (Error : Integer); + -- Raise Host_Error exception with message describing error code + -- (note hstrerror seems to be obsolete). + + -- Types needed for Socket_Set_Type + + type Socket_Set_Record is new Fd_Set; + + procedure Free is + new Ada.Unchecked_Deallocation (Socket_Set_Record, Socket_Set_Type); + + -- Types needed for Datagram_Socket_Stream_Type + + type Datagram_Socket_Stream_Type is new Root_Stream_Type with + record + Socket : Socket_Type; + To : Sock_Addr_Type; + From : Sock_Addr_Type; + end record; + + type Datagram_Socket_Stream_Access is + access all Datagram_Socket_Stream_Type; + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -- Types needed for Stream_Socket_Stream_Type + + type Stream_Socket_Stream_Type is new Root_Stream_Type with + record + Socket : Socket_Type; + end record; + + type Stream_Socket_Stream_Access is + access all Stream_Socket_Stream_Type; + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -------------------- + -- Abort_Selector -- + -------------------- + + procedure Abort_Selector (Selector : Selector_Type) is + begin + -- Send an empty array to unblock C select system call + + if Selector.In_Progress then + declare + Buf : Character; + Res : C.int; + begin + Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 0); + end; + end if; + end Abort_Selector; + + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := C_Accept (C.int (Server), Sin'Address, Len'Access); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + + Address.Addr := To_Inet_Addr (Sin.Sin_Addr); + Address.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + end Accept_Socket; + + --------------- + -- Addresses -- + --------------- + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) + return Inet_Addr_Type + is + begin + return E.Addresses (N); + end Addresses; + + ---------------------- + -- Addresses_Length -- + ---------------------- + + function Addresses_Length (E : Host_Entry_Type) return Natural is + begin + return E.Addresses_Length; + end Addresses_Length; + + ------------- + -- Aliases -- + ------------- + + function Aliases + (E : Host_Entry_Type; + N : Positive := 1) + return String + is + begin + return To_String (E.Aliases (N)); + end Aliases; + + -------------------- + -- Aliases_Length -- + -------------------- + + function Aliases_Length (E : Host_Entry_Type) return Natural is + begin + return E.Aliases_Length; + end Aliases_Length; + + ----------------- + -- Bind_Socket -- + ----------------- + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + if Address.Family = Family_Inet6 then + raise Socket_Error; + end if; + + Sin.Sin_Family := C.unsigned_short (Families (Address.Family)); + Sin.Sin_Port := Port_To_Network (C.unsigned_short (Address.Port)); + + Res := C_Bind (C.int (Socket), Sin'Address, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Bind_Socket; + + -------------------- + -- Check_Selector -- + -------------------- + + procedure Check_Selector + (Selector : in out Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Duration := Forever) + is + Res : C.int; + Len : C.int; + RSet : aliased Fd_Set; + WSet : aliased Fd_Set; + TVal : aliased Timeval; + TPtr : Timeval_Access; + + begin + Status := Completed; + + -- No timeout or Forever is indicated by a null timeval pointer. + + if Timeout = Forever then + TPtr := null; + else + TVal := To_Timeval (Timeout); + TPtr := TVal'Unchecked_Access; + end if; + + -- Copy R_Socket_Set in RSet and add read signalling socket. + + if R_Socket_Set = null then + RSet := Null_Fd_Set; + else + RSet := Fd_Set (R_Socket_Set.all); + end if; + + Set (RSet, C.int (Selector.R_Sig_Socket)); + Len := Max (RSet) + 1; + + -- Copy W_Socket_Set in WSet. + + if W_Socket_Set = null then + WSet := Null_Fd_Set; + else + WSet := Fd_Set (W_Socket_Set.all); + end if; + Len := C.int'Max (Max (RSet) + 1, Len); + + Selector.In_Progress := True; + Res := + C_Select + (Len, + RSet'Unchecked_Access, + WSet'Unchecked_Access, + null, TPtr); + Selector.In_Progress := False; + + -- If Select was resumed because of read signalling socket, + -- read this data and remove socket from set. + + if Is_Set (RSet, C.int (Selector.R_Sig_Socket)) then + Clear (RSet, C.int (Selector.R_Sig_Socket)); + + declare + Buf : Character; + begin + Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 0); + end; + + -- Select was resumed because of read signalling socket, but + -- the call is said aborted only when there is no other read + -- or write event. + + if Is_Empty (RSet) + and then Is_Empty (WSet) + then + Status := Aborted; + end if; + + elsif Res = 0 then + Status := Expired; + end if; + + if R_Socket_Set /= null then + R_Socket_Set.all := Socket_Set_Record (RSet); + end if; + + if W_Socket_Set /= null then + W_Socket_Set.all := Socket_Set_Record (WSet); + end if; + end Check_Selector; + + ----------- + -- Clear -- + ----------- + + procedure Clear + (Item : in out Socket_Set_Type; + Socket : Socket_Type) + is + begin + if Item = null then + Item := new Socket_Set_Record; + Empty (Fd_Set (Item.all)); + end if; + + Clear (Fd_Set (Item.all), C.int (Socket)); + end Clear; + + -------------------- + -- Close_Selector -- + -------------------- + + procedure Close_Selector (Selector : in out Selector_Type) is + begin + begin + Close_Socket (Selector.R_Sig_Socket); + exception when Socket_Error => + null; + end; + + begin + Close_Socket (Selector.W_Sig_Socket); + exception when Socket_Error => + null; + end; + end Close_Selector; + + ------------------ + -- Close_Socket -- + ------------------ + + procedure Close_Socket (Socket : Socket_Type) is + Res : C.int; + + begin + Res := C_Close (C.int (Socket)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Close_Socket; + + -------------------- + -- Connect_Socket -- + -------------------- + + procedure Connect_Socket + (Socket : Socket_Type; + Server : in out Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + if Server.Family = Family_Inet6 then + raise Socket_Error; + end if; + + Sin.Sin_Family := C.unsigned_short (Families (Server.Family)); + Sin.Sin_Addr := To_In_Addr (Server.Addr); + Sin.Sin_Port := Port_To_Network (C.unsigned_short (Server.Port)); + + Res := C_Connect (C.int (Socket), Sin'Address, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Connect_Socket; + + -------------------- + -- Control_Socket -- + -------------------- + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type) + is + Arg : aliased C.int; + Res : C.int; + + begin + case Request.Name is + when Non_Blocking_IO => + Arg := C.int (Boolean'Pos (Request.Enabled)); + + when N_Bytes_To_Read => + null; + + end case; + + Res := C_Ioctl + (C.int (Socket), + Requests (Request.Name), + Arg'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Request.Name is + when Non_Blocking_IO => + null; + + when N_Bytes_To_Read => + Request.Size := Natural (Arg); + + end case; + end Control_Socket; + + --------------------- + -- Create_Selector -- + --------------------- + + procedure Create_Selector (Selector : out Selector_Type) is + S0 : C.int; + S1 : C.int; + S2 : C.int; + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Err : Integer; + + begin + -- We open two signalling sockets. One socket to send a signal + -- to a another socket that always included in a C_Select + -- socket set. When received, it resumes the task suspended in + -- C_Select. + + -- Create a listening socket + + S0 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); + if S0 = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + -- Sin is already correctly initialized. Bind the socket to any + -- unused port. + + Res := C_Bind (S0, Sin'Address, Len); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + -- Get the port used by the socket + + Res := C_Getsockname (S0, Sin'Address, Len'Access); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + Res := C_Listen (S0, 2); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); + if S1 = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Raise_Socket_Error (Err); + end if; + + -- Use INADDR_LOOPBACK + + Sin.Sin_Addr.S_B1 := 127; + Sin.Sin_Addr.S_B2 := 0; + Sin.Sin_Addr.S_B3 := 0; + Sin.Sin_Addr.S_B4 := 1; + + -- Do a connect and accept the connection + + Res := C_Connect (S1, Sin'Address, Len); + if Res = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Res := C_Close (S1); + Raise_Socket_Error (Err); + end if; + + S2 := C_Accept (S0, Sin'Address, Len'Access); + if S2 = Failure then + Err := Socket_Errno; + Res := C_Close (S0); + Res := C_Close (S1); + Raise_Socket_Error (Err); + end if; + + Res := C_Close (S0); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Selector.R_Sig_Socket := Socket_Type (S1); + Selector.W_Sig_Socket := Socket_Type (S2); + end Create_Selector; + + ------------------- + -- Create_Socket -- + ------------------- + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream) + is + Res : C.int; + + begin + Res := C_Socket (Families (Family), Modes (Mode), 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + end Create_Socket; + + ----------- + -- Empty -- + ----------- + + procedure Empty (Item : in out Socket_Set_Type) is + begin + if Item /= null then + Free (Item); + end if; + end Empty; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if not Finalized + and then Initialized + then + Finalized := True; + Thin.Finalize; + end if; + end Finalize; + + ----------------- + -- Get_Address -- + ----------------- + + function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is + begin + if Stream = null then + raise Socket_Error; + + elsif Stream.all in Datagram_Socket_Stream_Type then + return Datagram_Socket_Stream_Type (Stream.all).From; + + else + return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); + end if; + end Get_Address; + + ------------------------- + -- Get_Host_By_Address -- + ------------------------- + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) + return Host_Entry_Type + is + HA : aliased In_Addr := To_In_Addr (Address); + Res : Hostent_Access; + Err : Integer; + + begin + -- This C function is not always thread-safe. Protect against + -- concurrent access. + + Task_Lock.Lock; + Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET); + + if Res = null then + Err := Socket_Errno; + Task_Lock.Unlock; + Raise_Host_Error (Err); + end if; + + -- Translate from the C format to the API format + + declare + HE : Host_Entry_Type := To_Host_Entry (Res.all); + + begin + Task_Lock.Unlock; + return HE; + end; + end Get_Host_By_Address; + + ---------------------- + -- Get_Host_By_Name -- + ---------------------- + + function Get_Host_By_Name + (Name : String) + return Host_Entry_Type + is + HN : C.char_array := C.To_C (Name); + Res : Hostent_Access; + Err : Integer; + + begin + -- This C function is not always thread-safe. Protect against + -- concurrent access. + + Task_Lock.Lock; + Res := C_Gethostbyname (HN); + + if Res = null then + Err := Socket_Errno; + Task_Lock.Unlock; + Raise_Host_Error (Err); + end if; + + -- Translate from the C format to the API format + + declare + HE : Host_Entry_Type := To_Host_Entry (Res.all); + + begin + Task_Lock.Unlock; + return HE; + end; + end Get_Host_By_Name; + + ------------------- + -- Get_Peer_Name -- + ------------------- + + function Get_Peer_Name + (Socket : Socket_Type) + return Sock_Addr_Type + is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : Sock_Addr_Type (Family_Inet); + + begin + if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Res.Addr := To_Inet_Addr (Sin.Sin_Addr); + Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + + return Res; + end Get_Peer_Name; + + --------------------- + -- Get_Socket_Name -- + --------------------- + + function Get_Socket_Name + (Socket : Socket_Type) + return Sock_Addr_Type + is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : Sock_Addr_Type (Family_Inet); + + begin + if C_Getsockname (C.int (Socket), Sin'Address, Len'Access) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Res.Addr := To_Inet_Addr (Sin.Sin_Addr); + Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + + return Res; + end Get_Socket_Name; + + ----------------------- + -- Get_Socket_Option -- + ----------------------- + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name) + return Option_Type + is + use type C.unsigned_char; + + V8 : aliased Two_Int; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + Len : aliased C.int; + Add : System.Address; + Res : C.int; + Opt : Option_Type (Name); + + begin + case Name is + when Multicast_Loop | + Multicast_TTL => + Len := V1'Size / 8; + Add := V1'Address; + + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay | + Send_Buffer | + Receive_Buffer | + Error => + Len := V4'Size / 8; + Add := V4'Address; + + when Linger | + Add_Membership | + Drop_Membership => + Len := V8'Size / 8; + Add := V8'Address; + + end case; + + Res := C_Getsockopt + (C.int (Socket), + Levels (Level), + Options (Name), + Add, Len'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => + Opt.Enabled := (V4 /= 0); + + when Linger => + Opt.Enabled := (V8 (V8'First) /= 0); + Opt.Seconds := Natural (V8 (V8'Last)); + + when Send_Buffer | + Receive_Buffer => + Opt.Size := Natural (V4); + + when Error => + Opt.Error := Resolve_Error (Integer (V4)); + + when Add_Membership | + Drop_Membership => + Opt.Multiaddr := To_Inet_Addr (To_In_Addr (V8 (V8'First))); + Opt.Interface := To_Inet_Addr (To_In_Addr (V8 (V8'Last))); + + when Multicast_TTL => + Opt.Time_To_Live := Integer (V1); + + when Multicast_Loop => + Opt.Enabled := (V1 /= 0); + + end case; + + return Opt; + end Get_Socket_Option; + + --------------- + -- Host_Name -- + --------------- + + function Host_Name return String is + Name : aliased C.char_array (1 .. 64); + Res : C.int; + + begin + Res := C_Gethostname (Name'Address, Name'Length); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + return C.To_Ada (Name); + end Host_Name; + + ----------- + -- Image -- + ----------- + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) + return String + is + -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It + -- has at most a length of 3 plus one '.' character. + + Buffer : String (1 .. 4 * Val'Length); + Length : Natural := 1; + Separator : Character; + + procedure Img10 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in decimal format + + procedure Img16 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in hexadecimal format + + procedure Img10 (V : Inet_Addr_Comp_Type) is + Img : constant String := V'Img; + Len : Natural := Img'Length - 1; + + begin + Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last); + Length := Length + Len; + end Img10; + + procedure Img16 (V : Inet_Addr_Comp_Type) is + begin + Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1); + Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1); + Length := Length + 2; + end Img16; + + -- Start of processing for Image + + begin + if Hex then + Separator := ':'; + else + Separator := '.'; + end if; + + for J in Val'Range loop + if Hex then + Img16 (Val (J)); + else + Img10 (Val (J)); + end if; + + if J /= Val'Last then + Buffer (Length) := Separator; + Length := Length + 1; + end if; + end loop; + + return Buffer (1 .. Length - 1); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Inet_Addr_Type) return String is + begin + if Value.Family = Family_Inet then + return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); + else + return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Sock_Addr_Type) return String is + Port : constant String := Value.Port'Img; + + begin + return Image (Value.Addr) & ':' & Port (2 .. Port'Last); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Socket : Socket_Type) return String is + begin + return Socket'Img; + end Image; + + --------------- + -- Inet_Addr -- + --------------- + + function Inet_Addr (Image : String) return Inet_Addr_Type is + use Interfaces.C.Strings; + + Img : chars_ptr := New_String (Image); + Res : C.int; + Err : Integer; + + begin + Res := C_Inet_Addr (Img); + Err := Errno; + Free (Img); + + if Res = Failure then + Raise_Socket_Error (Err); + end if; + + return To_Inet_Addr (To_In_Addr (Res)); + end Inet_Addr; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean := False) is + begin + if not Initialized then + Initialized := True; + Thin.Initialize (Process_Blocking_IO); + end if; + end Initialize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Item : Socket_Set_Type) return Boolean is + begin + return Item = null or else Is_Empty (Fd_Set (Item.all)); + end Is_Empty; + + ------------ + -- Is_Set -- + ------------ + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) return Boolean + is + begin + return Item /= null + and then Is_Set (Fd_Set (Item.all), C.int (Socket)); + end Is_Set; + + ------------------- + -- Listen_Socket -- + ------------------- + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Positive := 15) + is + Res : C.int; + + begin + Res := C_Listen (C.int (Socket), C.int (Length)); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Listen_Socket; + + ------------------- + -- Official_Name -- + ------------------- + + function Official_Name (E : Host_Entry_Type) return String is + begin + return To_String (E.Official); + end Official_Name; + + --------------------- + -- Port_To_Network -- + --------------------- + + function Port_To_Network + (Port : C.unsigned_short) + return C.unsigned_short + is + use type C.unsigned_short; + begin + if Default_Bit_Order = High_Order_First then + + -- No conversion needed. On these platforms, htons() defaults + -- to a null procedure. + + return Port; + + else + -- We need to swap the high and low byte on this short to make + -- the port number network compliant. + + return (Port / 256) + (Port mod 256) * 256; + end if; + end Port_To_Network; + + ---------------------- + -- Raise_Host_Error -- + ---------------------- + + procedure Raise_Host_Error (Error : Integer) is + + function Error_Message return String; + -- We do not use a C function like strerror because hstrerror + -- that would correspond seems to be obsolete. Return + -- appropriate string for error value. + + function Error_Message return String is + begin + case Error is + when Constants.HOST_NOT_FOUND => return "Host not found"; + when Constants.TRY_AGAIN => return "Try again"; + when Constants.NO_RECOVERY => return "No recovery"; + when Constants.NO_ADDRESS => return "No address"; + when others => return "Unknown error"; + end case; + end Error_Message; + + -- Start of processing for Raise_Host_Error + + begin + Ada.Exceptions.Raise_Exception (Host_Error'Identity, Error_Message); + end Raise_Host_Error; + + ------------------------ + -- Raise_Socket_Error -- + ------------------------ + + procedure Raise_Socket_Error (Error : Integer) is + use type C.Strings.chars_ptr; + + function Image (E : Integer) return String; + function Image (E : Integer) return String is + Msg : String := E'Img & "] "; + begin + Msg (Msg'First) := '['; + return Msg; + end Image; + + begin + Ada.Exceptions.Raise_Exception + (Socket_Error'Identity, Image (Error) & Socket_Error_Message (Error)); + end Raise_Socket_Error; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Receive_Socket + (Stream.Socket, + Item (First .. Max), + Index, + Stream.From); + + Last := Index; + + -- Exit when all or zero data received. Zero means that + -- the socket peer is closed. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + end Read; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Receive_Socket (Stream.Socket, Item (First .. Max), Index); + Last := Index; + + -- Exit when all or zero data received. Zero means that + -- the socket peer is closed. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + end Read; + + ------------------- + -- Resolve_Error -- + ------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) + return Error_Type + is + use GNAT.Sockets.Constants; + + begin + if not From_Errno then + case Error_Value is + when HOST_NOT_FOUND => return Unknown_Host; + when TRY_AGAIN => return Host_Name_Lookup_Failure; + when NO_RECOVERY => return No_Address_Associated_With_Name; + when NO_ADDRESS => return Unknown_Server_Error; + when others => return Cannot_Resolve_Error; + end case; + end if; + case Error_Value is + when EACCES => return Permission_Denied; + when EADDRINUSE => return Address_Already_In_Use; + when EADDRNOTAVAIL => return Cannot_Assign_Requested_Address; + when EAFNOSUPPORT => + return Address_Family_Not_Supported_By_Protocol; + when EALREADY => return Operation_Already_In_Progress; + when EBADF => return Bad_File_Descriptor; + when ECONNREFUSED => return Connection_Refused; + when EFAULT => return Bad_Address; + when EINPROGRESS => return Operation_Now_In_Progress; + when EINTR => return Interrupted_System_Call; + when EINVAL => return Invalid_Argument; + when EIO => return Input_Output_Error; + when EISCONN => return Transport_Endpoint_Already_Connected; + when EMSGSIZE => return Message_Too_Long; + when ENETUNREACH => return Network_Is_Unreachable; + when ENOBUFS => return No_Buffer_Space_Available; + when ENOPROTOOPT => return Protocol_Not_Available; + when ENOTCONN => return Transport_Endpoint_Not_Connected; + when EOPNOTSUPP => return Operation_Not_Supported; + when EPROTONOSUPPORT => return Protocol_Not_Supported; + when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported; + when ETIMEDOUT => return Connection_Timed_Out; + when EWOULDBLOCK => return Resource_Temporarily_Unavailable; + when others => return Cannot_Resolve_Error; + end case; + end Resolve_Error; + + ----------------------- + -- Resolve_Exception -- + ----------------------- + + function Resolve_Exception + (Occurrence : Exception_Occurrence) + return Error_Type + is + Id : Exception_Id := Exception_Identity (Occurrence); + Msg : constant String := Exception_Message (Occurrence); + First : Natural := Msg'First; + Last : Natural; + Val : Integer; + + begin + while First <= Msg'Last + and then Msg (First) not in '0' .. '9' + loop + First := First + 1; + end loop; + + if First > Msg'Last then + return Cannot_Resolve_Error; + end if; + + Last := First; + + while Last < Msg'Last + and then Msg (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + + Val := Integer'Value (Msg (First .. Last)); + + if Id = Socket_Error_Id then + return Resolve_Error (Val); + + elsif Id = Host_Error_Id then + return Resolve_Error (Val, False); + + else + return Cannot_Resolve_Error; + end if; + end Resolve_Exception; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + + begin + Res := C_Recv + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end Receive_Socket; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + From : out Sock_Addr_Type) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := C_Recvfrom + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0, + Sin'Unchecked_Access, + Len'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + + From.Addr := To_Inet_Addr (Sin.Sin_Addr); + From.Port := Port_Type (Network_To_Port (Sin.Sin_Port)); + end Receive_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + + begin + Res := C_Send + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end Send_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : Sock_Addr_Type) + is + use type Ada.Streams.Stream_Element_Offset; + + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Sin.Sin_Family := C.unsigned_short (Families (To.Family)); + Sin.Sin_Addr := To_In_Addr (To.Addr); + Sin.Sin_Port := Port_To_Network (C.unsigned_short (To.Port)); + + Res := C_Sendto + (C.int (Socket), + Item (Item'First)'Address, + Item'Length, 0, + Sin'Unchecked_Access, + Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end Send_Socket; + + --------- + -- Set -- + --------- + + procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is + begin + if Item = null then + Item := new Socket_Set_Record'(Socket_Set_Record (Null_Fd_Set)); + end if; + + Set (Fd_Set (Item.all), C.int (Socket)); + end Set; + + ----------------------- + -- Set_Socket_Option -- + ----------------------- + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type) + is + V8 : aliased Two_Int; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + Len : aliased C.int; + Add : System.Address := Null_Address; + Res : C.int; + + begin + case Option.Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + No_Delay => + V4 := C.int (Boolean'Pos (Option.Enabled)); + Len := V4'Size / 8; + Add := V4'Address; + + when Linger => + V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); + V8 (V8'Last) := C.int (Option.Seconds); + Len := V8'Size / 8; + Add := V8'Address; + + when Send_Buffer | + Receive_Buffer => + V4 := C.int (Option.Size); + Len := V4'Size / 8; + Add := V4'Address; + + when Error => + V4 := C.int (Boolean'Pos (True)); + Len := V4'Size / 8; + Add := V4'Address; + + when Add_Membership | + Drop_Membership => + V8 (V8'First) := To_Int (To_In_Addr (Option.Multiaddr)); + V8 (V8'Last) := To_Int (To_In_Addr (Option.Interface)); + Len := V8'Size / 8; + Add := V8'Address; + + when Multicast_TTL => + V1 := C.unsigned_char (Option.Time_To_Live); + Len := V1'Size / 8; + Add := V1'Address; + + when Multicast_Loop => + V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); + Len := V1'Size / 8; + Add := V1'Address; + + end case; + + Res := C_Setsockopt + (C.int (Socket), + Levels (Level), + Options (Option.Name), + Add, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Set_Socket_Option; + + --------------------- + -- Shutdown_Socket -- + --------------------- + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write) + is + Res : C.int; + + begin + Res := C_Shutdown (C.int (Socket), Shutmodes (How)); + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Shutdown_Socket; + + ------------ + -- Stream -- + ------------ + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) + return Stream_Access + is + S : Datagram_Socket_Stream_Access; + + begin + S := new Datagram_Socket_Stream_Type; + S.Socket := Socket; + S.To := Send_To; + S.From := Get_Socket_Name (Socket); + return Stream_Access (S); + end Stream; + + ------------ + -- Stream -- + ------------ + + function Stream + (Socket : Socket_Type) + return Stream_Access + is + S : Stream_Socket_Stream_Access; + + begin + S := new Stream_Socket_Stream_Type; + S.Socket := Socket; + return Stream_Access (S); + end Stream; + + ---------- + -- To_C -- + ---------- + + function To_C (Socket : Socket_Type) return Integer is + begin + return Integer (Socket); + end To_C; + + ------------------- + -- To_Host_Entry -- + ------------------- + + function To_Host_Entry + (Host : Hostent) + return Host_Entry_Type + is + use type C.size_t; + + Official : constant String := + C.Strings.Value (Host.H_Name); + + Aliases : constant Chars_Ptr_Array := + Chars_Ptr_Pointers.Value (Host.H_Aliases); + -- H_Aliases points to a list of name aliases. The list is + -- terminated by a NULL pointer. + + Addresses : constant In_Addr_Access_Array := + In_Addr_Access_Pointers.Value (Host.H_Addr_List); + -- H_Addr_List points to a list of binary addresses (in network + -- byte order). The list is terminated by a NULL pointer. + + -- H_Length is not used because it is currently only set to 4. + -- H_Addrtype is always AF_INET + + Result : Host_Entry_Type + (Aliases_Length => Aliases'Length - 1, + Addresses_Length => Addresses'Length - 1); + -- The last element is a null pointer. + + Source : C.size_t; + Target : Natural; + + begin + Result.Official := To_Host_Name (Official); + + Source := Aliases'First; + Target := Result.Aliases'First; + while Target <= Result.Aliases_Length loop + Result.Aliases (Target) := + To_Host_Name (C.Strings.Value (Aliases (Source))); + Source := Source + 1; + Target := Target + 1; + end loop; + + Source := Addresses'First; + Target := Result.Addresses'First; + while Target <= Result.Addresses_Length loop + Result.Addresses (Target) := + To_Inet_Addr (Addresses (Source).all); + Source := Source + 1; + Target := Target + 1; + end loop; + + return Result; + end To_Host_Entry; + + ------------------ + -- To_Host_Name -- + ------------------ + + function To_Host_Name (N : String) return Host_Name_Type is + begin + return (N'Length, N); + end To_Host_Name; + + ---------------- + -- To_In_Addr -- + ---------------- + + function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is + begin + if Addr.Family = Family_Inet then + return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), + S_B2 => C.unsigned_char (Addr.Sin_V4 (2)), + S_B3 => C.unsigned_char (Addr.Sin_V4 (3)), + S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); + end if; + + raise Socket_Error; + end To_In_Addr; + + ------------------ + -- To_Inet_Addr -- + ------------------ + + function To_Inet_Addr + (Addr : In_Addr) + return Inet_Addr_Type + is + Result : Inet_Addr_Type; + + begin + Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1); + Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2); + Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3); + Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4); + + return Result; + end To_Inet_Addr; + + --------------- + -- To_String -- + --------------- + + function To_String (HN : Host_Name_Type) return String is + begin + return HN.Name (1 .. HN.Length); + end To_String; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (Val : Duration) return Timeval is + S : Timeval_Unit := Timeval_Unit (Val); + MS : Timeval_Unit := Timeval_Unit (1_000_000 * (Val - Duration (S))); + + begin + return (S, MS); + end To_Timeval; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Send_Socket + (Stream.Socket, + Item (First .. Max), + Index, + Stream.To); + + -- Exit when all or zero data sent. Zero means that the + -- socket has been closed by peer. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + + if Index /= Max then + raise Socket_Error; + end if; + end Write; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Send_Socket (Stream.Socket, Item (First .. Max), Index); + + -- Exit when all or zero data sent. Zero means that the + -- socket has been closed by peer. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + + if Index /= Max then + raise Socket_Error; + end if; + end Write; + +end GNAT.Sockets; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads new file mode 100644 index 00000000000..e43ce857e99 --- /dev/null +++ b/gcc/ada/g-socket.ads @@ -0,0 +1,891 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.22 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface to the sockets communication facility +-- provided on many operating systems. Currently this is implemented on all +-- native GNAT ports except for VMS. It is not yet implemented for any of +-- the cross-ports (e.g. it is not available for VxWorks or LynxOS). +-- Another restriction is that there is no multicast support under Windows +-- or under any system on which the multicast support is not available or +-- installed. + +with Ada.Exceptions; +with Ada.Streams; + +package GNAT.Sockets is + + -- Sockets are designed to provide a consistent communication + -- facility between applications. This package provides an + -- Ada-like interface similar to the one proposed as part of the + -- BSD socket layer. This is a system independant thick binding. + -- Here is a typical example of what you can do. + + -- with GNAT.Sockets; use GNAT.Sockets; + -- + -- with Ada.Text_IO; + -- with Ada.Exceptions; use Ada.Exceptions; + -- + -- procedure PingPong is + -- + -- Group : constant String := "239.255.128.128"; + -- -- Multicast groupe: administratively scoped IP address + -- + -- task Pong is + -- entry Start; + -- entry Stop; + -- end Pong; + -- + -- task body Pong is + -- Address : Sock_Addr_Type; + -- Server : Socket_Type; + -- Socket : Socket_Type; + -- Channel : Stream_Access; + -- + -- begin + -- accept Start; + -- + -- -- Get an Internet address of a host (here "localhost"). + -- -- Note that a host can have several addresses. Here we get + -- -- the first one which is supposed to be the official one. + -- + -- Address.Addr := Addresses (Get_Host_By_Name ("localhost"), 1); + -- + -- -- Get a socket address that is an Internet address and a port + -- + -- Address.Port := 5432; + -- + -- -- The first step is to create a socket. Once created, this + -- -- socket must be associated to with an address. Usually only a + -- -- server (Pong here) needs to bind an address explicitly. + -- -- Most of the time clients can skip this step because the + -- -- socket routines will bind an arbitrary address to an unbound + -- -- socket. + -- + -- Create_Socket (Server); + -- + -- -- Allow reuse of local addresses. + -- + -- Set_Socket_Option + -- (Server, + -- Socket_Level, + -- (Reuse_Address, True)); + -- + -- Bind_Socket (Server, Address); + -- + -- -- A server marks a socket as willing to receive connect events. + -- + -- Listen_Socket (Server); + -- + -- -- Once a server calls Listen_Socket, incoming connects events + -- -- can be accepted. The returned Socket is a new socket that + -- -- represents the server side of the connection. Server remains + -- -- available to receive further connections. + -- + -- Accept_Socket (Server, Socket, Address); + -- + -- -- Return a stream associated to the connected socket. + -- + -- Channel := Stream (Socket); + -- + -- -- Force Pong to block + -- + -- delay 0.2; + -- + -- -- Receive and print message from client Ping. + -- + -- declare + -- Message : String := String'Input (Channel); + -- + -- begin + -- Ada.Text_IO.Put_Line (Message); + -- + -- -- Send same message to server Pong. + -- + -- String'Output (Channel, Message); + -- end; + -- + -- Close_Socket (Server); + -- Close_Socket (Socket); + -- + -- -- Part of the multicast example + -- + -- -- Create a datagram socket to send connectionless, unreliable + -- -- messages of a fixed maximum length. + -- + -- Create_Socket (Socket, Family_Inet, Socket_Datagram); + -- + -- -- Allow reuse of local addresses. + -- + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + -- + -- -- Join a multicast group. + -- + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); + -- + -- -- Controls the live time of the datagram to avoid it being + -- -- looped forever due to routing errors. Routers decrement + -- -- the TTL of every datagram as it traverses from one network + -- -- to another and when its value reaches 0 the packet is + -- -- dropped. Default is 1. + -- + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_TTL, 1)); + -- + -- -- Want the data you send to be looped back to your host. + -- + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_Loop, True)); + -- + -- -- If this socket is intended to receive messages, bind it to a + -- -- given socket address. + -- + -- Address.Addr := Any_Inet_Addr; + -- Address.Port := 55505; + -- + -- Bind_Socket (Socket, Address); + -- + -- -- If this socket is intended to send messages, provide the + -- -- receiver socket address. + -- + -- Address.Addr := Inet_Addr (Group); + -- Address.Port := 55506; + -- + -- Channel := Stream (Socket, Address); + -- + -- -- Receive and print message from client Ping. + -- + -- declare + -- Message : String := String'Input (Channel); + -- + -- begin + -- + -- -- Get the address of the sender. + -- + -- Address := Get_Address (Channel); + -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); + -- + -- -- Send same message to server Pong. + -- + -- String'Output (Channel, Message); + -- end; + -- + -- Close_Socket (Socket); + -- + -- accept Stop; + -- + -- exception when E : others => + -- Ada.Text_IO.Put_Line + -- (Exception_Name (E) & ": " & Exception_Message (E)); + -- end Pong; + -- + -- task Ping is + -- entry Start; + -- entry Stop; + -- end Ping; + -- + -- task body Ping is + -- Address : Sock_Addr_Type; + -- Socket : Socket_Type; + -- Channel : Stream_Access; + -- + -- begin + -- accept Start; + -- + -- -- See comments in Ping section for the first steps. + -- + -- Address.Addr := Addresses (Get_Host_By_Name ("localhost"), 1); + -- Address.Port := 5432; + -- Create_Socket (Socket); + -- + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + -- + -- -- Force Pong to block + -- + -- delay 0.2; + -- + -- -- If the client's socket is not bound, Connect_Socket will + -- -- bind to an unused address. The client uses Connect_Socket to + -- -- create a logical connection between the client's socket and + -- -- a server's socket returned by Accept_Socket. + -- + -- Connect_Socket (Socket, Address); + -- + -- Channel := Stream (Socket); + -- + -- -- Send message to server Pong. + -- + -- String'Output (Channel, "Hello world"); + -- + -- -- Force Ping to block + -- + -- delay 0.2; + -- + -- -- Receive and print message from server Pong. + -- + -- Ada.Text_IO.Put_Line (String'Input (Channel)); + -- Close_Socket (Socket); + -- + -- -- Part of multicast example. Code similar to Pong's one. + -- + -- Create_Socket (Socket, Family_Inet, Socket_Datagram); + -- + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + -- + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); + -- + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_TTL, 1)); + -- + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_Loop, True)); + -- + -- Address.Addr := Any_Inet_Addr; + -- Address.Port := 55506; + -- + -- Bind_Socket (Socket, Address); + -- + -- Address.Addr := Inet_Addr (Group); + -- Address.Port := 55505; + -- + -- Channel := Stream (Socket, Address); + -- + -- -- Send message to server Pong. + -- + -- String'Output (Channel, "Hello world"); + -- + -- -- Receive and print message from server Pong. + -- + -- declare + -- Message : String := String'Input (Channel); + -- + -- begin + -- Address := Get_Address (Channel); + -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); + -- end; + -- + -- Close_Socket (Socket); + -- + -- accept Stop; + -- + -- exception when E : others => + -- Ada.Text_IO.Put_Line + -- (Exception_Name (E) & ": " & Exception_Message (E)); + -- end Ping; + -- + -- begin + -- -- Indicate whether the thread library provides process + -- -- blocking IO. Basically, if you are not using FSU threads + -- -- the default is ok. + -- + -- Initialize (Process_Blocking_IO => False); + -- Ping.Start; + -- Pong.Start; + -- Ping.Stop; + -- Pong.Stop; + -- Finalize; + -- end PingPong; + + procedure Initialize (Process_Blocking_IO : Boolean := False); + -- Initialize must be called before using any socket routines. If + -- the thread library provides process blocking IO - basically + -- with FSU threads - GNAT.Sockets should be initialized with a + -- value of True to simulate thread blocking IO. Further calls to + -- Initialize will be ignored. + + procedure Finalize; + -- After Finalize is called it is not possible to use any routines + -- exported in by this package. This procedure is idempotent. + + type Socket_Type is private; + -- Sockets are used to implement a reliable bi-directional + -- point-to-point, stream-based connections between + -- hosts. No_Socket provides a special value to denote + -- uninitialized sockets. + + No_Socket : constant Socket_Type; + + Socket_Error : exception; + -- There is only one exception in this package to deal with an + -- error during a socket routine. Once raised, its message + -- contains a string describing the error code. + + function Image (Socket : Socket_Type) return String; + -- Return a printable string for Socket + + function To_C (Socket : Socket_Type) return Integer; + -- Return a file descriptor to be used by external subprograms + -- especially the C functions that are not yet interfaced in this + -- package. + + type Family_Type is (Family_Inet, Family_Inet6); + -- Address family (or protocol family) identifies the + -- communication domain and groups protocols with similar address + -- formats. IPv6 will soon be supported. + + type Mode_Type is (Socket_Stream, Socket_Datagram); + -- Stream sockets provide connection-oriented byte + -- streams. Datagram sockets support unreliable connectionless + -- message based communication. + + type Shutmode_Type is (Shut_Read, Shut_Write, Shut_Read_Write); + -- When a process closes a socket, the policy is to retain any + -- data queued until either a delivery or a timeout expiration (in + -- this case, the data are discarded). A finer control is + -- available through shutdown. With Shut_Read, no more data can be + -- received from the socket. With_Write, no more data can be + -- transmitted. Neither transmission nor reception can be + -- performed with Shut_Read_Write. + + type Port_Type is new Natural; + -- Classical port definition. No_Port provides a special value to + -- denote uninitialized port. Any_Port provides a special value + -- enabling all ports. + + Any_Port : constant Port_Type; + No_Port : constant Port_Type; + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; + -- An Internet address depends on an address family (IPv4 contains + -- 4 octets and Ipv6 contains 16 octets). Any_Inet_Address is a + -- special value treated like a wildcard enabling all addresses. + -- No_Inet_Addr provides a special value to denote uninitialized + -- inet addresses. + + Any_Inet_Addr : constant Inet_Addr_Type; + No_Inet_Addr : constant Inet_Addr_Type; + + type Sock_Addr_Type (Family : Family_Type := Family_Inet) is record + Addr : Inet_Addr_Type (Family); + Port : Port_Type; + end record; + -- Socket addresses fully define a socket connection with a + -- protocol family, an Internet address and a port. No_Sock_Addr + -- provides a special value for uninitialized socket addresses. + + No_Sock_Addr : constant Sock_Addr_Type; + + function Image (Value : Inet_Addr_Type) return String; + -- Return an image of an Internet address. IPv4 notation consists + -- in 4 octets in decimal format separated by dots. IPv6 notation + -- consists in 16 octets in hexadecimal format separated by + -- colons (and possibly dots). + + function Image (Value : Sock_Addr_Type) return String; + -- Return inet address image and port image separated by a colon. + + function Inet_Addr (Image : String) return Inet_Addr_Type; + -- Convert address image from numbers-and-dots notation into an + -- inet address. + + -- Host entries provide a complete information on a given host: + -- the official name, an array of alternative names or aliases and + -- array of network addresses. + + type Host_Entry_Type + (Aliases_Length, Addresses_Length : Natural) is private; + + function Official_Name (E : Host_Entry_Type) return String; + -- Return official name in host entry + + function Aliases_Length (E : Host_Entry_Type) return Natural; + -- Return number of aliases in host entry + + function Addresses_Length (E : Host_Entry_Type) return Natural; + -- Return number of addresses in host entry + + function Aliases + (E : Host_Entry_Type; + N : Positive := 1) + return String; + -- Return N'th aliases in host entry. The first index is 1. + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) + return Inet_Addr_Type; + -- Return N'th addresses in host entry. The first index is 1. + + Host_Error : exception; + -- Exception raised by the two following procedures. Once raised, + -- its message contains a string describing the error code. This + -- exception is raised when an host entry can not be retrieved. + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) + return Host_Entry_Type; + -- Return host entry structure for the given inet address + + function Get_Host_By_Name + (Name : String) + return Host_Entry_Type; + -- Return host entry structure for the given host name + + function Host_Name return String; + -- Return the name of the current host + + -- Errors are described by an enumeration type. There is only one + -- exception Socket_Error in this package to deal with an error + -- during a socket routine. Once raised, its message contains the + -- error code between brackets and a string describing the error + -- code. + + type Error_Type is + (Permission_Denied, + Address_Already_In_Use, + Cannot_Assign_Requested_Address, + Address_Family_Not_Supported_By_Protocol, + Operation_Already_In_Progress, + Bad_File_Descriptor, + Connection_Refused, + Bad_Address, + Operation_Now_In_Progress, + Interrupted_System_Call, + Invalid_Argument, + Input_Output_Error, + Transport_Endpoint_Already_Connected, + Message_Too_Long, + Network_Is_Unreachable, + No_Buffer_Space_Available, + Protocol_Not_Available, + Transport_Endpoint_Not_Connected, + Operation_Not_Supported, + Protocol_Not_Supported, + Socket_Type_Not_Supported, + Connection_Timed_Out, + Resource_Temporarily_Unavailable, + Unknown_Host, + Host_Name_Lookup_Failure, + No_Address_Associated_With_Name, + Unknown_Server_Error, + Cannot_Resolve_Error); + + -- Get_Socket_Options and Set_Socket_Options manipulate options + -- associated with a socket. Options may exist at multiple + -- protocol levels in the communication stack. Socket_Level is the + -- uppermost socket level. + + type Level_Type is ( + Socket_Level, + IP_Protocol_For_IP_Level, + IP_Protocol_For_UDP_Level, + IP_Protocol_For_TCP_Level); + + -- There are several options available to manipulate sockets. Each + -- option has a name and several values available. Most of the + -- time, the value is a boolean to enable or disable this option. + + type Option_Name is ( + Keep_Alive, -- Enable sending of keep-alive messages + Reuse_Address, -- Allow bind to reuse local address + Broadcast, -- Enable datagram sockets to recv/send broadcast packets + Send_Buffer, -- Set/get the maximum socket send buffer in bytes + Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes + Linger, -- Shutdown wait for msg to be sent or timeout occur + Error, -- Get and clear the pending socket error + No_Delay, -- Do not delay send to coalesce packets (TCP_NODELAY) + Add_Membership, -- Join a multicast group + Drop_Membership, -- Leave a multicast group + Multicast_TTL, -- Indicates the time-to-live of sent multicast packets + Multicast_Loop); -- Sent multicast packets are looped to the local socket + + type Option_Type (Name : Option_Name := Keep_Alive) is record + case Name is + when Keep_Alive | + Reuse_Address | + Broadcast | + Linger | + No_Delay | + Multicast_Loop => + Enabled : Boolean; + + case Name is + when Linger => + Seconds : Natural; + when others => + null; + end case; + + when Send_Buffer | + Receive_Buffer => + Size : Natural; + + when Error => + Error : Error_Type; + + when Add_Membership | + Drop_Membership => + Multiaddr : Inet_Addr_Type; + Interface : Inet_Addr_Type; + + when Multicast_TTL => + Time_To_Live : Natural; + + end case; + end record; + + -- There are several controls available to manipulate + -- sockets. Each option has a name and several values available. + -- These controls differ from the socket options in that they are + -- not specific to sockets but are available for any device. + + type Request_Name is ( + Non_Blocking_IO, -- Cause a caller not to wait on blocking operations. + N_Bytes_To_Read); -- Return the number of bytes available to read + + type Request_Type (Name : Request_Name := Non_Blocking_IO) is record + case Name is + when Non_Blocking_IO => + Enabled : Boolean; + + when N_Bytes_To_Read => + Size : Natural; + + end case; + end record; + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream); + -- Create an endpoint for communication. Raise Socket_Error on error. + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type); + -- Extract the first connection request on the queue of pending + -- connections, creates a new connected socket with mostly the + -- same properties as Server, and allocates a new socket. The + -- returned Address is filled in with the address of the + -- connection. Raise Socket_Error on error. + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type); + -- Once a socket is created, assign a local address to it. Raise + -- Socket_Error on error. + + procedure Close_Socket (Socket : Socket_Type); + -- Close a socket and more specifically a non-connected socket. + -- Fail silently. + + procedure Connect_Socket + (Socket : Socket_Type; + Server : in out Sock_Addr_Type); + -- Make a connection to another socket which has the address of + -- Server. Raise Socket_Error on error. + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type); + -- Obtain or set parameter values that control the socket. This + -- control differs from the socket options in that they are not + -- specific to sockets but are avaiable for any device. + + function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type; + -- Return the peer or remote socket address of a socket. Raise + -- Socket_Error on error. + + function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type; + -- Return the local or current socket address of a socket. Raise + -- Socket_Error on error. + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name) + return Option_Type; + -- Get the options associated with a socket. Raise Socket_Error on + -- error. + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Positive := 15); + -- To accept connections, a socket is first created with + -- Create_Socket, a willingness to accept incoming connections and + -- a queue Length for incoming connections are specified. Raise + -- Socket_Error on error. + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Receive message from Socket. Last is the index value such that + -- Item (Last) is the last character assigned. Note that Last is + -- set to Item'First - 1 when the socket has been closed by + -- peer. This is not an error and no exception is raised. Raise + -- Socket_Error on error. + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + From : out Sock_Addr_Type); + -- Receive message from Socket. If Socket is not + -- connection-oriented, the source address From of the message is + -- filled in. Last is the index value such that Item (Last) is the + -- last character assigned. Raise Socket_Error on error. + + function Resolve_Exception + (Occurrence : Ada.Exceptions.Exception_Occurrence) + return Error_Type; + -- When Socket_Error or Host_Error are raised, the exception + -- message contains the error code between brackets and a string + -- describing the error code. Resolve_Error extracts the error + -- code from an exception message and translate it into an + -- enumeration value. + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Transmit a message to another socket. Note that Last is set to + -- Item'First when socket has been closed by peer. This is not an + -- error and no exception is raised. Raise Socket_Error on error; + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : Sock_Addr_Type); + -- Transmit a message to another socket. The address is given by + -- To. Raise Socket_Error on error; + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type); + -- Manipulate socket options. Raise Socket_Error on error. + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write); + -- Shutdown a connected socket. If How is Shut_Read, further + -- receives will be disallowed. If How is Shut_Write, further + -- sends will be disallowed. If how is Shut_Read_Write, further + -- sends and receives will be disallowed. Fail silently. + + type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class; + -- Same interface as Ada.Streams.Stream_IO + + function Stream + (Socket : Socket_Type) + return Stream_Access; + -- Associate a stream with a stream-based socket that is already + -- connected. + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) + return Stream_Access; + -- Associate a stream with a datagram-based socket that is already + -- bound. Send_To is the socket address to which messages are + -- being sent. + + function Get_Address + (Stream : Stream_Access) + return Sock_Addr_Type; + -- Return the socket address from which the last message was + -- received. + + type Socket_Set_Type is private; + -- This type allows to manipulate sets of sockets. It allows to + -- wait for events on multiple endpoints at one time. This is an + -- access type on a system dependent structure. To avoid memory + -- leaks it is highly recommended to clean the access value with + -- procedure Empty. + + procedure Clear (Item : in out Socket_Set_Type; Socket : Socket_Type); + -- Remove Socket from Item + + procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type); + -- Insert Socket into Item + + procedure Empty (Item : in out Socket_Set_Type); + -- Remove all Sockets from Item and deallocate internal data + + function Is_Empty + (Item : Socket_Set_Type) + return Boolean; + -- Return True if Item is empty + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) + return Boolean; + -- Return True if Socket is present in Item + + -- C select() waits for a number of file descriptors to change + -- status. Usually, three independant sets of descriptors are + -- watched (read, write and exception). A timeout gives an upper + -- bound on the amount of time elapsed before select returns. + -- This function blocks until an event occurs. On some platforms, + -- C select can block the full process. + -- + -- Check_Selector provides the very same behaviour. The only + -- difference is that it does not watch for exception events. Note + -- that on some platforms it is kept process blocking in purpose. + -- The timeout parameter allows the user to have the behaviour he + -- wants. Abort_Selector allows to abort safely a Check_Selector + -- that is blocked forever. A special file descriptor is opened by + -- Create_Selector and included in each call to + -- Check_Selector. Abort_Selector causes an event to occur on this + -- descriptor in order to unblock Check_Selector. The user must + -- call Close_Selector to discard this special file. A reason to + -- abort a select operation is typically to add a socket in one of + -- the socket sets when the timeout is set to forever. + + Forever : constant Duration; + + type Selector_Type is limited private; + type Selector_Access is access all Selector_Type; + + procedure Create_Selector (Selector : out Selector_Type); + -- Create a new selector + + procedure Close_Selector (Selector : in out Selector_Type); + -- Close Selector and all internal descriptors associated + + type Selector_Status is (Completed, Expired, Aborted); + + procedure Check_Selector + (Selector : in out Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Duration := Forever); + -- Return when one Socket in R_Socket_Set has some data to be read + -- or if one Socket in W_Socket_Set is ready to receive some + -- data. In these cases Status is set to Completed and sockets + -- that are ready are set in R_Socket_Set or W_Socket_Set. Status + -- is set to Expired if no socket was ready after a Timeout + -- expiration. Status is set to Aborted if an abort signal as been + -- received while checking socket status. As this procedure + -- returns when Timeout occurs, it is a design choice to keep this + -- procedure process blocking. Note that a Timeout of 0.0 returns + -- immediatly. + + procedure Abort_Selector (Selector : Selector_Type); + -- Send an abort signal to the selector. + +private + + type Socket_Type is new Integer; + No_Socket : constant Socket_Type := -1; + + Forever : constant Duration := Duration'Last; + + type Selector_Type is limited record + R_Sig_Socket : Socket_Type; + W_Sig_Socket : Socket_Type; + In_Progress : Boolean := False; + end record; + -- The two signalling sockets are used to abort a select + -- operation. + + type Socket_Set_Record; + type Socket_Set_Type is access all Socket_Set_Record; + + subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; + -- Octet for Internet address + + type Inet_Addr_VN_Type is array (Natural range <>) of Inet_Addr_Comp_Type; + + subtype Inet_Addr_V4_Type is Inet_Addr_VN_Type (1 .. 4); + subtype Inet_Addr_V6_Type is Inet_Addr_VN_Type (1 .. 16); + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record + case Family is + when Family_Inet => + Sin_V4 : Inet_Addr_V4_Type := (others => 0); + + when Family_Inet6 => + Sin_V6 : Inet_Addr_V6_Type := (others => 0); + end case; + end record; + + Any_Port : constant Port_Type := 0; + No_Port : constant Port_Type := 0; + + Any_Inet_Addr : constant Inet_Addr_Type := (Family_Inet, (others => 0)); + No_Inet_Addr : constant Inet_Addr_Type := (Family_Inet, (others => 0)); + + No_Sock_Addr : constant Sock_Addr_Type := (Family_Inet, No_Inet_Addr, 0); + + Max_Host_Name_Length : constant := 64; + -- The constant MAXHOSTNAMELEN is usually set to 64 + + subtype Host_Name_Index is Natural range 1 .. Max_Host_Name_Length; + + type Host_Name_Type + (Length : Host_Name_Index := Max_Host_Name_Length) + is record + Name : String (1 .. Length); + end record; + -- We need fixed strings to avoid access types in host entry type + + type Host_Name_Array is array (Natural range <>) of Host_Name_Type; + type Inet_Addr_Array is array (Natural range <>) of Inet_Addr_Type; + + type Host_Entry_Type (Aliases_Length, Addresses_Length : Natural) is record + Official : Host_Name_Type; + Aliases : Host_Name_Array (1 .. Aliases_Length); + Addresses : Inet_Addr_Array (1 .. Addresses_Length); + end record; + +end GNAT.Sockets; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb new file mode 100644 index 00000000000..7fdf17e3660 --- /dev/null +++ b/gcc/ada/g-socthi.adb @@ -0,0 +1,495 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin is + + -- When this package is initialized with Process_Blocking_IO set + -- to True, sockets are set in non-blocking mode to avoid blocking + -- the whole process when a thread wants to perform a blocking IO + -- operation. But the user can set a socket in non-blocking mode + -- by purpose. We track the socket in such a mode by redefining + -- C_Ioctl. In blocking IO operations, we exit normally when the + -- non-blocking flag is set by user, we poll and try later when + -- this flag is set automatically by this package. + + type Socket_Info is record + Non_Blocking : Boolean := False; + end record; + + Table : array (C.int range 0 .. 31) of Socket_Info; + -- Get info on blocking flag. This array is limited to 32 sockets + -- because the select operation allows socket set of less then 32 + -- sockets. + + Quantum : constant Duration := 0.2; + -- comment needed ??? + + Thread_Blocking_IO : Boolean := True; + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) + return C.int; + pragma Import (C, Syscall_Accept, "accept"); + + function Syscall_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + pragma Import (C, Syscall_Connect, "connect"); + + function Syscall_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) + return C.int; + pragma Import (C, Syscall_Ioctl, "ioctl"); + + function Syscall_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + pragma Import (C, Syscall_Recv, "recv"); + + function Syscall_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) + return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + pragma Import (C, Syscall_Send, "send"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int; + pragma Import (C, Syscall_Sendto, "sendto"); + + function Syscall_Socket + (Domain, Typ, Protocol : C.int) + return C.int; + pragma Import (C, Syscall_Socket, "socket"); + + procedure Set_Non_Blocking (S : C.int); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Accept (S, Addr, Addrlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + if not Thread_Blocking_IO + and then Res /= Failure + then + -- A socket inherits the properties ot its server especially + -- the FNDELAY flag. + + Table (Res).Non_Blocking := Table (S).Non_Blocking; + Set_Non_Blocking (Res); + end if; + + return Res; + end C_Accept; + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int + is + Res : C.int; + + begin + Res := Syscall_Connect (S, Name, Namelen); + + if Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EINPROGRESS + then + return Res; + end if; + + declare + Set : aliased Fd_Set; + Now : aliased Timeval; + + begin + loop + Set := 2 ** Natural (S); + Now := Immediat; + Res := C_Select + (S + 1, + null, Set'Unchecked_Access, + null, Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + return Res; + end if; + + delay Quantum; + end loop; + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = Constants.EISCONN + then + return Thin.Success; + else + return Res; + end if; + end C_Connect; + + ------------- + -- C_Ioctl -- + ------------- + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) + return C.int + is + begin + if not Thread_Blocking_IO + and then Req = Constants.FIONBIO + then + Table (S).Non_Blocking := (Arg.all /= 0); + end if; + + return Syscall_Ioctl (S, Req, Arg); + end C_Ioctl; + + ------------ + -- C_Recv -- + ------------ + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recv (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recv; + + ---------------- + -- C_Recvfrom -- + ---------------- + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + ------------ + -- C_Send -- + ------------ + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Send (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Send; + + -------------- + -- C_Sendto -- + -------------- + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Sendto; + + -------------- + -- C_Socket -- + -------------- + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) + return C.int + is + Res : C.int; + + begin + Res := Syscall_Socket (Domain, Typ, Protocol); + + if not Thread_Blocking_IO + and then Res /= Failure + then + Set_Non_Blocking (Res); + end if; + + return Res; + end C_Socket; + + ----------- + -- Clear -- + ----------- + + procedure Clear + (Item : in out Fd_Set; + Socket : in C.int) + is + Mask : constant Fd_Set := 2 ** Natural (Socket); + + begin + if (Item and Mask) /= 0 then + Item := Item xor Mask; + end if; + end Clear; + + ----------- + -- Empty -- + ----------- + + procedure Empty (Item : in out Fd_Set) is + begin + Item := 0; + end Empty; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + begin + Thread_Blocking_IO := not Process_Blocking_IO; + end Initialize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Item : Fd_Set) return Boolean is + begin + return Item = 0; + end Is_Empty; + + ------------ + -- Is_Set -- + ------------ + + function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is + begin + return (Item and 2 ** Natural (Socket)) /= 0; + end Is_Set; + + --------- + -- Max -- + --------- + + function Max (Item : Fd_Set) return C.int + is + L : C.int := -1; + C : Fd_Set := Item; + + begin + while C /= 0 loop + L := L + 1; + C := C / 2; + end loop; + return L; + end Max; + + --------- + -- Set -- + --------- + + procedure Set (Item : in out Fd_Set; Socket : in C.int) is + begin + Item := Item or 2 ** Natural (Socket); + end Set; + + ---------------------- + -- Set_Non_Blocking -- + ---------------------- + + procedure Set_Non_Blocking (S : C.int) is + Res : C.int; + Val : aliased C.int := 1; + + begin + + -- Do not use C_Fcntl because this subprogram tracks the + -- sockets set by user in non-blocking mode. + + Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access); + end Set_Non_Blocking; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message (Errno : Integer) return String is + use type Interfaces.C.Strings.chars_ptr; + + C_Msg : C.Strings.chars_ptr; + + begin + C_Msg := C_Strerror (C.int (Errno)); + + if C_Msg = C.Strings.Null_Ptr then + return "Unknown system error"; + + else + return C.Strings.Value (C_Msg); + end if; + end Socket_Error_Message; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads new file mode 100644 index 00000000000..2e46390a5bd --- /dev/null +++ b/gcc/ada/g-socthi.ads @@ -0,0 +1,343 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C.Pointers; + +with Interfaces.C.Strings; +with GNAT.Sockets.Constants; +with GNAT.OS_Lib; + +with System; + +package GNAT.Sockets.Thin is + + -- ??? more comments needed ??? + + -- This package is intended for hosts implementing BSD sockets with a + -- standard interface. It will be used as a default for all the platforms + -- that do not have a specific version of this file. + + package C renames Interfaces.C; + + use type C.int; + -- This is so we can declare the Failure constant below + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; + -- Returns last socket error number. + + function Socket_Error_Message (Errno : Integer) return String; + -- Returns the error message string for the error number Errno. If + -- Errno is not known it returns "Unknown system error". + + type Fd_Set is mod 2 ** 32; + pragma Convention (C, Fd_Set); + + Null_Fd_Set : constant Fd_Set := 0; + + type Fd_Set_Access is access all Fd_Set; + pragma Convention (C, Fd_Set_Access); + + type Timeval_Unit is new C.int; + pragma Convention (C, Timeval_Unit); + + type Timeval is record + Tv_Sec : Timeval_Unit; + Tv_Usec : Timeval_Unit; + end record; + pragma Convention (C, Timeval); + + type Timeval_Access is access all Timeval; + pragma Convention (C, Timeval_Access); + + Immediat : constant Timeval := (0, 0); + + type Int_Access is access all C.int; + pragma Convention (C, Int_Access); + -- Access to C integers + + type Chars_Ptr_Array is array (C.size_t range <>) of + aliased C.Strings.chars_ptr; + + package Chars_Ptr_Pointers is + new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, + C.Strings.Null_Ptr); + -- Arrays of C (char *) + + type In_Addr is record + S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; + end record; + pragma Convention (C, In_Addr); + -- Internet address + + type In_Addr_Access is access all In_Addr; + pragma Convention (C, In_Addr_Access); + -- Access to internet address + + Inaddr_Any : aliased constant In_Addr := (others => 0); + -- Any internet address (all the interfaces) + + type In_Addr_Access_Array is array (C.size_t range <>) + of aliased In_Addr_Access; + pragma Convention (C, In_Addr_Access_Array); + + package In_Addr_Access_Pointers is + new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); + -- Array of internet addresses + + type Sockaddr is record + Sa_Family : C.unsigned_short; + Sa_Data : C.char_array (1 .. 14); + end record; + pragma Convention (C, Sockaddr); + -- Socket address + + type Sockaddr_Access is access all Sockaddr; + pragma Convention (C, Sockaddr_Access); + -- Access to socket address + + type Sockaddr_In is record + Sin_Family : C.unsigned_short := Constants.AF_INET; + Sin_Port : C.unsigned_short := 0; + Sin_Addr : In_Addr := Inaddr_Any; + Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); + end record; + pragma Convention (C, Sockaddr_In); + -- Internet socket address + + type Sockaddr_In_Access is access all Sockaddr_In; + pragma Convention (C, Sockaddr_In_Access); + -- Access to internet socket address + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : C.int; + H_Length : C.int; + H_Addr_List : In_Addr_Access_Pointers.Pointer; + end record; + pragma Convention (C, Hostent); + -- Host entry + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + type Two_Int is array (0 .. 1) of C.int; + pragma Convention (C, Two_Int); + -- Used with pipe() + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) + return C.int; + + function C_Bind + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Close + (Fd : C.int) + return C.int; + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Gethostbyaddr + (Addr : System.Address; + Len : C.int; + Typ : C.int) + return Hostent_Access; + + function C_Gethostbyname + (Name : C.char_array) + return Hostent_Access; + + function C_Gethostname + (Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : access C.int) + return C.int; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : access C.int) + return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : access C.int) + return C.int; + + function C_Inet_Addr + (Cp : C.Strings.chars_ptr) + return C.int; + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) + return C.int; + + function C_Listen (S, Backlog : C.int) return C.int; + + function C_Read + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) + return C.int; + + function C_Select + (Nfds : C.int; + Readfds : Fd_Set_Access; + Writefds : Fd_Set_Access; + Exceptfds : Fd_Set_Access; + Timeout : Timeval_Access) + return C.int; + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int; + + function C_Setsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : C.int) + return C.int; + + function C_Shutdown + (S : C.int; + How : C.int) + return C.int; + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) + return C.int; + + function C_Strerror + (Errnum : C.int) + return C.Strings.chars_ptr; + + function C_System + (Command : System.Address) + return C.int; + + function C_Write + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + -- Return highest numbered socket (what does this refer to???) + + procedure Clear (Item : in out Fd_Set; Socket : in C.int); + procedure Empty (Item : in out Fd_Set); + function Is_Empty (Item : Fd_Set) return Boolean; + function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean; + function Max (Item : Fd_Set) return C.int; + procedure Set (Item : in out Fd_Set; Socket : in C.int); + + procedure Finalize; + procedure Initialize (Process_Blocking_IO : Boolean); + +private + + pragma Import (C, C_Bind, "bind"); + pragma Import (C, C_Close, "close"); + pragma Import (C, C_Gethostbyaddr, "gethostbyaddr"); + pragma Import (C, C_Gethostbyname, "gethostbyname"); + pragma Import (C, C_Gethostname, "gethostname"); + pragma Import (C, C_Getpeername, "getpeername"); + pragma Import (C, C_Getsockname, "getsockname"); + pragma Import (C, C_Getsockopt, "getsockopt"); + pragma Import (C, C_Inet_Addr, "inet_addr"); + pragma Import (C, C_Listen, "listen"); + pragma Import (C, C_Read, "read"); + pragma Import (C, C_Select, "select"); + pragma Import (C, C_Setsockopt, "setsockopt"); + pragma Import (C, C_Shutdown, "shutdown"); + pragma Import (C, C_Strerror, "strerror"); + pragma Import (C, C_System, "system"); + pragma Import (C, C_Write, "write"); + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-soliop.ads b/gcc/ada/g-soliop.ads new file mode 100644 index 00000000000..26f621c41ea --- /dev/null +++ b/gcc/ada/g-soliop.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package GNAT.Sockets.Linker_Options is + + -- Empty version of this package. + +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/g-souinf.ads b/gcc/ada/g-souinf.ads new file mode 100644 index 00000000000..6d647118bc5 --- /dev/null +++ b/gcc/ada/g-souinf.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . S O U R C E _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides some useful utility subprograms that provide access +-- to source code information known at compile time. These subprograms are +-- intrinsic operations that provide information known to the compiler in +-- a form that can be embedded into the source program for identification +-- and logging purposes. For example, an exception handler can print out +-- the name of the source file in which the exception is handled. + +package GNAT.Source_Info is +pragma Pure (Source_Info); + + function File return String; + -- Return the name of the current file, not including the path information. + -- The result is considered to be a static string constant. + + function Line return Positive; + -- Return the current input line number. The result is considered + -- to be a static expression. + + function Source_Location return String; + -- Return a string literal of the form "name:line", where name is the + -- current source file name without path information, and line is the + -- current line number. In the event that instantiations are involved, + -- additional suffixes of the same form are appended after the separating + -- string " instantiated at ". The result is considered to be a static + -- string constant. + + function Enclosing_Entity return String; + -- Return the name of the current subprogram, package, task, entry or + -- protected subprogram. The string is in exactly the form used for the + -- declaration of the entity (casing and encoding conventions), and is + -- considered to be a static string constant. + -- + -- Note: if this function is used at the outer level of a generic + -- package, the string returned will be the name of the instance, + -- not the generic package itself. This is useful in identifying + -- and logging information from within generic templates. + +private + pragma Import (Intrinsic, File); + pragma Import (Intrinsic, Line); + pragma Import (Intrinsic, Source_Location); + pragma Import (Intrinsic, Enclosing_Entity); +end GNAT.Source_Info; diff --git a/gcc/ada/g-speche.adb b/gcc/ada/g-speche.adb new file mode 100644 index 00000000000..07d5e62f2e4 --- /dev/null +++ b/gcc/ada/g-speche.adb @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . S P E L L I N G _ C H E C K E R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Spelling_Checker is + + ------------------------ + -- Is_Bad_Spelling_Of -- + ------------------------ + + function Is_Bad_Spelling_Of + (Found : String; + Expect : String) + return Boolean + is + FN : constant Natural := Found'Length; + FF : constant Natural := Found'First; + FL : constant Natural := Found'Last; + + EN : constant Natural := Expect'Length; + EF : constant Natural := Expect'First; + EL : constant Natural := Expect'Last; + + begin + -- If both strings null, then we consider this a match, but if one + -- is null and the other is not, then we definitely do not match + + if FN = 0 then + return (EN = 0); + + elsif EN = 0 then + return False; + + -- If first character does not match, then definitely not misspelling + + elsif Found (FF) /= Expect (EF) then + return False; + + -- Not a bad spelling if both strings are 1-2 characters long + + elsif FN < 3 and then EN < 3 then + return False; + + -- Lengths match. Execute loop to check for a single error, single + -- transposition or exact match (we only fall through this loop if + -- one of these three conditions is found). + + elsif FN = EN then + for J in 1 .. FN - 2 loop + if Expect (EF + J) /= Found (FF + J) then + + -- If both mismatched characters are digits, then we do + -- not consider it a misspelling (e.g. B345 is not a + -- misspelling of B346, it is something quite different) + + if Expect (EF + J) in '0' .. '9' + and then Found (FF + J) in '0' .. '9' + then + return False; + + elsif Expect (EF + J + 1) = Found (FF + J + 1) + and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL) + then + return True; + + elsif Expect (EF + J) = Found (FF + J + 1) + and then Expect (EF + J + 1) = Found (FF + J) + and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL) + then + return True; + + else + return False; + end if; + end if; + end loop; + + -- At last character. Test digit case as above, otherwise we + -- have a match since at most this last character fails to match. + + if Expect (EL) in '0' .. '9' + and then Found (FL) in '0' .. '9' + and then Expect (EL) /= Found (FL) + then + return False; + else + return True; + end if; + + -- Length is 1 too short. Execute loop to check for single deletion + + elsif FN = EN - 1 then + for J in 1 .. FN - 1 loop + if Found (FF + J) /= Expect (EF + J) then + return Found (FF + J .. FL) = Expect (EF + J + 1 .. EL); + end if; + end loop; + + -- If we fall through then the last character was missing, which + -- we consider to be a match (e.g. found xyz, expected xyza). + + return True; + + -- Length is 1 too long. Execute loop to check for single insertion + + elsif FN = EN + 1 then + for J in 1 .. FN - 1 loop + if Found (FF + J) /= Expect (EF + J) then + return Found (FF + J + 1 .. FL) = Expect (EF + J .. EL); + end if; + end loop; + + -- If we fall through then the last character was an additional + -- character, which is a match (e.g. found xyza, expected xyz). + + return True; + + -- Length is completely wrong + + else + return False; + end if; + + end Is_Bad_Spelling_Of; + +end GNAT.Spelling_Checker; diff --git a/gcc/ada/g-speche.ads b/gcc/ada/g-speche.ads new file mode 100644 index 00000000000..80604599194 --- /dev/null +++ b/gcc/ada/g-speche.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . S P E L L I N G _ C H E C K E R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Spelling checker + +-- This package provides a utility routine for checking for bad spellings + +package GNAT.Spelling_Checker is +pragma Pure (Spelling_Checker); + + function Is_Bad_Spelling_Of + (Found : String; + Expect : String) + return Boolean; + -- Determines if the string Found is a plausible misspelling of the + -- string Expect. Returns True for an exact match or a probably + -- misspelling, False if no near match is detected. This routine + -- is case sensitive, so the caller should fold both strings to + -- get a case insensitive match. + -- + -- Note: the spec of this routine is deliberately rather vague. This + -- routine is the one used by GNAT itself to detect misspelled keywords + -- and identifiers, and is heuristically adjusted to be appropriate to + -- this usage. It will work well in any similar case of named entities + -- with relatively short mnemonic names. + +end GNAT.Spelling_Checker; diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb new file mode 100644 index 00000000000..fbacdb600c9 --- /dev/null +++ b/gcc/ada/g-spipat.adb @@ -0,0 +1,6328 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . P A T T E R N S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1998-2001, Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the data structures and general approach used in this implementation +-- are derived from the original MINIMAL sources for SPITBOL. The code is not +-- a direct translation, but the approach is followed closely. In particular, +-- we use the one stack approach developed in the SPITBOL implementation. + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; + +with System; use System; + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body GNAT.Spitbol.Patterns is + + ------------------------ + -- Internal Debugging -- + ------------------------ + + Internal_Debug : constant Boolean := False; + -- Set this flag to True to activate some built-in debugging traceback + -- These are all lines output with PutD and Put_LineD. + + procedure New_LineD; + pragma Inline (New_LineD); + -- Output new blank line with New_Line if Internal_Debug is True + + procedure PutD (Str : String); + pragma Inline (PutD); + -- Output string with Put if Internal_Debug is True + + procedure Put_LineD (Str : String); + pragma Inline (Put_LineD); + -- Output string with Put_Line if Internal_Debug is True + + ----------------------------- + -- Local Type Declarations -- + ----------------------------- + + subtype String_Ptr is Ada.Strings.Unbounded.String_Access; + subtype File_Ptr is Ada.Text_IO.File_Access; + + function To_PE_Ptr is new Unchecked_Conversion (Address, PE_Ptr); + function To_Address is new Unchecked_Conversion (PE_Ptr, Address); + -- Used only for debugging output purposes + + subtype AFC is Ada.Finalization.Controlled; + + N : constant PE_Ptr := null; + -- Shorthand used to initialize Copy fields to null + + type Character_Ptr is access all Character; + type Natural_Ptr is access all Natural; + type Pattern_Ptr is access all Pattern; + + -------------------------------------------------- + -- Description of Algorithm and Data Structures -- + -------------------------------------------------- + + -- A pattern structure is represented as a linked graph of nodes + -- with the following structure: + + -- +------------------------------------+ + -- I Pcode I + -- +------------------------------------+ + -- I Index I + -- +------------------------------------+ + -- I Pthen I + -- +------------------------------------+ + -- I parameter(s) I + -- +------------------------------------+ + + -- Pcode is a code value indicating the type of the patterm node. This + -- code is used both as the discriminant value for the record, and as + -- the case index in the main match routine that branches to the proper + -- match code for the given element. + + -- Index is a serial index number. The use of these serial index + -- numbers is described in a separate section. + + -- Pthen is a pointer to the successor node, i.e the node to be matched + -- if the attempt to match the node succeeds. If this is the last node + -- of the pattern to be matched, then Pthen points to a dummy node + -- of kind PC_EOP (end of pattern), which initiales pattern exit. + + -- The parameter or parameters are present for certain node types, + -- and the type varies with the pattern code. + + type Pattern_Code is ( + PC_Arb_Y, + PC_Assign, + PC_Bal, + PC_BreakX_X, + PC_Cancel, + PC_EOP, + PC_Fail, + PC_Fence, + PC_Fence_X, + PC_Fence_Y, + PC_R_Enter, + PC_R_Remove, + PC_R_Restore, + PC_Rest, + PC_Succeed, + PC_Unanchored, + + PC_Alt, + PC_Arb_X, + PC_Arbno_S, + PC_Arbno_X, + + PC_Rpat, + + PC_Pred_Func, + + PC_Assign_Imm, + PC_Assign_OnM, + PC_Any_VP, + PC_Break_VP, + PC_BreakX_VP, + PC_NotAny_VP, + PC_NSpan_VP, + PC_Span_VP, + PC_String_VP, + + PC_Write_Imm, + PC_Write_OnM, + + PC_Null, + PC_String, + + PC_String_2, + PC_String_3, + PC_String_4, + PC_String_5, + PC_String_6, + + PC_Setcur, + + PC_Any_CH, + PC_Break_CH, + PC_BreakX_CH, + PC_Char, + PC_NotAny_CH, + PC_NSpan_CH, + PC_Span_CH, + + PC_Any_CS, + PC_Break_CS, + PC_BreakX_CS, + PC_NotAny_CS, + PC_NSpan_CS, + PC_Span_CS, + + PC_Arbno_Y, + PC_Len_Nat, + PC_Pos_Nat, + PC_RPos_Nat, + PC_RTab_Nat, + PC_Tab_Nat, + + PC_Pos_NF, + PC_Len_NF, + PC_RPos_NF, + PC_RTab_NF, + PC_Tab_NF, + + PC_Pos_NP, + PC_Len_NP, + PC_RPos_NP, + PC_RTab_NP, + PC_Tab_NP, + + PC_Any_VF, + PC_Break_VF, + PC_BreakX_VF, + PC_NotAny_VF, + PC_NSpan_VF, + PC_Span_VF, + PC_String_VF); + + type IndexT is range 0 .. +(2 **15 - 1); + + type PE (Pcode : Pattern_Code) is record + + Index : IndexT; + -- Serial index number of pattern element within pattern. + + Pthen : PE_Ptr; + -- Successor element, to be matched after this one + + case Pcode is + + when PC_Arb_Y | + PC_Assign | + PC_Bal | + PC_BreakX_X | + PC_Cancel | + PC_EOP | + PC_Fail | + PC_Fence | + PC_Fence_X | + PC_Fence_Y | + PC_Null | + PC_R_Enter | + PC_R_Remove | + PC_R_Restore | + PC_Rest | + PC_Succeed | + PC_Unanchored => null; + + when PC_Alt | + PC_Arb_X | + PC_Arbno_S | + PC_Arbno_X => Alt : PE_Ptr; + + when PC_Rpat => PP : Pattern_Ptr; + + when PC_Pred_Func => BF : Boolean_Func; + + when PC_Assign_Imm | + PC_Assign_OnM | + PC_Any_VP | + PC_Break_VP | + PC_BreakX_VP | + PC_NotAny_VP | + PC_NSpan_VP | + PC_Span_VP | + PC_String_VP => VP : VString_Ptr; + + when PC_Write_Imm | + PC_Write_OnM => FP : File_Ptr; + + when PC_String => Str : String_Ptr; + + when PC_String_2 => Str2 : String (1 .. 2); + + when PC_String_3 => Str3 : String (1 .. 3); + + when PC_String_4 => Str4 : String (1 .. 4); + + when PC_String_5 => Str5 : String (1 .. 5); + + when PC_String_6 => Str6 : String (1 .. 6); + + when PC_Setcur => Var : Natural_Ptr; + + when PC_Any_CH | + PC_Break_CH | + PC_BreakX_CH | + PC_Char | + PC_NotAny_CH | + PC_NSpan_CH | + PC_Span_CH => Char : Character; + + when PC_Any_CS | + PC_Break_CS | + PC_BreakX_CS | + PC_NotAny_CS | + PC_NSpan_CS | + PC_Span_CS => CS : Character_Set; + + when PC_Arbno_Y | + PC_Len_Nat | + PC_Pos_Nat | + PC_RPos_Nat | + PC_RTab_Nat | + PC_Tab_Nat => Nat : Natural; + + when PC_Pos_NF | + PC_Len_NF | + PC_RPos_NF | + PC_RTab_NF | + PC_Tab_NF => NF : Natural_Func; + + when PC_Pos_NP | + PC_Len_NP | + PC_RPos_NP | + PC_RTab_NP | + PC_Tab_NP => NP : Natural_Ptr; + + when PC_Any_VF | + PC_Break_VF | + PC_BreakX_VF | + PC_NotAny_VF | + PC_NSpan_VF | + PC_Span_VF | + PC_String_VF => VF : VString_Func; + + end case; + end record; + + subtype PC_Has_Alt is Pattern_Code range PC_Alt .. PC_Arbno_X; + -- Range of pattern codes that has an Alt field. This is used in the + -- recursive traversals, since these links must be followed. + + EOP_Element : aliased constant PE := (PC_EOP, 0, N); + -- This is the end of pattern element, and is thus the representation of + -- a null pattern. It has a zero index element since it is never placed + -- inside a pattern. Furthermore it does not need a successor, since it + -- marks the end of the pattern, so that no more successors are needed. + + EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access; + -- This is the end of pattern pointer, that is used in the Pthen pointer + -- of other nodes to signal end of pattern. + + -- The following array is used to determine if a pattern used as an + -- argument for Arbno is eligible for treatment using the simple Arbno + -- structure (i.e. it is a pattern that is guaranteed to match at least + -- one character on success, and not to make any entries on the stack. + + OK_For_Simple_Arbno : + array (Pattern_Code) of Boolean := ( + PC_Any_CS | + PC_Any_CH | + PC_Any_VF | + PC_Any_VP | + PC_Char | + PC_Len_Nat | + PC_NotAny_CS | + PC_NotAny_CH | + PC_NotAny_VF | + PC_NotAny_VP | + PC_Span_CS | + PC_Span_CH | + PC_Span_VF | + PC_Span_VP | + PC_String | + PC_String_2 | + PC_String_3 | + PC_String_4 | + PC_String_5 | + PC_String_6 => True, + + others => False); + + ------------------------------- + -- The Pattern History Stack -- + ------------------------------- + + -- The pattern history stack is used for controlling backtracking when + -- a match fails. The idea is to stack entries that give a cursor value + -- to be restored, and a node to be reestablished as the current node to + -- attempt an appropriate rematch operation. The processing for a pattern + -- element that has rematch alternatives pushes an appropriate entry or + -- entry on to the stack, and the proceeds. If a match fails at any point, + -- the top element of the stack is popped off, resetting the cursor and + -- the match continues by accessing the node stored with this entry. + + type Stack_Entry is record + + Cursor : Integer; + -- Saved cursor value that is restored when this entry is popped + -- from the stack if a match attempt fails. Occasionally, this + -- field is used to store a history stack pointer instead of a + -- cursor. Such cases are noted in the documentation and the value + -- stored is negative since stack pointer values are always negative. + + Node : PE_Ptr; + -- This pattern element reference is reestablished as the current + -- Node to be matched (which will attempt an appropriate rematch). + + end record; + + subtype Stack_Range is Integer range -Stack_Size .. -1; + + type Stack_Type is array (Stack_Range) of Stack_Entry; + -- The type used for a history stack. The actual instance of the stack + -- is declared as a local variable in the Match routine, to properly + -- handle recursive calls to Match. All stack pointer values are negative + -- to distinguish them from normal cursor values. + + -- Note: the pattern matching stack is used only to handle backtracking. + -- If no backtracking occurs, its entries are never accessed, and never + -- popped off, and in particular it is normal for a successful match + -- to terminate with entries on the stack that are simply discarded. + + -- Note: in subsequent diagrams of the stack, we always place element + -- zero (the deepest element) at the top of the page, then build the + -- stack down on the page with the most recent (top of stack) element + -- being the bottom-most entry on the page. + + -- Stack checking is handled by labeling every pattern with the maximum + -- number of stack entries that are required, so a single check at the + -- start of matching the pattern suffices. There are two exceptions. + + -- First, the count does not include entries for recursive pattern + -- references. Such recursions must therefore perform a specific + -- stack check with respect to the number of stack entries required + -- by the recursive pattern that is accessed and the amount of stack + -- that remains unused. + + -- Second, the count includes only one iteration of an Arbno pattern, + -- so a specific check must be made on subsequent iterations that there + -- is still enough stack space left. The Arbno node has a field that + -- records the number of stack entries required by its argument for + -- this purpose. + + --------------------------------------------------- + -- Use of Serial Index Field in Pattern Elements -- + --------------------------------------------------- + + -- The serial index numbers for the pattern elements are assigned as + -- a pattern is consructed from its constituent elements. Note that there + -- is never any sharing of pattern elements between patterns (copies are + -- always made), so the serial index numbers are unique to a particular + -- pattern as referenced from the P field of a value of type Pattern. + + -- The index numbers meet three separate invariants, which are used for + -- various purposes as described in this section. + + -- First, the numbers uniquely identify the pattern elements within a + -- pattern. If Num is the number of elements in a given pattern, then + -- the serial index numbers for the elements of this pattern will range + -- from 1 .. Num, so that each element has a separate value. + + -- The purpose of this assignment is to provide a convenient auxiliary + -- data structure mechanism during operations which must traverse a + -- pattern (e.g. copy and finalization processing). Once constructed + -- patterns are strictly read only. This is necessary to allow sharing + -- of patterns between tasks. This means that we cannot go marking the + -- pattern (e.g. with a visited bit). Instead we cosntuct a separate + -- vector that contains the necessary information indexed by the Index + -- values in the pattern elements. For this purpose the only requirement + -- is that they be uniquely assigned. + + -- Second, the pattern element referenced directly, i.e. the leading + -- pattern element, is always the maximum numbered element and therefore + -- indicates the total number of elements in the pattern. More precisely, + -- the element referenced by the P field of a pattern value, or the + -- element returned by any of the internal pattern construction routines + -- in the body (that return a value of type PE_Ptr) always is this + -- maximum element, + + -- The purpose of this requirement is to allow an immediate determination + -- of the number of pattern elements within a pattern. This is used to + -- properly size the vectors used to contain auxiliary information for + -- traversal as described above. + + -- Third, as compound pattern structures are constructed, the way in which + -- constituent parts of the pattern are constructed is stylized. This is + -- an automatic consequence of the way that these compounjd structures + -- are constructed, and basically what we are doing is simply documenting + -- and specifying the natural result of the pattern construction. The + -- section describing compound pattern structures gives details of the + -- numbering of each compound pattern structure. + + -- The purpose of specifying the stylized numbering structures for the + -- compound patterns is to help simplify the processing in the Image + -- function, since it eases the task of retrieving the original recursive + -- structure of the pattern from the flat graph structure of elements. + -- This use in the Image function is the only point at which the code + -- makes use of the stylized structures. + + type Ref_Array is array (IndexT range <>) of PE_Ptr; + -- This type is used to build an array whose N'th entry references the + -- element in a pattern whose Index value is N. See Build_Ref_Array. + + procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array); + -- Given a pattern element which is the leading element of a pattern + -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the + -- Ref_Array so that its N'th entry references the element of the + -- referenced pattern whose Index value is N. + + ------------------------------- + -- Recursive Pattern Matches -- + ------------------------------- + + -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func + -- causes a recursive pattern match. This cannot be handled by an actual + -- recursive call to the outer level Match routine, since this would not + -- allow for possible backtracking into the region matched by the inner + -- pattern. Indeed this is the classical clash between recursion and + -- backtracking, and a simple recursive stack structure does not suffice. + + -- This section describes how this recursion and the possible associated + -- backtracking is handled. We still use a single stack, but we establish + -- the concept of nested regions on this stack, each of which has a stack + -- base value pointing to the deepest stack entry of the region. The base + -- value for the outer level is zero. + + -- When a recursive match is established, two special stack entries are + -- made. The first entry is used to save the original node that starts + -- the recursive match. This is saved so that the successor field of + -- this node is accessible at the end of the match, but it is never + -- popped and executed. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the recursive pattern is matched and + -- it can make history stack entries in the normal matter, so now + -- the stack looks like: + + -- (stack entries made by outer level) + + -- (Special entry, node is (+P) successor + -- cursor entry is not used) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base + -- saved base value for the enclosing region) + + -- (stack entries made by inner level) + + -- If a subsequent failure occurs and pops the PC_R_Remove node, it + -- removes itself and the special entry immediately underneath it, + -- restores the stack base value for the enclosing region, and then + -- again signals failure to look for alternatives that were stacked + -- before the recursion was initiated. + + -- Now we need to consider what happens if the inner pattern succeeds, as + -- signalled by accessing the special PC_EOP pattern primitive. First we + -- recognize the nested case by looking at the Base value. If this Base + -- value is Stack'First, then the entire match has succeeded, but if the + -- base value is greater than Stack'First, then we have successfully + -- matched an inner pattern, and processing continues at the outer level. + + -- There are two cases. The simple case is when the inner pattern has made + -- no stack entries, as recognized by the fact that the current stack + -- pointer is equal to the current base value. In this case it is fine to + -- remove all trace of the recursion by restoring the outer base value and + -- using the special entry to find the appropriate successor node. + + -- The more complex case arises when the inner match does make stack + -- entries. In this case, the PC_EOP processing stacks a special entry + -- whose cursor value saves the saved inner base value (the one that + -- references the corresponding PC_R_Remove value), and whose node + -- pointer references a PC_R_Restore node, so the stack looks like: + + -- (stack entries made by outer level) + + -- (Special entry, node is (+P) successor, + -- cursor entry is not used) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by inner level) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If the entire match succeeds, then these stack entries are, as usual, + -- ignored and abandoned. If on the other hand a subsequent failure + -- causes the PC_Region_Replace entry to be popped, it restores the + -- inner base value from its saved "cursor" value and then fails again. + -- Note that it is OK that the cursor is temporarily clobbered by this + -- pop, since the second failure will reestablish a proper cursor value. + + --------------------------------- + -- Compound Pattern Structures -- + --------------------------------- + + -- This section discusses the compound structures used to represent + -- constructed patterns. It shows the graph structures of pattern + -- elements that are constructed, and in the case of patterns that + -- provide backtracking possibilities, describes how the history + -- stack is used to control the backtracking. Finally, it notes the + -- way in which the Index numbers are assigned to the structure. + + -- In all diagrams, solid lines (built witth minus signs or vertical + -- bars, represent successor pointers (Pthen fields) with > or V used + -- to indicate the direction of the pointer. The initial node of the + -- structure is in the upper left of the diagram. A dotted line is an + -- alternative pointer from the element above it to the element below + -- it. See individual sections for details on how alternatives are used. + + ------------------- + -- Concatenation -- + ------------------- + + -- In the pattern structures listed in this section, a line that looks + -- lile ----> with nothing to the right indicates an end of pattern + -- (EOP) pointer that represents the end of the match. + + -- When a pattern concatenation (L & R) occurs, the resulting structure + -- is obtained by finding all such EOP pointers in L, and replacing + -- them to point to R. This is the most important flattening that + -- occurs in constructing a pattern, and it means that the pattern + -- matching circuitry does not have to keep track of the structure + -- of a pattern with respect to concatenation, since the appropriate + -- succesor is always at hand. + + -- Concatenation itself generates no additional possibilities for + -- backtracking, but the constituent patterns of the concatenated + -- structure will make stack entries as usual. The maximum amount + -- of stack required by the structure is thus simply the sum of the + -- maximums required by L and R. + + -- The index numbering of a concatenation structure works by leaving + -- the numbering of the right hand pattern, R, unchanged and adjusting + -- the numbers in the left hand pattern, L up by the count of elements + -- in R. This ensures that the maximum numbered element is the leading + -- element as required (given that it was the leading element in L). + + ----------------- + -- Alternation -- + ----------------- + + -- A pattern (L or R) constructs the structure: + + -- +---+ +---+ + -- | A |---->| L |----> + -- +---+ +---+ + -- . + -- . + -- +---+ + -- | R |----> + -- +---+ + + -- The A element here is a PC_Alt node, and the dotted line represents + -- the contents of the Alt field. When the PC_Alt element is matched, + -- it stacks a pointer to the leading element of R on the history stack + -- so that on subsequent failure, a match of R is attempted. + + -- The A node is the higest numbered element in the pattern. The + -- original index numbers of R are unchanged, but the index numbers + -- of the L pattern are adjusted up by the count of elements in R. + + -- Note that the difference between the index of the L leading element + -- the index of the R leading element (after building the alt structure) + -- indicates the number of nodes in L, and this is true even after the + -- structure is incorporated into some larger structure. For example, + -- if the A node has index 16, and L has index 15 and R has index + -- 5, then we know that L has 10 (15-5) elements in it. + + -- Suppose that we now concatenate this structure to another pattern + -- with 9 elements in it. We will now have the A node with an index + -- of 25, L with an index of 24 and R with an index of 14. We still + -- know that L has 10 (24-14) elements in it, numbered 15-24, and + -- consequently the successor of the alternation structure has an + -- index with a value less than 15. This is used in Image to figure + -- out the original recursive structure of a pattern. + + -- To clarify the interaction of the alternation and concatenation + -- structures, here is a more complex example of the structure built + -- for the pattern: + + -- (V or W or X) (Y or Z) + + -- where A,B,C,D,E are all single element patterns: + + -- +---+ +---+ +---+ +---+ + -- I A I---->I V I---+-->I A I---->I Y I----> + -- +---+ +---+ I +---+ +---+ + -- . I . + -- . I . + -- +---+ +---+ I +---+ + -- I A I---->I W I-->I I Z I----> + -- +---+ +---+ I +---+ + -- . I + -- . I + -- +---+ I + -- I X I------------>+ + -- +---+ + + -- The numbering of the nodes would be as follows: + + -- +---+ +---+ +---+ +---+ + -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I----> + -- +---+ +---+ I +---+ +---+ + -- . I . + -- . I . + -- +---+ +---+ I +---+ + -- I 6 I---->I 5 I-->I I 1 I----> + -- +---+ +---+ I +---+ + -- . I + -- . I + -- +---+ I + -- I 4 I------------>+ + -- +---+ + + -- Note: The above structure actually corresponds to + + -- (A or (B or C)) (D or E) + + -- rather than + + -- ((A or B) or C) (D or E) + + -- which is the more natural interpretation, but in fact alternation + -- is associative, and the construction of an alternative changes the + -- left grouped pattern to the right grouped pattern in any case, so + -- that the Image function produces a more natural looking output. + + --------- + -- Arb -- + --------- + + -- An Arb pattern builds the structure + + -- +---+ + -- | X |----> + -- +---+ + -- . + -- . + -- +---+ + -- | Y |----> + -- +---+ + + -- The X node is a PC_Arb_X node, which matches null, and stacks a + -- pointer to Y node, which is the PC_Arb_Y node that matches one + -- extra character and restacks itself. + + -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1. + + ------------------------- + -- Arbno (simple case) -- + ------------------------- + + -- The simple form of Arbno can be used where the pattern always + -- matches at least one character if it succeeds, and it is known + -- not to make any history stack entries. In this case, Arbno (P) + -- can construct the following structure: + + -- +-------------+ + -- | ^ + -- V | + -- +---+ | + -- | S |----> | + -- +---+ | + -- . | + -- . | + -- +---+ | + -- | P |---------->+ + -- +---+ + + -- The S (PC_Arbno_S) node matches null stacking a pointer to the + -- pattern P. If a subsequent failure causes P to be matched and + -- this match succeeds, then node A gets restacked to try another + -- instance if needed by a subsequent failure. + + -- The node numbering of the constituent pattern P is not affected. + -- The S node has a node number of P.Index + 1. + + -------------------------- + -- Arbno (complex case) -- + -------------------------- + + -- A call to Arbno (P), where P can match null (or at least is not + -- known to require a non-null string) and/or P requires pattern stack + -- entries, constructs the following structure: + + -- +--------------------------+ + -- | ^ + -- V | + -- +---+ | + -- | X |----> | + -- +---+ | + -- . | + -- . | + -- +---+ +---+ +---+ | + -- | E |---->| P |---->| Y |--->+ + -- +---+ +---+ +---+ + + -- The node X (PC_Arbno_X) matches null, stacking a pointer to the + -- E-P-X structure used to match one Arbno instance. + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry whose node field is + -- not used at all, and whose cursor field has the initial cursor. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped and + -- it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops + -- the inner region. There are two possibilities. If matching P left + -- no stack entries, then all traces of the inner region can be removed. + -- If there are stack entries, then we push an PC_Region_Replace stack + -- entry whose "cursor" value is the inner stack base value, and then + -- restore the outer stack base value, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- Now that we have matched another instance of the Arbno pattern, + -- we need to move to the successor. There are two cases. If the + -- Arbno pattern matched null, then there is no point in seeking + -- alternatives, since we would just match a whole bunch of nulls. + -- In this case we look through the alternative node, and move + -- directly to its successor (i.e. the successor of the Arbno + -- pattern). If on the other hand a non-null string was matched, + -- we simply follow the successor to the alternative node, which + -- sets up for another possible match of the Arbno pattern. + + -- As noted in the section on stack checking, the stack count (and + -- hence the stack check) for a pattern includes only one iteration + -- of the Arbno pattern. To make sure that multiple iterations do not + -- overflow the stack, the Arbno node saves the stack count required + -- by a single iteration, and the Concat function increments this to + -- include stack entries required by any successor. The PC_Arbno_Y + -- node uses this count to ensure that sufficient stack remains + -- before proceeding after matching each new instance. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the Y node is numbered N + 1, + -- the E node is N + 2, and the X node is N + 3. + + ---------------------- + -- Assign Immediate -- + ---------------------- + + -- Immediate assignment (P * V) constructs the following structure + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry whose node field is + -- not used at all, and whose cursor field has the initial cursor. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped + -- and it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node A, which is the actual + -- PC_Assign_Imm node, executes the assignment (using the stack + -- base to locate the entry with the saved starting cursor value), + -- and the pops the inner region. There are two possibilities, if + -- matching P left no stack entries, then all traces of the inner + -- region can be removed. If there are stack entries, then we push + -- an PC_Region_Replace stack entry whose "cursor" value is the + -- inner stack base value, and then restore the outer stack base + -- value, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Region_Replace entry, "cursor" value is the (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure occurs, the PC_Region_Replace node restores + -- the inner stack base value and signals failure to explore rematches + -- of the pattern P. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + --------------------- + -- Assign On Match -- + --------------------- + + -- The assign on match (**) pattern is quite similar to the assign + -- immediate pattern, except that the actual assignment has to be + -- delayed. The following structure is constructed: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The operation of this pattern is identical to that described above + -- for deferred assignment, up to the point where P has been matched. + + -- The A node, which is the PC_Assign_OnM node first pushes a + -- PC_Assign node onto the history stack. This node saves the ending + -- cursor and acts as a flag for the final assignment, as further + -- described below. + + -- It then stores a pointer to itself in the special entry node field. + -- This was otherwise unused, and is now used to retrive the address + -- of the variable to be assigned at the end of the pattern. + + -- After that the inner region is terminated in the usual manner, + -- by stacking a PC_R_Restore entry as described for the assign + -- immediate case. Note that the optimization of completely + -- removing the inner region does not happen in this case, since + -- we have at least one stack entry (the PC_Assign one we just made). + -- The stack now looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node points to copy of + -- the PC_Assign_OnM node, and the + -- cursor field saves the initial cursor). + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Assign entry, saves final cursor) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure causes the PC_Assign node to execute it + -- simply removes itself and propagates the failure. + + -- If the match succeeds, then the history stack is scanned for + -- PC_Assign nodes, and the assignments are executed (examination + -- of the above diagram will show that all the necessary data is + -- at hand for the assignment). + + -- To optimize the common case where no assign-on-match operations + -- are present, a global flag Assign_OnM is maintained which is + -- initialize to False, and gets set True as part of the execution + -- of the PC_Assign_OnM node. The scan of the history stack for + -- PC_Assign entries is done only if this flag is set. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + --------- + -- Bal -- + --------- + + -- Bal builds a single node: + + -- +---+ + -- | B |----> + -- +---+ + + -- The node B is the PC_Bal node which matches a parentheses balanced + -- string, starting at the current cursor position. It then updates + -- the cursor past this matched string, and stacks a pointer to itself + -- with this updated cursor value on the history stack, to extend the + -- matched string on a subequent failure. + + -- Since this is a single node it is numbered 1 (the reason we include + -- it in the compound patterns section is that it backtracks). + + ------------ + -- BreakX -- + ------------ + + -- BreakX builds the structure + + -- +---+ +---+ + -- | B |---->| A |----> + -- +---+ +---+ + -- ^ . + -- | . + -- | +---+ + -- +<------| X | + -- +---+ + + -- Here the B node is the BreakX_xx node that performs a normal Break + -- function. The A node is an alternative (PC_Alt) node that matches + -- null, but stacks a pointer to node X (the PC_BreakX_X node) which + -- extends the match one character (to eat up the previously detected + -- break character), and then rematches the break. + + -- The B node is numbered 3, the alternative node is 1, and the X + -- node is 2. + + ----------- + -- Fence -- + ----------- + + -- Fence builds a single node: + + -- +---+ + -- | F |----> + -- +---+ + + -- The element F, PC_Fence, matches null, and stacks a pointer to a + -- PC_Cancel element which will abort the match on a subsequent failure. + + -- Since this is a single element it is numbered 1 (the reason we + -- include it in the compound patterns section is that it backtracks). + + -------------------- + -- Fence Function -- + -------------------- + + -- A call to the Fence function builds the structure: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| X |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry which is not used at + -- all in the fence case (it is present merely for uniformity with + -- other cases of region enter operations). + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before fence pattern) + + -- (Special entry, not used at all) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped + -- and it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node X, the PC_Fence_X node, gets + -- control. One might be tempted to think that at this point, the + -- history stack entries made by matching P can just be removed since + -- they certainly are not going to be used for rematching (that is + -- whole point of Fence after all!) However, this is wrong, because + -- it would result in the loss of possible assign-on-match entries + -- for deferred pattern assignments. + + -- Instead what we do is to make a special entry whose node references + -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e. + -- the pointer to the PC_R_Remove entry. Then the outer stack base + -- pointer is restored, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, not used at all) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Fence_Y entry, "cursor" value is (negative) stack + -- pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure occurs, then the PC_Fence_Y entry removes + -- the entire inner region, including all entries made by matching P, + -- and alternatives prior to the Fence pattern are sought. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the X node is numbered N + 1, + -- and the E node is N + 2. + + ------------- + -- Succeed -- + ------------- + + -- Succeed builds a single node: + + -- +---+ + -- | S |----> + -- +---+ + + -- The node S is the PC_Succeed node which matches null, and stacks + -- a pointer to itself on the history stack, so that a subsequent + -- failure repeats the same match. + + -- Since this is a single node it is numbered 1 (the reason we include + -- it in the compound patterns section is that it backtracks). + + --------------------- + -- Write Immediate -- + --------------------- + + -- The structure built for a write immediate operation (P * F, where + -- F is a file access value) is: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The + -- handling is identical to that described above for Assign Immediate, + -- except that at the point where a successful match occurs, the matched + -- substring is written to the referenced file. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + -------------------- + -- Write On Match -- + -------------------- + + -- The structure built for a write on match operation (P ** F, where + -- F is a file access value) is: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The + -- handling is identical to that described above for Assign On Match, + -- except that at the point where a successful match has completed, + -- the matched substring is written to the referenced file. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + ----------------------- + -- Constant Patterns -- + ----------------------- + + -- The following pattern elements are referenced only from the pattern + -- history stack. In each case the processing for the pattern element + -- results in pattern match abort, or futher failure, so there is no + -- need for a successor and no need for a node number + + CP_Assign : aliased PE := (PC_Assign, 0, N); + CP_Cancel : aliased PE := (PC_Cancel, 0, N); + CP_Fence_Y : aliased PE := (PC_Fence_Y, 0, N); + CP_R_Remove : aliased PE := (PC_R_Remove, 0, N); + CP_R_Restore : aliased PE := (PC_R_Restore, 0, N); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Alternate (L, R : PE_Ptr) return PE_Ptr; + function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate; + -- Build pattern structure corresponding to the alternation of L, R. + -- (i.e. try to match L, and if that fails, try to match R). + + function Arbno_Simple (P : PE_Ptr) return PE_Ptr; + -- Build simple Arbno pattern, P is a pattern that is guaranteed to + -- match at least one character if it succeeds and to require no + -- stack entries under all circumstances. The result returned is + -- a simple Arbno structure as previously described. + + function Bracket (E, P, A : PE_Ptr) return PE_Ptr; + -- Given two single node pattern elements E and A, and a (possible + -- complex) pattern P, construct the concatenation E-->P-->A and + -- return a pointer to E. The concatenation does not affect the + -- node numbering in P. A has a number one higher than the maximum + -- number in P, and E has a number two higher than the maximum + -- number in P (see for example the Assign_Immediate structure to + -- understand a typical use of this function). + + function BreakX_Make (B : PE_Ptr) return Pattern; + -- Given a pattern element for a Break patternx, returns the + -- corresponding BreakX compound pattern structure. + + function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr; + -- Creates a pattern eelement that represents a concatenation of the + -- two given pattern elements (i.e. the pattern L followed by R). + -- The result returned is always the same as L, but the pattern + -- referenced by L is modified to have R as a successor. This + -- procedure does not copy L or R, so if a copy is required, it + -- is the responsibility of the caller. The Incr parameter is an + -- amount to be added to the Nat field of any P_Arbno_Y node that is + -- in the left operand, it represents the additional stack space + -- required by the right operand. + + function "&" (L, R : PE_Ptr) return PE_Ptr; + pragma Inline ("&"); + -- Equivalent to Concat (L, R, 0) + + function C_To_PE (C : PChar) return PE_Ptr; + -- Given a character, constructs a pattern element that matches + -- the single character. + + function Copy (P : PE_Ptr) return PE_Ptr; + -- Creates a copy of the pattern element referenced by the given + -- pattern element reference. This is a deep copy, which means that + -- it follows the Next and Alt pointers. + + function Image (P : PE_Ptr) return String; + -- Returns the image of the address of the referenced pattern element. + -- This is equivalent to Image (To_Address (P)); + + function Is_In (C : Character; Str : String) return Boolean; + pragma Inline (Is_In); + -- Determines if the character C is in string Str. + + procedure Logic_Error; + -- Called to raise Program_Error with an appropriate message if an + -- internal logic error is detected. + + function Str_BF (A : Boolean_Func) return String; + function Str_FP (A : File_Ptr) return String; + function Str_NF (A : Natural_Func) return String; + function Str_NP (A : Natural_Ptr) return String; + function Str_PP (A : Pattern_Ptr) return String; + function Str_VF (A : VString_Func) return String; + function Str_VP (A : VString_Ptr) return String; + -- These are debugging routines, which return a representation of the + -- given access value (they are called only by Image and Dump) + + procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr); + -- Adjusts all EOP pointers in Pat to point to Succ. No other changes + -- are made. In particular, Succ is unchanged, and no index numbers + -- are modified. Note that Pat may not be equal to EOP on entry. + + function S_To_PE (Str : PString) return PE_Ptr; + -- Given a string, constructs a pattern element that matches the string + + procedure Uninitialized_Pattern; + pragma No_Return (Uninitialized_Pattern); + -- Called to raise Program_Error with an appropriate error message if + -- an uninitialized pattern is used in any pattern construction or + -- pattern matching operation. + + procedure XMatch + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural); + -- This is the common pattern match routine. It is passed a string and + -- a pattern, and it indicates success or failure, and on success the + -- section of the string matched. It does not perform any assignments + -- to the subject string, so pattern replacement is for the caller. + -- + -- Subject The subject string. The lower bound is always one. In the + -- Match procedures, it is fine to use strings whose lower bound + -- is not one, but we perform a one time conversion before the + -- call to XMatch, so that XMatch does not have to be bothered + -- with strange lower bounds. + -- + -- Pat_P Points to initial pattern element of pattern to be matched + -- + -- Pat_S Maximum required stack entries for pattern to be matched + -- + -- Start If match is successful, starting index of matched section. + -- This value is always non-zero. A value of zero is used to + -- indicate a failed match. + -- + -- Stop If match is successful, ending index of matched section. + -- This can be zero if we match the null string at the start, + -- in which case Start is set to zero, and Stop to one. If the + -- Match fails, then the contents of Stop is undefined. + + procedure XMatchD + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural); + -- Identical in all respects to XMatch, except that trace information is + -- output on Standard_Ouput during execution of the match. This is the + -- version that is called if the original Match call has Debug => True. + + --------- + -- "&" -- + --------- + + function "&" (L : PString; R : Pattern) return Pattern is + begin + return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk)); + end "&"; + + function "&" (L : Pattern; R : PString) return Pattern is + begin + return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0)); + end "&"; + + function "&" (L : PChar; R : Pattern) return Pattern is + begin + return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk)); + end "&"; + + function "&" (L : Pattern; R : PChar) return Pattern is + begin + return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0)); + end "&"; + + function "&" (L : Pattern; R : Pattern) return Pattern is + begin + return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk)); + end "&"; + + function "&" (L, R : PE_Ptr) return PE_Ptr is + begin + return Concat (L, R, 0); + end "&"; + + --------- + -- "*" -- + --------- + + -- Assign immediate + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + function "*" (P : Pattern; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, A)); + end "*"; + + function "*" (P : PString; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "*"; + + function "*" (P : PChar; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "*"; + + -- Write immediate + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + function "*" (P : Pattern; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + function "*" (P : PString; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + function "*" (P : PChar; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + ---------- + -- "**" -- + ---------- + + -- Assign on match + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + function "**" (P : Pattern; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, A)); + end "**"; + + function "**" (P : PString; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "**"; + + function "**" (P : PChar; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "**"; + + -- Write on match + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + function "**" (P : Pattern; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, W)); + end "**"; + + function "**" (P : PString; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "**"; + + function "**" (P : PChar; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "**"; + + --------- + -- "+" -- + --------- + + function "+" (Str : VString_Var) return Pattern is + begin + return + (AFC with 0, + new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access)); + end "+"; + + function "+" (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str)); + end "+"; + + function "+" (P : Pattern_Var) return Pattern is + begin + return + (AFC with 3, + new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access)); + end "+"; + + function "+" (P : Boolean_Func) return Pattern is + begin + return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P)); + end "+"; + + ---------- + -- "or" -- + ---------- + + function "or" (L : PString; R : Pattern) return Pattern is + begin + return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P)); + end "or"; + + function "or" (L : Pattern; R : PString) return Pattern is + begin + return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R)); + end "or"; + + function "or" (L : PString; R : PString) return Pattern is + begin + return (AFC with 1, S_To_PE (L) or S_To_PE (R)); + end "or"; + + function "or" (L : Pattern; R : Pattern) return Pattern is + begin + return (AFC with + Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P)); + end "or"; + + function "or" (L : PChar; R : Pattern) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or Copy (R.P)); + end "or"; + + function "or" (L : Pattern; R : PChar) return Pattern is + begin + return (AFC with 1, Copy (L.P) or C_To_PE (R)); + end "or"; + + function "or" (L : PChar; R : PChar) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or C_To_PE (R)); + end "or"; + + function "or" (L : PString; R : PChar) return Pattern is + begin + return (AFC with 1, S_To_PE (L) or C_To_PE (R)); + end "or"; + + function "or" (L : PChar; R : PString) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or S_To_PE (R)); + end "or"; + + ------------ + -- Adjust -- + ------------ + + -- No two patterns share the same pattern elements, so the adjust + -- procedure for a Pattern assignment must do a deep copy of the + -- pattern element structure. + + procedure Adjust (Object : in out Pattern) is + begin + Object.P := Copy (Object.P); + end Adjust; + + --------------- + -- Alternate -- + --------------- + + function Alternate (L, R : PE_Ptr) return PE_Ptr is + begin + -- If the left pattern is null, then we just add the alternation + -- node with an index one greater than the right hand pattern. + + if L = EOP then + return new PE'(PC_Alt, R.Index + 1, EOP, R); + + -- If the left pattern is non-null, then build a reference vector + -- for its elements, and adjust their index values to acccomodate + -- the right hand elements. Then add the alternation node. + + else + declare + Refs : Ref_Array (1 .. L.Index); + + begin + Build_Ref_Array (L, Refs); + + for J in Refs'Range loop + Refs (J).Index := Refs (J).Index + R.Index; + end loop; + end; + + return new PE'(PC_Alt, L.Index + 1, L, R); + end if; + end Alternate; + + --------- + -- Any -- + --------- + + function Any (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str))); + end Any; + + function Any (Str : VString) return Pattern is + begin + return Any (S (Str)); + end Any; + + function Any (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str)); + end Any; + + function Any (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str)); + end Any; + + function Any (Str : access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str))); + end Any; + + function Any (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str)); + end Any; + + --------- + -- Arb -- + --------- + + -- +---+ + -- | X |----> + -- +---+ + -- . + -- . + -- +---+ + -- | Y |----> + -- +---+ + + -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1. + + function Arb return Pattern is + Y : constant PE_Ptr := new PE'(PC_Arb_Y, 1, EOP); + X : constant PE_Ptr := new PE'(PC_Arb_X, 2, EOP, Y); + + begin + return (AFC with 1, X); + end Arb; + + ----------- + -- Arbno -- + ----------- + + function Arbno (P : PString) return Pattern is + begin + if P'Length = 0 then + return (AFC with 0, EOP); + + else + return (AFC with 0, Arbno_Simple (S_To_PE (P))); + end if; + end Arbno; + + function Arbno (P : PChar) return Pattern is + begin + return (AFC with 0, Arbno_Simple (C_To_PE (P))); + end Arbno; + + function Arbno (P : Pattern) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + + begin + if P.Stk = 0 + and then OK_For_Simple_Arbno (Pat.Pcode) + then + return (AFC with 0, Arbno_Simple (Pat)); + end if; + + -- This is the complex case, either the pattern makes stack entries + -- or it is possible for the pattern to match the null string (more + -- accurately, we don't know that this is not the case). + + -- +--------------------------+ + -- | ^ + -- V | + -- +---+ | + -- | X |----> | + -- +---+ | + -- . | + -- . | + -- +---+ +---+ +---+ | + -- | E |---->| P |---->| Y |--->+ + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the Y node is numbered N + 1, + -- the E node is N + 2, and the X node is N + 3. + + declare + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + X : constant PE_Ptr := new PE'(PC_Arbno_X, 0, EOP, E); + Y : constant PE_Ptr := new PE'(PC_Arbno_Y, 0, X, P.Stk + 3); + EPY : constant PE_Ptr := Bracket (E, Pat, Y); + + begin + X.Alt := EPY; + X.Index := EPY.Index + 1; + return (AFC with P.Stk + 3, X); + end; + end Arbno; + + ------------------ + -- Arbno_Simple -- + ------------------ + + -- +-------------+ + -- | ^ + -- V | + -- +---+ | + -- | S |----> | + -- +---+ | + -- . | + -- . | + -- +---+ | + -- | P |---------->+ + -- +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- The S node has a node number of P.Index + 1. + + -- Note that we know that P cannot be EOP, because a null pattern + -- does not meet the requirements for simple Arbno. + + function Arbno_Simple (P : PE_Ptr) return PE_Ptr is + S : constant PE_Ptr := new PE'(PC_Arbno_S, P.Index + 1, EOP, P); + + begin + Set_Successor (P, S); + return S; + end Arbno_Simple; + + --------- + -- Bal -- + --------- + + function Bal return Pattern is + begin + return (AFC with 1, new PE'(PC_Bal, 1, EOP)); + end Bal; + + ------------- + -- Bracket -- + ------------- + + function Bracket (E, P, A : PE_Ptr) return PE_Ptr is + begin + if P = EOP then + E.Pthen := A; + E.Index := 2; + A.Index := 1; + + else + E.Pthen := P; + Set_Successor (P, A); + E.Index := P.Index + 2; + A.Index := P.Index + 1; + end if; + + return E; + end Bracket; + + ----------- + -- Break -- + ----------- + + function Break (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str))); + end Break; + + function Break (Str : VString) return Pattern is + begin + return Break (S (Str)); + end Break; + + function Break (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str)); + end Break; + + function Break (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str)); + end Break; + + function Break (Str : access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_VP, 1, EOP, VString_Ptr (Str))); + end Break; + + function Break (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str)); + end Break; + + ------------ + -- BreakX -- + ------------ + + function BreakX (Str : String) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str))); + end BreakX; + + function BreakX (Str : VString) return Pattern is + begin + return BreakX (S (Str)); + end BreakX; + + function BreakX (Str : Character) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str)); + end BreakX; + + function BreakX (Str : Character_Set) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str)); + end BreakX; + + function BreakX (Str : access VString) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str))); + end BreakX; + + function BreakX (Str : VString_Func) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str)); + end BreakX; + + ----------------- + -- BreakX_Make -- + ----------------- + + -- +---+ +---+ + -- | B |---->| A |----> + -- +---+ +---+ + -- ^ . + -- | . + -- | +---+ + -- +<------| X | + -- +---+ + + -- The B node is numbered 3, the alternative node is 1, and the X + -- node is 2. + + function BreakX_Make (B : PE_Ptr) return Pattern is + X : constant PE_Ptr := new PE'(PC_BreakX_X, 2, B); + A : constant PE_Ptr := new PE'(PC_Alt, 1, EOP, X); + + begin + B.Pthen := A; + return (AFC with 2, B); + end BreakX_Make; + + --------------------- + -- Build_Ref_Array -- + --------------------- + + procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is + + procedure Record_PE (E : PE_Ptr); + -- Record given pattern element if not already recorded in RA, + -- and also record any referenced pattern elements recursively. + + procedure Record_PE (E : PE_Ptr) is + begin + PutD (" Record_PE called with PE_Ptr = " & Image (E)); + + if E = EOP or else RA (E.Index) /= null then + Put_LineD (", nothing to do"); + return; + + else + Put_LineD (", recording" & IndexT'Image (E.Index)); + RA (E.Index) := E; + Record_PE (E.Pthen); + + if E.Pcode in PC_Has_Alt then + Record_PE (E.Alt); + end if; + end if; + end Record_PE; + + -- Start of processing for Build_Ref_Array + + begin + New_LineD; + Put_LineD ("Entering Build_Ref_Array"); + Record_PE (E); + New_LineD; + end Build_Ref_Array; + + ------------- + -- C_To_PE -- + ------------- + + function C_To_PE (C : PChar) return PE_Ptr is + begin + return new PE'(PC_Char, 1, EOP, C); + end C_To_PE; + + ------------ + -- Cancel -- + ------------ + + function Cancel return Pattern is + begin + return (AFC with 0, new PE'(PC_Cancel, 1, EOP)); + end Cancel; + + ------------ + -- Concat -- + ------------ + + -- Concat needs to traverse the left operand performing the following + -- set of fixups: + + -- a) Any successor pointers (Pthen fields) that are set to EOP are + -- reset to point to the second operand. + + -- b) Any PC_Arbno_Y node has its stack count field incremented + -- by the parameter Incr provided for this purpose. + + -- d) Num fields of all pattern elements in the left operand are + -- adjusted to include the elements of the right operand. + + -- Note: we do not use Set_Successor in the processing for Concat, since + -- there is no point in doing two traversals, we may as well do everything + -- at the same time. + + function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr is + begin + if L = EOP then + return R; + + elsif R = EOP then + return L; + + else + declare + Refs : Ref_Array (1 .. L.Index); + -- We build a reference array for L whose N'th element points to + -- the pattern element of L whose original Index value is N. + + P : PE_Ptr; + + begin + Build_Ref_Array (L, Refs); + + for J in Refs'Range loop + P := Refs (J); + + P.Index := P.Index + R.Index; + + if P.Pcode = PC_Arbno_Y then + P.Nat := P.Nat + Incr; + end if; + + if P.Pthen = EOP then + P.Pthen := R; + end if; + + if P.Pcode in PC_Has_Alt and then P.Alt = EOP then + P.Alt := R; + end if; + end loop; + end; + + return L; + end if; + end Concat; + + ---------- + -- Copy -- + ---------- + + function Copy (P : PE_Ptr) return PE_Ptr is + begin + if P = null then + Uninitialized_Pattern; + + else + declare + Refs : Ref_Array (1 .. P.Index); + -- References to elements in P, indexed by Index field + + Copy : Ref_Array (1 .. P.Index); + -- Holds copies of elements of P, indexed by Index field. + + E : PE_Ptr; + + begin + Build_Ref_Array (P, Refs); + + -- Now copy all nodes + + for J in Refs'Range loop + Copy (J) := new PE'(Refs (J).all); + end loop; + + -- Adjust all internal references + + for J in Copy'Range loop + E := Copy (J); + + -- Adjust successor pointer to point to copy + + if E.Pthen /= EOP then + E.Pthen := Copy (E.Pthen.Index); + end if; + + -- Adjust Alt pointer if there is one to point to copy + + if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then + E.Alt := Copy (E.Alt.Index); + end if; + + -- Copy referenced string + + if E.Pcode = PC_String then + E.Str := new String'(E.Str.all); + end if; + end loop; + + return Copy (P.Index); + end; + end if; + end Copy; + + ---------- + -- Dump -- + ---------- + + procedure Dump (P : Pattern) is + + subtype Count is Ada.Text_IO.Count; + Scol : Count; + -- Used to keep track of column in dump output + + Refs : Ref_Array (1 .. P.P.Index); + -- We build a reference array whose N'th element points to the + -- pattern element whose Index value is N. + + Cols : Natural := 2; + -- Number of columns used for pattern numbers, minimum is 2 + + E : PE_Ptr; + + procedure Write_Node_Id (E : PE_Ptr); + -- Writes out a string identifying the given pattern element. + + procedure Write_Node_Id (E : PE_Ptr) is + begin + if E = EOP then + Put ("EOP"); + + for J in 4 .. Cols loop + Put (' '); + end loop; + + else + declare + Str : String (1 .. Cols); + N : Natural := Natural (E.Index); + + begin + Put ("#"); + + for J in reverse Str'Range loop + Str (J) := Character'Val (48 + N mod 10); + N := N / 10; + end loop; + + Put (Str); + end; + end if; + end Write_Node_Id; + + begin + New_Line; + Put ("Pattern Dump Output (pattern at " & + Image (P'Address) & + ", S = " & Natural'Image (P.Stk) & ')'); + + Scol := Col; + New_Line; + + while Col < Scol loop + Put ('-'); + end loop; + + New_Line; + + -- If uninitialized pattern, dump line and we are done + + if P.P = null then + Put_Line ("Uninitialized pattern value"); + return; + end if; + + -- If null pattern, just dump it and we are all done + + if P.P = EOP then + Put_Line ("EOP (null pattern)"); + return; + end if; + + Build_Ref_Array (P.P, Refs); + + -- Set number of columns required for node numbers + + while 10 ** Cols - 1 < Integer (P.P.Index) loop + Cols := Cols + 1; + end loop; + + -- Now dump the nodes in reverse sequence. We output them in reverse + -- sequence since this corresponds to the natural order used to + -- construct the patterns. + + for J in reverse Refs'Range loop + E := Refs (J); + Write_Node_Id (E); + Set_Col (Count (Cols) + 4); + Put (Image (E)); + Put (" "); + Put (Pattern_Code'Image (E.Pcode)); + Put (" "); + Set_Col (21 + Count (Cols) + Address_Image_Length); + Write_Node_Id (E.Pthen); + Set_Col (24 + 2 * Count (Cols) + Address_Image_Length); + + case E.Pcode is + + when PC_Alt | + PC_Arb_X | + PC_Arbno_S | + PC_Arbno_X => + Write_Node_Id (E.Alt); + + when PC_Rpat => + Put (Str_PP (E.PP)); + + when PC_Pred_Func => + Put (Str_BF (E.BF)); + + when PC_Assign_Imm | + PC_Assign_OnM | + PC_Any_VP | + PC_Break_VP | + PC_BreakX_VP | + PC_NotAny_VP | + PC_NSpan_VP | + PC_Span_VP | + PC_String_VP => + Put (Str_VP (E.VP)); + + when PC_Write_Imm | + PC_Write_OnM => + Put (Str_FP (E.FP)); + + when PC_String => + Put (Image (E.Str.all)); + + when PC_String_2 => + Put (Image (E.Str2)); + + when PC_String_3 => + Put (Image (E.Str3)); + + when PC_String_4 => + Put (Image (E.Str4)); + + when PC_String_5 => + Put (Image (E.Str5)); + + when PC_String_6 => + Put (Image (E.Str6)); + + when PC_Setcur => + Put (Str_NP (E.Var)); + + when PC_Any_CH | + PC_Break_CH | + PC_BreakX_CH | + PC_Char | + PC_NotAny_CH | + PC_NSpan_CH | + PC_Span_CH => + Put (''' & E.Char & '''); + + when PC_Any_CS | + PC_Break_CS | + PC_BreakX_CS | + PC_NotAny_CS | + PC_NSpan_CS | + PC_Span_CS => + Put ('"' & To_Sequence (E.CS) & '"'); + + when PC_Arbno_Y | + PC_Len_Nat | + PC_Pos_Nat | + PC_RPos_Nat | + PC_RTab_Nat | + PC_Tab_Nat => + Put (S (E.Nat)); + + when PC_Pos_NF | + PC_Len_NF | + PC_RPos_NF | + PC_RTab_NF | + PC_Tab_NF => + Put (Str_NF (E.NF)); + + when PC_Pos_NP | + PC_Len_NP | + PC_RPos_NP | + PC_RTab_NP | + PC_Tab_NP => + Put (Str_NP (E.NP)); + + when PC_Any_VF | + PC_Break_VF | + PC_BreakX_VF | + PC_NotAny_VF | + PC_NSpan_VF | + PC_Span_VF | + PC_String_VF => + Put (Str_VF (E.VF)); + + when others => null; + + end case; + + New_Line; + end loop; + + New_Line; + end Dump; + + ---------- + -- Fail -- + ---------- + + function Fail return Pattern is + begin + return (AFC with 0, new PE'(PC_Fail, 1, EOP)); + end Fail; + + ----------- + -- Fence -- + ----------- + + -- Simple case + + function Fence return Pattern is + begin + return (AFC with 1, new PE'(PC_Fence, 1, EOP)); + end Fence; + + -- Function case + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| X |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the X node is numbered N + 1, + -- and the E node is N + 2. + + function Fence (P : Pattern) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + X : constant PE_Ptr := new PE'(PC_Fence_X, 0, EOP); + + begin + return (AFC with P.Stk + 1, Bracket (E, Pat, X)); + end Fence; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Pattern) is + + procedure Free is new Unchecked_Deallocation (PE, PE_Ptr); + procedure Free is new Unchecked_Deallocation (String, String_Ptr); + + begin + -- Nothing to do if already freed + + if Object.P = null then + return; + + -- Otherwise we must free all elements + + else + declare + Refs : Ref_Array (1 .. Object.P.Index); + -- References to elements in pattern to be finalized + + begin + Build_Ref_Array (Object.P, Refs); + + for J in Refs'Range loop + if Refs (J).Pcode = PC_String then + Free (Refs (J).Str); + end if; + + Free (Refs (J)); + end loop; + + Object.P := null; + end; + end if; + end Finalize; + + ----------- + -- Image -- + ----------- + + function Image (P : PE_Ptr) return String is + begin + return Image (To_Address (P)); + end Image; + + function Image (P : Pattern) return String is + begin + return S (Image (P)); + end Image; + + function Image (P : Pattern) return VString is + + Kill_Ampersand : Boolean := False; + -- Set True to delete next & to be output to Result + + Result : VString := Nul; + -- The result is accumulated here, using Append + + Refs : Ref_Array (1 .. P.P.Index); + -- We build a reference array whose N'th element points to the + -- pattern element whose Index value is N. + + procedure Delete_Ampersand; + -- Deletes the ampersand at the end of Result + + procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean); + -- E refers to a pattern structure whose successor is given by Succ. + -- This procedure appends to Result a representation of this pattern. + -- The Paren parameter indicates whether parentheses are required if + -- the output is more than one element. + + procedure Image_One (E : in out PE_Ptr); + -- E refers to a pattern structure. This procedure appends to Result + -- a representation of the single simple or compound pattern structure + -- at the start of E and updates E to point to its successor. + + ---------------------- + -- Delete_Ampersand -- + ---------------------- + + procedure Delete_Ampersand is + L : Natural := Length (Result); + + begin + if L > 2 then + Delete (Result, L - 1, L); + end if; + end Delete_Ampersand; + + --------------- + -- Image_One -- + --------------- + + procedure Image_One (E : in out PE_Ptr) is + + ER : PE_Ptr := E.Pthen; + -- Successor set as result in E unless reset + + begin + case E.Pcode is + + when PC_Cancel => + Append (Result, "Cancel"); + + when PC_Alt => Alt : declare + + Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index; + -- Number of elements in left pattern of alternation. + + Lowest_In_L : constant IndexT := E.Index - Elmts_In_L; + -- Number of lowest index in elements of left pattern + + E1 : PE_Ptr; + + begin + -- The successor of the alternation node must have a lower + -- index than any node that is in the left pattern or a + -- higher index than the alternation node itself. + + while ER /= EOP + and then ER.Index >= Lowest_In_L + and then ER.Index < E.Index + loop + ER := ER.Pthen; + end loop; + + Append (Result, '('); + + E1 := E; + loop + Image_Seq (E1.Pthen, ER, False); + Append (Result, " or "); + E1 := E1.Alt; + exit when E1.Pcode /= PC_Alt; + end loop; + + Image_Seq (E1, ER, False); + Append (Result, ')'); + end Alt; + + when PC_Any_CS => + Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Any_VF => + Append (Result, "Any (" & Str_VF (E.VF) & ')'); + + when PC_Any_VP => + Append (Result, "Any (" & Str_VP (E.VP) & ')'); + + when PC_Arb_X => + Append (Result, "Arb"); + + when PC_Arbno_S => + Append (Result, "Arbno ("); + Image_Seq (E.Alt, E, False); + Append (Result, ')'); + + when PC_Arbno_X => + Append (Result, "Arbno ("); + Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False); + Append (Result, ')'); + + when PC_Assign_Imm => + Delete_Ampersand; + Append (Result, "* " & Str_VP (Refs (E.Index - 1).VP)); + + when PC_Assign_OnM => + Delete_Ampersand; + Append (Result, "** " & Str_VP (Refs (E.Index - 1).VP)); + + when PC_Any_CH => + Append (Result, "Any ('" & E.Char & "')"); + + when PC_Bal => + Append (Result, "Bal"); + + when PC_Break_CH => + Append (Result, "Break ('" & E.Char & "')"); + + when PC_Break_CS => + Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Break_VF => + Append (Result, "Break (" & Str_VF (E.VF) & ')'); + + when PC_Break_VP => + Append (Result, "Break (" & Str_VP (E.VP) & ')'); + + when PC_BreakX_CH => + Append (Result, "BreakX ('" & E.Char & "')"); + ER := ER.Pthen; + + when PC_BreakX_CS => + Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')'); + ER := ER.Pthen; + + when PC_BreakX_VF => + Append (Result, "BreakX (" & Str_VF (E.VF) & ')'); + ER := ER.Pthen; + + when PC_BreakX_VP => + Append (Result, "BreakX (" & Str_VP (E.VP) & ')'); + ER := ER.Pthen; + + when PC_Char => + Append (Result, ''' & E.Char & '''); + + when PC_Fail => + Append (Result, "Fail"); + + when PC_Fence => + Append (Result, "Fence"); + + when PC_Fence_X => + Append (Result, "Fence ("); + Image_Seq (E.Pthen, Refs (E.Index - 1), False); + Append (Result, ")"); + ER := Refs (E.Index - 1).Pthen; + + when PC_Len_Nat => + Append (Result, "Len (" & E.Nat & ')'); + + when PC_Len_NF => + Append (Result, "Len (" & Str_NF (E.NF) & ')'); + + when PC_Len_NP => + Append (Result, "Len (" & Str_NP (E.NP) & ')'); + + when PC_NotAny_CH => + Append (Result, "NotAny ('" & E.Char & "')"); + + when PC_NotAny_CS => + Append (Result, "NotAny (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_NotAny_VF => + Append (Result, "NotAny (" & Str_VF (E.VF) & ')'); + + when PC_NotAny_VP => + Append (Result, "NotAny (" & Str_VP (E.VP) & ')'); + + when PC_NSpan_CH => + Append (Result, "NSpan ('" & E.Char & "')"); + + when PC_NSpan_CS => + Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_NSpan_VF => + Append (Result, "NSpan (" & Str_VF (E.VF) & ')'); + + when PC_NSpan_VP => + Append (Result, "NSpan (" & Str_VP (E.VP) & ')'); + + when PC_Null => + Append (Result, """"""); + + when PC_Pos_Nat => + Append (Result, "Pos (" & E.Nat & ')'); + + when PC_Pos_NF => + Append (Result, "Pos (" & Str_NF (E.NF) & ')'); + + when PC_Pos_NP => + Append (Result, "Pos (" & Str_NP (E.NP) & ')'); + + when PC_R_Enter => + Kill_Ampersand := True; + + when PC_Rest => + Append (Result, "Rest"); + + when PC_Rpat => + Append (Result, "(+ " & Str_PP (E.PP) & ')'); + + when PC_Pred_Func => + Append (Result, "(+ " & Str_BF (E.BF) & ')'); + + when PC_RPos_Nat => + Append (Result, "RPos (" & E.Nat & ')'); + + when PC_RPos_NF => + Append (Result, "RPos (" & Str_NF (E.NF) & ')'); + + when PC_RPos_NP => + Append (Result, "RPos (" & Str_NP (E.NP) & ')'); + + when PC_RTab_Nat => + Append (Result, "RTab (" & E.Nat & ')'); + + when PC_RTab_NF => + Append (Result, "RTab (" & Str_NF (E.NF) & ')'); + + when PC_RTab_NP => + Append (Result, "RTab (" & Str_NP (E.NP) & ')'); + + when PC_Setcur => + Append (Result, "Setcur (" & Str_NP (E.Var) & ')'); + + when PC_Span_CH => + Append (Result, "Span ('" & E.Char & "')"); + + when PC_Span_CS => + Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Span_VF => + Append (Result, "Span (" & Str_VF (E.VF) & ')'); + + when PC_Span_VP => + Append (Result, "Span (" & Str_VP (E.VP) & ')'); + + when PC_String => + Append (Result, Image (E.Str.all)); + + when PC_String_2 => + Append (Result, Image (E.Str2)); + + when PC_String_3 => + Append (Result, Image (E.Str3)); + + when PC_String_4 => + Append (Result, Image (E.Str4)); + + when PC_String_5 => + Append (Result, Image (E.Str5)); + + when PC_String_6 => + Append (Result, Image (E.Str6)); + + when PC_String_VF => + Append (Result, "(+" & Str_VF (E.VF) & ')'); + + when PC_String_VP => + Append (Result, "(+" & Str_VP (E.VP) & ')'); + + when PC_Succeed => + Append (Result, "Succeed"); + + when PC_Tab_Nat => + Append (Result, "Tab (" & E.Nat & ')'); + + when PC_Tab_NF => + Append (Result, "Tab (" & Str_NF (E.NF) & ')'); + + when PC_Tab_NP => + Append (Result, "Tab (" & Str_NP (E.NP) & ')'); + + when PC_Write_Imm => + Append (Result, '('); + Image_Seq (E, Refs (E.Index - 1), True); + Append (Result, " * " & Str_FP (Refs (E.Index - 1).FP)); + ER := Refs (E.Index - 1).Pthen; + + when PC_Write_OnM => + Append (Result, '('); + Image_Seq (E.Pthen, Refs (E.Index - 1), True); + Append (Result, " ** " & Str_FP (Refs (E.Index - 1).FP)); + ER := Refs (E.Index - 1).Pthen; + + -- Other pattern codes should not appear as leading elements + + when PC_Arb_Y | + PC_Arbno_Y | + PC_Assign | + PC_BreakX_X | + PC_EOP | + PC_Fence_Y | + PC_R_Remove | + PC_R_Restore | + PC_Unanchored => + Append (Result, "???"); + + end case; + + E := ER; + end Image_One; + + --------------- + -- Image_Seq -- + --------------- + + procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is + E1 : PE_Ptr := E; + Mult : Boolean := False; + Indx : Natural := Length (Result); + + begin + -- The image of EOP is "" (the null string) + + if E = EOP then + Append (Result, """"""); + + -- Else generate appropriate concatenation sequence + + else + loop + Image_One (E1); + exit when E1 = Succ; + exit when E1 = EOP; + Mult := True; + + if Kill_Ampersand then + Kill_Ampersand := False; + else + Append (Result, " & "); + end if; + end loop; + end if; + + if Mult and Paren then + Insert (Result, Indx + 1, "("); + Append (Result, ")"); + end if; + end Image_Seq; + + -- Start of processing for Image + + begin + Build_Ref_Array (P.P, Refs); + Image_Seq (P.P, EOP, False); + return Result; + end Image; + + ----------- + -- Is_In -- + ----------- + + function Is_In (C : Character; Str : String) return Boolean is + begin + for J in Str'Range loop + if Str (J) = C then + return True; + end if; + end loop; + + return False; + end Is_In; + + --------- + -- Len -- + --------- + + function Len (Count : Natural) return Pattern is + begin + -- Note, the following is not just an optimization, it is needed + -- to ensure that Arbno (Len (0)) does not generate an infinite + -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno). + + if Count = 0 then + return (AFC with 0, new PE'(PC_Null, 1, EOP)); + + else + return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count)); + end if; + end Len; + + function Len (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count)); + end Len; + + function Len (Count : access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count))); + end Len; + + ----------------- + -- Logic_Error -- + ----------------- + + procedure Logic_Error is + begin + Raise_Exception + (Program_Error'Identity, + "Internal logic error in GNAT.Spitbol.Patterns"); + end Logic_Error; + + ----------- + -- Match -- + ----------- + + function Match + (Subject : VString; + Pat : Pattern) + return Boolean + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + return Start /= 0; + end Match; + + function Match + (Subject : String; + Pat : Pattern) + return Boolean + is + Start, Stop : Natural; + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + end if; + + return Start /= 0; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : VString) + return Boolean + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, + Start, Stop, Get_String (Replace).all); + return True; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : String) + return Boolean + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, Replace); + return True; + end if; + end Match; + + procedure Match + (Subject : VString; + Pat : Pattern) + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + end Match; + + procedure Match + (Subject : String; + Pat : Pattern) + is + Start, Stop : Natural; + subtype String1 is String (1 .. Subject'Length); + begin + if Debug_Mode then + XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : VString) + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Get_String (Replace).all); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : String) + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Replace); + end if; + end Match; + + function Match + (Subject : VString; + Pat : PString) + return Boolean + is + Pat_Len : constant Natural := Pat'Length; + Sub_Len : constant Natural := Length (Subject); + Sub_Str : constant String_Access := Get_String (Subject); + + begin + if Anchored_Mode then + if Pat_Len > Sub_Len then + return False; + else + return Pat = Sub_Str.all (1 .. Pat_Len); + end if; + + else + for J in 1 .. Sub_Len - Pat_Len + 1 loop + if Pat = Sub_Str.all (J .. J + (Pat_Len - 1)) then + return True; + end if; + end loop; + + return False; + end if; + end Match; + + function Match + (Subject : String; + Pat : PString) + return Boolean + is + Pat_Len : constant Natural := Pat'Length; + Sub_Len : constant Natural := Subject'Length; + SFirst : constant Natural := Subject'First; + + begin + if Anchored_Mode then + if Pat_Len > Sub_Len then + return False; + else + return Pat = Subject (SFirst .. SFirst + Pat_Len - 1); + end if; + + else + for J in SFirst .. SFirst + Sub_Len - Pat_Len loop + if Pat = Subject (J .. J + (Pat_Len - 1)) then + return True; + end if; + end loop; + + return False; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : VString) + return Boolean + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + else + XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, + Start, Stop, Get_String (Replace).all); + return True; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : String) + return Boolean + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + else + XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, Replace); + return True; + end if; + end Match; + + procedure Match + (Subject : VString; + Pat : PString) + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + else + XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : String; + Pat : PString) + is + Start, Stop : Natural; + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : VString) + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + else + XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Get_String (Replace).all); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : String) + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + else + XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Replace); + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Result : Match_Result_Var) + return Boolean + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + Result'Unrestricted_Access.all.Var := null; + return False; + + else + Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access; + Result'Unrestricted_Access.all.Start := Start; + Result'Unrestricted_Access.all.Stop := Stop; + return True; + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Result : out Match_Result) + is + Start, Stop : Natural; + + begin + if Debug_Mode then + XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + else + XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + Result.Var := null; + + else + Result.Var := Subject'Unrestricted_Access; + Result.Start := Start; + Result.Stop := Stop; + end if; + end Match; + + --------------- + -- New_LineD -- + --------------- + + procedure New_LineD is + begin + if Internal_Debug then + New_Line; + end if; + end New_LineD; + + ------------ + -- NotAny -- + ------------ + + function NotAny (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str))); + end NotAny; + + function NotAny (Str : VString) return Pattern is + begin + return NotAny (S (Str)); + end NotAny; + + function NotAny (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str)); + end NotAny; + + function NotAny (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str)); + end NotAny; + + function NotAny (Str : access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str))); + end NotAny; + + function NotAny (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str)); + end NotAny; + + ----------- + -- NSpan -- + ----------- + + function NSpan (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str))); + end NSpan; + + function NSpan (Str : VString) return Pattern is + begin + return NSpan (S (Str)); + end NSpan; + + function NSpan (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str)); + end NSpan; + + function NSpan (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str)); + end NSpan; + + function NSpan (Str : access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str))); + end NSpan; + + function NSpan (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str)); + end NSpan; + + --------- + -- Pos -- + --------- + + function Pos (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count)); + end Pos; + + function Pos (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count)); + end Pos; + + function Pos (Count : access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count))); + end Pos; + + ---------- + -- PutD -- + ---------- + + procedure PutD (Str : String) is + begin + if Internal_Debug then + Put (Str); + end if; + end PutD; + + --------------- + -- Put_LineD -- + --------------- + + procedure Put_LineD (Str : String) is + begin + if Internal_Debug then + Put_Line (Str); + end if; + end Put_LineD; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Result : in out Match_Result; + Replace : VString) + is + begin + if Result.Var /= null then + Replace_Slice + (Result.Var.all, + Result.Start, + Result.Stop, + Get_String (Replace).all); + Result.Var := null; + end if; + end Replace; + + ---------- + -- Rest -- + ---------- + + function Rest return Pattern is + begin + return (AFC with 0, new PE'(PC_Rest, 1, EOP)); + end Rest; + + ---------- + -- Rpos -- + ---------- + + function Rpos (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count)); + end Rpos; + + function Rpos (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count)); + end Rpos; + + function Rpos (Count : access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count))); + end Rpos; + + ---------- + -- Rtab -- + ---------- + + function Rtab (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count)); + end Rtab; + + function Rtab (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count)); + end Rtab; + + function Rtab (Count : access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count))); + end Rtab; + + ------------- + -- S_To_PE -- + ------------- + + function S_To_PE (Str : PString) return PE_Ptr is + Len : constant Natural := Str'Length; + + begin + case Len is + when 0 => + return new PE'(PC_Null, 1, EOP); + + when 1 => + return new PE'(PC_Char, 1, EOP, Str (1)); + + when 2 => + return new PE'(PC_String_2, 1, EOP, Str); + + when 3 => + return new PE'(PC_String_3, 1, EOP, Str); + + when 4 => + return new PE'(PC_String_4, 1, EOP, Str); + + when 5 => + return new PE'(PC_String_5, 1, EOP, Str); + + when 6 => + return new PE'(PC_String_6, 1, EOP, Str); + + when others => + return new PE'(PC_String, 1, EOP, new String'(Str)); + + end case; + end S_To_PE; + + ------------------- + -- Set_Successor -- + ------------------- + + -- Note: this procedure is not used by the normal concatenation circuit, + -- since other fixups are required on the left operand in this case, and + -- they might as well be done all together. + + procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is + begin + if Pat = null then + Uninitialized_Pattern; + + elsif Pat = EOP then + Logic_Error; + + else + declare + Refs : Ref_Array (1 .. Pat.Index); + -- We build a reference array for L whose N'th element points to + -- the pattern element of L whose original Index value is N. + + P : PE_Ptr; + + begin + Build_Ref_Array (Pat, Refs); + + for J in Refs'Range loop + P := Refs (J); + + if P.Pthen = EOP then + P.Pthen := Succ; + end if; + + if P.Pcode in PC_Has_Alt and then P.Alt = EOP then + P.Alt := Succ; + end if; + end loop; + end; + end if; + end Set_Successor; + + ------------ + -- Setcur -- + ------------ + + function Setcur (Var : access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var))); + end Setcur; + + ---------- + -- Span -- + ---------- + + function Span (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str))); + end Span; + + function Span (Str : VString) return Pattern is + begin + return Span (S (Str)); + end Span; + + function Span (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str)); + end Span; + + function Span (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str)); + end Span; + + function Span (Str : access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str))); + end Span; + + function Span (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str)); + end Span; + + ------------ + -- Str_BF -- + ------------ + + function Str_BF (A : Boolean_Func) return String is + function To_A is new Unchecked_Conversion (Boolean_Func, Address); + + begin + return "BF(" & Image (To_A (A)) & ')'; + end Str_BF; + + ------------ + -- Str_FP -- + ------------ + + function Str_FP (A : File_Ptr) return String is + begin + return "FP(" & Image (A.all'Address) & ')'; + end Str_FP; + + ------------ + -- Str_NF -- + ------------ + + function Str_NF (A : Natural_Func) return String is + function To_A is new Unchecked_Conversion (Natural_Func, Address); + + begin + return "NF(" & Image (To_A (A)) & ')'; + end Str_NF; + + ------------ + -- Str_NP -- + ------------ + + function Str_NP (A : Natural_Ptr) return String is + begin + return "NP(" & Image (A.all'Address) & ')'; + end Str_NP; + + ------------ + -- Str_PP -- + ------------ + + function Str_PP (A : Pattern_Ptr) return String is + begin + return "PP(" & Image (A.all'Address) & ')'; + end Str_PP; + + ------------ + -- Str_VF -- + ------------ + + function Str_VF (A : VString_Func) return String is + function To_A is new Unchecked_Conversion (VString_Func, Address); + + begin + return "VF(" & Image (To_A (A)) & ')'; + end Str_VF; + + ------------ + -- Str_VP -- + ------------ + + function Str_VP (A : VString_Ptr) return String is + begin + return "VP(" & Image (A.all'Address) & ')'; + end Str_VP; + + ------------- + -- Succeed -- + ------------- + + function Succeed return Pattern is + begin + return (AFC with 1, new PE'(PC_Succeed, 1, EOP)); + end Succeed; + + --------- + -- Tab -- + --------- + + function Tab (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count)); + end Tab; + + function Tab (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count)); + end Tab; + + function Tab (Count : access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count))); + end Tab; + + --------------------------- + -- Uninitialized_Pattern -- + --------------------------- + + procedure Uninitialized_Pattern is + begin + Raise_Exception + (Program_Error'Identity, + "uninitialized value of type GNAT.Spitbol.Patterns.Pattern"); + end Uninitialized_Pattern; + + ------------ + -- XMatch -- + ------------ + + procedure XMatch + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural) + is + Node : PE_Ptr; + -- Pointer to current pattern node. Initialized from Pat_P, and then + -- updated as the match proceeds through its constituent elements. + + Length : constant Natural := Subject'Length; + -- Length of string (= Subject'Last, since Subject'First is always 1) + + Cursor : Integer := 0; + -- If the value is non-negative, then this value is the index showing + -- the current position of the match in the subject string. The next + -- character to be matched is at Subject (Cursor + 1). Note that since + -- our view of the subject string in XMatch always has a lower bound + -- of one, regardless of original bounds, that this definition exactly + -- corresponds to the cursor value as referenced by functions like Pos. + -- + -- If the value is negative, then this is a saved stack pointer, + -- typically a base pointer of an inner or outer region. Cursor + -- temporarily holds such a value when it is popped from the stack + -- by Fail. In all cases, Cursor is reset to a proper non-negative + -- cursor value before the match proceeds (e.g. by propagating the + -- failure and popping a "real" cursor value from the stack. + + PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); + -- Dummy pattern element used in the unanchored case. + + Stack : Stack_Type; + -- The pattern matching failure stack for this call to Match + + Stack_Ptr : Stack_Range; + -- Current stack pointer. This points to the top element of the stack + -- that is currently in use. At the outer level this is the special + -- entry placed on the stack according to the anchor mode. + + Stack_Init : constant Stack_Range := Stack'First + 1; + -- This is the initial value of the Stack_Ptr and Stack_Base. The + -- initial (Stack'First) element of the stack is not used so that + -- when we pop the last element off, Stack_Ptr is still in range. + + Stack_Base : Stack_Range; + -- This value is the stack base value, i.e. the stack pointer for the + -- first history stack entry in the current stack region. See separate + -- section on handling of recursive pattern matches. + + Assign_OnM : Boolean := False; + -- Set True if assign-on-match or write-on-match operations may be + -- present in the history stack, which must then be scanned on a + -- successful match. + + procedure Pop_Region; + pragma Inline (Pop_Region); + -- Used at the end of processing of an inner region. if the inner + -- region left no stack entries, then all trace of it is removed. + -- Otherwise a PC_Restore_Region entry is pushed to ensure proper + -- handling of alternatives in the inner region. + + procedure Push (Node : PE_Ptr); + pragma Inline (Push); + -- Make entry in pattern matching stack with current cursor valeu + + procedure Push_Region; + pragma Inline (Push_Region); + -- This procedure makes a new region on the history stack. The + -- caller first establishes the special entry on the stack, but + -- does not push the stack pointer. Then this call stacks a + -- PC_Remove_Region node, on top of this entry, using the cursor + -- field of the PC_Remove_Region entry to save the outer level + -- stack base value, and resets the stack base to point to this + -- PC_Remove_Region node. + + ---------------- + -- Pop_Region -- + ---------------- + + procedure Pop_Region is + begin + -- If nothing was pushed in the inner region, we can just get + -- rid of it entirely, leaving no traces that it was ever there + + if Stack_Ptr = Stack_Base then + Stack_Ptr := Stack_Base - 2; + Stack_Base := Stack (Stack_Ptr + 2).Cursor; + + -- If stuff was pushed in the inner region, then we have to + -- push a PC_R_Restore node so that we properly handle possible + -- rematches within the region. + + else + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Restore'Access; + Stack_Base := Stack (Stack_Base).Cursor; + end if; + end Pop_Region; + + ---------- + -- Push -- + ---------- + + procedure Push (Node : PE_Ptr) is + begin + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Cursor; + Stack (Stack_Ptr).Node := Node; + end Push; + + ----------------- + -- Push_Region -- + ----------------- + + procedure Push_Region is + begin + Stack_Ptr := Stack_Ptr + 2; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Remove'Access; + Stack_Base := Stack_Ptr; + end Push_Region; + + -- Start of processing for XMatch + + begin + if Pat_P = null then + Uninitialized_Pattern; + end if; + + -- Check we have enough stack for this pattern. This check deals with + -- every possibility except a match of a recursive pattern, where we + -- make a check at each recursion level. + + if Pat_S >= Stack_Size - 1 then + raise Pattern_Stack_Overflow; + end if; + + -- In anchored mode, the bottom entry on the stack is an abort entry + + if Anchored_Mode then + Stack (Stack_Init).Node := CP_Cancel'Access; + Stack (Stack_Init).Cursor := 0; + + -- In unanchored more, the bottom entry on the stack references + -- the special pattern element PE_Unanchored, whose Pthen field + -- points to the initial pattern element. The cursor value in this + -- entry is the number of anchor moves so far. + + else + Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; + Stack (Stack_Init).Cursor := 0; + end if; + + Stack_Ptr := Stack_Init; + Stack_Base := Stack_Ptr; + Cursor := 0; + Node := Pat_P; + goto Match; + + ----------------------------------------- + -- Main Pattern Matching State Control -- + ----------------------------------------- + + -- This is a state machine which uses gotos to change state. The + -- initial state is Match, to initiate the matching of the first + -- element, so the goto Match above starts the match. In the + -- following descriptions, we indicate the global values that + -- are relevant for the state transition. + + -- Come here if entire match fails + + <<Match_Fail>> + Start := 0; + Stop := 0; + return; + + -- Come here if entire match succeeds + + -- Cursor current position in subject string + + <<Match_Succeed>> + Start := Stack (Stack_Init).Cursor + 1; + Stop := Cursor; + + -- Scan history stack for deferred assignments or writes + + if Assign_OnM then + for S in Stack_Init .. Stack_Ptr loop + if Stack (S).Node = CP_Assign'Access then + declare + Inner_Base : constant Stack_Range := + Stack (S + 1).Cursor; + Special_Entry : constant Stack_Range := + Inner_Base - 1; + Node_OnM : constant PE_Ptr := + Stack (Special_Entry).Node; + Start : constant Natural := + Stack (Special_Entry).Cursor + 1; + Stop : constant Natural := Stack (S).Cursor; + + begin + if Node_OnM.Pcode = PC_Assign_OnM then + Set_String (Node_OnM.VP.all, Subject (Start .. Stop)); + + elsif Node_OnM.Pcode = PC_Write_OnM then + Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); + + else + Logic_Error; + end if; + end; + end if; + end loop; + end if; + + return; + + -- Come here if attempt to match current element fails + + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <<Fail>> + Cursor := Stack (Stack_Ptr).Cursor; + Node := Stack (Stack_Ptr).Node; + Stack_Ptr := Stack_Ptr - 1; + goto Match; + + -- Come here if attempt to match current element succeeds + + -- Cursor current position in subject string + -- Node pointer to node successfully matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <<Succeed>> + Node := Node.Pthen; + + -- Come here to match the next pattern element + + -- Cursor current position in subject string + -- Node pointer to node to be matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <<Match>> + + -------------------------------------------------- + -- Main Pattern Match Element Matching Routines -- + -------------------------------------------------- + + -- Here is the case statement that processes the current node. The + -- processing for each element does one of five things: + + -- goto Succeed to move to the successor + -- goto Match_Succeed if the entire match succeeds + -- goto Match_Fail if the entire match fails + -- goto Fail to signal failure of current match + + -- Processing is NOT allowed to fall through + + case Node.Pcode is + + -- Cancel + + when PC_Cancel => + goto Match_Fail; + + -- Alternation + + when PC_Alt => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Any (one character case) + + when PC_Any_CH => + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (character set case) + + when PC_Any_CS => + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (string function case) + + when PC_Any_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Any (string pointer case) + + when PC_Any_VP => declare + Str : constant String_Access := Get_String (Node.VP.all); + + begin + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Arb (initial match) + + when PC_Arb_X => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arb (extension) + + when PC_Arb_Y => + if Cursor < Length then + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + else + goto Fail; + end if; + + -- Arbno_S (simple Arbno initialize). This is the node that + -- initiates the match of a simple Arbno structure. + + when PC_Arbno_S => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_X (Arbno initialize). This is the node that initiates + -- the match of a complex Arbno structure. + + when PC_Arbno_X => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_Y (Arbno rematch). This is the node that is executed + -- following successful matching of one instance of a complex + -- Arbno pattern. + + when PC_Arbno_Y => declare + Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor); + + begin + Pop_Region; + + -- If arbno extension matched null, then immediately fail + + if Null_Match then + goto Fail; + end if; + + -- Here we must do a stack check to make sure enough stack + -- is left. This check will happen once for each instance of + -- the Arbno pattern that is matched. The Nat field of a + -- PC_Arbno pattern contains the maximum stack entries needed + -- for the Arbno with one instance and the successor pattern + + if Stack_Ptr + Node.Nat >= Stack'Last then + raise Pattern_Stack_Overflow; + end if; + + goto Succeed; + end; + + -- Assign. If this node is executed, it means the assign-on-match + -- or write-on-match operation will not happen after all, so we + -- is propagate the failure, removing the PC_Assign node. + + when PC_Assign => + goto Fail; + + -- Assign immediate. This node performs the actual assignment. + + when PC_Assign_Imm => + Set_String + (Node.VP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Assign on match. This node sets up for the eventual assignment + + when PC_Assign_OnM => + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + -- Bal + + when PC_Bal => + if Cursor >= Length or else Subject (Cursor + 1) = ')' then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + declare + Paren_Count : Natural := 1; + + begin + loop + Cursor := Cursor + 1; + + if Cursor >= Length then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + Paren_Count := Paren_Count + 1; + + elsif Subject (Cursor + 1) = ')' then + Paren_Count := Paren_Count - 1; + exit when Paren_Count = 0; + end if; + end loop; + end; + end if; + + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + + -- Break (one character case) + + when PC_Break_CH => + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (character set case) + + when PC_Break_CS => + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (string function case) + + when PC_Break_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- Break (string pointer case) + + when PC_Break_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (one character case) + + when PC_BreakX_CH => + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (character set case) + + when PC_BreakX_CS => + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (string function case) + + when PC_BreakX_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (string pointer case) + + when PC_BreakX_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX_X (BreakX extension). See section on "Compound Pattern + -- Structures". This node is the alternative that is stacked to + -- skip past the break character and extend the break. + + when PC_BreakX_X => + Cursor := Cursor + 1; + goto Succeed; + + -- Character (one character string) + + when PC_Char => + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- End of Pattern + + when PC_EOP => + if Stack_Base = Stack_Init then + goto Match_Succeed; + + -- End of recursive inner match. See separate section on + -- handing of recursive pattern matches for details. + + else + Node := Stack (Stack_Base - 1).Node; + Pop_Region; + goto Match; + end if; + + -- Fail + + when PC_Fail => + goto Fail; + + -- Fence (built in pattern) + + when PC_Fence => + Push (CP_Cancel'Access); + goto Succeed; + + -- Fence function node X. This is the node that gets control + -- after a successful match of the fenced pattern. + + when PC_Fence_X => + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_Fence_Y'Access; + Stack_Base := Stack (Stack_Base).Cursor; + goto Succeed; + + -- Fence function node Y. This is the node that gets control on + -- a failure that occurs after the fenced pattern has matched. + + -- Note: the Cursor at this stage is actually the inner stack + -- base value. We don't reset this, but we do use it to strip + -- off all the entries made by the fenced pattern. + + when PC_Fence_Y => + Stack_Ptr := Cursor - 2; + goto Fail; + + -- Len (integer case) + + when PC_Len_Nat => + if Cursor + Node.Nat > Length then + goto Fail; + else + Cursor := Cursor + Node.Nat; + goto Succeed; + end if; + + -- Len (Integer function case) + + when PC_Len_NF => declare + N : constant Natural := Node.NF.all; + + begin + if Cursor + N > Length then + goto Fail; + else + Cursor := Cursor + N; + goto Succeed; + end if; + end; + + -- Len (integer pointer case) + + when PC_Len_NP => + if Cursor + Node.NP.all > Length then + goto Fail; + else + Cursor := Cursor + Node.NP.all; + goto Succeed; + end if; + + -- NotAny (one character case) + + when PC_NotAny_CH => + if Cursor < Length + and then Subject (Cursor + 1) /= Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (character set case) + + when PC_NotAny_CS => + if Cursor < Length + and then not Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (string function case) + + when PC_NotAny_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NotAny (string pointer case) + + when PC_NotAny_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NSpan (one character case) + + when PC_NSpan_CH => + while Cursor < Length + and then Subject (Cursor + 1) = Node.Char + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (character set case) + + when PC_NSpan_CS => + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (string function case) + + when PC_NSpan_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- NSpan (string pointer case) + + when PC_NSpan_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- Null string + + when PC_Null => + goto Succeed; + + -- Pos (integer case) + + when PC_Pos_Nat => + if Cursor = Node.Nat then + goto Succeed; + else + goto Fail; + end if; + + -- Pos (Integer function case) + + when PC_Pos_NF => declare + N : constant Natural := Node.NF.all; + + begin + if Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- Pos (integer pointer case) + + when PC_Pos_NP => + if Cursor = Node.NP.all then + goto Succeed; + else + goto Fail; + end if; + + -- Predicate function + + when PC_Pred_Func => + if Node.BF.all then + goto Succeed; + else + goto Fail; + end if; + + -- Region Enter. Initiate new pattern history stack region + + when PC_R_Enter => + Stack (Stack_Ptr + 1).Cursor := Cursor; + Push_Region; + goto Succeed; + + -- Region Remove node. This is the node stacked by an R_Enter. + -- It removes the special format stack entry right underneath, and + -- then restores the outer level stack base and signals failure. + + -- Note: the cursor value at this stage is actually the (negative) + -- stack base value for the outer level. + + when PC_R_Remove => + Stack_Base := Cursor; + Stack_Ptr := Stack_Ptr - 1; + goto Fail; + + -- Region restore node. This is the node stacked at the end of an + -- inner level match. Its function is to restore the inner level + -- region, so that alternatives in this region can be sought. + + -- Note: the Cursor at this stage is actually the negative of the + -- inner stack base value, which we use to restore the inner region. + + when PC_R_Restore => + Stack_Base := Cursor; + goto Fail; + + -- Rest + + when PC_Rest => + Cursor := Length; + goto Succeed; + + -- Initiate recursive match (pattern pointer case) + + when PC_Rpat => + Stack (Stack_Ptr + 1).Node := Node.Pthen; + Push_Region; + + if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then + raise Pattern_Stack_Overflow; + else + Node := Node.PP.all.P; + goto Match; + end if; + + -- RPos (integer case) + + when PC_RPos_Nat => + if Cursor = (Length - Node.Nat) then + goto Succeed; + else + goto Fail; + end if; + + -- RPos (integer function case) + + when PC_RPos_NF => declare + N : constant Natural := Node.NF.all; + + begin + if Length - Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- RPos (integer pointer case) + + when PC_RPos_NP => + if Cursor = (Length - Node.NP.all) then + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer case) + + when PC_RTab_Nat => + if Cursor <= (Length - Node.Nat) then + Cursor := Length - Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer function case) + + when PC_RTab_NF => declare + N : constant Natural := Node.NF.all; + + begin + if Length - Cursor >= N then + Cursor := Length - N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- RTab (integer pointer case) + + when PC_RTab_NP => + if Cursor <= (Length - Node.NP.all) then + Cursor := Length - Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Cursor assignment + + when PC_Setcur => + Node.Var.all := Cursor; + goto Succeed; + + -- Span (one character case) + + when PC_Span_CH => declare + P : Natural := Cursor; + + begin + while P < Length + and then Subject (P + 1) = Node.Char + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (character set case) + + when PC_Span_CS => declare + P : Natural := Cursor; + + begin + while P < Length + and then Is_In (Subject (P + 1), Node.CS) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string function case) + + when PC_Span_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + P : Natural := Cursor; + + begin + while P < Length + and then Is_In (Subject (P + 1), Str.all) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string pointer case) + + when PC_Span_VP => declare + Str : String_Access := Get_String (Node.VP.all); + P : Natural := Cursor; + + begin + while P < Length + and then Is_In (Subject (P + 1), Str.all) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (two character case) + + when PC_String_2 => + if (Length - Cursor) >= 2 + and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 + then + Cursor := Cursor + 2; + goto Succeed; + else + goto Fail; + end if; + + -- String (three character case) + + when PC_String_3 => + if (Length - Cursor) >= 3 + and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 + then + Cursor := Cursor + 3; + goto Succeed; + else + goto Fail; + end if; + + -- String (four character case) + + when PC_String_4 => + if (Length - Cursor) >= 4 + and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 + then + Cursor := Cursor + 4; + goto Succeed; + else + goto Fail; + end if; + + -- String (five character case) + + when PC_String_5 => + if (Length - Cursor) >= 5 + and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 + then + Cursor := Cursor + 5; + goto Succeed; + else + goto Fail; + end if; + + -- String (six character case) + + when PC_String_6 => + if (Length - Cursor) >= 6 + and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 + then + Cursor := Cursor + 6; + goto Succeed; + else + goto Fail; + end if; + + -- String (case of more than six characters) + + when PC_String => declare + Len : constant Natural := Node.Str'Length; + + begin + if (Length - Cursor) >= Len + and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (function case) + + when PC_String_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + Len : constant Natural := Str'Length; + + begin + if (Length - Cursor) >= Len + and then Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (pointer case) + + when PC_String_VP => declare + S : String_Access := Get_String (Node.VP.all); + Len : constant Natural := S'Length; + + begin + if (Length - Cursor) >= Len + and then S.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Succeed + + when PC_Succeed => + Push (Node); + goto Succeed; + + -- Tab (integer case) + + when PC_Tab_Nat => + if Cursor <= Node.Nat then + Cursor := Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- Tab (integer function case) + + when PC_Tab_NF => declare + N : constant Natural := Node.NF.all; + + begin + if Cursor <= N then + Cursor := N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Tab (integer pointer case) + + when PC_Tab_NP => + if Cursor <= Node.NP.all then + Cursor := Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Unanchored movement + + when PC_Unanchored => + + -- All done if we tried every position + + if Cursor > Length then + goto Match_Fail; + + -- Otherwise extend the anchor point, and restack ourself + + else + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + end if; + + -- Write immediate. This node performs the actual write + + when PC_Write_Imm => + Put_Line + (Node.FP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Write on match. This node sets up for the eventual write + + when PC_Write_OnM => + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + end case; + + -- We are NOT allowed to fall though this case statement, since every + -- match routine must end by executing a goto to the appropriate point + -- in the finite state machine model. + + Logic_Error; + + end XMatch; + + ------------- + -- XMatchD -- + ------------- + + -- Maintenance note: There is a LOT of code duplication between XMatch + -- and XMatchD. This is quite intentional, the point is to avoid any + -- unnecessary debugging overhead in the XMatch case, but this does mean + -- that any changes to XMatchD must be mirrored in XMatch. In case of + -- any major changes, the proper approach is to delete XMatch, make the + -- changes to XMatchD, and then make a copy of XMatchD, removing all + -- calls to Dout, and all Put and Put_Line operations. This copy becomes + -- the new XMatch. + + procedure XMatchD + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural) + is + Node : PE_Ptr; + -- Pointer to current pattern node. Initialized from Pat_P, and then + -- updated as the match proceeds through its constituent elements. + + Length : constant Natural := Subject'Length; + -- Length of string (= Subject'Last, since Subject'First is always 1) + + Cursor : Integer := 0; + -- If the value is non-negative, then this value is the index showing + -- the current position of the match in the subject string. The next + -- character to be matched is at Subject (Cursor + 1). Note that since + -- our view of the subject string in XMatch always has a lower bound + -- of one, regardless of original bounds, that this definition exactly + -- corresponds to the cursor value as referenced by functions like Pos. + -- + -- If the value is negative, then this is a saved stack pointer, + -- typically a base pointer of an inner or outer region. Cursor + -- temporarily holds such a value when it is popped from the stack + -- by Fail. In all cases, Cursor is reset to a proper non-negative + -- cursor value before the match proceeds (e.g. by propagating the + -- failure and popping a "real" cursor value from the stack. + + PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); + -- Dummy pattern element used in the unanchored case. + + Region_Level : Natural := 0; + -- Keeps track of recursive region level. This is used only for + -- debugging, it is the number of saved history stack base values. + + Stack : Stack_Type; + -- The pattern matching failure stack for this call to Match + + Stack_Ptr : Stack_Range; + -- Current stack pointer. This points to the top element of the stack + -- that is currently in use. At the outer level this is the special + -- entry placed on the stack according to the anchor mode. + + Stack_Init : constant Stack_Range := Stack'First + 1; + -- This is the initial value of the Stack_Ptr and Stack_Base. The + -- initial (Stack'First) element of the stack is not used so that + -- when we pop the last element off, Stack_Ptr is still in range. + + Stack_Base : Stack_Range; + -- This value is the stack base value, i.e. the stack pointer for the + -- first history stack entry in the current stack region. See separate + -- section on handling of recursive pattern matches. + + Assign_OnM : Boolean := False; + -- Set True if assign-on-match or write-on-match operations may be + -- present in the history stack, which must then be scanned on a + -- successful match. + + procedure Dout (Str : String); + -- Output string to standard error with bars indicating region level. + + procedure Dout (Str : String; A : Character); + -- Calls Dout with the string S ('A') + + procedure Dout (Str : String; A : Character_Set); + -- Calls Dout with the string S ("A") + + procedure Dout (Str : String; A : Natural); + -- Calls Dout with the string S (A) + + procedure Dout (Str : String; A : String); + -- Calls Dout with the string S ("A") + + function Img (P : PE_Ptr) return String; + -- Returns a string of the form #nnn where nnn is P.Index + + procedure Pop_Region; + pragma Inline (Pop_Region); + -- Used at the end of processing of an inner region. if the inner + -- region left no stack entries, then all trace of it is removed. + -- Otherwise a PC_Restore_Region entry is pushed to ensure proper + -- handling of alternatives in the inner region. + + procedure Push (Node : PE_Ptr); + pragma Inline (Push); + -- Make entry in pattern matching stack with current cursor valeu + + procedure Push_Region; + pragma Inline (Push_Region); + -- This procedure makes a new region on the history stack. The + -- caller first establishes the special entry on the stack, but + -- does not push the stack pointer. Then this call stacks a + -- PC_Remove_Region node, on top of this entry, using the cursor + -- field of the PC_Remove_Region entry to save the outer level + -- stack base value, and resets the stack base to point to this + -- PC_Remove_Region node. + + ---------- + -- Dout -- + ---------- + + procedure Dout (Str : String) is + begin + for J in 1 .. Region_Level loop + Put ("| "); + end loop; + + Put_Line (Str); + end Dout; + + procedure Dout (Str : String; A : Character) is + begin + Dout (Str & " ('" & A & "')"); + end Dout; + + procedure Dout (Str : String; A : Character_Set) is + begin + Dout (Str & " (" & Image (To_Sequence (A)) & ')'); + end Dout; + + procedure Dout (Str : String; A : Natural) is + begin + Dout (Str & " (" & A & ')'); + end Dout; + + procedure Dout (Str : String; A : String) is + begin + Dout (Str & " (" & Image (A) & ')'); + end Dout; + + --------- + -- Img -- + --------- + + function Img (P : PE_Ptr) return String is + begin + return "#" & Integer (P.Index) & " "; + end Img; + + ---------------- + -- Pop_Region -- + ---------------- + + procedure Pop_Region is + begin + Region_Level := Region_Level - 1; + + -- If nothing was pushed in the inner region, we can just get + -- rid of it entirely, leaving no traces that it was ever there + + if Stack_Ptr = Stack_Base then + Stack_Ptr := Stack_Base - 2; + Stack_Base := Stack (Stack_Ptr + 2).Cursor; + + -- If stuff was pushed in the inner region, then we have to + -- push a PC_R_Restore node so that we properly handle possible + -- rematches within the region. + + else + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Restore'Access; + Stack_Base := Stack (Stack_Base).Cursor; + end if; + end Pop_Region; + + ---------- + -- Push -- + ---------- + + procedure Push (Node : PE_Ptr) is + begin + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Cursor; + Stack (Stack_Ptr).Node := Node; + end Push; + + ----------------- + -- Push_Region -- + ----------------- + + procedure Push_Region is + begin + Region_Level := Region_Level + 1; + Stack_Ptr := Stack_Ptr + 2; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Remove'Access; + Stack_Base := Stack_Ptr; + end Push_Region; + + -- Start of processing for XMatchD + + begin + New_Line; + Put_Line ("Initiating pattern match, subject = " & Image (Subject)); + Put ("--------------------------------------"); + + for J in 1 .. Length loop + Put ('-'); + end loop; + + New_Line; + Put_Line ("subject length = " & Length); + + if Pat_P = null then + Uninitialized_Pattern; + end if; + + -- Check we have enough stack for this pattern. This check deals with + -- every possibility except a match of a recursive pattern, where we + -- make a check at each recursion level. + + if Pat_S >= Stack_Size - 1 then + raise Pattern_Stack_Overflow; + end if; + + -- In anchored mode, the bottom entry on the stack is an abort entry + + if Anchored_Mode then + Stack (Stack_Init).Node := CP_Cancel'Access; + Stack (Stack_Init).Cursor := 0; + + -- In unanchored more, the bottom entry on the stack references + -- the special pattern element PE_Unanchored, whose Pthen field + -- points to the initial pattern element. The cursor value in this + -- entry is the number of anchor moves so far. + + else + Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; + Stack (Stack_Init).Cursor := 0; + end if; + + Stack_Ptr := Stack_Init; + Stack_Base := Stack_Ptr; + Cursor := 0; + Node := Pat_P; + goto Match; + + ----------------------------------------- + -- Main Pattern Matching State Control -- + ----------------------------------------- + + -- This is a state machine which uses gotos to change state. The + -- initial state is Match, to initiate the matching of the first + -- element, so the goto Match above starts the match. In the + -- following descriptions, we indicate the global values that + -- are relevant for the state transition. + + -- Come here if entire match fails + + <<Match_Fail>> + Dout ("match fails"); + New_Line; + Start := 0; + Stop := 0; + return; + + -- Come here if entire match succeeds + + -- Cursor current position in subject string + + <<Match_Succeed>> + Dout ("match succeeds"); + Start := Stack (Stack_Init).Cursor + 1; + Stop := Cursor; + Dout ("first matched character index = " & Start); + Dout ("last matched character index = " & Stop); + Dout ("matched substring = " & Image (Subject (Start .. Stop))); + + -- Scan history stack for deferred assignments or writes + + if Assign_OnM then + for S in Stack'First .. Stack_Ptr loop + if Stack (S).Node = CP_Assign'Access then + declare + Inner_Base : constant Stack_Range := + Stack (S + 1).Cursor; + Special_Entry : constant Stack_Range := + Inner_Base - 1; + Node_OnM : constant PE_Ptr := + Stack (Special_Entry).Node; + Start : constant Natural := + Stack (Special_Entry).Cursor + 1; + Stop : constant Natural := Stack (S).Cursor; + + begin + if Node_OnM.Pcode = PC_Assign_OnM then + Set_String (Node_OnM.VP.all, Subject (Start .. Stop)); + Dout + (Img (Stack (S).Node) & + "deferred assignment of " & + Image (Subject (Start .. Stop))); + + elsif Node_OnM.Pcode = PC_Write_OnM then + Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); + Dout + (Img (Stack (S).Node) & + "deferred write of " & + Image (Subject (Start .. Stop))); + + else + Logic_Error; + end if; + end; + end if; + end loop; + end if; + + New_Line; + return; + + -- Come here if attempt to match current element fails + + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <<Fail>> + Cursor := Stack (Stack_Ptr).Cursor; + Node := Stack (Stack_Ptr).Node; + Stack_Ptr := Stack_Ptr - 1; + + if Cursor >= 0 then + Dout ("failure, cursor reset to " & Cursor); + end if; + + goto Match; + + -- Come here if attempt to match current element succeeds + + -- Cursor current position in subject string + -- Node pointer to node successfully matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <<Succeed>> + Dout ("success, cursor = " & Cursor); + Node := Node.Pthen; + + -- Come here to match the next pattern element + + -- Cursor current position in subject string + -- Node pointer to node to be matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <<Match>> + + -------------------------------------------------- + -- Main Pattern Match Element Matching Routines -- + -------------------------------------------------- + + -- Here is the case statement that processes the current node. The + -- processing for each element does one of five things: + + -- goto Succeed to move to the successor + -- goto Match_Succeed if the entire match succeeds + -- goto Match_Fail if the entire match fails + -- goto Fail to signal failure of current match + + -- Processing is NOT allowed to fall through + + case Node.Pcode is + + -- Cancel + + when PC_Cancel => + Dout (Img (Node) & "matching Cancel"); + goto Match_Fail; + + -- Alternation + + when PC_Alt => + Dout + (Img (Node) & "setting up alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Any (one character case) + + when PC_Any_CH => + Dout (Img (Node) & "matching Any", Node.Char); + + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (character set case) + + when PC_Any_CS => + Dout (Img (Node) & "matching Any", Node.CS); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (string function case) + + when PC_Any_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + Dout (Img (Node) & "matching Any", Str.all); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Any (string pointer case) + + when PC_Any_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + Dout (Img (Node) & "matching Any", Str.all); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Arb (initial match) + + when PC_Arb_X => + Dout (Img (Node) & "matching Arb"); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arb (extension) + + when PC_Arb_Y => + Dout (Img (Node) & "extending Arb"); + + if Cursor < Length then + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + else + goto Fail; + end if; + + -- Arbno_S (simple Arbno initialize). This is the node that + -- initiates the match of a simple Arbno structure. + + when PC_Arbno_S => + Dout (Img (Node) & + "setting up Arbno alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_X (Arbno initialize). This is the node that initiates + -- the match of a complex Arbno structure. + + when PC_Arbno_X => + Dout (Img (Node) & + "setting up Arbno alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_Y (Arbno rematch). This is the node that is executed + -- following successful matching of one instance of a complex + -- Arbno pattern. + + when PC_Arbno_Y => declare + Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor); + + begin + Dout (Img (Node) & "extending Arbno"); + Pop_Region; + + -- If arbno extension matched null, then immediately fail + + if Null_Match then + Dout ("Arbno extension matched null, so fails"); + goto Fail; + end if; + + -- Here we must do a stack check to make sure enough stack + -- is left. This check will happen once for each instance of + -- the Arbno pattern that is matched. The Nat field of a + -- PC_Arbno pattern contains the maximum stack entries needed + -- for the Arbno with one instance and the successor pattern + + if Stack_Ptr + Node.Nat >= Stack'Last then + raise Pattern_Stack_Overflow; + end if; + + goto Succeed; + end; + + -- Assign. If this node is executed, it means the assign-on-match + -- or write-on-match operation will not happen after all, so we + -- is propagate the failure, removing the PC_Assign node. + + when PC_Assign => + Dout (Img (Node) & "deferred assign/write cancelled"); + goto Fail; + + -- Assign immediate. This node performs the actual assignment. + + when PC_Assign_Imm => + Dout + (Img (Node) & "executing immediate assignment of " & + Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor))); + Set_String + (Node.VP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Assign on match. This node sets up for the eventual assignment + + when PC_Assign_OnM => + Dout (Img (Node) & "registering deferred assignment"); + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + -- Bal + + when PC_Bal => + Dout (Img (Node) & "matching or extending Bal"); + if Cursor >= Length or else Subject (Cursor + 1) = ')' then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + declare + Paren_Count : Natural := 1; + + begin + loop + Cursor := Cursor + 1; + + if Cursor >= Length then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + Paren_Count := Paren_Count + 1; + + elsif Subject (Cursor + 1) = ')' then + Paren_Count := Paren_Count - 1; + exit when Paren_Count = 0; + end if; + end loop; + end; + end if; + + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + + -- Break (one character case) + + when PC_Break_CH => + Dout (Img (Node) & "matching Break", Node.Char); + + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (character set case) + + when PC_Break_CS => + Dout (Img (Node) & "matching Break", Node.CS); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (string function case) + + when PC_Break_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + Dout (Img (Node) & "matching Break", Str.all); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- Break (string pointer case) + + when PC_Break_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + Dout (Img (Node) & "matching Break", Str.all); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (one character case) + + when PC_BreakX_CH => + Dout (Img (Node) & "matching BreakX", Node.Char); + + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (character set case) + + when PC_BreakX_CS => + Dout (Img (Node) & "matching BreakX", Node.CS); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (string function case) + + when PC_BreakX_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + Dout (Img (Node) & "matching BreakX", Str.all); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (string pointer case) + + when PC_BreakX_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + Dout (Img (Node) & "matching BreakX", Str.all); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Str.all) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX_X (BreakX extension). See section on "Compound Pattern + -- Structures". This node is the alternative that is stacked + -- to skip past the break character and extend the break. + + when PC_BreakX_X => + Dout (Img (Node) & "extending BreakX"); + + Cursor := Cursor + 1; + goto Succeed; + + -- Character (one character string) + + when PC_Char => + Dout (Img (Node) & "matching '" & Node.Char & '''); + + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- End of Pattern + + when PC_EOP => + if Stack_Base = Stack_Init then + Dout ("end of pattern"); + goto Match_Succeed; + + -- End of recursive inner match. See separate section on + -- handing of recursive pattern matches for details. + + else + Dout ("terminating recursive match"); + Node := Stack (Stack_Base - 1).Node; + Pop_Region; + goto Match; + end if; + + -- Fail + + when PC_Fail => + Dout (Img (Node) & "matching Fail"); + goto Fail; + + -- Fence (built in pattern) + + when PC_Fence => + Dout (Img (Node) & "matching Fence"); + Push (CP_Cancel'Access); + goto Succeed; + + -- Fence function node X. This is the node that gets control + -- after a successful match of the fenced pattern. + + when PC_Fence_X => + Dout (Img (Node) & "matching Fence function"); + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_Fence_Y'Access; + Stack_Base := Stack (Stack_Base).Cursor; + Region_Level := Region_Level - 1; + goto Succeed; + + -- Fence function node Y. This is the node that gets control on + -- a failure that occurs after the fenced pattern has matched. + + -- Note: the Cursor at this stage is actually the inner stack + -- base value. We don't reset this, but we do use it to strip + -- off all the entries made by the fenced pattern. + + when PC_Fence_Y => + Dout (Img (Node) & "pattern matched by Fence caused failure"); + Stack_Ptr := Cursor - 2; + goto Fail; + + -- Len (integer case) + + when PC_Len_Nat => + Dout (Img (Node) & "matching Len", Node.Nat); + + if Cursor + Node.Nat > Length then + goto Fail; + else + Cursor := Cursor + Node.Nat; + goto Succeed; + end if; + + -- Len (Integer function case) + + when PC_Len_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Len", N); + + if Cursor + N > Length then + goto Fail; + else + Cursor := Cursor + N; + goto Succeed; + end if; + end; + + -- Len (integer pointer case) + + when PC_Len_NP => + Dout (Img (Node) & "matching Len", Node.NP.all); + + if Cursor + Node.NP.all > Length then + goto Fail; + else + Cursor := Cursor + Node.NP.all; + goto Succeed; + end if; + + -- NotAny (one character case) + + when PC_NotAny_CH => + Dout (Img (Node) & "matching NotAny", Node.Char); + + if Cursor < Length + and then Subject (Cursor + 1) /= Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (character set case) + + when PC_NotAny_CS => + Dout (Img (Node) & "matching NotAny", Node.CS); + + if Cursor < Length + and then not Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (string function case) + + when PC_NotAny_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + Dout (Img (Node) & "matching NotAny", Str.all); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NotAny (string pointer case) + + when PC_NotAny_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + Dout (Img (Node) & "matching NotAny", Str.all); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), Str.all) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NSpan (one character case) + + when PC_NSpan_CH => + Dout (Img (Node) & "matching NSpan", Node.Char); + + while Cursor < Length + and then Subject (Cursor + 1) = Node.Char + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (character set case) + + when PC_NSpan_CS => + Dout (Img (Node) & "matching NSpan", Node.CS); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (string function case) + + when PC_NSpan_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + + begin + Dout (Img (Node) & "matching NSpan", Str.all); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- NSpan (string pointer case) + + when PC_NSpan_VP => declare + Str : String_Access := Get_String (Node.VP.all); + + begin + Dout (Img (Node) & "matching NSpan", Str.all); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Str.all) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + when PC_Null => + Dout (Img (Node) & "matching null"); + goto Succeed; + + -- Pos (integer case) + + when PC_Pos_Nat => + Dout (Img (Node) & "matching Pos", Node.Nat); + + if Cursor = Node.Nat then + goto Succeed; + else + goto Fail; + end if; + + -- Pos (Integer function case) + + when PC_Pos_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Pos", N); + + if Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- Pos (integer pointer case) + + when PC_Pos_NP => + Dout (Img (Node) & "matching Pos", Node.NP.all); + + if Cursor = Node.NP.all then + goto Succeed; + else + goto Fail; + end if; + + -- Predicate function + + when PC_Pred_Func => + Dout (Img (Node) & "matching predicate function"); + + if Node.BF.all then + goto Succeed; + else + goto Fail; + end if; + + -- Region Enter. Initiate new pattern history stack region + + when PC_R_Enter => + Dout (Img (Node) & "starting match of nested pattern"); + Stack (Stack_Ptr + 1).Cursor := Cursor; + Push_Region; + goto Succeed; + + -- Region Remove node. This is the node stacked by an R_Enter. + -- It removes the special format stack entry right underneath, and + -- then restores the outer level stack base and signals failure. + + -- Note: the cursor value at this stage is actually the (negative) + -- stack base value for the outer level. + + when PC_R_Remove => + Dout ("failure, match of nested pattern terminated"); + Stack_Base := Cursor; + Region_Level := Region_Level - 1; + Stack_Ptr := Stack_Ptr - 1; + goto Fail; + + -- Region restore node. This is the node stacked at the end of an + -- inner level match. Its function is to restore the inner level + -- region, so that alternatives in this region can be sought. + + -- Note: the Cursor at this stage is actually the negative of the + -- inner stack base value, which we use to restore the inner region. + + when PC_R_Restore => + Dout ("failure, search for alternatives in nested pattern"); + Region_Level := Region_Level + 1; + Stack_Base := Cursor; + goto Fail; + + -- Rest + + when PC_Rest => + Dout (Img (Node) & "matching Rest"); + Cursor := Length; + goto Succeed; + + -- Initiate recursive match (pattern pointer case) + + when PC_Rpat => + Stack (Stack_Ptr + 1).Node := Node.Pthen; + Push_Region; + Dout (Img (Node) & "initiating recursive match"); + + if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then + raise Pattern_Stack_Overflow; + else + Node := Node.PP.all.P; + goto Match; + end if; + + -- RPos (integer case) + + when PC_RPos_Nat => + Dout (Img (Node) & "matching RPos", Node.Nat); + + if Cursor = (Length - Node.Nat) then + goto Succeed; + else + goto Fail; + end if; + + -- RPos (integer function case) + + when PC_RPos_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching RPos", N); + + if Length - Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- RPos (integer pointer case) + + when PC_RPos_NP => + Dout (Img (Node) & "matching RPos", Node.NP.all); + + if Cursor = (Length - Node.NP.all) then + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer case) + + when PC_RTab_Nat => + Dout (Img (Node) & "matching RTab", Node.Nat); + + if Cursor <= (Length - Node.Nat) then + Cursor := Length - Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer function case) + + when PC_RTab_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching RPos", N); + + if Length - Cursor >= N then + Cursor := Length - N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- RTab (integer pointer case) + + when PC_RTab_NP => + Dout (Img (Node) & "matching RPos", Node.NP.all); + + if Cursor <= (Length - Node.NP.all) then + Cursor := Length - Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Cursor assignment + + when PC_Setcur => + Dout (Img (Node) & "matching Setcur"); + Node.Var.all := Cursor; + goto Succeed; + + -- Span (one character case) + + when PC_Span_CH => declare + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Node.Char); + + while P < Length + and then Subject (P + 1) = Node.Char + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (character set case) + + when PC_Span_CS => declare + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Node.CS); + + while P < Length + and then Is_In (Subject (P + 1), Node.CS) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string function case) + + when PC_Span_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Str.all); + + while P < Length + and then Is_In (Subject (P + 1), Str.all) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string pointer case) + + when PC_Span_VP => declare + Str : String_Access := Get_String (Node.VP.all); + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Str.all); + + while P < Length + and then Is_In (Subject (P + 1), Str.all) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (two character case) + + when PC_String_2 => + Dout (Img (Node) & "matching " & Image (Node.Str2)); + + if (Length - Cursor) >= 2 + and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 + then + Cursor := Cursor + 2; + goto Succeed; + else + goto Fail; + end if; + + -- String (three character case) + + when PC_String_3 => + Dout (Img (Node) & "matching " & Image (Node.Str3)); + + if (Length - Cursor) >= 3 + and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 + then + Cursor := Cursor + 3; + goto Succeed; + else + goto Fail; + end if; + + -- String (four character case) + + when PC_String_4 => + Dout (Img (Node) & "matching " & Image (Node.Str4)); + + if (Length - Cursor) >= 4 + and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 + then + Cursor := Cursor + 4; + goto Succeed; + else + goto Fail; + end if; + + -- String (five character case) + + when PC_String_5 => + Dout (Img (Node) & "matching " & Image (Node.Str5)); + + if (Length - Cursor) >= 5 + and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 + then + Cursor := Cursor + 5; + goto Succeed; + else + goto Fail; + end if; + + -- String (six character case) + + when PC_String_6 => + Dout (Img (Node) & "matching " & Image (Node.Str6)); + + if (Length - Cursor) >= 6 + and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 + then + Cursor := Cursor + 6; + goto Succeed; + else + goto Fail; + end if; + + -- String (case of more than six characters) + + when PC_String => declare + Len : constant Natural := Node.Str'Length; + + begin + Dout (Img (Node) & "matching " & Image (Node.Str.all)); + + if (Length - Cursor) >= Len + and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (function case) + + when PC_String_VF => declare + U : constant VString := Node.VF.all; + Str : constant String_Access := Get_String (U); + Len : constant Natural := Str'Length; + + begin + Dout (Img (Node) & "matching " & Image (Str.all)); + + if (Length - Cursor) >= Len + and then Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (vstring pointer case) + + when PC_String_VP => declare + S : String_Access := Get_String (Node.VP.all); + Len : constant Natural := + Ada.Strings.Unbounded.Length (Node.VP.all); + + begin + Dout + (Img (Node) & "matching " & Image (S.all)); + + if (Length - Cursor) >= Len + and then S.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Succeed + + when PC_Succeed => + Dout (Img (Node) & "matching Succeed"); + Push (Node); + goto Succeed; + + -- Tab (integer case) + + when PC_Tab_Nat => + Dout (Img (Node) & "matching Tab", Node.Nat); + + if Cursor <= Node.Nat then + Cursor := Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- Tab (integer function case) + + when PC_Tab_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Tab ", N); + + if Cursor <= N then + Cursor := N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Tab (integer pointer case) + + when PC_Tab_NP => + Dout (Img (Node) & "matching Tab ", Node.NP.all); + + if Cursor <= Node.NP.all then + Cursor := Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Unanchored movement + + when PC_Unanchored => + Dout ("attempting to move anchor point"); + + -- All done if we tried every position + + if Cursor > Length then + goto Match_Fail; + + -- Otherwise extend the anchor point, and restack ourself + + else + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + end if; + + -- Write immediate. This node performs the actual write + + when PC_Write_Imm => + Dout (Img (Node) & "executing immediate write of " & + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + + Put_Line + (Node.FP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Write on match. This node sets up for the eventual write + + when PC_Write_OnM => + Dout (Img (Node) & "registering deferred write"); + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + end case; + + -- We are NOT allowed to fall though this case statement, since every + -- match routine must end by executing a goto to the appropriate point + -- in the finite state machine model. + + Logic_Error; + + end XMatchD; + +end GNAT.Spitbol.Patterns; diff --git a/gcc/ada/g-spipat.ads b/gcc/ada/g-spipat.ads new file mode 100644 index 00000000000..9b66d9e3e72 --- /dev/null +++ b/gcc/ada/g-spipat.ads @@ -0,0 +1,1204 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . P A T T E R N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.17 $ +-- -- +-- Copyright (C) 1997-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL-like pattern construction and matching + +-- This child package of GNAT.SPITBOL provides a complete implementation +-- of the SPITBOL-like pattern construction and matching operations. This +-- package is based on Macro-SPITBOL created by Robert Dewar. + +------------------------------------------------------------ +-- Summary of Pattern Matching Packages in GNAT Hierarchy -- +------------------------------------------------------------ + +-- There are three related packages that perform pattern maching functions. +-- the following is an outline of these packages, to help you determine +-- which is best for your needs. + +-- GNAT.Regexp (files g-regexp.ads/g-regexp.adb) +-- This is a simple package providing Unix-style regular expression +-- matching with the restriction that it matches entire strings. It +-- is particularly useful for file name matching, and in particular +-- it provides "globbing patterns" that are useful in implementing +-- unix or DOS style wild card matching for file names. + +-- GNAT.Regpat (files g-regpat.ads/g-regpat.adb) +-- This is a more complete implementation of Unix-style regular +-- expressions, copied from the original V7 style regular expression +-- library written in C by Henry Spencer. It is functionally the +-- same as this library, and uses the same internal data structures +-- stored in a binary compatible manner. + +-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) +-- This is a completely general patterm matching package based on the +-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern +-- language is modeled on context free grammars, with context sensitive +-- extensions that provide full (type 0) computational capabilities. + +with Ada.Finalization; use Ada.Finalization; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Text_IO; use Ada.Text_IO; + +package GNAT.Spitbol.Patterns is +pragma Elaborate_Body (Patterns); + + ------------------------------- + -- Pattern Matching Tutorial -- + ------------------------------- + + -- A pattern matching operation (a call to one of the Match subprograms) + -- takes a subject string and a pattern, and optionally a replacement + -- string. The replacement string option is only allowed if the subject + -- is a variable. + + -- The pattern is matched against the subject string, and either the + -- match fails, or it succeeds matching a contiguous substring. If a + -- replacement string is specified, then the subject string is modified + -- by replacing the matched substring with the given replacement. + + + -- Concatenation and Alternation + -- ============================= + + -- A pattern consists of a series of pattern elements. The pattern is + -- built up using either the concatenation operator: + + -- A & B + + -- which means match A followed immediately by matching B, or the + -- alternation operator: + + -- A or B + + -- which means first attempt to match A, and then if that does not + -- succeed, match B. + + -- There is full backtracking, which means that if a given pattern + -- element fails to match, then previous alternatives are matched. + -- For example if we have the pattern: + + -- (A or B) & (C or D) & (E or F) + + -- First we attempt to match A, if that succeeds, then we go on to try + -- to match C, and if that succeeds, we go on to try to match E. If E + -- fails, then we try F. If F fails, then we go back and try matching + -- D instead of C. Let's make this explicit using a specific example, + -- and introducing the simplest kind of pattern element, which is a + -- literal string. The meaning of this pattern element is simply to + -- match the characters that correspond to the string characters. Now + -- let's rewrite the above pattern form with specific string literals + -- as the pattern elements: + + -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") + + -- The following strings will be attempted in sequence: + + -- ABC . DEF . GH + -- ABC . DEF . IJ + -- ABC . CDE . GH + -- ABC . CDE . IJ + -- AB . DEF . GH + -- AB . DEF . IJ + -- AB . CDE . GH + -- AB . CDE . IJ + + -- Here we use the dot simply to separate the pieces of the string + -- matched by the three separate elements. + + + -- Moving the Start Point + -- ====================== + + -- A pattern is not required to match starting at the first character + -- of the string, and is not required to match to the end of the string. + -- The first attempt does indeed attempt to match starting at the first + -- character of the string, trying all the possible alternatives. But + -- if all alternatives fail, then the starting point of the match is + -- moved one character, and all possible alternatives are attempted at + -- the new anchor point. + + -- The entire match fails only when every possible starting point has + -- been attempted. As an example, suppose that we had the subject + -- string + + -- "ABABCDEIJKL" + + -- matched using the pattern in the previous example: + + -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") + + -- would succeed, afer two anchor point moves: + + -- "ABABCDEIJKL" + -- ^^^^^^^ + -- matched + -- section + + -- This mode of pattern matching is called the unanchored mode. It is + -- also possible to put the pattern matcher into anchored mode by + -- setting the global variable Anchored_Mode to True. This will cause + -- all subsequent matches to be performed in anchored mode, where the + -- match is required to start at the first character. + + -- We will also see later how the effect of an anchored match can be + -- obtained for a single specified anchor point if this is desired. + + + -- Other Pattern Elements + -- ====================== + + -- In addition to strings (or single characters), there are many special + -- pattern elements that correspond to special predefined alternations: + + -- Arb Matches any string. First it matches the null string, and + -- then on a subsequent failure, matches one character, and + -- then two characters, and so on. It only fails if the + -- entire remaining string is matched. + + -- Bal Matches a non-empty string that is parentheses balanced + -- with respect to ordinary () characters. Examples of + -- balanced strings are "ABC", "A((B)C)", and "A(B)C(D)E". + -- Bal matches the shortest possible balanced string on the + -- first attempt, and if there is a subsequent failure, + -- attempts to extend the string. + + -- Cancel Immediately aborts the entire pattern match, signalling + -- failure. This is a specialized pattern element, which is + -- useful in conjunction with some of the special pattern + -- elements that have side effects. + + -- Fail The null alternation. Matches no possible strings, so it + -- always signals failure. This is a specialized pattern + -- element, which is useful in conjunction with some of the + -- special pattern elements that have side effects. + + -- Fence Matches the null string at first, and then if a failure + -- causes alternatives to be sought, aborts the match (like + -- a Cancel). Note that using Fence at the start of a pattern + -- has the same effect as matching in anchored mode. + + -- Rest Matches from the current point to the last character in + -- the string. This is a specialized pattern element, which + -- is useful in conjunction with some of the special pattern + -- elements that have side effects. + + -- Succeed Repeatedly matches the null string (it is equivalent to + -- the alternation ("" or "" or "" ....). This is a special + -- pattern element, which is useful in conjunction with some + -- of the special pattern elements that have side effects. + + + -- Pattern Construction Functions + -- ============================== + + -- The following functions construct additional pattern elements + + -- Any(S) Where S is a string, matches a single character that is + -- any one of the characters in S. Fails if the current + -- character is not one of the given set of characters. + + -- Arbno(P) Where P is any pattern, matches any number of instances + -- of the pattern, starting with zero occurrences. It is + -- thus equivalent to ("" or (P & ("" or (P & ("" ....)))). + -- The pattern P may contain any number of pattern elements + -- including the use of alternatiion and concatenation. + + -- Break(S) Where S is a string, matches a string of zero or more + -- characters up to but not including a break character + -- that is one of the characters given in the string S. + -- Can match the null string, but cannot match the last + -- character in the string, since a break character is + -- required to be present. + + -- BreakX(S) Where S is a string, behaves exactly like Break(S) when + -- it first matches, but if a string is successfully matched, + -- then a susequent failure causes an attempt to extend the + -- matched string. + + -- Fence(P) Where P is a pattern, attempts to match the pattern P + -- including trying all possible alternatives of P. If none + -- of these alternatives succeeds, then the Fence pattern + -- fails. If one alternative succeeds, then the pattern + -- match proceeds, but on a subsequent failure, no attempt + -- is made to search for alternative matches of P. The + -- pattern P may contain any number of pattern elements + -- including the use of alternatiion and concatenation. + + -- Len(N) Where N is a natural number, matches the given number of + -- characters. For example, Len(10) matches any string that + -- is exactly ten characters long. + + -- NotAny(S) Where S is a string, matches a single character that is + -- not one of the characters of S. Fails if the current + -- characer is one of the given set of characters. + + -- NSpan(S) Where S is a string, matches a string of zero or more + -- characters that is among the characters given in the + -- string. Always matches the longest possible such string. + -- Always succeeds, since it can match the null string. + + -- Pos(N) Where N is a natural number, matches the null string + -- if exactly N characters have been matched so far, and + -- otherwise fails. + + -- Rpos(N) Where N is a natural number, matches the null string + -- if exactly N characters remain to be matched, and + -- otherwise fails. + + -- Rtab(N) Where N is a natural number, matches characters from + -- the current position until exactly N characters remain + -- to be matched in the string. Fails if fewer than N + -- unmatched characters remain in the string. + + -- Tab(N) Where N is a natural number, matches characters from + -- the current position until exactly N characters have + -- been matched in all. Fails if more than N characters + -- have already been matched. + + -- Span(S) Where S is a string, matches a string of one or more + -- characters that is among the characters given in the + -- string. Always matches the longest possible such string. + -- Fails if the current character is not one of the given + -- set of characters. + + -- Recursive Pattern Matching + -- ========================== + + -- The plus operator (+P) where P is a pattern variable, creates + -- a recursive pattern that will, at pattern matching time, follow + -- the pointer to obtain the referenced pattern, and then match this + -- pattern. This may be used to construct recursive patterns. Consider + -- for example: + + -- P := ("A" or ("B" & (+P))) + + -- On the first attempt, this pattern attempts to match the string "A". + -- If this fails, then the alternative matches a "B", followed by an + -- attempt to match P again. This second attempt first attempts to + -- match "A", and so on. The result is a pattern that will match a + -- string of B's followed by a single A. + + -- This particular example could simply be written as NSpan('B') & 'A', + -- but the use of recursive patterns in the general case can construct + -- complex patterns which could not otherwise be built. + + + -- Pattern Assignment Operations + -- ============================= + + -- In addition to the overall result of a pattern match, which indicates + -- success or failure, it is often useful to be able to keep track of + -- the pieces of the subject string that are matched by individual + -- pattern elements, or subsections of the pattern. + + -- The pattern assignment operators allow this capability. The first + -- form is the immediate assignment: + + -- P * S + + -- Here P is an arbitrary pattern, and S is a variable of type VString + -- that will be set to the substring matched by P. This assignment + -- happens during pattern matching, so if P matches more than once, + -- then the assignment happens more than once. + + -- The deferred assignment operation: + + -- P ** S + + -- avoids these multiple assignments by deferring the assignment to the + -- end of the match. If the entire match is successful, and if the + -- pattern P was part of the successful match, then at the end of the + -- matching operation the assignment to S of the string matching P is + -- performed. + + -- The cursor assignment operation: + + -- Setcur(N'Access) + + -- assigns the current cursor position to the natural variable N. The + -- cursor position is defined as the count of characters that have been + -- matched so far (including any start point moves). + + -- Finally the operations * and ** may be used with values of type + -- Text_IO.File_Access. The effect is to do a Put_Line operation of + -- the matched substring. These are particularly useful in debugging + -- pattern matches. + + + -- Deferred Matching + -- ================= + + -- The pattern construction functions (such as Len and Any) all permit + -- the use of pointers to natural or string values, or functions that + -- return natural or string values. These forms cause the actual value + -- to be obtained at pattern matching time. This allows interesting + -- possibilities for constructing dynamic patterns as illustrated in + -- the examples section. + + -- In addition the (+S) operator may be used where S is a pointer to + -- string or function returning string, with a similar deferred effect. + + -- A special use of deferred matching is the construction of predicate + -- functions. The element (+P) where P is an access to a function that + -- returns a Boolean value, causes the function to be called at the + -- time the element is matched. If the function returns True, then the + -- null string is matched, if the function returns False, then failure + -- is signalled and previous alternatives are sought. + + -- Deferred Replacement + -- ==================== + + -- The simple model given for pattern replacement (where the matched + -- substring is replaced by the string given as the third argument to + -- Match) works fine in simple cases, but this approach does not work + -- in the case where the expression used as the replacement string is + -- dependent on values set by the match. + + -- For example, suppose we want to find an instance of a parenthesized + -- character, and replace the parentheses with square brackets. At first + -- glance it would seem that: + + -- Match (Subject, '(' & Len (1) * Char & ')', '[' & Char & ']'); + + -- would do the trick, but that does not work, because the third + -- argument to Match gets evaluated too early, before the call to + -- Match, and before the pattern match has had a chance to set Char. + + -- To solve this problem we provide the deferred replacement capability. + -- With this approach, which of course is only needed if the pattern + -- involved has side effects, is to do the match in two stages. The + -- call to Match sets a pattern result in a variable of the private + -- type Match_Result, and then a subsequent Replace operation uses + -- this Match_Result object to perform the required replacement. + + -- Using this approach, we can now write the above operation properly + -- in a manner that will work: + + -- M : Match_Result; + -- ... + -- Match (Subject, '(' & Len (1) * Char & ')', M); + -- Replace (M, '[' & Char & ']'); + + -- As with other Match cases, there is a function and procedure form + -- of this match call. A call to Replace after a failed match has no + -- effect. Note that Subject should not be modified between the calls. + + -- Examples of Pattern Matching + -- ============================ + + -- First a simple example of the use of pattern replacement to remove + -- a line number from the start of a string. We assume that the line + -- number has the form of a string of decimal digits followed by a + -- period, followed by one or more spaces. + + -- Digs : constant Pattern := Span("0123456789"); + + -- Lnum : constant Pattern := Pos(0) & Digs & '.' & Span(' '); + + -- Now to use this pattern we simply do a match with a replacement: + + -- Match (Line, Lnum, ""); + + -- which replaces the line number by the null string. Note that it is + -- also possible to use an Ada.Strings.Maps.Character_Set value as an + -- argument to Span and similar functions, and in particular all the + -- useful constants 'in Ada.Strings.Maps.Constants are available. This + -- means that we could define Digs as: + + -- Digs : constant Pattern := Span(Decimal_Digit_Set); + + -- The style we use here, of defining constant patterns and then using + -- them is typical. It is possible to build up patterns dynamically, + -- but it is usually more efficient to build them in pieces in advance + -- using constant declarations. Note in particular that although it is + -- possible to construct a pattern directly as an argument for the + -- Match routine, it is much more efficient to preconstruct the pattern + -- as we did in this example. + + -- Now let's look at the use of pattern assignment to break a + -- string into sections. Suppose that the input string has two + -- unsigned decimal integers, separated by spaces or a comma, + -- with spaces allowed anywhere. Then we can isolate the two + -- numbers with the following pattern: + + -- Num1, Num2 : aliased VString; + + -- B : constant Pattern := NSpan(' '); + + -- N : constant Pattern := Span("0123456789"); + + -- T : constant Pattern := + -- NSpan(' ') & N * Num1 & Span(" ,") & N * Num2; + + -- The match operation Match (" 124, 257 ", T) would assign the + -- string 124 to Num1 and the string 257 to Num2. + + -- Now let's see how more complex elements can be built from the + -- set of primitive elements. The following pattern matches strings + -- that have the syntax of Ada 95 based literals: + + -- Digs : constant Pattern := Span(Decimal_Digit_Set); + -- UDigs : constant Pattern := Digs & Arbno('_' & Digs); + + -- Edig : constant Pattern := Span(Hexadecimal_Digit_Set); + -- UEdig : constant Pattern := Edig & Arbno('_' & Edig); + + -- Bnum : constant Pattern := Udigs & '#' & UEdig & '#'; + + -- A match against Bnum will now match the desired strings, e.g. + -- it will match 16#123_abc#, but not a#b#. However, this pattern + -- is not quite complete, since it does not allow colons to replace + -- the pound signs. The following is more complete: + + -- Bchar : constant Pattern := Any("#:"); + -- Bnum : constant Pattern := Udigs & Bchar & UEdig & Bchar; + + -- but that is still not quite right, since it allows # and : to be + -- mixed, and they are supposed to be used consistently. We solve + -- this by using a deferred match. + + -- Temp : aliased VString; + + -- Bnum : constant Pattern := + -- Udigs & Bchar * Temp & UEdig & (+Temp) + + -- Here the first instance of the base character is stored in Temp, and + -- then later in the pattern we rematch the value that was assigned. + + -- For an example of a recursive pattern, let's define a pattern + -- that is like the built in Bal, but the string matched is balanced + -- with respect to square brackets or curly brackets. + + -- The language for such strings might be defined in extended BNF as + + -- ELEMENT ::= <any character other than [] or {}> + -- | '[' BALANCED_STRING ']' + -- | '{' BALANCED_STRING '}' + + -- BALANCED_STRING ::= ELEMENT {ELEMENT} + + -- Here we use {} to indicate zero or more occurrences of a term, as + -- is common practice in extended BNF. Now we can translate the above + -- BNF into recursive patterns as follows: + + -- Element, Balanced_String : aliased Pattern; + -- . + -- . + -- . + -- Element := NotAny ("[]{}") + -- or + -- ('[' & (+Balanced_String) & ']') + -- or + -- ('{' & (+Balanced_String) & '}'); + + -- Balanced_String := Element & Arbno (Element); + + -- Note the important use of + here to refer to a pattern not yet + -- defined. Note also that we use assignments precisely because we + -- cannot refer to as yet undeclared variables in initializations. + + -- Now that this pattern is constructed, we can use it as though it + -- were a new primitive pattern element, and for example, the match: + + -- Match ("xy[ab{cd}]", Balanced_String * Current_Output & Fail); + + -- will generate the output: + + -- x + -- xy + -- xy[ab{cd}] + -- y + -- y[ab{cd}] + -- [ab{cd}] + -- a + -- ab + -- ab{cd} + -- b + -- b{cd} + -- {cd} + -- c + -- cd + -- d + + -- Note that the function of the fail here is simply to force the + -- pattern Balanced_String to match all possible alternatives. Studying + -- the operation of this pattern in detail is highly instructive. + + -- Finally we give a rather elaborate example of the use of deferred + -- matching. The following declarations build up a pattern which will + -- find the longest string of decimal digits in the subject string. + + -- Max, Cur : VString; + -- Loc : Natural; + + -- function GtS return Boolean is + -- begin + -- return Length (Cur) > Length (Max); + -- end GtS; + + -- Digit : constant Character_Set := Decimal_Digit_Set; + + -- Digs : constant Pattern := Span(Digit); + + -- Find : constant Pattern := + -- "" * Max & Fence & -- initialize Max to null + -- BreakX (Digit) & -- scan looking for digits + -- ((Span(Digit) * Cur & -- assign next string to Cur + -- (+GtS'Unrestricted_Access) & -- check size(Cur) > Size(Max) + -- Setcur(Loc'Access)) -- if so, save location + -- * Max) & -- and assign to Max + -- Fail; -- seek all alternatives + + -- As we see from the comments here, complex patterns like this take + -- on aspects of sequential programs. In fact they are sequential + -- programs with general backtracking. In this pattern, we first use + -- a pattern assignment that matches null and assigns it to Max, so + -- that it is initialized for the new match. Now BreakX scans to the + -- next digit. Arb would do here, but BreakX will be more efficient. + -- Once we have found a digit, we scan out the longest string of + -- digits with Span, and assign it to Cur. The deferred call to GtS + -- tests if the string we assigned to Cur is the longest so far. If + -- not, then failure is signalled, and we seek alternatives (this + -- means that BreakX will extend and look for the next digit string). + -- If the call to GtS succeeds then the matched string is assigned + -- as the largest string so far into Max and its location is saved + -- in Loc. Finally Fail forces the match to fail and seek alternatives, + -- so that the entire string is searched. + + -- If the pattern Find is matched against a string, the variable Max + -- at the end of the pattern will have the longest string of digits, + -- and Loc will be the starting character location of the string. For + -- example, Match("ab123cd4657ef23", Find) will assign "4657" to Max + -- and 11 to Loc (indicating that the string ends with the eleventh + -- character of the string). + + -- Note: the use of Unrestricted_Access to reference GtS will not + -- be needed if GtS is defined at the outer level, but definitely + -- will be necessary if GtS is a nested function (in which case of + -- course the scope of the pattern Find will be restricted to this + -- nested scope, and this cannot be checked, i.e. use of the pattern + -- outside this scope is erroneous). Generally it is a good idea to + -- define patterns and the functions they call at the outer level + -- where possible, to avoid such problems. + + + -- Correspondence with Pattern Matching in SPITBOL + -- =============================================== + + -- Generally the Ada syntax and names correspond closely to SPITBOL + -- syntax for pattern matching construction. + + -- The basic pattern construction operators are renamed as follows: + + -- Spitbol Ada + + -- (space) & + -- | or + -- $ * + -- . ** + + -- The Ada operators were chosen so that the relative precedences of + -- these operators corresponds to that of the Spitbol operators, but + -- as always, the use of parentheses is advisable to clarify. + + -- The pattern construction operators all have similar names except for + + -- Spitbol Ada + + -- Abort Cancel + -- Rem Rest + + -- where we have clashes with Ada reserved names. + + -- Ada requires the use of 'Access to refer to functions used in the + -- pattern match, and often the use of 'Unrestricted_Access may be + -- necessary to get around the scope restrictions if the functions + -- are not declared at the outer level. + + -- The actual pattern matching syntax is modified in Ada as follows: + + -- Spitbol Ada + + -- X Y Match (X, Y); + -- X Y = Z Match (X, Y, Z); + + -- and pattern failure is indicated by returning a Boolean result from + -- the Match function (True for success, False for failure). + + ----------------------- + -- Type Declarations -- + ----------------------- + + type Pattern is private; + -- Type representing a pattern. This package provides a complete set of + -- operations for constructing patterns that can be used in the pattern + -- matching operations provided. + + type Boolean_Func is access function return Boolean; + -- General Boolean function type. When this type is used as a formal + -- parameter type in this package, it indicates a deferred predicate + -- pattern. The function will be called when the pattern element is + -- matched and failure signalled if False is returned. + + type Natural_Func is access function return Natural; + -- General Natural function type. When this type is used as a formal + -- parameter type in this package, it indicates a deferred pattern. + -- The function will be called when the pattern element is matched + -- to obtain the currently referenced Natural value. + + type VString_Func is access function return VString; + -- General VString function type. When this type is used as a formal + -- parameter type in this package, it indicates a deferred pattern. + -- The function will be called when the pattern element is matched + -- to obtain the currently referenced string value. + + subtype PString is String; + -- This subtype is used in the remainder of the package to indicate a + -- formal parameter that is converted to its corresponding pattern, + -- i.e. a pattern that matches the characters of the string. + + subtype PChar is Character; + -- Similarly, this subtype is used in the remainder of the package to + -- indicate a formal parameter that is converted to its corresponding + -- pattern, i.e. a pattern that matches this one character. + + subtype VString_Var is VString; + subtype Pattern_Var is Pattern; + -- These synonyms are used as formal parameter types to a function where, + -- if the language allowed, we would use in out parameters, but we are + -- not allowed to have in out parameters for functions. Instead we pass + -- actuals which must be variables, and with a bit of trickery in the + -- body, manage to interprete them properly as though they were indeed + -- in out parameters. + + -------------------------------- + -- Basic Pattern Construction -- + -------------------------------- + + function "&" (L : Pattern; R : Pattern) return Pattern; + function "&" (L : PString; R : Pattern) return Pattern; + function "&" (L : Pattern; R : PString) return Pattern; + function "&" (L : PChar; R : Pattern) return Pattern; + function "&" (L : Pattern; R : PChar) return Pattern; + + -- Pattern concatenation. Matches L followed by R. + + function "or" (L : Pattern; R : Pattern) return Pattern; + function "or" (L : PString; R : Pattern) return Pattern; + function "or" (L : Pattern; R : PString) return Pattern; + function "or" (L : PString; R : PString) return Pattern; + function "or" (L : PChar; R : Pattern) return Pattern; + function "or" (L : Pattern; R : PChar) return Pattern; + function "or" (L : PChar; R : PChar) return Pattern; + function "or" (L : PString; R : PChar) return Pattern; + function "or" (L : PChar; R : PString) return Pattern; + -- Pattern alternation. Creates a pattern that will first try to match + -- L and then on a subsequent failure, attempts to match R instead. + + ---------------------------------- + -- Pattern Assignment Functions -- + ---------------------------------- + + function "*" (P : Pattern; Var : VString_Var) return Pattern; + function "*" (P : PString; Var : VString_Var) return Pattern; + function "*" (P : PChar; Var : VString_Var) return Pattern; + -- Matches P, and if the match succeeds, assigns the matched substring + -- to the given VString variable S. This assignment happens as soon as + -- the substring is matched, and if the pattern P1 is matched more than + -- once during the course of the match, then the assignment will occur + -- more than once. + + function "**" (P : Pattern; Var : VString_Var) return Pattern; + function "**" (P : PString; Var : VString_Var) return Pattern; + function "**" (P : PChar; Var : VString_Var) return Pattern; + -- Like "*" above, except that the assignment happens at most once + -- after the entire match is completed successfully. If the match + -- fails, then no assignment takes place. + + ---------------------------------- + -- Deferred Matching Operations -- + ---------------------------------- + + function "+" (Str : VString_Var) return Pattern; + -- Here Str must be a VString variable. This function constructs a + -- pattern which at pattern matching time will access the current + -- value of this variable, and match against these characters. + + function "+" (Str : VString_Func) return Pattern; + -- Constructs a pattern which at pattern matching time calls the given + -- function, and then matches against the string or character value + -- that is returned by the call. + + function "+" (P : Pattern_Var) return Pattern; + -- Here P must be a Pattern variable. This function constructs a + -- pattern which at pattern matching time will access the current + -- value of this variable, and match against the pattern value. + + function "+" (P : Boolean_Func) return Pattern; + -- Constructs a predicate pattern function that at pattern matching time + -- calls the given function. If True is returned, then the pattern matches. + -- If False is returned, then failure is signalled. + + -------------------------------- + -- Pattern Building Functions -- + -------------------------------- + + function Arb return Pattern; + -- Constructs a pattern that will match any string. On the first attempt, + -- the pattern matches a null string, then on each successive failure, it + -- matches one more character, and only fails if matching the entire rest + -- of the string. + + function Arbno (P : Pattern) return Pattern; + function Arbno (P : PString) return Pattern; + function Arbno (P : PChar) return Pattern; + -- Pattern repetition. First matches null, then on a subsequent failure + -- attempts to match an additional instance of the given pattern. + -- Equivalent to (but more efficient than) P & ("" or (P & ("" or ... + + function Any (Str : String) return Pattern; + function Any (Str : VString) return Pattern; + function Any (Str : Character) return Pattern; + function Any (Str : Character_Set) return Pattern; + function Any (Str : access VString) return Pattern; + function Any (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches a single character that is one of + -- the characters in the given argument. The pattern fails if the current + -- character is not in Str. + + function Bal return Pattern; + -- Constructs a pattern that will match any non-empty string that is + -- parentheses balanced with respect to the normal parentheses characters. + -- Attempts to extend the string if a subsequent failure occurs. + + function Break (Str : String) return Pattern; + function Break (Str : VString) return Pattern; + function Break (Str : Character) return Pattern; + function Break (Str : Character_Set) return Pattern; + function Break (Str : access VString) return Pattern; + function Break (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches a (possibly null) string which + -- is immediately followed by a character in the given argument. This + -- character is not part of the matched string. The pattern fails if + -- the remaining characters to be matched do not include any of the + -- characters in Str. + + function BreakX (Str : String) return Pattern; + function BreakX (Str : VString) return Pattern; + function BreakX (Str : Character) return Pattern; + function BreakX (Str : Character_Set) return Pattern; + function BreakX (Str : access VString) return Pattern; + function BreakX (Str : VString_Func) return Pattern; + -- Like Break, but the pattern attempts to extend on a failure to find + -- the next occurrence of a character in Str, and only fails when the + -- last such instance causes a failure. + + function Cancel return Pattern; + -- Constructs a pattern that immediately aborts the entire match + + function Fail return Pattern; + -- Constructs a pattern that always fails. + + function Fence return Pattern; + -- Constructs a pattern that matches null on the first attempt, and then + -- causes the entire match to be aborted if a subsequent failure occurs. + + function Fence (P : Pattern) return Pattern; + -- Constructs a pattern that first matches P. if P fails, then the + -- constructed pattern fails. If P succeeds, then the match proceeds, + -- but if subsequent failure occurs, alternatives in P are not sought. + -- The idea of Fence is that each time the pattern is matched, just + -- one attempt is made to match P, without trying alternatives. + + function Len (Count : Natural) return Pattern; + function Len (Count : access Natural) return Pattern; + function Len (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches exactly the given number of + -- characters. The pattern fails if fewer than this number of characters + -- remain to be matched in the string. + + function NotAny (Str : String) return Pattern; + function NotAny (Str : VString) return Pattern; + function NotAny (Str : Character) return Pattern; + function NotAny (Str : Character_Set) return Pattern; + function NotAny (Str : access VString) return Pattern; + function NotAny (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches a single character that is not + -- one of the characters in the given argument. The pattern Fails if + -- the current character is in Str. + + function NSpan (Str : String) return Pattern; + function NSpan (Str : VString) return Pattern; + function NSpan (Str : Character) return Pattern; + function NSpan (Str : Character_Set) return Pattern; + function NSpan (Str : access VString) return Pattern; + function NSpan (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches the longest possible string + -- consisting entirely of characters from the given argument. The + -- string may be empty, so this pattern always succeeds. + + function Pos (Count : Natural) return Pattern; + function Pos (Count : access Natural) return Pattern; + function Pos (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches the null string if exactly Count + -- characters have already been matched, and otherwise fails. + + function Rest return Pattern; + -- Constructs a pattern that always succeeds, matching the remaining + -- unmatched characters in the pattern. + + function Rpos (Count : Natural) return Pattern; + function Rpos (Count : access Natural) return Pattern; + function Rpos (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches the null string if exactly Count + -- characters remain to be matched in the string, and otherwise fails. + + function Rtab (Count : Natural) return Pattern; + function Rtab (Count : access Natural) return Pattern; + function Rtab (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches from the current location until + -- exactly Count characters remain to be matched in the string. The + -- pattern fails if fewer than Count characters remain to be matched. + + function Setcur (Var : access Natural) return Pattern; + -- Constructs a pattern that matches the null string, and assigns the + -- current cursor position in the string. This value is the number of + -- characters matched so far. So it is zero at the start of the match. + + function Span (Str : String) return Pattern; + function Span (Str : VString) return Pattern; + function Span (Str : Character) return Pattern; + function Span (Str : Character_Set) return Pattern; + function Span (Str : access VString) return Pattern; + function Span (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches the longest possible string + -- consisting entirely of characters from the given argument. The + -- string cannot be empty , so the pattern fails if the current + -- character is not one of the characters in Str. + + function Succeed return Pattern; + -- Constructs a pattern that succeeds matching null, both on the first + -- attempt, and on any rematch attempt, i.e. it is equivalent to an + -- infinite alternation of null strings. + + function Tab (Count : Natural) return Pattern; + function Tab (Count : access Natural) return Pattern; + function Tab (Count : Natural_Func) return Pattern; + -- Constructs a pattern that from the current location until Count + -- characters have been matched. The pattern fails if more than Count + -- characters have already been matched. + + --------------------------------- + -- Pattern Matching Operations -- + --------------------------------- + + -- The Match function performs an actual pattern matching operation. + -- The versions with three parameters perform a match without modifying + -- the subject string and return a Boolean result indicating if the + -- match is successful or not. The Anchor parameter is set to True to + -- obtain an anchored match in which the pattern is required to match + -- the first character of the string. In an unanchored match, which is + + -- the default, successive attempts are made to match the given pattern + -- at each character of the subject string until a match succeeds, or + -- until all possibilities have failed. + + -- Note that pattern assignment functions in the pattern may generate + -- side effects, so these functions are not necessarily pure. + + Anchored_Mode : Boolean := False; + -- This global variable can be set True to cause all subsequent pattern + -- matches to operate in anchored mode. In anchored mode, no attempt is + -- made to move the anchor point, so that if the match succeeds it must + -- succeed starting at the first character. Note that the effect of + -- anchored mode may be achieved in individual pattern matches by using + -- Fence or Pos(0) at the start of the pattern. + + Pattern_Stack_Overflow : exception; + -- Exception raised if internal pattern matching stack overflows. This + -- is typically the result of runaway pattern recursion. If there is a + -- genuine case of stack overflow, then either the match must be broken + -- down into simpler steps, or the stack limit must be reset. + + Stack_Size : constant Positive := 2000; + -- Size used for internal pattern matching stack. Increase this size if + -- complex patterns cause Pattern_Stack_Overflow to be raised. + + -- Simple match functions. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed, and + -- the returned value indicates whether or not the match succeeded. + + function Match + (Subject : VString; + Pat : Pattern) + return Boolean; + + function Match + (Subject : VString; + Pat : PString) + return Boolean; + + function Match + (Subject : String; + Pat : Pattern) + return Boolean; + + function Match + (Subject : String; + Pat : PString) + return Boolean; + + -- Replacement functions. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed, and + -- the returned value indicates whether or not the match succeeded. + -- If the match succeeds, then the matched part of the subject string + -- is replaced by the given Replace string. + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : VString) + return Boolean; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : VString) + return Boolean; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : String) + return Boolean; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : String) + return Boolean; + + -- Simple match procedures. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed. No + -- indication of success or failure is returned. + + procedure Match + (Subject : VString; + Pat : Pattern); + + procedure Match + (Subject : VString; + Pat : PString); + + procedure Match + (Subject : String; + Pat : Pattern); + + procedure Match + (Subject : String; + Pat : PString); + + -- Replacement procedures. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed. No + -- indication of success or failure is returned. If the match succeeds, + -- then the matched part of the subject string is replaced by the given + -- Replace string. + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : VString); + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : VString); + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : String); + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : String); + + -- Deferred Replacement + + type Match_Result is private; + -- Type used to record result of pattern match + + subtype Match_Result_Var is Match_Result; + -- This synonyms is used as a formal parameter type to a function where, + -- if the language allowed, we would use an in out parameter, but we are + -- not allowed to have in out parameters for functions. Instead we pass + -- actuals which must be variables, and with a bit of trickery in the + -- body, manage to interprete them properly as though they were indeed + -- in out parameters. + + function Match + (Subject : VString_Var; + Pat : Pattern; + Result : Match_Result_Var) + return Boolean; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Result : out Match_Result); + + procedure Replace + (Result : in out Match_Result; + Replace : VString); + -- Given a previous call to Match which set Result, performs a pattern + -- replacement if the match was successful. Has no effect if the match + -- failed. This call should immediately follow the Match call. + + ------------------------ + -- Debugging Routines -- + ------------------------ + + -- Debugging pattern matching operations can often be quite complex, + -- since there is no obvious way to trace the progress of the match. + -- The declarations in this section provide some debugging assistance. + + Debug_Mode : Boolean := False; + -- This global variable can be set True to generate debugging on all + -- subsequent calls to Match. The debugging output is a full trace of + -- the actions of the pattern matcher, written to Standard_Output. The + -- level of this information is intended to be comprehensible at the + -- abstract level of this package declaration. However, note that the + -- use of this switch often generates large amounts of output. + + function "*" (P : Pattern; Fil : File_Access) return Pattern; + function "*" (P : PString; Fil : File_Access) return Pattern; + function "*" (P : PChar; Fil : File_Access) return Pattern; + function "**" (P : Pattern; Fil : File_Access) return Pattern; + function "**" (P : PString; Fil : File_Access) return Pattern; + function "**" (P : PChar; Fil : File_Access) return Pattern; + -- These are similar to the corresponding pattern assignment operations + -- except that instead of setting the value of a variable, the matched + -- substring is written to the appropriate file. This can be useful in + -- following the progress of a match without generating the full amount + + -- of information obtained by setting Debug_Mode to True. + + Terminal : constant File_Access := Standard_Error; + Output : constant File_Access := Standard_Output; + -- Two handy synonyms for use with the above pattern write operations. + + -- Finally we have some routines that are useful for determining what + -- patterns are in use, particularly if they are constructed dynamically. + + function Image (P : Pattern) return String; + function Image (P : Pattern) return VString; + -- This procedures yield strings that corresponds to the syntax needed + -- to create the given pattern using the functions in this package. The + -- form of this string is such that it could actually be compiled and + -- evaluated to yield the required pattern except for references to + -- variables and functions, which are output using one of the following + -- forms: + -- + -- access Natural NP(16#...#) + -- access Pattern PP(16#...#) + -- access VString VP(16#...#) + -- + -- Natural_Func NF(16#...#) + -- VString_Func VF(16#...#) + -- + -- where 16#...# is the hex representation of the integer address that + -- corresponds to the given access value + + procedure Dump (P : Pattern); + -- This procedure writes information about the pattern to Standard_Out. + -- The format of this information is keyed to the internal data structures + -- used to implement patterns. The information provided by Dump is thus + -- more precise than that yielded by Image, but is also a bit more obscure + -- (i.e. it cannot be interpreted solely in terms of this spec, you have + -- to know something about the data structures). + + ------------------ + -- Private Part -- + ------------------ + +private + type PE; + -- Pattern element, a pattern is a plex structure of PE's. This type + -- is defined and sdescribed in the body of this package. + + type PE_Ptr is access all PE; + -- Pattern reference. PE's use PE_Ptr values to reference other PE's + + type Pattern is new Controlled with record + + Stk : Natural; + -- Maximum number of stack entries required for matching this + -- pattern. See description of pattern history stack in body. + + P : PE_Ptr; + -- Pointer to initial pattern element for pattern + + end record; + + pragma Finalize_Storage_Only (Pattern); + + procedure Adjust (Object : in out Pattern); + -- Adjust routine used to copy pattern objects + + procedure Finalize (Object : in out Pattern); + -- Finalization routine used to release storage allocated for a pattern. + + type VString_Ptr is access all VString; + + type Match_Result is record + Var : VString_Ptr; + -- Pointer to subject string. Set to null if match failed. + + Start : Natural; + -- Starting index position (1's origin) of matched section of + -- subject string. Only valid if Var is non-null. + + Stop : Natural; + -- Ending index position (1's origin) of matched section of + -- subject string. Only valid if Var is non-null. + + end record; + + pragma Volatile (Match_Result); + -- This ensures that the Result parameter is passed by reference, so + -- that we can play our games with the bogus Match_Result_Var parameter + -- in the function case to treat it as though it were an in out parameter. + +end GNAT.Spitbol.Patterns; diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb new file mode 100644 index 00000000000..cb2cee8f410 --- /dev/null +++ b/gcc/ada/g-spitbo.adb @@ -0,0 +1,764 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ -- +-- -- +-- Copyright (C) 1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings; use Ada.Strings; +with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; +with GNAT.IO; use GNAT.IO; + +with Unchecked_Deallocation; + +package body GNAT.Spitbol is + + --------- + -- "&" -- + --------- + + function "&" (Num : Integer; Str : String) return String is + begin + return S (Num) & Str; + end "&"; + + function "&" (Str : String; Num : Integer) return String is + begin + return Str & S (Num); + end "&"; + + function "&" (Num : Integer; Str : VString) return VString is + begin + return S (Num) & Str; + end "&"; + + function "&" (Str : VString; Num : Integer) return VString is + begin + return Str & S (Num); + end "&"; + + ---------- + -- Char -- + ---------- + + function Char (Num : Natural) return Character is + begin + return Character'Val (Num); + end Char; + + ---------- + -- Lpad -- + ---------- + + function Lpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') + return VString + is + begin + if Length (Str) >= Len then + return Str; + else + return Tail (Str, Len, Pad); + end if; + end Lpad; + + function Lpad + (Str : String; + Len : Natural; + Pad : Character := ' ') + return VString + is + begin + if Str'Length >= Len then + return V (Str); + + else + declare + R : String (1 .. Len); + + begin + for J in 1 .. Len - Str'Length loop + R (J) := Pad; + end loop; + + R (Len - Str'Length + 1 .. Len) := Str; + return V (R); + end; + end if; + end Lpad; + + procedure Lpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' ') + is + begin + if Length (Str) >= Len then + return; + else + Tail (Str, Len, Pad); + end if; + end Lpad; + + ------- + -- N -- + ------- + + function N (Str : VString) return Integer is + begin + return Integer'Value (Get_String (Str).all); + end N; + + -------------------- + -- Reverse_String -- + -------------------- + + function Reverse_String (Str : VString) return VString is + Len : constant Natural := Length (Str); + Result : String (1 .. Len); + Chars : String_Access := Get_String (Str); + + begin + for J in 1 .. Len loop + Result (J) := Chars (Len + 1 - J); + end loop; + + return V (Result); + end Reverse_String; + + function Reverse_String (Str : String) return VString is + Result : String (1 .. Str'Length); + + begin + for J in 1 .. Str'Length loop + Result (J) := Str (Str'Last + 1 - J); + end loop; + + return V (Result); + end Reverse_String; + + procedure Reverse_String (Str : in out VString) is + Len : constant Natural := Length (Str); + Chars : String_Access := Get_String (Str); + Temp : Character; + + begin + for J in 1 .. Len / 2 loop + Temp := Chars (J); + Chars (J) := Chars (Len + 1 - J); + Chars (Len + 1 - J) := Temp; + end loop; + end Reverse_String; + + ---------- + -- Rpad -- + ---------- + + function Rpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') + return VString + is + begin + if Length (Str) >= Len then + return Str; + else + return Head (Str, Len, Pad); + end if; + end Rpad; + + function Rpad + (Str : String; + Len : Natural; + Pad : Character := ' ') + return VString + is + begin + if Str'Length >= Len then + return V (Str); + + else + declare + R : String (1 .. Len); + + begin + for J in Str'Length + 1 .. Len loop + R (J) := Pad; + end loop; + + R (1 .. Str'Length) := Str; + return V (R); + end; + end if; + end Rpad; + + procedure Rpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' ') + is + begin + if Length (Str) >= Len then + return; + + else + Head (Str, Len, Pad); + end if; + end Rpad; + + ------- + -- S -- + ------- + + function S (Num : Integer) return String is + Buf : String (1 .. 30); + Ptr : Natural := Buf'Last + 1; + Val : Natural := abs (Num); + + begin + loop + Ptr := Ptr - 1; + Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + exit when Val = 0; + end loop; + + if Num < 0 then + Ptr := Ptr - 1; + Buf (Ptr) := '-'; + end if; + + return Buf (Ptr .. Buf'Last); + end S; + + ------------ + -- Substr -- + ------------ + + function Substr + (Str : VString; + Start : Positive; + Len : Natural) + return VString + is + begin + if Start > Length (Str) then + raise Index_Error; + + elsif Start + Len - 1 > Length (Str) then + raise Length_Error; + + else + return V (Get_String (Str).all (Start .. Start + Len - 1)); + end if; + end Substr; + + function Substr + (Str : String; + Start : Positive; + Len : Natural) + return VString + is + begin + if Start > Str'Length then + raise Index_Error; + + elsif Start + Len > Str'Length then + raise Length_Error; + + else + return + V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2)); + end if; + end Substr; + + ----------- + -- Table -- + ----------- + + package body Table is + + procedure Free is new + Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Hash (Str : String) return Unsigned_32; + -- Compute hash function for given String + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Table) is + Ptr1 : Hash_Element_Ptr; + Ptr2 : Hash_Element_Ptr; + + begin + for J in Object.Elmts'Range loop + Ptr1 := Object.Elmts (J)'Unrestricted_Access; + + if Ptr1.Name /= null then + loop + Ptr1.Name := new String'(Ptr1.Name.all); + exit when Ptr1.Next = null; + Ptr2 := Ptr1.Next; + Ptr1.Next := new Hash_Element'(Ptr2.all); + Ptr1 := Ptr1.Next; + end loop; + end if; + end loop; + end Adjust; + + ----------- + -- Clear -- + ----------- + + procedure Clear (T : in out Table) is + Ptr1 : Hash_Element_Ptr; + Ptr2 : Hash_Element_Ptr; + + begin + for J in T.Elmts'Range loop + if T.Elmts (J).Name /= null then + Free (T.Elmts (J).Name); + T.Elmts (J).Value := Null_Value; + + Ptr1 := T.Elmts (J).Next; + T.Elmts (J).Next := null; + + while Ptr1 /= null loop + Ptr2 := Ptr1.Next; + Free (Ptr1.Name); + Free (Ptr1); + Ptr1 := Ptr2; + end loop; + end if; + end loop; + end Clear; + + ---------------------- + -- Convert_To_Array -- + ---------------------- + + function Convert_To_Array (T : Table) return Table_Array is + Num_Elmts : Natural := 0; + Elmt : Hash_Element_Ptr; + + begin + for J in T.Elmts'Range loop + Elmt := T.Elmts (J)'Unrestricted_Access; + + if Elmt.Name /= null then + loop + Num_Elmts := Num_Elmts + 1; + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + + declare + TA : Table_Array (1 .. Num_Elmts); + P : Natural := 1; + + begin + for J in T.Elmts'Range loop + Elmt := T.Elmts (J)'Unrestricted_Access; + + if Elmt.Name /= null then + loop + Set_String (TA (P).Name, Elmt.Name.all); + TA (P).Value := Elmt.Value; + P := P + 1; + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + + return TA; + end; + end Convert_To_Array; + + ---------- + -- Copy -- + ---------- + + procedure Copy (From : in Table; To : in out Table) is + Elmt : Hash_Element_Ptr; + + begin + Clear (To); + + for J in From.Elmts'Range loop + Elmt := From.Elmts (J)'Unrestricted_Access; + if Elmt.Name /= null then + loop + Set (To, Elmt.Name.all, Elmt.Value); + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (T : in out Table; Name : Character) is + begin + Delete (T, String'(1 => Name)); + end Delete; + + procedure Delete (T : in out Table; Name : VString) is + begin + Delete (T, Get_String (Name).all); + end Delete; + + procedure Delete (T : in out Table; Name : String) is + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + Next : Hash_Element_Ptr; + + begin + if Elmt.Name = null then + null; + + elsif Elmt.Name.all = Name then + Free (Elmt.Name); + + if Elmt.Next = null then + Elmt.Value := Null_Value; + return; + + else + Next := Elmt.Next; + Elmt.Name := Next.Name; + Elmt.Value := Next.Value; + Elmt.Next := Next.Next; + Free (Next); + return; + end if; + + else + loop + Next := Elmt.Next; + + if Next = null then + return; + + elsif Next.Name.all = Name then + Free (Next.Name); + Elmt.Next := Next.Next; + Free (Next); + return; + + else + Elmt := Next; + end if; + end loop; + end if; + end Delete; + + ---------- + -- Dump -- + ---------- + + procedure Dump (T : Table; Str : String := "Table") is + Num_Elmts : Natural := 0; + Elmt : Hash_Element_Ptr; + + begin + for J in T.Elmts'Range loop + Elmt := T.Elmts (J)'Unrestricted_Access; + + if Elmt.Name /= null then + loop + Num_Elmts := Num_Elmts + 1; + Put_Line + (Str & '<' & Image (Elmt.Name.all) & "> = " & + Img (Elmt.Value)); + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + + if Num_Elmts = 0 then + Put_Line (Str & " is empty"); + end if; + end Dump; + + procedure Dump (T : Table_Array; Str : String := "Table_Array") is + begin + if T'Length = 0 then + Put_Line (Str & " is empty"); + + else + for J in T'Range loop + Put_Line + (Str & '(' & Image (To_String (T (J).Name)) & ") = " & + Img (T (J).Value)); + end loop; + end if; + end Dump; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Table) is + Ptr1 : Hash_Element_Ptr; + Ptr2 : Hash_Element_Ptr; + + begin + for J in Object.Elmts'Range loop + Ptr1 := Object.Elmts (J).Next; + Free (Object.Elmts (J).Name); + while Ptr1 /= null loop + Ptr2 := Ptr1.Next; + Free (Ptr1.Name); + Free (Ptr1); + Ptr1 := Ptr2; + end loop; + end loop; + end Finalize; + + --------- + -- Get -- + --------- + + function Get (T : Table; Name : Character) return Value_Type is + begin + return Get (T, String'(1 => Name)); + end Get; + + function Get (T : Table; Name : VString) return Value_Type is + begin + return Get (T, Get_String (Name).all); + end Get; + + function Get (T : Table; Name : String) return Value_Type is + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + + begin + if Elmt.Name = null then + return Null_Value; + + else + loop + if Name = Elmt.Name.all then + return Elmt.Value; + + else + Elmt := Elmt.Next; + + if Elmt = null then + return Null_Value; + end if; + end if; + end loop; + end if; + end Get; + + ---------- + -- Hash -- + ---------- + + function Hash (Str : String) return Unsigned_32 is + Result : Unsigned_32 := Str'Length; + + begin + for J in Str'Range loop + Result := Rotate_Left (Result, 1) + + Unsigned_32 (Character'Pos (Str (J))); + end loop; + + return Result; + end Hash; + + ------------- + -- Present -- + ------------- + + function Present (T : Table; Name : Character) return Boolean is + begin + return Present (T, String'(1 => Name)); + end Present; + + function Present (T : Table; Name : VString) return Boolean is + begin + return Present (T, Get_String (Name).all); + end Present; + + function Present (T : Table; Name : String) return Boolean is + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + + begin + if Elmt.Name = null then + return False; + + else + loop + if Name = Elmt.Name.all then + return True; + + else + Elmt := Elmt.Next; + + if Elmt = null then + return False; + end if; + end if; + end loop; + end if; + end Present; + + --------- + -- Set -- + --------- + + procedure Set (T : in out Table; Name : VString; Value : Value_Type) is + begin + Set (T, Get_String (Name).all, Value); + end Set; + + procedure Set (T : in out Table; Name : Character; Value : Value_Type) is + begin + Set (T, String'(1 => Name), Value); + end Set; + + procedure Set + (T : in out Table; + Name : String; + Value : Value_Type) + is + begin + if Value = Null_Value then + Delete (T, Name); + + else + declare + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + + subtype String1 is String (1 .. Name'Length); + + begin + if Elmt.Name = null then + Elmt.Name := new String'(String1 (Name)); + Elmt.Value := Value; + return; + + else + loop + if Name = Elmt.Name.all then + Elmt.Value := Value; + return; + + elsif Elmt.Next = null then + Elmt.Next := new Hash_Element'( + Name => new String'(String1 (Name)), + Value => Value, + Next => null); + return; + + else + Elmt := Elmt.Next; + end if; + end loop; + end if; + end; + end if; + end Set; + end Table; + + ---------- + -- Trim -- + ---------- + + function Trim (Str : VString) return VString is + begin + return Trim (Str, Right); + end Trim; + + function Trim (Str : String) return VString is + begin + for J in reverse Str'Range loop + if Str (J) /= ' ' then + return V (Str (Str'First .. J)); + end if; + end loop; + + return Nul; + end Trim; + + procedure Trim (Str : in out VString) is + begin + Trim (Str, Right); + end Trim; + + ------- + -- V -- + ------- + + function V (Num : Integer) return VString is + Buf : String (1 .. 30); + Ptr : Natural := Buf'Last + 1; + Val : Natural := abs (Num); + + begin + loop + Ptr := Ptr - 1; + Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + exit when Val = 0; + end loop; + + if Num < 0 then + Ptr := Ptr - 1; + Buf (Ptr) := '-'; + end if; + + return V (Buf (Ptr .. Buf'Last)); + end V; + +end GNAT.Spitbol; diff --git a/gcc/ada/g-spitbo.ads b/gcc/ada/g-spitbo.ads new file mode 100644 index 00000000000..ebf2620e156 --- /dev/null +++ b/gcc/ada/g-spitbo.ads @@ -0,0 +1,403 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ -- +-- -- +-- Copyright (C) 1997-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL-like interface facilities + +-- This package provides a set of interfaces to semantic operations copied +-- from SPITBOL, including a complete implementation of SPITBOL pattern +-- matching. The code is derived from the original SPITBOL MINIMAL sources, +-- created by Robert Dewar. The translation is not exact, but the +-- algorithmic approaches are similar. + +with Ada.Finalization; use Ada.Finalization; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Interfaces; use Interfaces; + +package GNAT.Spitbol is +pragma Preelaborate (Spitbol); + + -- The Spitbol package relies heavily on the Unbounded_String package, + -- using the synonym VString for variable length string. The following + -- declarations define this type and other useful abbreviations. + + subtype VString is Ada.Strings.Unbounded.Unbounded_String; + + function V (Source : String) return VString + renames Ada.Strings.Unbounded.To_Unbounded_String; + + function S (Source : VString) return String + renames Ada.Strings.Unbounded.To_String; + + Nul : VString renames Ada.Strings.Unbounded.Null_Unbounded_String; + + ------------------------- + -- Facilities Provided -- + ------------------------- + + -- The SPITBOL support in GNAT consists of this package together with + -- several child packages. In this package, we have first a set of + -- useful string functions, copied exactly from the corresponding + -- SPITBOL functions, except that we had to rename REVERSE because + -- reverse is a reserved word (it is now Reverse_String). + + -- The second element of the parent package is a generic implementation + -- of a table facility. In SPITBOL, the TABLE function allows general + -- mappings from any datatype to any other datatype, and of course, as + -- always, we can freely mix multiple types in the same table. + + -- The Ada version of tables is strongly typed, so the indexing type and + -- the range type are always of a consistent type. In this implementation + -- we only provide VString as an indexing type, since this is by far the + -- most common case. The generic instantiation specifies the range type + -- to be used. + + -- Three child packages provide standard instantiations of this table + -- package for three common datatypes: + + -- GNAT.Spitbol.Table_Boolean (file g-sptabo.ads) + + -- The range type is Boolean. The default value is False. This + -- means that this table is essentially a representation of a set. + + -- GNAT.Spitbol.Table_Integer (file g-sptain.ads) + + -- The range type is Integer. The default value is Integer'First. + -- This provides a general mapping from strings to integers. + + -- GNAT.Spitbol.Table_VString (file g-sptavs.ads) + + -- The range type is VString. The default value is the null string. + -- This provides a general mapping from strings to strings. + + -- Finally there is another child package: + + -- GNAT.Spitbol.Patterns (file g-spipat.ads) + + -- This child package provides a complete implementation of SPITBOL + -- pattern matching. The spec contains a complete tutorial on the + -- use of pattern matching. + + --------------------------------- + -- Standard String Subprograms -- + --------------------------------- + + -- This section contains some operations on unbounded strings that are + -- closely related to those in the package Unbounded.Strings, but they + -- correspond to the SPITBOL semantics for these operations. + + function Char (Num : Natural) return Character; + pragma Inline (Char); + -- Equivalent to Character'Val (Num) + + function Lpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') + return VString; + function Lpad + (Str : String; + Len : Natural; + Pad : Character := ' ') + return VString; + -- If the length of Str is greater than or equal to Len, then Str is + -- returned unchanged. Otherwise, The value returned is obtained by + -- concatenating Length (Str) - Len instances of the Pad character to + -- the left hand side. + + procedure Lpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' '); + -- The procedure form is identical to the function form, except that + -- the result overwrites the input argument Str. + + function Reverse_String (Str : VString) return VString; + function Reverse_String (Str : String) return VString; + -- Returns result of reversing the string Str, i.e. the result returned + -- is a mirror image (end-for-end reversal) of the input string. + + procedure Reverse_String (Str : in out VString); + -- The procedure form is identical to the function form, except that the + -- result overwrites the input argument Str. + + function Rpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') + return VString; + function Rpad + (Str : String; + Len : Natural; + Pad : Character := ' ') + return VString; + -- If the length of Str is greater than or equal to Len, then Str is + -- returned unchanged. Otherwise, The value returned is obtained by + -- concatenating Length (Str) - Len instances of the Pad character to + -- the right hand side. + + procedure Rpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' '); + -- The procedure form is identical to the function form, except that the + -- result overwrites the input argument Str. + + function Size (Source : VString) return Natural + renames Ada.Strings.Unbounded.Length; + + function Substr + (Str : VString; + Start : Positive; + Len : Natural) + return VString; + function Substr + (Str : String; + Start : Positive; + Len : Natural) + return VString; + -- Returns the substring starting at the given character position (which + -- is always counted from the start of the string, regardless of bounds, + -- e.g. 2 means starting with the second character of the string), and + -- with the length (Len) given. Indexing_Error is raised if the starting + -- position is out of range, and Length_Error is raised if Len is too long. + + function Trim (Str : VString) return VString; + function Trim (Str : String) return VString; + -- Returns the string obtained by removing all spaces from the right + -- hand side of the string Str. + + procedure Trim (Str : in out VString); + -- The procedure form is identical to the function form, except that the + -- result overwrites the input argument Str. + + ----------------------- + -- Utility Functions -- + ----------------------- + + -- In SPITBOL, integer values can be freely treated as strings. The + -- following definitions help provide some of this capability in + -- some common cases. + + function "&" (Num : Integer; Str : String) return String; + function "&" (Str : String; Num : Integer) return String; + function "&" (Num : Integer; Str : VString) return VString; + function "&" (Str : VString; Num : Integer) return VString; + -- In all these concatenation operations, the integer is converted to + -- its corresponding decimal string form, with no leading blank. + + function S (Num : Integer) return String; + function V (Num : Integer) return VString; + -- These operators return the given integer converted to its decimal + -- string form with no leading blank. + + function N (Str : VString) return Integer; + -- Converts string to number (same as Integer'Value (S (Str))) + + ------------------- + -- Table Support -- + ------------------- + + -- So far, we only provide support for tables whose indexing data values + -- are strings (or unbounded strings). The values stored may be of any + -- type, as supplied by the generic formal parameter. + + generic + + type Value_Type is private; + -- Any non-limited type can be used as the value type in the table + + Null_Value : Value_Type; + -- Value used to represent a value that is not present in the table. + + with function Img (A : Value_Type) return String; + -- Used to provide image of value in Dump procedure + + with function "=" (A, B : Value_Type) return Boolean is <>; + -- This allows a user-defined equality function to override the + -- predefined equality function. + + package Table is + + ------------------------ + -- Table Declarations -- + ------------------------ + + type Table (N : Unsigned_32) is private; + -- This is the table type itself. A table is a mapping from string + -- values to values of Value_Type. The discriminant is an estimate of + -- the number of values in the table. If the estimate is much too + -- high, some space is wasted, if the estimate is too low, access to + -- table elements is slowed down. The type Table has copy semantics, + -- not reference semantics. This means that if a table is copied + -- using simple assignment, then the two copies refer to entirely + -- separate tables. + + ----------------------------- + -- Table Access Operations -- + ----------------------------- + + function Get (T : Table; Name : VString) return Value_Type; + function Get (T : Table; Name : Character) return Value_Type; + pragma Inline (Get); + function Get (T : Table; Name : String) return Value_Type; + + -- If an entry with the given name exists in the table, then the + -- corresponding Value_Type value is returned. Otherwise Null_Value + -- is returned. + + function Present (T : Table; Name : VString) return Boolean; + function Present (T : Table; Name : Character) return Boolean; + pragma Inline (Present); + function Present (T : Table; Name : String) return Boolean; + -- Determines if an entry with the given name is present in the table. + -- A returned value of True means that it is in the table, otherwise + -- False indicates that it is not in the table. + + procedure Delete (T : in out Table; Name : VString); + procedure Delete (T : in out Table; Name : Character); + pragma Inline (Delete); + procedure Delete (T : in out Table; Name : String); + -- Deletes the table element with the given name from the table. If + -- no element in the table has this name, then the call has no effect. + + procedure Set (T : in out Table; Name : VString; Value : Value_Type); + procedure Set (T : in out Table; Name : Character; Value : Value_Type); + pragma Inline (Set); + procedure Set (T : in out Table; Name : String; Value : Value_Type); + -- Sets the value of the element with the given name to the given + -- value. If Value is equal to Null_Value, the effect is to remove + -- the entry from the table. If no element with the given name is + -- currently in the table, then a new element with the given value + -- is created. + + ---------------------------- + -- Allocation and Copying -- + ---------------------------- + + -- Table is a controlled type, so that all storage associated with + -- tables is properly reclaimed when a Table value is abandoned. + -- Tables have value semantics rather than reference semantics as + -- in Spitbol, i.e. when you assign a copy you end up with two + -- distinct copies of the table, as though COPY had been used in + -- Spitbol. It seems clearly more appropriate in Ada to require + -- the use of explicit pointers for reference semantics. + + procedure Clear (T : in out Table); + -- Clears all the elements of the given table, freeing associated + -- storage. On return T is an empty table with no elements. + + procedure Copy (From : in Table; To : in out Table); + -- First all the elements of table To are cleared (as described for + -- the Clear procedure above), then all the elements of table From + -- are copied into To. In the case where the tables From and To have + -- the same declared size (i.e. the same discriminant), the call to + -- Copy has the same effect as the assignment of From to To. The + -- difference is that, unlike the assignment statement, which will + -- cause a Constraint_Error if the source and target are of different + -- sizes, Copy works fine with different sized tables. + + ---------------- + -- Conversion -- + ---------------- + + type Table_Entry is record + Name : VString; + Value : Value_Type; + end record; + + type Table_Array is array (Positive range <>) of Table_Entry; + + function Convert_To_Array (T : Table) return Table_Array; + -- Returns a Table_Array value with a low bound of 1, and a length + -- corresponding to the number of elements in the table. The elements + -- of the array give the elements of the table in unsorted order. + + --------------- + -- Debugging -- + --------------- + + procedure Dump (T : Table; Str : String := "Table"); + -- Dump contents of given table to the standard output file. The + -- string value Str is used as the name of the table in the dump. + + procedure Dump (T : Table_Array; Str : String := "Table_Array"); + -- Dump contents of given table array to the current output file. The + -- string value Str is used as the name of the table array in the dump. + + private + + ------------------ + -- Private Part -- + ------------------ + + -- A Table is a pointer to a hash table which contains the indicated + -- number of hash elements (the number is forced to the next odd value + -- if it is even to improve hashing performance). If more than one + -- of the entries in a table hashes to the same slot, the Next field + -- is used to chain entries from the header. The chains are not kept + -- ordered. A chain is terminated by a null pointer in Next. An unused + -- chain is marked by an element whose Name is null and whose value + -- is Null_Value. + + type Hash_Element; + type Hash_Element_Ptr is access all Hash_Element; + + type Hash_Element is record + Name : String_Access := null; + Value : Value_Type := Null_Value; + Next : Hash_Element_Ptr := null; + end record; + + type Hash_Table is + array (Unsigned_32 range <>) of aliased Hash_Element; + + type Table (N : Unsigned_32) is new Controlled with record + Elmts : Hash_Table (1 .. N); + end record; + + pragma Finalize_Storage_Only (Table); + + procedure Adjust (Object : in out Table); + -- The Adjust procedure does a deep copy of the table structure + -- so that the effect of assignment is, like other assignments + -- in Ada, value-oriented. + + procedure Finalize (Object : in out Table); + -- This is the finalization routine that ensures that all storage + -- associated with a table is properly released when a table object + -- is abandoned and finalized. + + end Table; + +end GNAT.Spitbol; diff --git a/gcc/ada/g-sptabo.ads b/gcc/ada/g-sptabo.ads new file mode 100644 index 00000000000..f6c170e3250 --- /dev/null +++ b/gcc/ada/g-sptabo.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . T A B L E _ B O O L E A N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1997-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL tables with boolean values (sets) + +-- This package provides a predefined instantiation of the table abstraction +-- for type Standard.Boolean. The null value is False, so the only non-null +-- value is True, i.e. this table acts essentially as a set representation. +-- This package is based on Macro-SPITBOL created by Robert Dewar. + +package GNAT.Spitbol.Table_Boolean is new + GNAT.Spitbol.Table (Boolean, False, Boolean'Image); +pragma Preelaborate (Table_Boolean); diff --git a/gcc/ada/g-sptain.ads b/gcc/ada/g-sptain.ads new file mode 100644 index 00000000000..24b824508b3 --- /dev/null +++ b/gcc/ada/g-sptain.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . T A B L E _ I N T E G E R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1997-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL tables with integer values + +-- This package provides a predefined instantiation of the table abstraction +-- for type Standard.Integer. The largest negative integer is used as the +-- null value for the table. This package is based on Macro-SPITBOL created +-- by Robert Dewar. + +package GNAT.Spitbol.Table_Integer is + new GNAT.Spitbol.Table (Integer, Integer'First, Integer'Image); +pragma Preelaborate (Table_Integer); diff --git a/gcc/ada/g-sptavs.ads b/gcc/ada/g-sptavs.ads new file mode 100644 index 00000000000..87d4d5cef21 --- /dev/null +++ b/gcc/ada/g-sptavs.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . T A B L E _ V S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1997-1998 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL tables with vstring (unbounded string) values + +-- This package provides a predefined instantiation of the table abstraction +-- for type VString (Ada.Strings.Unbounded.Unbounded_String). This package +-- is based on Macro-SPITBOL created by Robert Dewar. + +package GNAT.Spitbol.Table_VString is new + GNAT.Spitbol.Table (VString, Nul, To_String); +pragma Preelaborate (Table_VString); diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb new file mode 100644 index 00000000000..086f1de7970 --- /dev/null +++ b/gcc/ada/g-table.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . T A B L E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; + +package body GNAT.Table is + + Min : constant Integer := Integer (Table_Low_Bound); + -- Subscript of the minimum entry in the currently allocated table + + Max : Integer; + -- Subscript of the maximum entry in the currently allocated table + + Length : Integer := 0; + -- Number of entries in currently allocated table. The value of zero + -- ensures that we initially allocate the table. + + Last_Val : Integer; + -- Current value of Last. + + type size_t is new Integer; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Reallocate; + -- Reallocate the existing table according to the current value stored + -- in Max. Works correctly to do an initial allocation if the table + -- is currently null. + + -------------- + -- Allocate -- + -------------- + + function Allocate (Num : Integer := 1) return Table_Index_Type is + Old_Last : constant Integer := Last_Val; + + begin + Last_Val := Last_Val + Num; + + if Last_Val > Max then + Reallocate; + end if; + + return Table_Index_Type (Old_Last + 1); + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (New_Val : Table_Component_Type) is + begin + Increment_Last; + Table (Table_Index_Type (Last_Val)) := New_Val; + end Append; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last is + begin + Last_Val := Last_Val - 1; + end Decrement_Last; + + ---------- + -- Free -- + ---------- + + procedure Free is + procedure free (T : Table_Ptr); + pragma Import (C, free); + + begin + free (Table); + Table := null; + Length := 0; + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last is + begin + Last_Val := Last_Val + 1; + + if Last_Val > Max then + Reallocate; + end if; + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init is + Old_Length : Integer := Length; + + begin + Last_Val := Min - 1; + Max := Min + Table_Initial - 1; + Length := Max - Min + 1; + + -- If table is same size as before (happens when table is never + -- expanded which is a common case), then simply reuse it. Note + -- that this also means that an explicit Init call right after + -- the implicit one in the package body is harmless. + + if Old_Length = Length then + return; + + -- Otherwise we can use Reallocate to get a table of the right size. + -- Note that Reallocate works fine to allocate a table of the right + -- initial size when it is first allocated. + + else + Reallocate; + end if; + end Init; + + ---------- + -- Last -- + ---------- + + function Last return Table_Index_Type is + begin + return Table_Index_Type (Last_Val); + end Last; + + ---------------- + -- Reallocate -- + ---------------- + + procedure Reallocate is + + function realloc + (memblock : Table_Ptr; + size : size_t) + return Table_Ptr; + pragma Import (C, realloc); + + function malloc + (size : size_t) + return Table_Ptr; + pragma Import (C, malloc); + + New_Size : size_t; + + begin + if Max < Last_Val then + pragma Assert (not Locked); + + while Max < Last_Val loop + + -- Increase length using the table increment factor, but make + -- sure that we add at least ten elements (this avoids a loop + -- for silly small increment values) + + Length := Integer'Max + (Length * (100 + Table_Increment) / 100, + Length + 10); + Max := Min + Length - 1; + end loop; + end if; + + New_Size := + size_t ((Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + if Table = null then + Table := malloc (New_Size); + + elsif New_Size > 0 then + Table := + realloc + (memblock => Table, + size => New_Size); + end if; + + if Length /= 0 and then Table = null then + raise Storage_Error; + end if; + + end Reallocate; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Length := Last_Val - Integer (Table_Low_Bound) + 1; + Max := Last_Val; + Reallocate; + end Release; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type) + is + begin + if Integer (Index) > Max then + Set_Last (Index); + end if; + + Table (Index) := Item; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if Integer (New_Val) < Last_Val then + Last_Val := Integer (New_Val); + else + Last_Val := Integer (New_Val); + + if Last_Val > Max then + Reallocate; + end if; + end if; + end Set_Last; + +begin + Init; +end GNAT.Table; diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads new file mode 100644 index 00000000000..2ddd0b08d70 --- /dev/null +++ b/gcc/ada/g-table.ads @@ -0,0 +1,189 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . T A B L E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Resizable one dimensional array support + +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- This package provides a facility similar to that of GNAT.Dynamic_Tables, +-- except that this package declares a single instance of the table type, +-- while an instantiation of GNAT.Dynamic_Tables creates a type that can be +-- used to define dynamic instances of the table. + +-- Note that this interface should remain synchronized with those in +-- GNAT.Dynamic_Tables and the GNAT compiler source unit Table to keep +-- as much coherency as possible between these three related units. + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + Table_Increment : Natural; + +package GNAT.Table is +pragma Elaborate_Body (Table); + + -- Table_Component_Type and Table_Index_Type specify the type of the + -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- integer type. The effect is roughly to declare: + + -- Table : array (Table_Index_Type range Table_Low_Bound .. <>) + -- of Table_Component_Type; + + -- Note: since the upper bound can be one less than the lower + -- bound for an empty array, the table index type must be able + -- to cover this range, e.g. if the lower bound is 1, then the + -- Table_Index_Type should be Natural rather than Positive. + + -- Table_Component_Type may be any Ada type, except that controlled + -- types are not supported. Note however that default initialization + -- will NOT occur for array components. + + -- The Table_Initial values controls the allocation of the table when + -- it is first allocated, either by default, or by an explicit Init call. + + -- The Table_Increment value controls the amount of increase, if the + -- table has to be increased in size. The value given is a percentage + -- value (e.g. 100 = increase table size by 100%, i.e. double it). + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: we do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained + -- with the maximum possible range bound. This means that the pointer + -- is a thin pointer, which is more efficient. Since subscript checks + -- in any case must be on the logical, rather than physical bounds, + -- safety is not compromised by this approach. + + type Table_Ptr is access all Big_Table_Type; + -- The table is actually represented as a pointer to allow reallocation + + Table : aliased Table_Ptr := null; + -- The table itself. The lower bound is the value of Low_Bound. + -- Logically the upper bound is the current value of Last (although + -- the actual size of the allocated table may be larger than this). + -- The program may only access and modify Table entries in the range + -- First .. Last. + + Locked : Boolean := False; + -- Table expansion is permitted only if this switch is set to False. A + -- client may set Locked to True, in which case any attempt to expand + -- the table will cause an assertion failure. Note that while a table + -- is locked, its address in memory remains fixed and unchanging. + + procedure Init; + -- This procedure allocates a new table of size Initial (freeing any + -- previously allocated larger table). It is not necessary to call + -- Init when a table is first instantiated (since the instantiation does + -- the same initialization steps). However, it is harmless to do so, and + -- Init is convenient in reestablishing a table for new use. + + function Last return Table_Index_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, which + -- can then be used as a subscript for Table. Note that the only way to + -- modify Last is to call the Set_Last procedure. Last must always be + -- used to determine the logically last entry. + + procedure Release; + -- Storage is allocated in chunks according to the values given in the + -- Initial and Increment parameters. A call to Release releases all + -- storage that is allocated, but is not logically part of the current + -- array value. Current array values are not affected by this call. + + procedure Free; + -- Free all allocated memory for the table. A call to init is required + -- before any use of this table after calling Free. + + First : constant Table_Index_Type := Table_Low_Bound; + -- Export First as synonym for Low_Bound (parallel with use of Last) + + procedure Set_Last (New_Val : Table_Index_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the + -- table is reallocated to accomodate the new value (i.e. on return + -- the allocated table has an upper bound of at least Last). If Set_Last + -- reduces the size of the table, then logically entries are removed + -- from the table. If Set_Last increases the size of the table, then + -- new entries are logically added to the table. + + procedure Increment_Last; + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1). + + procedure Decrement_Last; + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1). + + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); + -- Equivalent to: + -- x.Increment_Last; + -- x.Table (x.Last) := New_Val; + -- i.e. the table size is increased by one, and the given new item + -- stored in the newly created table element. + + procedure Set_Item + (Index : Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. The table is expanded if the + -- current table length is less than Index and in that case Last is set to + -- Index. Item will replace any value already present in the table at this + -- position. + + function Allocate (Num : Integer := 1) return Table_Index_Type; + pragma Inline (Allocate); + -- Adds Num to Last, and returns the old value of Last + 1. Note that + -- this function has the possible side effect of reallocating the table. + -- This means that a reference X.Table (X.Allocate) is incorrect, since + -- the call to X.Allocate may modify the results of calling X.Table. + +end GNAT.Table; diff --git a/gcc/ada/g-tasloc.adb b/gcc/ada/g-tasloc.adb new file mode 100644 index 00000000000..375586c7c4e --- /dev/null +++ b/gcc/ada/g-tasloc.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A S K _ L O C K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1997-1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Soft_Links; +-- used for Lock_Task, Unlock_Task + +package body GNAT.Task_Lock is + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + System.Soft_Links.Lock_Task.all; + end Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + System.Soft_Links.Unlock_Task.all; + end Unlock; + +end GNAT.Task_Lock; diff --git a/gcc/ada/g-tasloc.ads b/gcc/ada/g-tasloc.ads new file mode 100644 index 00000000000..f80bdf49a60 --- /dev/null +++ b/gcc/ada/g-tasloc.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A S K _ L O C K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Simple task lock and unlock routines + +-- A small package containing a task lock and unlock routines for creating +-- a critical region. The lock involved is a global lock, shared by all +-- tasks, and by all calls to these routines, so these routines should be +-- used with care to avoid unnecessary reduction of concurrency. + +-- These routines may be used in a non-tasking program, and in that case +-- they have no effect (they do NOT cause the tasking runtime to be loaded). + +package GNAT.Task_Lock is +pragma Elaborate_Body (Task_Lock); + + procedure Lock; + pragma Inline (Lock); + -- Acquires the global lock, starts the execution of a critical region + -- which no other task can enter until the locking task calls Unlock + + procedure Unlock; + pragma Inline (Unlock); + -- Releases the global lock, allowing another task to successfully + -- complete a Lock operation. Terminates the critical region. + + -- The recommended protocol for using these two procedures is as + -- follows: + + -- Locked_Processing : begin + -- Lock; + -- ... + -- TSL.Unlock; + -- + -- exception + -- when others => + -- Unlock; + -- raise; + -- end Locked_Processing; + + -- This ensures that the lock is not left set if an exception is raised + -- explicitly or implicitly during the critical locked region. + + -- Note on multiple calls to Lock: It is permissible to call Lock + -- more than once with no intervening Unlock from a single task, + -- and the lock will not be released until the corresponding number + -- of Unlock operations has been performed. For example: + + -- GNAT.Task_Lock.Lock; -- acquires lock + -- GNAT.Task_Lock.Lock; -- no effect + -- GNAT.Task_Lock.Lock; -- no effect + -- GNAT.Task_Lock.Unlock; -- no effect + -- GNAT.Task_Lock.Unlock; -- no effect + -- GNAT.Task_Lock.Unlock; -- releases lock + + -- However, as previously noted, the Task_Lock facility should only + -- be used for very local locks where the probability of conflict is + -- low, so usually this kind of nesting is not a good idea in any case. + -- In more complex locking situations, it is more appropriate to define + -- an appropriate protected type to provide the required locking. + +end GNAT.Task_Lock; diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb new file mode 100644 index 00000000000..ad6b754106d --- /dev/null +++ b/gcc/ada/g-thread.adb @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . T H R E A D S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1998-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Task_Identification; use Ada.Task_Identification; +with System.Task_Primitives.Operations; +with System.Tasking; +with System.OS_Interface; +with Unchecked_Conversion; + +package body GNAT.Threads is + + use System; + + function To_Addr is new Unchecked_Conversion (Task_Id, Address); + function To_Id is new Unchecked_Conversion (Address, Task_Id); + function To_Id is new Unchecked_Conversion (Address, Tasking.Task_ID); + + type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr); + + task type Thread + (Stsz : Natural; + Prio : Any_Priority; + Parm : Void_Ptr; + Code : Code_Proc) + is + pragma Priority (Prio); + pragma Storage_Size (Stsz); + end Thread; + + task body Thread is + begin + Code.all (To_Addr (Current_Task), Parm); + end Thread; + + type Tptr is access Thread; + + ------------------- + -- Create_Thread -- + ------------------- + + function Create_Thread + (Code : Address; + Parm : Void_Ptr; + Size : Natural; + Prio : Integer) return System.Address + is + TP : Tptr; + + function To_CP is new Unchecked_Conversion (Address, Code_Proc); + + begin + TP := new Thread (Size, Prio, Parm, To_CP (Code)); + return To_Addr (TP'Identity); + end Create_Thread; + + -------------------- + -- Destroy_Thread -- + -------------------- + + procedure Destroy_Thread (Id : Address) is + Tid : Task_Id := To_Id (Id); + + begin + Abort_Task (Tid); + end Destroy_Thread; + + ---------------- + -- Get_Thread -- + ---------------- + + procedure Get_Thread (Id : Address; Thread : Address) is + use System.OS_Interface; + + Thr : Thread_Id; + for Thr use at Thread; + begin + Thr := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); + end Get_Thread; + +end GNAT.Threads; diff --git a/gcc/ada/g-thread.ads b/gcc/ada/g-thread.ads new file mode 100644 index 00000000000..4ccdda9b6d8 --- /dev/null +++ b/gcc/ada/g-thread.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . T H R E A D S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1998-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for creation of foreign threads for +-- use as Ada tasks. In order to execute general Ada code, the run-time +-- system must know about all tasks. This package allows foreign code, +-- e.g. a C program, to create a thread that the Ada run-time knows about. + +with System; + +package GNAT.Threads is + + type Void_Ptr is access all Integer; + + function Create_Thread + (Code : System.Address; -- pointer + Parm : Void_Ptr; -- pointer + Size : Natural; -- int + Prio : Integer) -- int + return System.Address; + pragma Export (C, Create_Thread, "__gnat_create_thread"); + -- Creates a thread with the given (Size) stack size in bytes, and + -- the given (Prio) priority. The task will execute a call to the + -- procedure whose address is given by Code. This procedure has + -- the prototype + -- + -- void thread_code (void *id, void *parm); + -- + -- where id is the id of the created task, and parm is the parameter + -- passed to Create_Thread. The called procedure is the body of the + -- code for the task, the task will be automatically terminated when + -- the procedure returns. + -- + -- This function returns the Ada Id of the created task that can then be + -- used as a parameter to the procedures below. + -- + -- C declaration: + -- + -- extern void *__gnat_create_thread + -- (void (*code)(void *, void *), void *parm, int size, int prio); + + procedure Destroy_Thread (Id : System.Address); + pragma Export (C, Destroy_Thread, "__gnat_destroy_thread"); + -- This procedure may be used to prematurely abort the created thread. + -- The value Id is the value that was passed to the thread code procedure + -- at activation time. + -- + -- C declaration: + -- + -- extern void __gnat_destroy_thread (void *id); + + procedure Get_Thread (Id : System.Address; Thread : System.Address); + pragma Export (C, Get_Thread, "__gnat_get_thread"); + -- This procedure is used to retrieve the thread id of a given task. + -- The value Id is the value that was passed to the thread code procedure + -- at activation time. + -- Thread is a pointer to a thread id that will be updated by this + -- procedure. + -- + -- C declaration: + -- + -- extern void __gnat_get_thread (void *id, pthread_t *thread); + +end GNAT.Threads; diff --git a/gcc/ada/g-traceb.adb b/gcc/ada/g-traceb.adb new file mode 100644 index 00000000000..d1d6c42a664 --- /dev/null +++ b/gcc/ada/g-traceb.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 1999-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time non-symbolic traceback support + +with System.Traceback; + +package body GNAT.Traceback is + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : out Tracebacks_Array; + Len : out Natural) + is + begin + System.Traceback.Call_Chain (Traceback'Address, Traceback'Length, Len); + end Call_Chain; + +end GNAT.Traceback; diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads new file mode 100644 index 00000000000..5f7a6ec1540 --- /dev/null +++ b/gcc/ada/g-traceb.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ +-- -- +-- Copyright (C) 1999-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time non-symbolic traceback support + +-- This package provides a method for generating a traceback of the +-- current execution location. The traceback shows the locations of +-- calls in the call chain, up to either the top or a designated +-- number of levels. + +-- The traceback information is in the form of absolute code locations. +-- These code locations may be converted to corresponding source locations +-- using the external addr2line utility, or from within GDB. + +-- To analyze the code locations later using addr2line or gdb, the necessary +-- units must be compiled with the debugging switch -g in the usual manner. +-- Note that it is not necesary to compile with -g to use Call_Chain. In +-- other words, the following sequence of steps can be used: + +-- Compile without -g +-- Run the program, and call Call_Chain +-- Recompile with -g +-- Use addr2line to interpret the absolute call locations + +-- This capability is currently supported on the following targets: + +-- All x86 ports +-- AiX PowerPC +-- HP-UX +-- Irix +-- Solaris sparc +-- Tru64 +-- VxWorks PowerPC +-- VxWorks Alpha + +with System; + +package GNAT.Traceback is + pragma Elaborate_Body; + + subtype Code_Loc is System.Address; + -- Code location used in building tracebacks + + type Tracebacks_Array is array (Positive range <>) of Code_Loc; + -- Traceback array used to hold a generated traceback list. + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain (Traceback : out Tracebacks_Array; Len : out Natural); + -- Store up to Traceback'Length tracebacks corresponding to the current + -- call chain. The first entry stored corresponds to the deepest level + -- of subprogram calls. Len shows the number of traceback entries stored. + -- It will be equal to Traceback'Length unless the entire traceback is + -- shorter, in which case positions in Traceback past the Len position + -- are undefined on return. + +end GNAT.Traceback; diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb new file mode 100644 index 00000000000..65ffe0feb0e --- /dev/null +++ b/gcc/ada/g-trasym.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1999 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support + +with System.Soft_Links; +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; + +package body GNAT.Traceback.Symbolic is + + pragma Linker_Options ("-laddr2line"); + pragma Linker_Options ("-lbfd"); + pragma Linker_Options ("-liberty"); + + package TSL renames System.Soft_Links; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + procedure convert_addresses + (addrs : System.Address; + n_addr : Integer; + buf : System.Address; + len : System.Address); + pragma Import (C, convert_addresses, "convert_addresses"); + -- This is the procedure version of the Ada aware addr2line that will + -- use argv[0] as the executable containing the debug information. + -- This procedure is provided by libaddr2line on targets that support + -- it. A dummy version is in a-adaint.c for other targets so that build + -- of shared libraries doesn't generate unresolved symbols. + -- + -- Note that this procedure is *not* thread-safe. + + Res : String (1 .. 256 * Traceback'Length); + Len : Integer; + + begin + if Traceback'Length > 0 then + TSL.Lock_Task.all; + convert_addresses + (Traceback'Address, Traceback'Length, Res (1)'Address, Len'Address); + TSL.Unlock_Task.all; + return Res (1 .. Len); + else + return ""; + end if; + end Symbolic_Traceback; + + function Symbolic_Traceback (E : Exception_Occurrence) return String is + begin + return Symbolic_Traceback (Tracebacks (E)); + end Symbolic_Traceback; + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads new file mode 100644 index 00000000000..c8f27b048b6 --- /dev/null +++ b/gcc/ada/g-trasym.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1999-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support + +-- Note: this is only available on selected targets. Currently it is +-- supported on Sparc/Solaris, Linux, Windows NT, HP-UX, IRIX and Tru64. + +-- The routines provided in this package assume that your application has +-- been compiled with debugging information turned on, since this information +-- is used to build a symbolic traceback. + +with Ada.Exceptions; use Ada.Exceptions; + +package GNAT.Traceback.Symbolic is +pragma Elaborate_Body (Traceback.Symbolic); + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String; + -- Build a string containing a symbolic traceback of the given call chain. + + function Symbolic_Traceback (E : Exception_Occurrence) return String; + -- Build a string containing a symbolic traceback of the given exception + -- occurrence. + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb new file mode 100644 index 00000000000..69b265fc869 --- /dev/null +++ b/gcc/ada/get_targ.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E T _ T A R G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Get_Targ is + + ---------------------- + -- Digits_From_Size -- + ---------------------- + + function Digits_From_Size (Size : Pos) return Pos is + begin + if Size = 32 then return 6; + elsif Size = 48 then return 9; + elsif Size = 64 then return 15; + elsif Size = 96 then return 18; + elsif Size = 128 then return 18; + else + raise Program_Error; + end if; + end Digits_From_Size; + + --------------------- + -- Width_From_Size -- + --------------------- + + function Width_From_Size (Size : Pos) return Pos is + begin + if Size = 8 then return 4; + elsif Size = 16 then return 6; + elsif Size = 32 then return 11; + elsif Size = 64 then return 21; + else + raise Program_Error; + end if; + end Width_From_Size; + +end Get_Targ; diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads new file mode 100644 index 00000000000..d6b0e3cbf3b --- /dev/null +++ b/gcc/ada/get_targ.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E T _ T A R G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1992-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an Import to the C functions which provide +-- values related to types on the target system. It is only needed for +-- exp_dbug and the elaboration of ttypes. + +-- NOTE: Any changes in this package must be reflected in jgettarg.ads! + +-- Note that all these values return sizes of C types with corresponding +-- names. This allows GNAT to define the corresponding Ada types to have +-- the same representation. There is one exception to this: the +-- Wide_Character_Type uses twice the size of a C char, instead of the +-- size of wchar_t. + +with Types; use Types; + +package Get_Targ is +pragma Preelaborate (Get_Targ); + + function Get_Bits_Per_Unit return Pos; + pragma Import (C, Get_Bits_Per_Unit, "get_target_bits_per_unit"); + + function Get_Bits_Per_Word return Pos; + pragma Import (C, Get_Bits_Per_Word, "get_target_bits_per_word"); + + function Get_Char_Size return Pos; -- Standard.Character'Size + pragma Import (C, Get_Char_Size, "get_target_char_size"); + + function Get_Wchar_T_Size return Pos; -- Interfaces.C.wchar_t'Size + pragma Import (C, Get_Wchar_T_Size, "get_target_wchar_t_size"); + + function Get_Short_Size return Pos; -- Standard.Short_Integer'Size + pragma Import (C, Get_Short_Size, "get_target_short_size"); + + function Get_Int_Size return Pos; -- Standard.Integer'Size + pragma Import (C, Get_Int_Size, "get_target_int_size"); + + function Get_Long_Size return Pos; -- Standard.Long_Integer'Size + pragma Import (C, Get_Long_Size, "get_target_long_size"); + + function Get_Long_Long_Size return Pos; -- Standard.Long_Long_Integer'Size + pragma Import (C, Get_Long_Long_Size, "get_target_long_long_size"); + + function Get_Float_Size return Pos; -- Standard.Float'Size + pragma Import (C, Get_Float_Size, "get_target_float_size"); + + function Get_Double_Size return Pos; -- Standard.Long_Float'Size + pragma Import (C, Get_Double_Size, "get_target_double_size"); + + function Get_Long_Double_Size return Pos; -- Standard.Long_Long_Float'Size + pragma Import (C, Get_Long_Double_Size, "get_target_long_double_size"); + + function Get_Pointer_Size return Pos; -- System.Address'Size + pragma Import (C, Get_Pointer_Size, "get_target_pointer_size"); + + function Get_Maximum_Alignment return Pos; + pragma Import (C, Get_Maximum_Alignment, "get_target_maximum_alignment"); + + function Get_No_Dollar_In_Label return Boolean; + pragma Import (C, Get_No_Dollar_In_Label, "get_target_no_dollar_in_label"); + + function Get_Float_Words_BE return Nat; + pragma Import (C, Get_Float_Words_BE, "get_float_words_be"); + + function Get_Words_BE return Nat; + pragma Import (C, Get_Words_BE, "get_words_be"); + + function Get_Bytes_BE return Nat; + pragma Import (C, Get_Bytes_BE, "get_bytes_be"); + + function Get_Bits_BE return Nat; + pragma Import (C, Get_Bits_BE, "get_bits_be"); + + function Get_Strict_Alignment return Nat; + pragma Import (C, Get_Strict_Alignment, "get_strict_alignment"); + + function Width_From_Size (Size : Pos) return Pos; + function Digits_From_Size (Size : Pos) return Pos; + -- Calculate values for 'Width or 'Digits from 'Size + +end Get_Targ; diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h new file mode 100644 index 00000000000..49d8533c8c9 --- /dev/null +++ b/gcc/ada/gigi.h @@ -0,0 +1,783 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * G I G I * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion 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. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* Declare all functions and types used by gigi. */ + +/* Decode all the language specific options that cannot be decoded by GCC. The + option decoding phase of GCC calls this routine on the flags that it cannot + decode. This routine returns 1 if it is successful, otherwise it + returns 0. */ +extern int gnat_decode_option PARAMS ((int, char **)); + +/* Perform all initialization steps for option processing. */ +extern void gnat_init_options PARAMS ((void)); + +/* Perform all the initialization steps that are language-specific. */ +extern void gnat_init PARAMS ((void)); + +/* See if DECL has an RTL that is indirect via a pseudo-register or a + memory location and replace it with an indirect reference if so. + This improves the debugger's ability to display the value. */ +extern void adjust_decl_rtl PARAMS ((tree)); + +/* Record the current code position in GNAT_NODE. */ +extern void record_code_position PARAMS ((Node_Id)); + +/* Insert the code for GNAT_NODE at the position saved for that node. */ +extern void insert_code_for PARAMS ((Node_Id)); + +/* Routine called by gcc for emitting a stack check. GNU_EXPR is the + expression that contains the last address on the stack to check. */ +extern tree emit_stack_check PARAMS ((tree)); + +/* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */ +extern tree make_transform_expr PARAMS ((Node_Id)); + +/* Update the setjmp buffer BUF with the current stack pointer. We assume + here that a __builtin_setjmp was done to BUF. */ +extern void update_setjmp_buf PARAMS ((tree)); + +/* Get the alias set corresponding to a type or expression. */ +extern HOST_WIDE_INT gnat_get_alias_set PARAMS ((tree)); + +/* GNU_TYPE is a type. Determine if it should be passed by reference by + default. */ +extern int default_pass_by_ref PARAMS ((tree)); + +/* GNU_TYPE is the type of a subprogram parameter. Determine from the type if + it should be passed by reference. */ +extern int must_pass_by_ref PARAMS ((tree)); + +/* Elaboration routines for the front end */ +extern void elab_all_gnat PARAMS ((void)); + +/* Emit a label UNITNAME_LABEL and specify that it is part of source + file FILENAME. If this is being written for SGI's Workshop + debugger, and we are writing Dwarf2 debugging information, add + additional debug info. */ +extern void emit_unit_label PARAMS ((char *, char *)); + +/* Initialize DUMMY_NODE_TABLE. */ +extern void init_dummy_type PARAMS ((void)); + +/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada + entity, this routine returns the equivalent GCC tree for that entity + (an ..._DECL node) and associates the ..._DECL node with the input GNAT + defining identifier. + + If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its + initial value (in GCC tree form). This is optional for variables. + For renamed entities, GNU_EXPR gives the object being renamed. + + DEFINITION is nonzero if this call is intended for a definition. This is + used for separate compilation where it necessary to know whether an + external declaration or a definition should be created if the GCC equivalent + was not created previously. The value of 1 is normally used for a non-zero + DEFINITION, but a value of 2 is used in special circumstances, defined in + the code. */ +extern tree gnat_to_gnu_entity PARAMS ((Entity_Id, tree, int)); + +/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a + GCC type corresponding to that entity. GNAT_ENTITY is assumed to + refer to an Ada type. */ +extern tree gnat_to_gnu_type PARAMS ((Entity_Id)); + +/* Given GNAT_ENTITY, elaborate all expressions that are required to + be elaborated at the point of its definition, but do nothing else. */ +extern void elaborate_entity PARAMS ((Entity_Id)); + +/* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark + any entities on its entity chain similarly. */ +extern void mark_out_of_scope PARAMS ((Entity_Id)); + +/* Make a dummy type corresponding to GNAT_TYPE. */ +extern tree make_dummy_type PARAMS ((Entity_Id)); + +/* Get the unpadded version of a GNAT type. */ +extern tree get_unpadded_type PARAMS ((Entity_Id)); + +/* Called when we need to protect a variable object using a save_expr. */ +extern tree maybe_variable PARAMS ((tree, Node_Id)); + +/* Create a record type that contains a field of TYPE with a starting bit + position so that it is aligned to ALIGN bits. */ +/* Create a record type that contains a field of TYPE with a starting bit + position so that it is aligned to ALIGN bits and is SIZE bytes long. */ +extern tree make_aligning_type PARAMS ((tree, int, tree)); + +/* Given a GNU tree and a GNAT list of choices, generate an expression to test + the value passed against the list of choices. */ +extern tree choices_to_gnu PARAMS ((tree, Node_Id)); + +/* Given a type T, a FIELD_DECL F, and a replacement value R, + return a new type with all size expressions that contain F + updated by replacing F with R. This is identical to GCC's + substitute_in_type except that it knows about TYPE_INDEX_TYPE. */ +extern tree gnat_substitute_in_type PARAMS ((tree, tree, tree)); + +/* Return the "RM size" of GNU_TYPE. This is the actual number of bits + needed to represent the object. */ +extern tree rm_size PARAMS ((tree)); + +/* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a + string, return a new IDENTIFIER_NODE that is the concatenation of + the name in GNU_ID and SUFFIX. */ +extern tree concat_id_with_name PARAMS ((tree, const char *)); + +/* Return the name to be used for GNAT_ENTITY. If a type, create a + fully-qualified name, possibly with type information encoding. + Otherwise, return the name. */ +extern tree get_entity_name PARAMS ((Entity_Id)); + +/* Return a name for GNAT_ENTITY concatenated with two underscores and + SUFFIX. */ +extern tree create_concat_name PARAMS ((Entity_Id, const char *)); + +/* Flag indicating whether file names are discarded in exception messages */ +extern int discard_file_names; + +/* If true, then gigi is being called on an analyzed but unexpanded + tree, and the only purpose of the call is to properly annotate + types with representation information */ +extern int type_annotate_only; + +/* Current file name without path */ +extern const char *ref_filename; + +/* List of TREE_LIST nodes representing a block stack. TREE_VALUE + of each gives the variable used for the setjmp buffer in the current + block, if any. */ +extern tree gnu_block_stack; + +/* For most front-ends, this is the parser for the language. For us, we + process the GNAT tree. */ +extern int yyparse PARAMS ((void)); + +/* This is the main program of the back-end. It sets up all the table + structures and then generates code. */ + +extern void gigi PARAMS ((Node_Id, int, int, struct Node *, + Node_Id *, Node_Id *, + struct Elist_Header *, + struct Elmt_Item *, + struct String_Entry *, + Char_Code *, + struct List_Header *, + Int, char *, + Entity_Id, Entity_Id, Entity_Id, + Int)); + +/* This function is the driver of the GNAT to GCC tree transformation process. + GNAT_NODE is the root of some gnat tree. It generates code for that + part of the tree. */ +extern void gnat_to_code PARAMS ((Node_Id)); + +/* GNAT_NODE is the root of some GNAT tree. Return the root of the + GCC tree corresponding to that GNAT tree. Normally, no code is generated; + we just return an equivalent tree which is used elsewhere to generate + code. */ +extern tree gnat_to_gnu PARAMS ((Node_Id)); + +/* Do the processing for the declaration of a GNAT_ENTITY, a type. If + a separate Freeze node exists, delay the bulk of the processing. Otherwise + make a GCC type for GNAT_ENTITY and set up the correspondance. */ + +extern void process_type PARAMS ((Entity_Id)); + +/* Determine the input_filename and the lineno from the source location + (Sloc) of GNAT_NODE node. Set the global variable input_filename and + lineno. If WRITE_NOTE_P is true, emit a line number note. */ +extern void set_lineno PARAMS ((Node_Id, int)); + +/* Post an error message. MSG is the error message, properly annotated. + NODE is the node at which to post the error and the node to use for the + "&" substitution. */ +extern void post_error PARAMS ((const char *, Node_Id)); + +/* Similar, but NODE is the node at which to post the error and ENT + is the node to use for the "&" substitution. */ +extern void post_error_ne PARAMS ((const char *, Node_Id, Entity_Id)); + +/* Similar, but NODE is the node at which to post the error, ENT is the node + to use for the "&" substitution, and N is the number to use for the ^. */ +extern void post_error_ne_num PARAMS ((const char *, Node_Id, Entity_Id, + int)); + +/* Similar to post_error_ne_num, but T is a GCC tree representing the number + to write. If the tree represents a constant that fits within a + host integer, the text inside curly brackets in MSG will be output + (presumably including a '^'). Otherwise that text will not be output + and the text inside square brackets will be output instead. */ +extern void post_error_ne_tree PARAMS ((const char *, Node_Id, Entity_Id, + tree)); + +/* Similar to post_error_ne_tree, except that NUM is a second + integer to write in the message. */ +extern void post_error_ne_tree_2 PARAMS ((const char *, Node_Id, Entity_Id, + tree, int)); + +/* Set the node for a second '&' in the error message. */ +extern void set_second_error_entity PARAMS ((Entity_Id)); + +/* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially + since it doesn't make any sense to put them in a SAVE_EXPR. */ +extern tree make_save_expr PARAMS ((tree)); + +/* Signal abort, with "Gigi abort" as the error label, and error_gnat_node + as the relevant node that provides the location info for the error. + The single parameter CODE is an integer code that is included in the + additional error message generated. */ +extern void gigi_abort PARAMS ((int)) ATTRIBUTE_NORETURN; + +/* Initialize the table that maps GNAT codes to GCC codes for simple + binary and unary operations. */ +extern void init_code_table PARAMS ((void)); + +/* Current node being treated, in case gigi_abort or Check_Elaboration_Code + called. */ +extern Node_Id error_gnat_node; + +/* This is equivalent to stabilize_reference in GCC's tree.c, but we know + how to handle our new nodes and we take an extra argument that says + whether to force evaluation of everything. */ + +extern tree gnat_stabilize_reference PARAMS ((tree, int)); + +/* Highest number in the front-end node table. */ +extern int max_gnat_nodes; + +/* If nonzero, pretend we are allocating at global level. */ +extern int force_global; + +/* Standard data type sizes. Most of these are not used. */ + +#ifndef CHAR_TYPE_SIZE +#define CHAR_TYPE_SIZE BITS_PER_UNIT +#endif + +#ifndef SHORT_TYPE_SIZE +#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) +#endif + +#ifndef INT_TYPE_SIZE +#define INT_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef LONG_TYPE_SIZE +#define LONG_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef LONG_LONG_TYPE_SIZE +#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#ifndef FLOAT_TYPE_SIZE +#define FLOAT_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef DOUBLE_TYPE_SIZE +#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#ifndef LONG_DOUBLE_TYPE_SIZE +#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +/* The choice of SIZE_TYPE here is very problematic. We need a signed + type whose bit width is Pmode. Assume "long" is such a type here. */ +#undef SIZE_TYPE +#define SIZE_TYPE "long int" + + +/* Data structures used to represent attributes. */ + +enum attr_type {ATTR_MACHINE_ATTRIBUTE, ATTR_LINK_ALIAS, + ATTR_LINK_SECTION, ATTR_WEAK_EXTERNAL}; + +struct attrib +{ + struct attrib *next; + enum attr_type type; + tree name; + tree arg; + Node_Id error_point; +}; + +/* Define the entries in the standard data array. */ +enum standard_datatypes +{ +/* Various standard data types and nodes. */ + ADT_longest_float_type, + ADT_void_type_decl, + + /* The type of an exception. */ + ADT_except_type, + + /* Type declaration node <==> typedef void *T */ + ADT_ptr_void_type, + + /* Function type declaration -- void T() */ + ADT_void_ftype, + + /* Type declaration node <==> typedef void *T() */ + ADT_ptr_void_ftype, + + /* A function declaration node for a run-time function for allocating memory. + Ada allocators cause calls to this function to be generated. */ + ADT_malloc_decl, + + /* Likewise for freeing memory. */ + ADT_free_decl, + + /* Types and decls used by our temporary exception mechanism. See + init_gigi_decls for details. */ + ADT_jmpbuf_type, + ADT_jmpbuf_ptr_type, + ADT_get_jmpbuf_decl, + ADT_set_jmpbuf_decl, + ADT_get_excptr_decl, + ADT_setjmp_decl, + ADT_longjmp_decl, + ADT_raise_nodefer_decl, + ADT_raise_constraint_error_decl, + ADT_raise_program_error_decl, + ADT_raise_storage_error_decl, + ADT_LAST}; + +extern tree gnat_std_decls[(int) ADT_LAST]; + +#define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] +#define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl] +#define except_type_node gnat_std_decls[(int) ADT_except_type] +#define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type] +#define void_ftype gnat_std_decls[(int) ADT_void_ftype] +#define ptr_void_ftype gnat_std_decls[(int) ADT_ptr_void_ftype] +#define malloc_decl gnat_std_decls[(int) ADT_malloc_decl] +#define free_decl gnat_std_decls[(int) ADT_free_decl] +#define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type] +#define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type] +#define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl] +#define set_jmpbuf_decl gnat_std_decls[(int) ADT_set_jmpbuf_decl] +#define get_excptr_decl gnat_std_decls[(int) ADT_get_excptr_decl] +#define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl] +#define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl] +#define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl] +#define raise_constraint_error_decl \ + gnat_std_decls[(int) ADT_raise_constraint_error_decl] +#define raise_program_error_decl \ + gnat_std_decls[(int) ADT_raise_program_error_decl] +#define raise_storage_error_decl \ + gnat_std_decls[(int) ADT_raise_storage_error_decl] + +/* Routines expected by the gcc back-end. They must have exactly the same + prototype and names as below. */ + +/* Returns non-zero if we are currently in the global binding level */ +extern int global_bindings_p PARAMS ((void)); + +/* Returns the list of declarations in the current level. Note that this list + is in reverse order (it has to be so for back-end compatibility). */ +extern tree getdecls PARAMS ((void)); + +/* Nonzero if the current level needs to have a BLOCK made. */ +extern int kept_level_p PARAMS ((void)); + +/* Enter a new binding level. The input parameter is ignored, but has to be + specified for back-end compatibility. */ +extern void pushlevel PARAMS ((int)); + +/* Exit a binding level. + Pop the level off, and restore the state of the identifier-decl mappings + that were in effect when this level was entered. + + If KEEP is nonzero, this level had explicit declarations, so + and create a "block" (a BLOCK node) for the level + to record its declarations and subblocks for symbol table output. + + If FUNCTIONBODY is nonzero, this level is the body of a function, + so create a block as if KEEP were set and also clear out all + label names. + + If REVERSE is nonzero, reverse the order of decls before putting + them into the BLOCK. */ +extern tree poplevel PARAMS ((int,int, int)); + +/* Insert BLOCK at the end of the list of subblocks of the + current binding level. This is used when a BIND_EXPR is expanded, + to handle the BLOCK node inside the BIND_EXPR. */ +extern void insert_block PARAMS ((tree)); + +/* Set the BLOCK node for the innermost scope + (the one we are currently in). */ +extern void set_block PARAMS ((tree)); + +/* Records a ..._DECL node DECL as belonging to the current lexical scope. + Returns the ..._DECL node. */ +extern tree pushdecl PARAMS ((tree)); + +/* Create the predefined scalar types such as `integer_type_node' needed + in the gcc back-end and initialize the global binding level. */ +extern void init_decl_processing PARAMS ((void)); +extern void init_gigi_decls PARAMS ((tree, tree)); + +/* Return an integer type with the number of bits of precision given by + PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise + it is a signed type. */ +extern tree type_for_size PARAMS ((unsigned, int)); + +/* Return a data type that has machine mode MODE. UNSIGNEDP selects + an unsigned type; otherwise a signed type is returned. */ +extern tree type_for_mode PARAMS ((enum machine_mode, int)); + +/* Return the unsigned version of a TYPE_NODE, a scalar type. */ +extern tree unsigned_type PARAMS ((tree)); + +/* Return the signed version of a TYPE_NODE, a scalar type. */ +extern tree signed_type PARAMS ((tree)); + +/* Return a type the same as TYPE except unsigned or signed according to + UNSIGNEDP. */ +extern tree signed_or_unsigned_type PARAMS ((int, tree)); + +/* This routine is called in tree.c to print an error message for invalid use + of an incomplete type. */ +extern void incomplete_type_error PARAMS ((tree, tree)); + +/* This function is called indirectly from toplev.c to handle incomplete + declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise, + compile_file in toplev.c makes an indirect call through the function pointer + incomplete_decl_finalize_hook which is initialized to this routine in + init_decl_processing. */ +extern void finish_incomplete_decl PARAMS ((tree)); + +/* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. */ +extern tree convert PARAMS ((tree, tree)); + +/* Routines created solely for the tree translator's sake. Their prototypes + can be changed as desired. */ + +/* GNAT_ENTITY is a GNAT tree node for a defining identifier. + GNU_DECL is the GCC tree which is to be associated with + GNAT_ENTITY. Such gnu tree node is always an ..._DECL node. + If NO_CHECK is nonzero, the latter check is suppressed. + If GNU_DECL is zero, a previous association is to be reset. */ +extern void save_gnu_tree PARAMS ((Entity_Id, tree, int)); + +/* GNAT_ENTITY is a GNAT tree node for a defining identifier. + Return the ..._DECL node that was associated with it. If there is no tree + node associated with GNAT_ENTITY, abort. */ +extern tree get_gnu_tree PARAMS ((Entity_Id)); + +/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ +extern int present_gnu_tree PARAMS ((Entity_Id)); + +/* Initialize tables for above routines. */ +extern void init_gnat_to_gnu PARAMS ((void)); + +/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL + nodes (FIELDLIST), finish constructing the record or union type. + If HAS_REP is nonzero, this record has a rep clause; don't call + layout_type but merely set the size and alignment ourselves. + If DEFER_DEBUG is nonzero, do not call the debugging routines + on this type; it will be done later. */ +extern void finish_record_type PARAMS ((tree, tree, int, int)); + +/* Returns a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the + subprogram. If it is void_type_node, then we are dealing with a procedure, + otherwise we are dealing with a function. PARAM_DECL_LIST is a list of + PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the + copy-in/copy-out list to be stored into TYPE_CI_CO_LIST. + RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained + object. RETURNS_BY_REF is nonzero if the function returns by reference. + RETURNS_WITH_DSP is nonzero if the function is to return with a + depressed stack pointer. */ +extern tree create_subprog_type PARAMS ((tree, tree, tree, int, int, + int)); + +/* Return a copy of TYPE, but safe to modify in any way. */ +extern tree copy_type PARAMS ((tree)); + +/* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose + TYPE_INDEX_TYPE is INDEX. */ +extern tree create_index_type PARAMS ((tree, tree, tree)); + +/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character + string) and TYPE is a ..._TYPE node giving its data type. + ARTIFICIAL_P is nonzero if this is a declaration that was generated + by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging + information about this type. */ +extern tree create_type_decl PARAMS ((tree, tree, struct attrib *, + int, int)); + +/* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable. + ASM_NAME is its assembler name (if provided). TYPE is + its data type (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an + optional initial expression; NULL_TREE if none. + + CONST_FLAG is nonzero if this variable is constant. + + PUBLIC_FLAG is nonzero if this definition is to be made visible outside of + the current compilation unit. This flag should be set when processing the + variable definitions in a package specification. EXTERN_FLAG is nonzero + when processing an external variable declaration (as opposed to a + definition: no storage is to be allocated for the variable here). + STATIC_FLAG is only relevant when not at top level. In that case + it indicates whether to always allocate storage to the variable. */ +extern tree create_var_decl PARAMS ((tree, tree, tree, tree, int, + int, int, int, + struct attrib *)); + +/* Given a DECL and ATTR_LIST, apply the listed attributes. */ +extern void process_attributes PARAMS ((tree, struct attrib *)); + +/* Obtain any pending elaborations and clear the old list. */ +extern tree get_pending_elaborations PARAMS ((void)); + +/* Return nonzero if there are pending elaborations. */ +extern int pending_elaborations_p PARAMS ((void)); + +/* Save a copy of the current pending elaboration list and make a new + one. */ +extern void push_pending_elaborations PARAMS ((void)); + +/* Pop the stack of pending elaborations. */ +extern void pop_pending_elaborations PARAMS ((void)); + +/* Return the current position in pending_elaborations so we can insert + elaborations after that point. */ +extern tree get_elaboration_location PARAMS ((void)); + +/* Insert the current elaborations after ELAB, which is in some elaboration + list. */ +extern void insert_elaboration_list PARAMS ((tree)); + +/* Add some pending elaborations to the current list. */ +extern void add_pending_elaborations PARAMS ((tree, tree)); + +/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its + type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if + this field is in a record type with a "pragma pack". If SIZE is nonzero + it is the specified size for this field. If POS is nonzero, it is the bit + position. If ADDRESSABLE is nonzero, it means we are allowed to take + the address of this field for aliasing purposes. */ +extern tree create_field_decl PARAMS ((tree, tree, tree, int, + tree, tree, int)); + +/* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, + PARAM_TYPE is its type. READONLY is nonzero if the parameter is + readonly (either an IN parameter or an address of a pass-by-ref + parameter). */ +extern tree create_param_decl PARAMS ((tree, tree, int)); + +/* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, + ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE + node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of + PARM_DECL nodes chained through the TREE_CHAIN field). + + INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate + fields in the FUNCTION_DECL. */ +extern tree create_subprog_decl PARAMS ((tree, tree, tree, tree, int, + int, int, struct attrib *)); + +/* Returns a LABEL_DECL node for LABEL_NAME. */ +extern tree create_label_decl PARAMS ((tree)); + +/* Set up the framework for generating code for SUBPROG_DECL, a subprogram + body. This routine needs to be invoked before processing the declarations + appearing in the subprogram. */ +extern void begin_subprog_body PARAMS ((tree)); + +/* Finish the definition of the current subprogram and compile it all the way + to assembler language output. */ +extern void end_subprog_body PARAMS ((void)); + +/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. + EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. + Return a constructor for the template. */ +extern tree build_template PARAMS ((tree, tree, tree)); + +/* Build a VMS descriptor from a Mechanism_Type, which must specify + a descriptor type, and the GCC type of an object. Each FIELD_DECL + in the type contains in its DECL_INITIAL the expression to use when + a constructor is made for the type. GNAT_ENTITY is a gnat node used + to print out an error message if the mechanism cannot be applied to + an object of that type and also for the name. */ + +extern tree build_vms_descriptor PARAMS ((tree, Mechanism_Type, + Entity_Id)); + +/* Build a type to be used to represent an aliased object whose nominal + type is an unconstrained array. This consists of a RECORD_TYPE containing + a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an + ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this + is used to represent an arbitrary unconstrained object. Use NAME + as the name of the record. */ +extern tree build_unc_object_type PARAMS ((tree, tree, tree)); + +/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In + the normal case this is just two adjustments, but we have more to do + if NEW is an UNCONSTRAINED_ARRAY_TYPE. */ +extern void update_pointer_to PARAMS ((tree, tree)); + +/* EXP is an expression for the size of an object. If this size contains + discriminant references, replace them with the maximum (if MAX_P) or + minimum (if ! MAX_P) possible value of the discriminant. */ +extern tree max_size PARAMS ((tree, int)); + +/* Remove all conversions that are done in EXP. This includes converting + from a padded type or converting to a left-justified modular type. */ +extern tree remove_conversions PARAMS ((tree)); + +/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that + refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, + likewise return an expression pointing to the underlying array. */ +extern tree maybe_unconstrained_array PARAMS ((tree)); + +/* Return an expression that does an unchecked converstion of EXPR to TYPE. */ +extern tree unchecked_convert PARAMS ((tree, tree)); + +/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical + operation. + + This preparation consists of taking the ordinary + representation of an expression expr and producing a valid tree + boolean expression describing whether expr is nonzero. We could + simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be the same as the input type. + This function is simpler than the corresponding C version since + the only possible operands will be things of Boolean type. */ +extern tree truthvalue_conversion PARAMS((tree)); + +/* Return the base type of TYPE. */ +extern tree get_base_type PARAMS((tree)); + +/* Likewise, but only return types known at Ada source. */ +extern tree get_ada_base_type PARAMS((tree)); + +/* EXP is a GCC tree representing an address. See if we can find how + strictly the object at that address is aligned. Return that alignment + strictly the object at that address is aligned. Return that alignment + in bits. If we don't know anything about the alignment, return 0. */ +extern unsigned int known_alignment PARAMS((tree)); + +/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type + desired for the result. Usually the operation is to be performed + in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 + in which case the type to be used will be derived from the operands. */ +extern tree build_binary_op PARAMS((enum tree_code, tree, tree, tree)); + +/* Similar, but make unary operation. */ +extern tree build_unary_op PARAMS((enum tree_code, tree, tree)); + +/* Similar, but for COND_EXPR. */ +extern tree build_cond_expr PARAMS((tree, tree, tree, tree)); + +/* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return + the CALL_EXPR. */ +extern tree build_call_1_expr PARAMS((tree, tree)); + +/* Build a CALL_EXPR to call FUNDECL with two argument, ARG1 & ARG2. Return + the CALL_EXPR. */ +extern tree build_call_2_expr PARAMS((tree, tree, tree)); + +/* Likewise to call FUNDECL with no arguments. */ +extern tree build_call_0_expr PARAMS((tree)); + +/* Call a function FCN that raises an exception and pass the line + number and file name, if requested. */ +extern tree build_call_raise PARAMS((tree)); + +/* Return a CONSTRUCTOR of TYPE whose list is LIST. */ +extern tree build_constructor PARAMS((tree, tree)); + +/* Return a COMPONENT_REF to access a field that is given by COMPONENT, + an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, + for the field, or both. */ +extern tree build_component_ref PARAMS((tree, tree, tree)); + +/* Build a GCC tree to call an allocation or deallocation function. + If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise, + genrate an allocator. + + GNU_SIZE is the size of the object and ALIGN is the alignment. + GNAT_PROC, if present is a procedure to call and GNAT_POOL is the + storage pool to use. If not preset, malloc and free will be used. */ +extern tree build_call_alloc_dealloc PARAMS((tree, tree, int, Entity_Id, + Entity_Id)); + +/* Build a GCC tree to correspond to allocating an object of TYPE whose + initial value if INIT, if INIT is nonzero. Convert the expression to + RESULT_TYPE, which must be some type of pointer. Return the tree. + GNAT_PROC and GNAT_POOL optionally give the procedure to call and + the storage pool to use. */ +extern tree build_allocator PARAMS((tree, tree, tree, Entity_Id, + Entity_Id)); + +/* Fill in a VMS descriptor for EXPR and return a constructor for it. + GNAT_FORMAL is how we find the descriptor record. */ + +extern tree fill_vms_descriptor PARAMS((tree, Entity_Id)); + +/* Indicate that we need to make the address of EXPR_NODE and it therefore + should not be allocated in a register. Return 1 if successful. */ +extern int mark_addressable PARAMS((tree)); + +/* These functions return the basic data type sizes and related parameters + about the target machine. */ + +extern Pos get_target_bits_per_unit PARAMS ((void)); +extern Pos get_target_bits_per_word PARAMS ((void)); +extern Pos get_target_char_size PARAMS ((void)); +extern Pos get_target_wchar_t_size PARAMS ((void)); +extern Pos get_target_short_size PARAMS ((void)); +extern Pos get_target_int_size PARAMS ((void)); +extern Pos get_target_long_size PARAMS ((void)); +extern Pos get_target_long_long_size PARAMS ((void)); +extern Pos get_target_float_size PARAMS ((void)); +extern Pos get_target_double_size PARAMS ((void)); +extern Pos get_target_long_double_size PARAMS ((void)); +extern Pos get_target_pointer_size PARAMS ((void)); +extern Pos get_target_maximum_alignment PARAMS ((void)); +extern Boolean get_target_no_dollar_in_label PARAMS ((void)); +extern Nat get_float_words_be PARAMS ((void)); +extern Nat get_words_be PARAMS ((void)); +extern Nat get_bytes_be PARAMS ((void)); +extern Nat get_bits_be PARAMS ((void)); +extern Nat get_strict_alignment PARAMS ((void)); diff --git a/gcc/ada/gmem.c b/gcc/ada/gmem.c new file mode 100644 index 00000000000..31e4b848eb2 --- /dev/null +++ b/gcc/ada/gmem.c @@ -0,0 +1,216 @@ +/**************************************************************************** + * * + * GNATMEM COMPONENTS * + * * + * G M E M * + * * + * $Revision: 1.1 $ + * * + * C Implementation File * + * * + * Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion 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. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This unit reads the allocation tracking log produced by augmented + __gnat_malloc and __gnat_free procedures (see file a-raise.c) and + provides GNATMEM tool with gdb-compliant output. The output is + processed by GNATMEM to detect dynamic memory allocation errors. + + See GNATMEM section in GNAT User's Guide for more information. + + NOTE: This capability is currently supported on the following targets: + + DEC Unix + SGI Irix + Linux x86 + Solaris (sparc and x86) (*) + Windows 98/95/NT (x86) + + (*) on these targets, the compilation must be done with -funwind-tables to + be able to build the stack backtrace. */ + +#ifdef __alpha_vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" + +static FILE *gmemfile; + +/* tb_len is the number of call level supported by this module */ +#define TB_LEN 200 + +static char *tracebk [TB_LEN]; +static int cur_tb_len, cur_tb_pos; + +extern void convert_addresses PARAMS ((char *[], int, void *, + int *)); +static void gmem_read_backtrace PARAMS ((void)); +static char *spc2nul PARAMS ((char *)); + +extern int __gnat_gmem_initialize PARAMS ((char *)); +extern void __gnat_gmem_a2l_initialize PARAMS ((char *)); +extern void __gnat_gmem_read_next PARAMS ((char *)); +extern void __gnat_gmem_read_bt_frame PARAMS ((char *)); + +/* Reads backtrace information from gmemfile placing them in tracebk + array. cur_tb_len is the size of this array. */ + +static void +gmem_read_backtrace () +{ + fread (&cur_tb_len, sizeof (int), 1, gmemfile); + fread (tracebk, sizeof (char *), cur_tb_len, gmemfile); + cur_tb_pos = 0; +} + +/* Initialize gmem feature from the dumpname file. Return 1 if the + dumpname has been generated by GMEM (instrumented malloc/free) and 0 if not + (i.e. probably a GDB generated file). */ + +int +__gnat_gmem_initialize (dumpname) + char *dumpname; +{ + char header[10]; + + gmemfile = fopen (dumpname, "rb"); + fread (header, 10, 1, gmemfile); + + /* Check for GMEM magic-tag. */ + if (memcmp (header, "GMEM DUMP\n", 10)) + { + fclose (gmemfile); + return 0; + } + + return 1; +} + +/* Initialize addr2line library */ + +void +__gnat_gmem_a2l_initialize (exename) + char *exename; +{ + extern char **gnat_argv; + char s [100]; + int l; + + gnat_argv [0] = exename; + convert_addresses (tracebk, 1, s, &l); +} + +/* Read next allocation of deallocation information from the GMEM file and + write an alloc/free information in buf to be processed by GDB (see gnatmem + implementation). */ + +void +__gnat_gmem_read_next (buf) + char *buf; +{ + void *addr; + int size; + char c; + + if ((c = fgetc (gmemfile)) == EOF) + { + fclose (gmemfile); + sprintf (buf, "Program exited."); + } + else + { + switch (c) + { + case 'A' : + fread (&addr, sizeof (char *), 1, gmemfile); + fread (&size, sizeof (int), 1, gmemfile); + sprintf (buf, "ALLOC^%d^0x%lx^", size, (long) addr); + break; + case 'D' : + fread (&addr, sizeof (char *), 1, gmemfile); + sprintf (buf, "DEALL^0x%lx^", (long) addr); + break; + default: + puts ("GMEM dump file corrupt"); + __gnat_os_exit (1); + } + + gmem_read_backtrace (); + } +} + +/* Scans the line until the space or new-line character is encountered; + this character is replaced by nul and its position is returned. */ + +static char * +spc2nul (s) + char *s; +{ + while (*++s) + if (*s == ' ' || *s == '\n') + { + *s = 0; + return s; + } + + abort (); +} + +/* Convert backtrace address in tracebk at position cur_tb_pos to a symbolic + traceback information returned in buf and to be processed by GDB (see + gnatmem implementation). */ + +void +__gnat_gmem_read_bt_frame (buf) + char *buf; +{ + int l = 0; + char s[1000]; + char *name, *file; + + if (cur_tb_pos >= cur_tb_len) + { + buf [0] = ' '; + buf [1] = '\0'; + return; + } + + convert_addresses (tracebk + cur_tb_pos, 1, s, &l); + s[l] = '\0'; + name = spc2nul (s) + 4; + file = spc2nul (name) + 4; + spc2nul (file); + ++cur_tb_pos; + + sprintf (buf, "# %s () at %s", name, file); +} diff --git a/gcc/ada/gnat.ads b/gcc/ada/gnat.ads new file mode 100644 index 00000000000..f42efcbd35d --- /dev/null +++ b/gcc/ada/gnat.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1992-2000 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the parent package for a library of useful units provided with GNAT + +package GNAT is +pragma Pure (GNAT); + +end GNAT; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb new file mode 100644 index 00000000000..afa04c6409a --- /dev/null +++ b/gcc/ada/gnat1drv.adb @@ -0,0 +1,642 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T 1 D R V -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.129 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Back_End; use Back_End; +with Comperr; +with Csets; use Csets; +with Debug; use Debug; +with Elists; +with Errout; use Errout; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Frontend; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Inline; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Namet; use Namet; +with Nlists; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Repinfo; use Repinfo; +with Restrict; use Restrict; +with Sem; +with Sem_Ch13; +with Sem_Warn; +with Sinfo; use Sinfo; +with Sinput.L; use Sinput.L; +with Snames; +with Sprint; use Sprint; +with Stringt; +with Targparm; +with Tree_Gen; +with Treepr; use Treepr; +with Ttypes; +with Types; use Types; +with Uintp; +with Uname; use Uname; +with Urealp; +with Usage; + +with System.Assertions; + +procedure Gnat1drv is + Main_Unit_Node : Node_Id; + -- Compilation unit node for main unit + + Main_Unit_Entity : Node_Id; + -- Compilation unit entity for main unit + + Main_Kind : Node_Kind; + -- Kind of main compilation unit node. + + Original_Operating_Mode : Operating_Mode_Type; + -- Save operating type specified by options + + Back_End_Mode : Back_End.Back_End_Mode_Type; + -- Record back end mode + +begin + -- This inner block is set up to catch assertion errors and constraint + -- errors. Since the code for handling these errors can cause another + -- exception to be raised (namely Unrecoverable_Error), we need two + -- nested blocks, so that the outer one handles unrecoverable error. + + begin + Osint.Initialize (Compiler); + Scan_Compiler_Arguments; + Osint.Add_Default_Search_Dirs; + + Sinput.Initialize; + Lib.Initialize; + Sem.Initialize; + Csets.Initialize; + Uintp.Initialize; + Urealp.Initialize; + Errout.Initialize; + Namet.Initialize; + Snames.Initialize; + Stringt.Initialize; + Inline.Initialize; + Sem_Ch13.Initialize; + + -- Output copyright notice if full list mode + + if (Verbose_Mode or Full_List) + and then (not Debug_Flag_7) + then + Write_Eol; + Write_Str ("GNAT "); + Write_Str (Gnat_Version_String); + Write_Str (" Copyright 1992-2001 Free Software Foundation, Inc."); + Write_Eol; + end if; + + -- Acquire target parameters and perform required setup + + Targparm.Get_Target_Parameters; + + if Targparm.High_Integrity_Mode_On_Target then + Set_No_Run_Time_Mode; + end if; + + -- Before we do anything else, adjust certain global values for + -- debug switches which modify their normal natural settings. + + if Debug_Flag_8 then + Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian; + end if; + + if Debug_Flag_M then + Targparm.OpenVMS_On_Target := True; + Hostparm.OpenVMS := True; + end if; + + if Debug_Flag_FF then + Targparm.Frontend_Layout_On_Target := True; + end if; + + -- We take the default exception mechanism into account + + if Targparm.ZCX_By_Default_On_Target then + if Targparm.GCC_ZCX_Support_On_Target then + Exception_Mechanism := GCC_ZCX; + else + Exception_Mechanism := Front_End_ZCX; + end if; + end if; + + -- We take the command line exception mechanism into account + + if Opt.Zero_Cost_Exceptions_Set then + if Opt.Zero_Cost_Exceptions_Val = False then + Exception_Mechanism := Setjmp_Longjmp; + + elsif Targparm.GCC_ZCX_Support_On_Target then + Exception_Mechanism := GCC_ZCX; + + elsif Targparm.Front_End_ZCX_Support_On_Target + or else Debug_Flag_XX + then + Exception_Mechanism := Front_End_ZCX; + + else + Osint.Fail + ("Zero Cost Exceptions not supported on this target"); + end if; + end if; + + -- Check we have exactly one source file, this happens only in + -- the case where the driver is called directly, it cannot happen + -- when gnat1 is invoked from gcc in the normal case. + + if Osint.Number_Of_Files /= 1 then + Usage; + Write_Eol; + Osint.Fail ("you must provide one source file"); + + elsif Usage_Requested then + Usage; + end if; + + Original_Operating_Mode := Operating_Mode; + Frontend; + Main_Unit_Node := Cunit (Main_Unit); + Main_Unit_Entity := Cunit_Entity (Main_Unit); + Main_Kind := Nkind (Unit (Main_Unit_Node)); + + -- Check for suspicious or incorrect body present if we are doing + -- semantic checking. We omit this check in syntax only mode, because + -- in that case we do not know if we need a body or not. + + if Operating_Mode /= Check_Syntax + and then + ((Main_Kind = N_Package_Declaration + and then not Body_Required (Main_Unit_Node)) + or else (Main_Kind = N_Generic_Package_Declaration + and then not Body_Required (Main_Unit_Node)) + or else Main_Kind = N_Package_Renaming_Declaration + or else Main_Kind = N_Subprogram_Renaming_Declaration + or else Nkind (Original_Node (Unit (Main_Unit_Node))) + in N_Generic_Instantiation) + then + declare + Sname : Unit_Name_Type := Unit_Name (Main_Unit); + Src_Ind : Source_File_Index; + Fname : File_Name_Type; + + procedure Bad_Body (Msg : String); + -- Issue message for bad body found + + procedure Bad_Body (Msg : String) is + begin + Error_Msg_N (Msg, Main_Unit_Node); + Error_Msg_Name_1 := Fname; + Error_Msg_N + ("remove incorrect body in file{!", Main_Unit_Node); + end Bad_Body; + + begin + Sname := Unit_Name (Main_Unit); + + -- If we do not already have a body name, then get the body + -- name (but how can we have a body name here ???) + + if not Is_Body_Name (Sname) then + Sname := Get_Body_Name (Sname); + end if; + + Fname := Get_File_Name (Sname, Subunit => False); + Src_Ind := Load_Source_File (Fname); + + -- Case where body is present and it is not a subunit. Exclude + -- the subunit case, because it has nothing to do with the + -- package we are compiling. It is illegal for a child unit + -- and a subunit with the same expanded name (RM 10.2(9)) to + -- appear together in a partition, but there is nothing to + -- stop a compilation environment from having both, and the + -- test here simply allows that. If there is an attempt to + -- include both in a partition, this is diagnosed at bind time. + -- In Ada 83 mode this is not a warning case. + + if Src_Ind /= No_Source_File + and then not Source_File_Is_Subunit (Src_Ind) + then + Error_Msg_Name_1 := Sname; + + -- Ada 83 case of a package body being ignored. This is not + -- an error as far as the Ada 83 RM is concerned, but it is + -- almost certainly not what is wanted so output a warning. + -- Give this message only if there were no errors, since + -- otherwise it may be incorrect (we may have misinterpreted + -- a junk spec as not needing a body when it really does). + + if Main_Kind = N_Package_Declaration + and then Ada_83 + and then Operating_Mode = Generate_Code + and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body + and then not Compilation_Errors + then + Error_Msg_N + ("package % does not require a body?!", Main_Unit_Node); + Error_Msg_Name_1 := Fname; + Error_Msg_N + ("body in file{?! will be ignored", Main_Unit_Node); + + -- Ada 95 cases of a body file present when no body is + -- permitted. This we consider to be an error. + + else + -- For generic instantiations, we never allow a body + + if Nkind (Original_Node (Unit (Main_Unit_Node))) + in N_Generic_Instantiation + then + Bad_Body + ("generic instantiation for % does not allow a body"); + + -- A library unit that is a renaming never allows a body + + elsif Main_Kind in N_Renaming_Declaration then + Bad_Body + ("renaming declaration for % does not allow a body!"); + + -- Remaining cases are packages and generic packages. + -- Here we only do the test if there are no previous + -- errors, because if there are errors, they may lead + -- us to incorrectly believe that a package does not + -- allow a body when in fact it does. + + elsif not Compilation_Errors then + if Main_Kind = N_Package_Declaration then + Bad_Body ("package % does not allow a body!"); + + elsif Main_Kind = N_Generic_Package_Declaration then + Bad_Body ("generic package % does not allow a body!"); + end if; + end if; + + end if; + end if; + end; + end if; + + -- Exit if compilation errors detected + + if Compilation_Errors then + Treepr.Tree_Dump; + Sem_Ch13.Validate_Unchecked_Conversions; + Errout.Finalize; + Namet.Finalize; + + -- Generate ALI file if specially requested + + if Opt.Force_ALI_Tree_File then + Write_ALI (Object => False); + Tree_Gen; + end if; + + Exit_Program (E_Errors); + end if; + + -- Check for unused with's. We do this whether or not code is generated + + Sem_Warn.Check_Unused_Withs; + + -- Set Generate_Code on main unit and its spec. We do this even if + -- are not generating code, since Lib-Writ uses this to determine + -- which units get written in the ali file. + + Set_Generate_Code (Main_Unit); + + -- If we have a corresponding spec, then we need object + -- code for the spec unit as well + + if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body + and then not Acts_As_Spec (Main_Unit_Node) + then + Set_Generate_Code + (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node))); + end if; + + -- Check for unused with's. We do this whether or not code is generated + + Sem_Warn.Check_Unused_Withs; + + -- Case of no code required to be generated, exit indicating no error + + if Original_Operating_Mode = Check_Syntax then + Treepr.Tree_Dump; + Errout.Finalize; + Tree_Gen; + Namet.Finalize; + Exit_Program (E_Success); + + elsif Original_Operating_Mode = Check_Semantics then + Back_End_Mode := Declarations_Only; + + -- All remaining cases are cases in which the user requested that code + -- be generated (i.e. no -gnatc or -gnats switch was used). Check if + -- we can in fact satisfy this request. + + -- Cannot generate code if someone has turned off code generation + -- for any reason at all. We will try to figure out a reason below. + + elsif Operating_Mode /= Generate_Code then + Back_End_Mode := Skip; + + -- We can generate code for a subprogram body unless its corresponding + -- subprogram spec is a generic delaration. Note that the check for + -- No (Library_Unit) here is a defensive check that should not be + -- necessary, since the Library_Unit field should be set properly. + + elsif Main_Kind = N_Subprogram_Body + and then not Subunits_Missing + and then (No (Library_Unit (Main_Unit_Node)) + or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /= + N_Generic_Subprogram_Declaration + or else Generic_Separately_Compiled (Main_Unit_Entity)) + then + Back_End_Mode := Generate_Object; + + -- We can generate code for a package body unless its corresponding + -- package spec is a generic declaration. As described above, the + -- check for No (LIbrary_Unit) is a defensive check. + + elsif Main_Kind = N_Package_Body + and then not Subunits_Missing + and then (No (Library_Unit (Main_Unit_Node)) + or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /= + N_Generic_Package_Declaration + or else Generic_Separately_Compiled (Main_Unit_Entity)) + + then + Back_End_Mode := Generate_Object; + + -- We can generate code for a package declaration or a subprogram + -- declaration only if it does not required a body. + + elsif (Main_Kind = N_Package_Declaration + or else + Main_Kind = N_Subprogram_Declaration) + and then + (not Body_Required (Main_Unit_Node) + or else + Distribution_Stub_Mode = Generate_Caller_Stub_Body) + then + Back_End_Mode := Generate_Object; + + -- We can generate code for a generic package declaration of a generic + -- subprogram declaration only if does not require a body, and if it + -- is a generic that is separately compiled. + + elsif (Main_Kind = N_Generic_Package_Declaration + or else + Main_Kind = N_Generic_Subprogram_Declaration) + and then not Body_Required (Main_Unit_Node) + and then Generic_Separately_Compiled (Main_Unit_Entity) + then + Back_End_Mode := Generate_Object; + + -- Compilation units that are renamings do not require bodies, + -- so we can generate code for them. + + elsif Main_Kind = N_Package_Renaming_Declaration + or else Main_Kind = N_Subprogram_Renaming_Declaration + then + Back_End_Mode := Generate_Object; + + -- Compilation units that are generic renamings do not require bodies + -- so we can generate code for them in the separately compiled case + + elsif Main_Kind in N_Generic_Renaming_Declaration + and then Generic_Separately_Compiled (Main_Unit_Entity) + then + Back_End_Mode := Generate_Object; + + -- In all other cases (specs which have bodies, generics, and bodies + -- where subunits are missing), we cannot generate code and we generate + -- a warning message. Note that generic instantiations are gone at this + -- stage since they have been replaced by their instances. + + else + Back_End_Mode := Skip; + end if; + + -- At this stage Call_Back_End is set to indicate if the backend + -- should be called to generate code. If it is not set, then code + -- generation has been turned off, even though code was requested + -- by the original command. This is not an error from the user + -- point of view, but it is an error from the point of view of + -- the gcc driver, so we must exit with an error status. + + -- We generate an informative message (from the gcc point of view, + -- it is an error message, but from the users point of view this + -- is not an error, just a consequence of compiling something that + -- cannot generate code). + + if Back_End_Mode = Skip then + Write_Str ("No code generated for "); + Write_Str ("file "); + Write_Name (Unit_File_Name (Main_Unit)); + + if Subunits_Missing then + Write_Str (" (missing subunits)"); + + elsif Main_Kind = N_Subunit then + Write_Str (" (subunit)"); + + elsif Main_Kind = N_Package_Body + or else Main_Kind = N_Subprogram_Body + then + Write_Str (" (generic unit)"); + + elsif Main_Kind = N_Subprogram_Declaration then + Write_Str (" (subprogram spec)"); + + -- Only other case is a package spec + + else + Write_Str (" (package spec)"); + end if; + + Write_Eol; + + Sem_Ch13.Validate_Unchecked_Conversions; + Errout.Finalize; + Treepr.Tree_Dump; + Tree_Gen; + Write_ALI (Object => False); + Namet.Finalize; + + -- Exit program with error indication, to kill object file + + Exit_Program (E_No_Code); + end if; + + -- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also + -- set as indicated by Back_Annotate_Rep_Info being set to True. + + -- We don't call for annotations on a subunit, because to process those + -- the back-end requires that the parent(s) be properly compiled. + + -- Annotation is also suppressed in the case of compiling for + -- the Java VM, since representations are largely symbolic there. + + if Back_End_Mode = Declarations_Only + and then (not (Back_Annotate_Rep_Info or Debug_Flag_AA) + or else Main_Kind = N_Subunit + or else Hostparm.Java_VM) + then + Sem_Ch13.Validate_Unchecked_Conversions; + Errout.Finalize; + Write_ALI (Object => False); + Tree_Dump; + Tree_Gen; + Namet.Finalize; + return; + end if; + + -- Ensure that we properly register a dependency on system.ads, + -- since even if we do not semantically depend on this, Targparm + -- has read system parameters from the system.ads file. + + Lib.Writ.Ensure_System_Dependency; + + -- Back end needs to explicitly unlock tables it needs to touch + + Atree.Lock; + Elists.Lock; + Fname.UF.Lock; + Inline.Lock; + Lib.Lock; + Nlists.Lock; + Sem.Lock; + Sinput.Lock; + Namet.Lock; + Stringt.Lock; + + -- There are cases where the back end emits warnings, e.g. on objects + -- that are too large and will cause Storage_Error. If such a warning + -- appears in a generic context, then it is always appropriately + -- placed on the instance rather than the template, since gigi only + -- deals with generated code in instances (in particular the warning + -- for oversize objects clearly belongs on the instance). + + Warn_On_Instance := True; + + -- Here we call the backend to generate the output code + + Back_End.Call_Back_End (Back_End_Mode); + + -- Once the backend is complete, we unlock the names table. This + -- call allows a few extra entries, needed for example for the file + -- name for the library file output. + + Namet.Unlock; + + -- Validate unchecked conversions (using the values for size + -- and alignment annotated by the backend where possible). + + Sem_Ch13.Validate_Unchecked_Conversions; + + -- Now we complete output of errors, rep info and the tree info. + -- These are delayed till now, since it is perfectly possible for + -- gigi to generate errors, modify the tree (in particular by setting + -- flags indicating that elaboration is required, and also to back + -- annotate representation information for List_Rep_Info. + + Errout.Finalize; + + if Opt.List_Representation_Info /= 0 or else Debug_Flag_AA then + List_Rep_Info; + end if; + + -- Only write the library if the backend did not generate any error + -- messages. Otherwise signal errors to the driver program so that + -- there will be no attempt to generate an object file. + + if Compilation_Errors then + Treepr.Tree_Dump; + Exit_Program (E_Errors); + end if; + + Write_ALI (Object => (Back_End_Mode = Generate_Object)); + + -- Generate the ASIS tree after writing the ALI file, since in + -- ASIS mode, Write_ALI may in fact result in further tree + -- decoration from the original tree file. Note that we dump + -- the tree just before generating it, so that the dump will + -- exactly reflect what is written out. + + Treepr.Tree_Dump; + Tree_Gen; + + -- Finalize name table and we are all done + + Namet.Finalize; + + exception + -- Handle fatal internal compiler errors + + when System.Assertions.Assert_Failure => + Comperr.Compiler_Abort ("Assert_Failure"); + + when Constraint_Error => + Comperr.Compiler_Abort ("Constraint_Error"); + + when Program_Error => + Comperr.Compiler_Abort ("Program_Error"); + + when Storage_Error => + + -- Assume this is a bug. If it is real, the message will in + -- any case say Storage_Error, giving a strong hint! + + Comperr.Compiler_Abort ("Storage_Error"); + end; + +-- The outer exception handles an unrecoverable error + +exception + when Unrecoverable_Error => + Errout.Finalize; + + Set_Standard_Error; + Write_Str ("compilation abandoned"); + Write_Eol; + + Set_Standard_Output; + Source_Dump; + Tree_Dump; + Exit_Program (E_Errors); + +end Gnat1drv; diff --git a/gcc/ada/gnat1drv.ads b/gcc/ada/gnat1drv.ads new file mode 100644 index 00000000000..192e1b840ee --- /dev/null +++ b/gcc/ada/gnat1drv.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T 1 D R V -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Main procedure for the GNAT compiler + +-- This driver processes a single main unit, generating output object code + +-- file.ad[sb] ---> front-end ---> back-end ---> file.o + +procedure Gnat1drv; diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb new file mode 100644 index 00000000000..61f4a01f476 --- /dev/null +++ b/gcc/ada/gnatbind.adb @@ -0,0 +1,486 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T B I N D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.68 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with ALI.Util; use ALI.Util; +with Bcheck; use Bcheck; +with Binde; use Binde; +with Binderr; use Binderr; +with Bindgen; use Bindgen; +with Bindusg; +with Butil; use Butil; +with Csets; +with Gnatvsn; use Gnatvsn; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Switch; use Switch; +with Types; use Types; + +procedure Gnatbind is + + Total_Errors : Nat := 0; + -- Counts total errors in all files + + Total_Warnings : Nat := 0; + -- Total warnings in all files + + Main_Lib_File : File_Name_Type; + -- Current main library file + + Std_Lib_File : File_Name_Type; + -- Standard library + + Text : Text_Buffer_Ptr; + Id : ALI_Id; + + Next_Arg : Positive; + + Output_File_Name_Seen : Boolean := False; + + Output_File_Name : String_Ptr := new String'(""); + + procedure Scan_Bind_Arg (Argv : String); + -- Scan and process binder specific arguments. Argv is a single argument. + -- All the one character arguments are still handled by Switch. This + -- routine handles -aO -aI and -I-. + + ------------------- + -- Scan_Bind_Arg -- + ------------------- + + procedure Scan_Bind_Arg (Argv : String) is + begin + -- Now scan arguments that are specific to the binder and are not + -- handled by the common circuitry in Switch. + + if Opt.Output_File_Name_Present + and then not Output_File_Name_Seen + then + Output_File_Name_Seen := True; + + if Argv'Length = 0 + or else (Argv'Length >= 1 + and then (Argv (1) = Switch_Character + or else Argv (1) = '-')) + then + Fail ("output File_Name missing after -o"); + + else + Output_File_Name := new String'(Argv); + end if; + + elsif Argv'Length >= 2 + and then (Argv (1) = Switch_Character + or else Argv (1) = '-') + then + -- -I- + + if Argv (2 .. Argv'Last) = "I-" then + Opt.Look_In_Primary_Dir := False; + + -- -Idir + + elsif Argv (2) = 'I' then + Add_Src_Search_Dir (Argv (3 .. Argv'Last)); + Add_Lib_Search_Dir (Argv (3 .. Argv'Last)); + + -- -Ldir + + elsif Argv (2) = 'L' then + if Argv'Length >= 3 then + Opt.Bind_For_Library := True; + Opt.Ada_Init_Name := + new String'(Argv (3 .. Argv'Last) & Opt.Ada_Init_Suffix); + Opt.Ada_Final_Name := + new String'(Argv (3 .. Argv'Last) & Opt.Ada_Final_Suffix); + Opt.Ada_Main_Name := + new String'(Argv (3 .. Argv'Last) & Opt.Ada_Main_Name_Suffix); + + -- This option (-Lxxx) implies -n + + Opt.Bind_Main_Program := False; + else + Fail + ("Prefix of initialization and finalization " & + "procedure names missing in -L"); + end if; + + -- -Sin -Slo -Shi -Sxx + + elsif Argv'Length = 4 + and then Argv (2) = 'S' + then + declare + C1 : Character := Argv (3); + C2 : Character := Argv (4); + + begin + if C1 in 'a' .. 'z' then + C1 := Character'Val (Character'Pos (C1) - 32); + end if; + + if C2 in 'a' .. 'z' then + C2 := Character'Val (Character'Pos (C2) - 32); + end if; + + if C1 = 'I' and then C2 = 'N' then + Initialize_Scalars_Mode := 'I'; + + elsif C1 = 'L' and then C2 = 'O' then + Initialize_Scalars_Mode := 'L'; + + elsif C1 = 'H' and then C2 = 'I' then + Initialize_Scalars_Mode := 'H'; + + elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'F') + and then + (C2 in '0' .. '9' or else C2 in 'A' .. 'F') + then + Initialize_Scalars_Mode := 'X'; + Initialize_Scalars_Val (1) := C1; + Initialize_Scalars_Val (2) := C2; + + -- Invalid -S switch, let Switch give error + + else + Scan_Binder_Switches (Argv); + end if; + end; + + -- -aIdir + + elsif Argv'Length >= 3 + and then Argv (2 .. 3) = "aI" + then + Add_Src_Search_Dir (Argv (4 .. Argv'Last)); + + -- -aOdir + + elsif Argv'Length >= 3 + and then Argv (2 .. 3) = "aO" + then + Add_Lib_Search_Dir (Argv (4 .. Argv'Last)); + + -- -nostdlib + + elsif Argv (2 .. Argv'Last) = "nostdlib" then + Opt.No_Stdlib := True; + + -- -nostdinc + + elsif Argv (2 .. Argv'Last) = "nostdinc" then + Opt.No_Stdinc := True; + + -- -static + + elsif Argv (2 .. Argv'Last) = "static" then + Opt.Shared_Libgnat := False; + + -- -shared + + elsif Argv (2 .. Argv'Last) = "shared" then + Opt.Shared_Libgnat := True; + + -- -Mname + + elsif Argv'Length >= 3 and then Argv (2) = 'M' then + Opt.Bind_Alternate_Main_Name := True; + Opt.Alternate_Main_Name := new String '(Argv (3 .. Argv'Last)); + + -- All other options are single character and are handled + -- by Scan_Binder_Switches. + + else + Scan_Binder_Switches (Argv); + end if; + + -- Not a switch, so must be a file name (if non-empty) + + elsif Argv'Length /= 0 then + if Argv'Length > 4 + and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali" + then + Set_Main_File_Name (Argv); + else + Set_Main_File_Name (Argv & ".ali"); + end if; + end if; + end Scan_Bind_Arg; + +-- Start of processing for Gnatbind + +begin + Osint.Initialize (Binder); + + -- Set default for Shared_Libgnat option + + declare + Shared_Libgnat_Default : Character; + pragma Import (C, Shared_Libgnat_Default, "shared_libgnat_default"); + + SHARED : constant Character := 'H'; + STATIC : constant Character := 'T'; + + begin + pragma Assert + (Shared_Libgnat_Default = SHARED + or else + Shared_Libgnat_Default = STATIC); + Shared_Libgnat := (Shared_Libgnat_Default = SHARED); + end; + + -- Use low level argument routines to avoid dragging in the secondary stack + + Next_Arg := 1; + Scan_Args : while Next_Arg < Arg_Count loop + declare + Next_Argv : String (1 .. Len_Arg (Next_Arg)); + + begin + Fill_Arg (Next_Argv'Address, Next_Arg); + Scan_Bind_Arg (Next_Argv); + end; + Next_Arg := Next_Arg + 1; + end loop Scan_Args; + + -- Test for trailing -o switch + + if Opt.Output_File_Name_Present + and then not Output_File_Name_Seen + then + Fail ("output file name missing after -o"); + end if; + + -- Output usage if requested + + if Usage_Requested then + Bindusg; + end if; + + -- Check that the Ada binder file specified has extension .adb and that + -- the C binder file has extension .c + + if Opt.Output_File_Name_Present + and then Output_File_Name_Seen + then + Check_Extensions : declare + Length : constant Natural := Output_File_Name'Length; + Last : constant Natural := Output_File_Name'Last; + + begin + if Ada_Bind_File then + if Length <= 4 + or else Output_File_Name (Last - 3 .. Last) /= ".adb" + then + Fail ("output file name should have .adb extension"); + end if; + + else + if Length <= 2 + or else Output_File_Name (Last - 1 .. Last) /= ".c" + then + Fail ("output file name should have .c extension"); + end if; + end if; + end Check_Extensions; + end if; + + Osint.Add_Default_Search_Dirs; + + if Verbose_Mode then + Write_Eol; + Write_Str ("GNATBIND "); + Write_Str (Gnat_Version_String); + Write_Str (" Copyright 1995-2001 Free Software Foundation, Inc."); + Write_Eol; + end if; + + -- Output usage information if no files + + if not More_Lib_Files then + Bindusg; + Exit_Program (E_Fatal); + end if; + + -- The block here is to catch the Unrecoverable_Error exception in the + -- case where we exceed the maximum number of permissible errors or some + -- other unrecoverable error occurs. + + begin + -- Carry out package initializations. These are initializations which + -- might logically be performed at elaboration time, but Namet at + -- least can't be done that way (because it is used in the Compiler), + -- and we decide to be consistent. Like elaboration, the order in + -- which these calls are made is in some cases important. + + Csets.Initialize; + Namet.Initialize; + Initialize_Binderr; + Initialize_ALI; + Initialize_ALI_Source; + + if Verbose_Mode then + Write_Eol; + end if; + + -- Input ALI files + + while More_Lib_Files loop + Main_Lib_File := Next_Main_Lib_File; + + if Verbose_Mode then + if Check_Only then + Write_Str ("Checking: "); + else + Write_Str ("Binding: "); + end if; + + Write_Name (Main_Lib_File); + Write_Eol; + end if; + + Text := Read_Library_Info (Main_Lib_File, True); + Id := Scan_ALI + (F => Main_Lib_File, + T => Text, + Ignore_ED => Force_RM_Elaboration_Order, + Err => False); + Free (Text); + end loop; + + -- Add System.Standard_Library to list to ensure that these files are + -- included in the bind, even if not directly referenced from Ada code + -- This is of course omitted in No_Run_Time mode + + if not No_Run_Time_Specified then + Name_Buffer (1 .. 12) := "s-stalib.ali"; + Name_Len := 12; + Std_Lib_File := Name_Find; + Text := Read_Library_Info (Std_Lib_File, True); + Id := + Scan_ALI + (F => Std_Lib_File, + T => Text, + Ignore_ED => Force_RM_Elaboration_Order, + Err => False); + Free (Text); + end if; + + -- Acquire all information in ALI files that have been read in + + for Index in ALIs.First .. ALIs.Last loop + Read_ALI (Index); + end loop; + + -- Warn if -f switch used with static model + + if Force_RM_Elaboration_Order + and Static_Elaboration_Model_Used + then + Error_Msg ("?static elaboration model used, but -f specified"); + Error_Msg ("?may result in missing run-time elaboration checks"); + end if; + + -- Quit if some file needs compiling + + if No_Object_Specified then + raise Unrecoverable_Error; + end if; + + -- Build source file table from the ALI files we have read in + + Set_Source_Table; + + -- Check that main library file is a suitable main program + + if Bind_Main_Program + and then ALIs.Table (ALIs.First).Main_Program = None + and then not No_Main_Subprogram + then + Error_Msg_Name_1 := Main_Lib_File; + Error_Msg ("% does not contain a unit that can be a main program"); + end if; + + -- Perform consistency and correctness checks + + Check_Duplicated_Subunits; + Check_Versions; + Check_Consistency; + Check_Configuration_Consistency; + + -- Complete bind if no errors + + if Errors_Detected = 0 then + Find_Elab_Order; + + if Errors_Detected = 0 then + if Elab_Order_Output then + Write_Eol; + Write_Str ("ELABORATION ORDER"); + Write_Eol; + + for J in Elab_Order.First .. Elab_Order.Last loop + Write_Str (" "); + Write_Unit_Name (Units.Table (Elab_Order.Table (J)).Uname); + Write_Eol; + end loop; + + Write_Eol; + end if; + + if not Check_Only then + Gen_Output_File (Output_File_Name.all); + end if; + end if; + end if; + + Total_Errors := Total_Errors + Errors_Detected; + Total_Warnings := Total_Warnings + Warnings_Detected; + + exception + when Unrecoverable_Error => + Total_Errors := Total_Errors + Errors_Detected; + Total_Warnings := Total_Warnings + Warnings_Detected; + end; + + -- All done. Set proper exit status. + + Finalize_Binderr; + Namet.Finalize; + + if Total_Errors > 0 then + Exit_Program (E_Errors); + elsif Total_Warnings > 0 then + Exit_Program (E_Warnings); + else + Exit_Program (E_Success); + end if; + +end Gnatbind; diff --git a/gcc/ada/gnatbind.ads b/gcc/ada/gnatbind.ads new file mode 100644 index 00000000000..39c03c3d94d --- /dev/null +++ b/gcc/ada/gnatbind.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T B I N D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Main program of GNAT binder + +procedure Gnatbind; diff --git a/gcc/ada/gnatbl.c b/gcc/ada/gnatbl.c new file mode 100644 index 00000000000..18529a272b7 --- /dev/null +++ b/gcc/ada/gnatbl.c @@ -0,0 +1,397 @@ +/**************************************************************************** + * * + * GNAT COMPILER TOOLS * + * * + * G N A T B L * + * * + * C Implementation File * + * * + * $Revision: 1.65 $ + * * + * Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +#include "config.h" +#include "system.h" + +#if defined (__EMX__) || defined (MSDOS) +#include <process.h> +#endif +#include "adaint.h" + +#ifdef VMS +#ifdef exit +#undef exit +#endif +#define exit __posix_exit +#endif + +/* These can be set by command line arguments */ +char *binder_path = 0; +char *linker_path = 0; +char *exec_file_name = 0; +char *ali_file_name = 0; +#define BIND_ARG_MAX 512 +char *bind_args[BIND_ARG_MAX]; +int bind_arg_index = -1; +#ifdef MSDOS +char *coff2exe_path = 0; +char *coff2exe_args[] = {(char *) 0, (char *) 0}; +char *del_command = 0; +#endif +int verbose = 0; +int o_present = 0; +int g_present = 0; + +int link_arg_max = -1; +char **link_args = (char **) 0; +int link_arg_index = -1; + +char *gcc_B_arg = 0; + +#ifndef DIR_SEPARATOR +#if defined (__EMX__) +#define DIR_SEPARATOR '\\' +#else +#define DIR_SEPARATOR '/' +#endif +#endif + +static int linkonly = 0; + +static void addarg PARAMS ((char *)); +static void process_args PARAMS ((int *, char *[])); + +static void +addarg (str) + char *str; +{ + int i; + + if (++link_arg_index >= link_arg_max) + { + char **new_link_args + = (char **) xcalloc (link_arg_max + 1000, sizeof (char *)); + + for (i = 0; i <= link_arg_max; i++) + new_link_args [i] = link_args [i]; + + if (link_args) + free (link_args); + + link_arg_max += 1000; + link_args = new_link_args; + } + + link_args [link_arg_index] = str; +} + +static void +process_args (p_argc, argv) + int *p_argc; + char *argv[]; +{ + int i, j; + + for (i = 1; i < *p_argc; i++) + { + /* -I is passed on to gnatbind */ + if (! strncmp( argv[i], "-I", 2)) + { + bind_arg_index += 1; + if (bind_arg_index >= BIND_ARG_MAX) + { + fprintf (stderr, "Too many arguments to gnatbind\n"); + exit (-1); + } + + bind_args[bind_arg_index] = argv[i]; + } + + /* -B is passed on to gcc */ + if (! strncmp (argv [i], "-B", 2)) + gcc_B_arg = argv[i]; + + /* -v turns on verbose option here and is passed on to gcc */ + + if (! strcmp (argv [i], "-v")) + verbose = 1; + + if (! strcmp (argv [i], "-o")) + { + o_present = 1; + exec_file_name = argv [i + 1]; + } + + if (! strcmp (argv [i], "-g")) + g_present = 1; + + if (! strcmp (argv [i], "-gnatbind")) + { + /* Explicit naming of binder. Grab the value then remove the + two arguments from the argument list. */ + if ( i + 1 >= *p_argc ) + { + fprintf (stderr, "Missing argument for -gnatbind\n"); + exit (1); + } + + binder_path = __gnat_locate_exec (argv [i + 1], (char *) "."); + if (!binder_path) + { + fprintf (stderr, "Could not locate binder: %s\n", argv [i + 1]); + exit (1); + } + + for (j = i + 2; j < *p_argc; j++) + argv [j - 2] = argv [j]; + + (*p_argc) -= 2; + i--; + } + + else if (! strcmp (argv [i], "-linkonly")) + { + /* Don't call the binder. Set the flag and then remove the + argument from the argument list. */ + linkonly = 1; + for (j = i + 1; j < *p_argc; j++) + argv [j - 1] = argv [j]; + + (*p_argc) -= 1; + i--; + } + + else if (! strcmp (argv [i], "-gnatlink")) + { + /* Explicit naming of binder. Grab the value then remove the + two arguments from the argument list. */ + if (i + 1 >= *p_argc) + { + fprintf (stderr, "Missing argument for -gnatlink\n"); + exit (1); + } + + linker_path = __gnat_locate_exec (argv [i + 1], (char *) "."); + if (!linker_path) + { + fprintf (stderr, "Could not locate linker: %s\n", argv [i + 1]); + exit (1); + } + + for (j = i + 2; j < *p_argc; j++) + argv [j - 2] = argv [j]; + (*p_argc) -= 2; + i--; + } + } +} +extern int main PARAMS ((int, char **)); + +int +main (argc, argv) + int argc; + char **argv; +{ + int i, j; + int done_an_ali = 0; + int retcode; +#ifdef VMS + /* Warning: getenv only retrieves the first directory in VAXC$PATH */ + char *pathval = + strdup (__gnat_to_canonical_dir_spec (getenv ("VAXC$PATH"), 0)); +#else + char *pathval = getenv ("PATH"); +#endif + char *spawn_args [5]; + int spawn_index = 0; + +#if defined (__EMX__) || defined(MSDOS) + char *tmppathval = malloc (strlen (pathval) + 3); + strcpy (tmppathval, ".;"); + pathval = strcat (tmppathval, pathval); +#endif + + process_args (&argc , argv); + + if (argc == 1) + { + fprintf + (stdout, + "Usage: %s 'name'.ali\n", argv[0]); + fprintf + (stdout, + " [-o exec_name] -- by default it is 'name'\n"); + fprintf + (stdout, + " [-v] -- verbose mode\n"); + fprintf + (stdout, + " [-linkonly] -- doesn't call binder\n"); + fprintf + (stdout, + " [-gnatbind name] -- full name for gnatbind\n"); + fprintf + (stdout, + " [-gnatlink name] -- full name for linker (gcc)\n"); + fprintf + (stdout, + " [list of objects] -- non Ada binaries\n"); + fprintf + (stdout, + " [linker options] -- other options for linker\n"); + exit (1); + } + + if (!binder_path && !linkonly) + binder_path = __gnat_locate_exec ((char *) "gnatbind", pathval); + + if (!binder_path && !linkonly) + { + fprintf (stderr, "Couldn't locate gnatbind\n"); + exit (1); + } + + if (!linker_path) + linker_path = __gnat_locate_exec ((char *) "gnatlink", pathval); + if (!linker_path) + { + fprintf (stderr, "Couldn't locate gnatlink\n"); + exit (1); + } + +#ifdef MSDOS + coff2exe_path = __gnat_locate_regular_file ("coff2exe.bat", pathval); + if (!coff2exe_path) + { + fprintf (stderr, "Couldn't locate %s\n", "coff2exe.bat"); + exit (1); + } + else + coff2exe_args[0] = coff2exe_path; +#endif + + addarg (linker_path); + + for (i = 1; i < argc; i++) + { + int arg_len = strlen (argv [i]); + + if (arg_len > 4 && ! strcmp (&argv [i][arg_len - 4], ".ali")) + { + if (done_an_ali) + { + fprintf (stderr, + "Sorry - cannot handle more than one ALI file\n"); + exit (1); + } + + done_an_ali = 1; + + if (__gnat_is_regular_file (argv [i])) + { + ali_file_name = argv[i]; + if (!linkonly) + { + /* Run gnatbind */ + spawn_index = 0; + spawn_args [spawn_index++] = binder_path; + spawn_args [spawn_index++] = ali_file_name; + for (j = 0 ; j <= bind_arg_index ; j++ ) + spawn_args [spawn_index++] = bind_args [j]; + spawn_args [spawn_index] = 0; + + if (verbose) + { + int i; + for (i = 0; i < 2; i++) + printf ("%s ", spawn_args [i]); + + putchar ('\n'); + } + + retcode = __gnat_portable_spawn (spawn_args); + if (retcode != 0) + exit (retcode); + } + } + else + addarg (argv [i]); + } +#ifdef MSDOS + else if (!strcmp (argv [i], "-o")) + { + addarg (argv [i]); + if (i < argc) + i++; + + { + char *ptr = strstr (argv[i], ".exe"); + + arg_len = strlen (argv [i]); + coff2exe_args[1] = malloc (arg_len + 1); + strcpy (coff2exe_args[1], argv[i]); + if (ptr != NULL && strlen (ptr) == 4) + coff2exe_args[1][arg_len-4] = 0; + + addarg (coff2exe_args[1]); + } + } +#endif + else + addarg (argv [i]); + } + + if (! done_an_ali) + { + fprintf (stderr, "No \".ali\" file specified\n"); + exit (1); + } + + addarg (ali_file_name); + addarg (NULL); + + if (verbose) + { + int i; + + for (i = 0; i < link_arg_index; i++) + printf ("%s ", link_args [i]); + + putchar ('\n'); + } + + retcode = __gnat_portable_spawn (link_args); + if (retcode != 0) + exit (retcode); + +#ifdef MSDOS + retcode = __gnat_portable_spawn (coff2exe_args); + if (retcode != 0) + exit (retcode); + + if (!g_present) + { + del_command = malloc (strlen (coff2exe_args[1]) + 5); + sprintf (del_command, "del %s", coff2exe_args[1]); + retcode = system (del_command); + } +#endif + + exit(0); +} diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb new file mode 100644 index 00000000000..acb644460f8 --- /dev/null +++ b/gcc/ada/gnatchop.adb @@ -0,0 +1,1696 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C H O P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.44 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Heap_Sort_G; +with GNAT.Table; + +with Gnatvsn; +with Hostparm; + +procedure Gnatchop is + + Cwrite : constant String := + "GNATCHOP " & + Gnatvsn.Gnat_Version_String & + " Copyright 1998-2000, Ada Core Technologies Inc."; + + Terminate_Program : exception; + -- Used to terminate execution immediately + + Config_File_Name : constant String_Access := new String'("gnat.adc"); + -- The name of the file holding the GNAT configuration pragmas + + Gnat_Cmd : String_Access; + -- Command to execute the GNAT compiler + + Gnat_Args : Argument_List_Access := new Argument_List' + (new String'("-c"), new String'("-x"), new String'("ada"), + new String'("-gnats"), new String'("-gnatu")); + -- Arguments used in Gnat_Cmd call + + EOF : constant Character := Character'Val (26); + -- Special character to signal end of file. Not required in input + -- files, but properly treated if present. Not generated in output + -- files except as a result of copying input file. + + -------------------- + -- File arguments -- + -------------------- + + subtype File_Num is Natural; + subtype File_Offset is Natural; + + type File_Entry is record + Name : String_Access; + -- Name of chop file or directory + + SR_Name : String_Access; + -- Null unless the chop file starts with a source reference pragma + -- in which case this field points to the file name from this pragma. + end record; + + package File is new GNAT.Table + (Table_Component_Type => File_Entry, + Table_Index_Type => File_Num, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100); + + Directory : String_Access; + -- Record name of directory, or a null string if no directory given + + Compilation_Mode : Boolean := False; + Overwrite_Files : Boolean := False; + Quiet_Mode : Boolean := False; + Source_References : Boolean := False; + Verbose_Mode : Boolean := False; + Exit_On_Error : Boolean := False; + -- Global options + + Write_gnat_adc : Boolean := False; + -- Gets set true if we append to gnat.adc or create a new gnat.adc. + -- Used to inhibit complaint about no units generated. + + --------------- + -- Unit list -- + --------------- + + type Line_Num is new Natural; + -- Line number (for source reference pragmas) + + type Unit_Count_Type is new Integer; + subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last; + -- Used to refer to unit number in unit table + + type SUnit_Num is new Integer; + -- Used to refer to entry in sorted units table. Note that entry + -- zero is only for use by Heapsort, and is not otherwise referenced. + + type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas); + + -- Structure to contain all necessary information for one unit. + -- Entries are also temporarily used to record config pragma sequences. + + type Unit_Info is record + File_Name : String_Access; + -- File name from GNAT output line + + Chop_File : File_Num; + -- File number in chop file sequence + + Start_Line : Line_Num; + -- Line number from GNAT output line + + Offset : File_Offset; + -- Offset name from GNAT output line + + SR_Present : Boolean; + -- Set True if SR parameter present + + Length : File_Offset; + -- A length of 0 means that the Unit is the last one in the file + + Kind : Unit_Kind; + -- Indicates kind of unit + + Sorted_Index : SUnit_Num; + -- Index of unit in sorted unit list + + Bufferg : String_Access; + -- Pointer to buffer containing configuration pragmas to be + -- prepended. Null if no pragmas to be prepended. + + end record; + + -- The following table stores the unit offset information + + package Unit is new GNAT.Table + (Table_Component_Type => Unit_Info, + Table_Index_Type => Unit_Count_Type, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 100); + + -- The following table is used as a sorted index to the Unit.Table. + -- The entries in Unit.Table are not moved, instead we just shuffle + -- the entries in Sorted_Units. Note that the zeroeth entry in this + -- table is used by GNAT.Heap_Sort_G. + + package Sorted_Units is new GNAT.Table + (Table_Component_Type => Unit_Num, + Table_Index_Type => SUnit_Num, + Table_Low_Bound => 0, + Table_Initial => 500, + Table_Increment => 100); + + function Is_Duplicated (U : SUnit_Num) return Boolean; + -- Returns true if U is duplicated by a later unit. + -- Note that this function returns false for the last entry. + + procedure Sort_Units; + -- Sort units and set up sorted unit table. + + ---------------------- + -- File_Descriptors -- + ---------------------- + + function dup (handle : File_Descriptor) return File_Descriptor; + function dup2 (from, to : File_Descriptor) return File_Descriptor; + -- File descriptor based functions needed for redirecting stdin/stdout + + pragma Import (C, dup, "dup"); + pragma Import (C, dup2, "dup2"); + + --------------------- + -- Local variables -- + --------------------- + + Warning_Count : Natural := 0; + -- Count of warnings issued so far + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Error_Msg (Message : String); + -- Produce an error message on standard error output + + function Files_Exist return Boolean; + -- Check Unit.Table for possible file names that already exist + -- in the file system. Returns true if files exist, False otherwise + + function Get_Maximum_File_Name_Length return Integer; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + -- Function to get maximum file name length for system + + Maximum_File_Name_Length : constant Integer := Get_Maximum_File_Name_Length; + Maximum_File_Name_Length_String : constant String := + Integer'Image + (Maximum_File_Name_Length); + + function Locate_Executable (Program_Name : String) return String_Access; + -- Locate executable for given program name. This takes into account + -- the target-prefix of the current command. + + subtype EOL_Length is Natural range 0 .. 2; + -- Possible lengths of end of line sequence + + type EOL_String (Len : EOL_Length := 0) is record + Str : String (1 .. Len); + end record; + + function Get_EOL + (Source : access String; + Start : Positive) + return EOL_String; + -- Return the line terminator used in the passed string + + procedure Parse_EOL (Source : access String; Ptr : in out Positive); + -- On return Source (Ptr) is the first character of the next line + -- or EOF. Source.all must be terminated by EOF. + + function Parse_File (Num : File_Num) return Boolean; + -- Calls the GNAT compiler to parse the given source file and parses the + -- output using Parse_Offset_Info. Returns True if parse operation + -- completes, False if some system error (e.g. failure to read the + -- offset information) occurs. + + procedure Parse_Offset_Info (Chop_File : File_Num; Source : access String); + -- Parses the output of the compiler indicating the offsets + -- and names of the compilation units in Chop_File. + + procedure Parse_Token + (Source : access String; + Ptr : in out Positive; + Token_Ptr : out Positive); + -- Skips any separators and stores the start of the token in Token_Ptr. + -- Then stores the position of the next separator in Ptr. + -- On return Source (Token_Ptr .. Ptr - 1) is the token. + + procedure Read_File + (FD : File_Descriptor; + Contents : out String_Access; + Success : out Boolean); + -- Reads file associated with FS into the newly allocated + -- string Contents. + -- [VMS] Success is true iff the number of bytes read is less than or + -- equal to the file size. + -- [Other] Success is true iff the number of bytes read is equal to + -- the file size. + + function Report_Duplicate_Units return Boolean; + -- Output messages about duplicate units in the input files in Unit.Table + -- Returns True if any duplicates found, Fals if no duplicates found. + + function Scan_Arguments return Boolean; + -- Scan command line options and set global variables accordingly. + -- Also scan out file and directory arguments. Returns True if scan + -- was successful, and False if the scan fails for any reason. + + procedure Usage; + -- Output message on standard output describing syntax of gnatchop command + + procedure Warning_Msg (Message : String); + -- Output a warning message on standard error and update warning count + + function Write_Chopped_Files (Input : File_Num) return Boolean; + -- Write all units that result from chopping the Input file + + procedure Write_Config_File (Input : File_Num; U : Unit_Num); + -- Call to write configuration pragmas (append them to gnat.adc) + -- Input is the file number for the chop file and U identifies the + -- unit entry for the configuration pragmas. + + function Get_Config_Pragmas + (Input : File_Num; + U : Unit_Num) + return String_Access; + -- Call to read configuration pragmas from given unit entry, and + -- return a buffer containing the pragmas to be appended to + -- following units. Input is the file number for the chop file and + -- U identifies the unit entry for the configuration pragmas. + + procedure Write_Source_Reference_Pragma + (Info : Unit_Info; + Line : Line_Num; + FD : File_Descriptor; + EOL : EOL_String; + Success : in out Boolean); + -- If Success is True on entry, writes a source reference pragma using + -- the chop file from Info, and the given line number. On return Sucess + -- indicates whether the write succeeded. If Success is False on entry, + -- or if the global flag Source_References is False, then the call to + -- Write_Source_Reference_Pragma has no effect. EOL indicates the end + -- of line sequence to be written at the end of the pragma. + + procedure Write_Unit + (Source : access String; + Num : Unit_Num; + Success : out Boolean); + -- Write one compilation unit of the source to file + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Message : String) is + begin + Put_Line (Standard_Error, Message); + Set_Exit_Status (Failure); + + if Exit_On_Error then + raise Terminate_Program; + end if; + end Error_Msg; + + ----------------- + -- Files_Exist -- + ----------------- + + function Files_Exist return Boolean is + Exists : Boolean := False; + + begin + for SNum in 1 .. SUnit_Num (Unit.Last) loop + + -- Only check and report for the last instance of duplicated files + + if not Is_Duplicated (SNum) then + declare + Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum)); + + begin + if Is_Writable_File (Info.File_Name.all) then + if Hostparm.OpenVMS then + Error_Msg + (Info.File_Name.all + & " already exists, use /OVERWRITE to overwrite"); + else + Error_Msg (Info.File_Name.all + & " already exists, use -w to overwrite"); + end if; + + Exists := True; + end if; + end; + end if; + end loop; + + return Exists; + end Files_Exist; + + ------------------------ + -- Get_Config_Pragmas -- + ------------------------ + + function Get_Config_Pragmas + (Input : File_Num; + U : Unit_Num) + return String_Access + is + Info : Unit_Info renames Unit.Table (U); + FD : File_Descriptor; + Name : aliased constant String := + File.Table (Input).Name.all & ASCII.Nul; + Length : File_Offset; + Buffer : String_Access; + Success : Boolean; + Result : String_Access; + + begin + FD := Open_Read (Name'Address, Binary); + + if FD = Invalid_FD then + Error_Msg ("cannot open " & File.Table (Input).Name.all); + return null; + end if; + + Read_File (FD, Buffer, Success); + + -- A length of 0 indicates that the rest of the file belongs to + -- this unit. The actual length must be calculated now. Take into + -- account that the last character (EOF) must not be written. + + if Info.Length = 0 then + Length := Buffer'Last - (Buffer'First + Info.Offset); + else + Length := Info.Length; + end if; + + Result := new String'(Buffer (1 .. Length)); + Close (FD); + return Result; + end Get_Config_Pragmas; + + ------------- + -- Get_EOL -- + ------------- + + function Get_EOL + (Source : access String; + Start : Positive) + return EOL_String + is + Ptr : Positive := Start; + First : Positive; + Last : Natural; + + begin + -- Skip to end of line + + while Source (Ptr) /= ASCII.CR and then + Source (Ptr) /= ASCII.LF and then + Source (Ptr) /= EOF + loop + Ptr := Ptr + 1; + end loop; + + Last := Ptr; + + if Source (Ptr) /= EOF then + + -- Found CR or LF + + First := Ptr; + + else + First := Ptr + 1; + end if; + + -- Recognize CR/LF or LF/CR combination + + if (Source (Ptr + 1) = ASCII.CR or Source (Ptr + 1) = ASCII.LF) + and then Source (Ptr) /= Source (Ptr + 1) + then + Last := First + 1; + end if; + + return (Len => Last + 1 - First, Str => Source (First .. Last)); + end Get_EOL; + + ------------------- + -- Is_Duplicated -- + ------------------- + + function Is_Duplicated (U : SUnit_Num) return Boolean is + begin + return U < SUnit_Num (Unit.Last) + and then + Unit.Table (Sorted_Units.Table (U)).File_Name.all = + Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all; + end Is_Duplicated; + + ----------------------- + -- Locate_Executable -- + ----------------------- + + function Locate_Executable (Program_Name : String) return String_Access is + Current_Command : constant String := Command_Name; + End_Of_Prefix : Natural; + Start_Of_Prefix : Positive := Current_Command'First; + Result : String_Access; + + begin + -- Find Start_Of_Prefix + + for J in reverse Current_Command'Range loop + if Current_Command (J) = '/' or + Current_Command (J) = Directory_Separator or + Current_Command (J) = ':' + then + Start_Of_Prefix := J + 1; + exit; + end if; + end loop; + + -- Find End_Of_Prefix + + End_Of_Prefix := Start_Of_Prefix - 1; + + for J in reverse Start_Of_Prefix .. Current_Command'Last loop + if Current_Command (J) = '-' then + End_Of_Prefix := J; + exit; + end if; + end loop; + + declare + Command : constant String := + Current_Command (Start_Of_Prefix .. End_Of_Prefix) & + Program_Name; + begin + Result := Locate_Exec_On_Path (Command); + + if Result = null then + Error_Msg + (Command & ": installation problem, executable not found"); + end if; + end; + + return Result; + end Locate_Executable; + + --------------- + -- Parse_EOL -- + --------------- + + procedure Parse_EOL (Source : access String; Ptr : in out Positive) is + begin + -- Skip to end of line + + while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF + and then Source (Ptr) /= EOF + loop + Ptr := Ptr + 1; + end loop; + + if Source (Ptr) /= EOF then + Ptr := Ptr + 1; -- skip CR or LF + end if; + + -- Skip past CR/LF or LF/CR combination + + if (Source (Ptr) = ASCII.CR or Source (Ptr) = ASCII.LF) + and then Source (Ptr) /= Source (Ptr - 1) + then + Ptr := Ptr + 1; + end if; + end Parse_EOL; + + ---------------- + -- Parse_File -- + ---------------- + + function Parse_File (Num : File_Num) return Boolean is + Chop_Name : constant String_Access := File.Table (Num).Name; + Offset_Name : Temp_File_Name; + Offset_FD : File_Descriptor; + Save_Stdout : File_Descriptor := dup (Standout); + Buffer : String_Access; + Success : Boolean; + Failure : exception; + + begin + -- Display copy of GNAT command if verbose mode + + if Verbose_Mode then + Put (Gnat_Cmd.all); + + for J in 1 .. Gnat_Args'Length loop + Put (' '); + Put (Gnat_Args (J).all); + end loop; + + Put (' '); + Put_Line (Chop_Name.all); + end if; + + -- Create temporary file + + Create_Temp_File (Offset_FD, Offset_Name); + + if Offset_FD = Invalid_FD then + Error_Msg ("gnatchop: cannot create temporary file"); + Close (Save_Stdout); + return False; + end if; + + -- Redirect Stdout to this temporary file in the Unix way + + if dup2 (Offset_FD, Standout) = Invalid_FD then + Error_Msg ("gnatchop: cannot redirect stdout to temporary file"); + Close (Save_Stdout); + Close (Offset_FD); + return False; + end if; + + -- Call Gnat on the source filename argument with special options + -- to generate offset information. If this special compilation completes + -- succesfully then we can do the actual gnatchop operation. + + Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success); + + if not Success then + Error_Msg (Chop_Name.all & ": parse errors detected"); + Error_Msg (Chop_Name.all & ": chop may not be successful"); + end if; + + -- Restore stdout + + if dup2 (Save_Stdout, Standout) = Invalid_FD then + Error_Msg ("gnatchop: cannot restore stdout"); + end if; + + -- Reopen the file to start reading from the beginning + + Close (Offset_FD); + Close (Save_Stdout); + Offset_FD := Open_Read (Offset_Name'Address, Binary); + + if Offset_FD = Invalid_FD then + Error_Msg ("gnatchop: cannot access offset info"); + raise Failure; + end if; + + Read_File (Offset_FD, Buffer, Success); + + if not Success then + Error_Msg ("gnatchop: error reading offset info"); + Close (Offset_FD); + raise Failure; + else + Parse_Offset_Info (Num, Buffer); + end if; + + -- Close and delete temporary file + + Close (Offset_FD); + Delete_File (Offset_Name'Address, Success); + + return Success; + + exception + when Failure | Terminate_Program => + Close (Offset_FD); + Delete_File (Offset_Name'Address, Success); + return False; + + end Parse_File; + + ----------------------- + -- Parse_Offset_Info -- + ----------------------- + + procedure Parse_Offset_Info + (Chop_File : File_Num; + Source : access String) + is + First_Unit : Unit_Num := Unit.Last + 1; + Bufferg : String_Access := null; + Parse_Ptr : File_Offset := Source'First; + Token_Ptr : File_Offset; + Info : Unit_Info; + + function Match (Literal : String) return Boolean; + -- Checks if given string appears at the current Token_Ptr location + -- and if so, bumps Parse_Ptr past the token and returns True. If + -- the string is not present, sets Parse_Ptr to Token_Ptr and + -- returns False. + + ----------- + -- Match -- + ----------- + + function Match (Literal : String) return Boolean is + begin + Parse_Token (Source, Parse_Ptr, Token_Ptr); + + if Source'Last + 1 - Token_Ptr < Literal'Length + or else + Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal + then + Parse_Ptr := Token_Ptr; + return False; + end if; + + Parse_Ptr := Token_Ptr + Literal'Length; + return True; + end Match; + + -- Start of processing for Parse_Offset_Info + + begin + loop + -- Set default values, should get changed for all + -- units/pragmas except for the last + + Info.Chop_File := Chop_File; + Info.Length := 0; + + -- Parse the current line of offset information into Info + -- and exit the loop if there are any errors or on EOF. + + -- First case, parse a line in the following format: + + -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads + + -- Note that the unit name can be an operator name in quotes. + -- This is of course illegal, but both GNAT and gnatchop handle + -- the case so that this error does not intefere with chopping. + + -- The SR ir present indicates that a source reference pragma + -- was processed as part of this unit (and that therefore no + -- Source_Reference pragma should be generated. + + if Match ("Unit") then + Parse_Token (Source, Parse_Ptr, Token_Ptr); + + if Match ("(body)") then + Info.Kind := Unit_Body; + elsif Match ("(spec)") then + Info.Kind := Unit_Spec; + else + exit; + end if; + + exit when not Match ("line"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Start_Line := Line_Num'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + exit when not Match ("file offset"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Offset := File_Offset'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + Info.SR_Present := Match ("SR, "); + + exit when not Match ("file name"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.File_Name := new String' + (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1)); + Parse_EOL (Source, Parse_Ptr); + + -- Second case, parse a line of the following form + + -- Configuration pragmas at line 10, file offset 223 + + elsif Match ("Configuration pragmas at") then + Info.Kind := Config_Pragmas; + Info.File_Name := Config_File_Name; + + exit when not Match ("line"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Start_Line := Line_Num'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + exit when not Match ("file offset"); + Parse_Token (Source, Parse_Ptr, Token_Ptr); + Info.Offset := File_Offset'Value + (Source (Token_Ptr .. Parse_Ptr - 1)); + + Parse_EOL (Source, Parse_Ptr); + + -- Third case, parse a line of the following form + + -- Source_Reference pragma for file "filename" + + -- This appears at the start of the file only, and indicates + -- the name to be used on any generated Source_Reference pragmas. + + elsif Match ("Source_Reference pragma for file ") then + Parse_Token (Source, Parse_Ptr, Token_Ptr); + File.Table (Chop_File).SR_Name := + new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2)); + Parse_EOL (Source, Parse_Ptr); + goto Continue; + + -- Unrecognized keyword or end of file + + else + exit; + end if; + + -- Store the data in the Info record in the Unit.Table + + Unit.Increment_Last; + Unit.Table (Unit.Last) := Info; + + -- If this is not the first unit from the file, calculate + -- the length of the previous unit as difference of the offsets + + if Unit.Last > First_Unit then + Unit.Table (Unit.Last - 1).Length := + Info.Offset - Unit.Table (Unit.Last - 1).Offset; + end if; + + -- If not in compilation mode combine current unit with any + -- preceeding configuration pragmas. + + if not Compilation_Mode + and then Unit.Last > First_Unit + and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas + then + Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line; + Info.Offset := Unit.Table (Unit.Last - 1).Offset; + + -- Delete the configuration pragma entry + + Unit.Table (Unit.Last - 1) := Info; + Unit.Decrement_Last; + end if; + + -- If in compilation mode, and previous entry is the initial + -- entry for the file and is for configuration pragmas, then + -- they are to be appended to every unit in the file. + + if Compilation_Mode + and then Unit.Last = First_Unit + 1 + and then Unit.Table (First_Unit).Kind = Config_Pragmas + then + Bufferg := + Get_Config_Pragmas + (Unit.Table (Unit.Last - 1).Chop_File, First_Unit); + Unit.Table (Unit.Last - 1) := Info; + Unit.Decrement_Last; + end if; + + Unit.Table (Unit.Last).Bufferg := Bufferg; + + -- If in compilation mode, and this is not the first item, + -- combine configuration pragmas with previous unit, which + -- will cause an error message to be generated when the unit + -- is compiled. + + if Compilation_Mode + and then Unit.Last > First_Unit + and then Unit.Table (Unit.Last).Kind = Config_Pragmas + then + Unit.Decrement_Last; + end if; + + <<Continue>> + null; + + end loop; + + -- Find out if the loop was exited prematurely because of + -- an error or if the EOF marker was found. + + if Source (Parse_Ptr) /= EOF then + Error_Msg + (File.Table (Chop_File).Name.all & ": error parsing offset info"); + return; + end if; + + -- Handle case of a chop file consisting only of config pragmas + + if Unit.Last = First_Unit + and then Unit.Table (Unit.Last).Kind = Config_Pragmas + then + -- In compilation mode, we append such a file to gnat.adc + + if Compilation_Mode then + Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit); + Unit.Decrement_Last; + + -- In default (non-compilation) mode, this is invalid + + else + Error_Msg + (File.Table (Chop_File).Name.all & + ": no units found (only pragmas)"); + Unit.Decrement_Last; + end if; + end if; + + -- Handle case of a chop file ending with config pragmas. This can + -- happen only in default non-compilation mode, since in compilation + -- mode such configuration pragmas are part of the preceding unit. + -- We simply concatenate such pragmas to the previous file which + -- will cause a compilation error, which is appropriate. + + if Unit.Last > First_Unit + and then Unit.Table (Unit.Last).Kind = Config_Pragmas + then + Unit.Decrement_Last; + end if; + end Parse_Offset_Info; + + ----------------- + -- Parse_Token -- + ----------------- + + procedure Parse_Token + (Source : access String; + Ptr : in out Positive; + Token_Ptr : out Positive) + is + In_Quotes : Boolean := False; + + begin + -- Skip separators + + while Source (Ptr) = ' ' or Source (Ptr) = ',' loop + Ptr := Ptr + 1; + end loop; + + Token_Ptr := Ptr; + + -- Find end-of-token + + while (In_Quotes or else not (Source (Ptr) = ' ' or Source (Ptr) = ',')) + and then Source (Ptr) >= ' ' + loop + if Source (Ptr) = '"' then + In_Quotes := not In_Quotes; + end if; + + Ptr := Ptr + 1; + end loop; + end Parse_Token; + + --------------- + -- Read_File -- + --------------- + + procedure Read_File + (FD : File_Descriptor; + Contents : out String_Access; + Success : out Boolean) + is + Length : constant File_Offset := File_Offset (File_Length (FD)); + -- Include room for EOF char + Buffer : constant String_Access := new String (1 .. Length + 1); + + This_Read : Integer; + Read_Ptr : File_Offset := 1; + + begin + + loop + This_Read := Read (FD, + A => Buffer (Read_Ptr)'Address, + N => Length + 1 - Read_Ptr); + Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); + exit when This_Read <= 0; + end loop; + + Buffer (Read_Ptr) := EOF; + Contents := new String (1 .. Read_Ptr); + Contents.all := Buffer (1 .. Read_Ptr); + + -- Things aren't simple on VMS due to the plethora of file types + -- and organizations. It seems clear that there shouldn't be more + -- bytes read than are contained in the file though. + + if Hostparm.OpenVMS then + Success := Read_Ptr <= Length + 1; + else + Success := Read_Ptr = Length + 1; + end if; + end Read_File; + + ---------------------------- + -- Report_Duplicate_Units -- + ---------------------------- + + function Report_Duplicate_Units return Boolean is + US : SUnit_Num; + U : Unit_Num; + + Duplicates : Boolean := False; + + begin + US := 1; + while US < SUnit_Num (Unit.Last) loop + U := Sorted_Units.Table (US); + + if Is_Duplicated (US) then + Duplicates := True; + + -- Move to last two versions of duplicated file to make it clearer + -- to understand which file is retained in case of overwriting. + + while US + 1 < SUnit_Num (Unit.Last) loop + exit when not Is_Duplicated (US + 1); + US := US + 1; + end loop; + + U := Sorted_Units.Table (US); + + if Overwrite_Files then + Warning_Msg (Unit.Table (U).File_Name.all + & " is duplicated (all but last will be skipped)"); + + elsif Unit.Table (U).Chop_File = + Unit.Table (Sorted_Units.Table (US + 1)).Chop_File + then + Error_Msg (Unit.Table (U).File_Name.all + & " is duplicated in " + & File.Table (Unit.Table (U).Chop_File).Name.all); + + else + Error_Msg (Unit.Table (U).File_Name.all + & " in " + & File.Table (Unit.Table (U).Chop_File).Name.all + & " is duplicated in " + & File.Table + (Unit.Table + (Sorted_Units.Table (US + 1)).Chop_File).Name.all); + end if; + end if; + + US := US + 1; + end loop; + + if Duplicates and not Overwrite_Files then + if Hostparm.OpenVMS then + Put_Line + ("use /OVERWRITE to overwrite files and keep last version"); + else + Put_Line ("use -w to overwrite files and keep last version"); + end if; + end if; + + return Duplicates; + end Report_Duplicate_Units; + + -------------------- + -- Scan_Arguments -- + -------------------- + + function Scan_Arguments return Boolean is + Kset : Boolean := False; + -- Set true if -k switch found + + begin + Initialize_Option_Scan; + + -- Scan options first + + loop + case Getopt ("c gnat? h k? q r v w x") is + when ASCII.NUL => + exit; + + when 'c' => + Compilation_Mode := True; + + when 'g' => + Gnat_Args := + new Argument_List'(Gnat_Args.all & + new String'("-gnat" & Parameter)); + + when 'h' => + Usage; + raise Terminate_Program; + + when 'k' => + declare + Param : String_Access := new String'(Parameter); + + begin + if Param.all /= "" then + for J in Param'Range loop + if Param (J) not in '0' .. '9' then + if Hostparm.OpenVMS then + Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" & + " requires numeric parameter"); + else + Error_Msg ("-k# requires numeric parameter"); + end if; + return False; + end if; + end loop; + + else + if Hostparm.OpenVMS then + Param := new String'("39"); + else + Param := new String'("8"); + end if; + end if; + + Gnat_Args := + new Argument_List'(Gnat_Args.all & + new String'("-gnatk" & Param.all)); + Kset := True; + end; + + when 'q' => + Quiet_Mode := True; + + when 'r' => + Source_References := True; + + when 'v' => + Verbose_Mode := True; + Put_Line (Standard_Error, Cwrite); + + when 'w' => + Overwrite_Files := True; + + when 'x' => + Exit_On_Error := True; + + when others => + null; + end case; + end loop; + + if not Kset and then Maximum_File_Name_Length > 0 then + + -- If this system has restricted filename lengths, tell gnat1 + -- about them, removing the leading blank from the image string. + + Gnat_Args := + new Argument_List'(Gnat_Args.all + & new String'("-gnatk" + & Maximum_File_Name_Length_String + (Maximum_File_Name_Length_String'First + 1 + .. Maximum_File_Name_Length_String'Last))); + end if; + + -- Scan file names + + loop + declare + S : constant String := Get_Argument (Do_Expansion => True); + + begin + exit when S = ""; + File.Increment_Last; + File.Table (File.Last).Name := new String'(S); + File.Table (File.Last).SR_Name := null; + end; + end loop; + + -- Case of more than one file where last file is a directory + + if File.Last > 1 + and then Is_Directory (File.Table (File.Last).Name.all) + then + Directory := File.Table (File.Last).Name; + File.Decrement_Last; + + -- Make sure Directory is terminated with a directory separator, + -- so we can generate the output by just appending a filename. + + if Directory (Directory'Last) /= Directory_Separator + and then Directory (Directory'Last) /= '/' + then + Directory := new String'(Directory.all & Directory_Separator); + end if; + + -- At least one filename must be given + + elsif File.Last = 0 then + Usage; + return False; + + -- No directory given, set directory to null, so that we can just + -- concatenate the directory name to the file name unconditionally. + + else + Directory := new String'(""); + end if; + + -- Finally check all filename arguments + + for File_Num in 1 .. File.Last loop + declare + F : constant String := File.Table (File_Num).Name.all; + + begin + + if Is_Directory (F) then + Error_Msg (F & " is a directory, cannot be chopped"); + return False; + + elsif not Is_Regular_File (F) then + Error_Msg (F & " not found"); + return False; + end if; + end; + end loop; + + return True; + + exception + when Invalid_Switch => + Error_Msg ("invalid switch " & Full_Switch); + return False; + + when Invalid_Parameter => + if Hostparm.OpenVMS then + Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" & + " requires numeric parameter"); + else + Error_Msg ("-k switch requires numeric parameter"); + end if; + + return False; + + end Scan_Arguments; + + ---------------- + -- Sort_Units -- + ---------------- + + procedure Sort_Units is + + procedure Move (From : Natural; To : Natural); + -- Procedure used to sort the unit list + -- Unit.Table (To) := Unit_List (From); used by sort + + function Lt (Left, Right : Natural) return Boolean; + -- Compares Left and Right units based on file name (first), + -- Chop_File (second) and Offset (third). This ordering is + -- important to keep the last version in case of duplicate files. + + package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt); + -- Used for sorting on filename to detect duplicates + + -------- + -- Lt -- + -------- + + function Lt (Left, Right : Natural) return Boolean is + L : Unit_Info renames + Unit.Table (Sorted_Units.Table (SUnit_Num (Left))); + + R : Unit_Info renames + Unit.Table (Sorted_Units.Table (SUnit_Num (Right))); + + begin + return L.File_Name.all < R.File_Name.all + or else (L.File_Name.all = R.File_Name.all + and then (L.Chop_File < R.Chop_File + or else (L.Chop_File = R.Chop_File + and then L.Offset < R.Offset))); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Sorted_Units.Table (SUnit_Num (To)) := + Sorted_Units.Table (SUnit_Num (From)); + end Move; + + -- Start of processing for Sort_Units + + begin + Sorted_Units.Set_Last (SUnit_Num (Unit.Last)); + + for J in 1 .. Unit.Last loop + Sorted_Units.Table (SUnit_Num (J)) := J; + end loop; + + -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch + + Unit_Sort.Sort (Natural (Unit.Last)); + + -- Set the Sorted_Index fields in the unit tables. + + for J in 1 .. SUnit_Num (Unit.Last) loop + Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J; + end loop; + end Sort_Units; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + Put_Line + ("Usage: gnatchop [-c] [-h] [-k#] " & + "[-r] [-q] [-v] [-w] [-x] file [file ...] [dir]"); + + New_Line; + Put_Line + (" -c compilation mode, configuration pragmas " & + "follow RM rules"); + + Put_Line + (" -gnatxxx passes the -gnatxxx switch to gnat parser"); + + Put_Line + (" -h help: output this usage information"); + + Put_Line + (" -k# krunch file names of generated files to " & + "no more than # characters"); + + Put_Line + (" -k krunch file names of generated files to " & + "no more than 8 characters"); + + Put_Line + (" -q quiet mode, no output of generated file " & + "names"); + + Put_Line + (" -r generate Source_Reference pragmas refer" & + "encing original source file"); + + Put_Line + (" -v verbose mode, output version and generat" & + "ed commands"); + + Put_Line + (" -w overwrite existing filenames"); + + Put_Line + (" -x exit on error"); + + New_Line; + Put_Line + (" file... list of source files to be chopped"); + + Put_Line + (" dir directory location for split files (defa" & + "ult = current directory)"); + end Usage; + + ----------------- + -- Warning_Msg -- + ----------------- + + procedure Warning_Msg (Message : String) is + begin + Warning_Count := Warning_Count + 1; + Put_Line (Standard_Error, "warning: " & Message); + end Warning_Msg; + + ------------------------- + -- Write_Chopped_Files -- + ------------------------- + + function Write_Chopped_Files (Input : File_Num) return Boolean is + Name : aliased constant String := + File.Table (Input).Name.all & ASCII.Nul; + FD : File_Descriptor; + Buffer : String_Access; + Success : Boolean; + + begin + FD := Open_Read (Name'Address, Binary); + + if FD = Invalid_FD then + Error_Msg ("cannot open " & File.Table (Input).Name.all); + return False; + end if; + + Read_File (FD, Buffer, Success); + + if not Success then + Error_Msg ("cannot read " & File.Table (Input).Name.all); + Close (FD); + return False; + end if; + + if not Quiet_Mode then + Put_Line ("splitting " & File.Table (Input).Name.all & " into:"); + end if; + + -- Only chop those units that come from this file + + for Num in 1 .. Unit.Last loop + if Unit.Table (Num).Chop_File = Input then + Write_Unit (Buffer, Num, Success); + exit when not Success; + end if; + end loop; + + Close (FD); + return Success; + + end Write_Chopped_Files; + + ----------------------- + -- Write_Config_File -- + ----------------------- + + procedure Write_Config_File (Input : File_Num; U : Unit_Num) is + FD : File_Descriptor; + Name : aliased constant String := "gnat.adc" & ASCII.NUL; + Buffer : String_Access; + Success : Boolean; + Append : Boolean; + Buffera : String_Access; + Bufferl : Natural; + + begin + Write_gnat_adc := True; + FD := Open_Read_Write (Name'Address, Binary); + + if FD = Invalid_FD then + FD := Create_File (Name'Address, Binary); + Append := False; + + if not Quiet_Mode then + Put_Line ("writing configuration pragmas from " & + File.Table (Input).Name.all & " to gnat.adc"); + end if; + + else + Append := True; + + if not Quiet_Mode then + Put_Line + ("appending configuration pragmas from " & + File.Table (Input).Name.all & " to gnat.adc"); + end if; + end if; + + Success := FD /= Invalid_FD; + + if not Success then + Error_Msg ("cannot create gnat.adc"); + return; + end if; + + -- In append mode, acquire existing gnat.adc file + + if Append then + Read_File (FD, Buffera, Success); + + if not Success then + Error_Msg ("cannot read gnat.adc"); + return; + end if; + + -- Find location of EOF byte if any to exclude from append + + Bufferl := 1; + while Bufferl <= Buffera'Last + and then Buffera (Bufferl) /= EOF + loop + Bufferl := Bufferl + 1; + end loop; + + Bufferl := Bufferl - 1; + Close (FD); + + -- Write existing gnat.adc to new gnat.adc file + + FD := Create_File (Name'Address, Binary); + Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl; + + if not Success then + Error_Msg ("error writing gnat.adc"); + return; + end if; + end if; + + Buffer := Get_Config_Pragmas (Input, U); + + if Buffer /= null then + Success := Write (FD, Buffer.all'Address, Buffer'Length) = + Buffer'Length; + + if not Success then + Error_Msg ("disk full writing gnat.adc"); + return; + end if; + end if; + + Close (FD); + end Write_Config_File; + + ----------------------------------- + -- Write_Source_Reference_Pragma -- + ----------------------------------- + + procedure Write_Source_Reference_Pragma + (Info : Unit_Info; + Line : Line_Num; + FD : File_Descriptor; + EOL : EOL_String; + Success : in out Boolean) + is + FTE : File_Entry renames File.Table (Info.Chop_File); + Nam : String_Access; + + begin + if Success and Source_References and not Info.SR_Present then + if FTE.SR_Name /= null then + Nam := FTE.SR_Name; + else + Nam := FTE.Name; + end if; + + declare + Reference : aliased String := + "pragma Source_Reference (000000, """ + & Nam.all & """);" & EOL.Str; + + Pos : Positive := Reference'First; + Lin : Line_Num := Line; + + begin + while Reference (Pos + 1) /= ',' loop + Pos := Pos + 1; + end loop; + + while Reference (Pos) = '0' loop + Reference (Pos) := Character'Val + (Character'Pos ('0') + Lin mod 10); + Lin := Lin / 10; + Pos := Pos - 1; + end loop; + + -- Assume there are enough zeroes for any program length + + pragma Assert (Lin = 0); + + Success := + Write (FD, Reference'Address, Reference'Length) + = Reference'Length; + end; + end if; + end Write_Source_Reference_Pragma; + + ---------------- + -- Write_Unit -- + ---------------- + + procedure Write_Unit + (Source : access String; + Num : Unit_Num; + Success : out Boolean) + is + Info : Unit_Info renames Unit.Table (Num); + FD : File_Descriptor; + Name : aliased constant String := Info.File_Name.all & ASCII.NUL; + Length : File_Offset; + EOL : constant EOL_String := + Get_EOL (Source, Source'First + Info.Offset); + + begin + -- Skip duplicated files + + if Is_Duplicated (Info.Sorted_Index) then + Put_Line (" " & Info.File_Name.all & " skipped"); + Success := Overwrite_Files; + return; + end if; + + if Overwrite_Files then + FD := Create_File (Name'Address, Binary); + else + FD := Create_New_File (Name'Address, Binary); + end if; + + Success := FD /= Invalid_FD; + + if not Success then + Error_Msg ("cannot create " & Info.File_Name.all); + return; + end if; + + -- A length of 0 indicates that the rest of the file belongs to + -- this unit. The actual length must be calculated now. Take into + -- account that the last character (EOF) must not be written. + + if Info.Length = 0 then + Length := Source'Last - (Source'First + Info.Offset); + else + Length := Info.Length; + end if; + + -- Prepend configuration pragmas if necessary + + if Success and then Info.Bufferg /= null then + Write_Source_Reference_Pragma (Info, 1, FD, EOL, Success); + Success := + Write (FD, Info.Bufferg.all'Address, Info.Bufferg'Length) = + Info.Bufferg'Length; + end if; + + Write_Source_Reference_Pragma (Info, Info.Start_Line, FD, EOL, Success); + + if Success then + Success := Write (FD, Source (Source'First + Info.Offset)'Address, + Length) = Length; + end if; + + if not Success then + Error_Msg ("disk full writing " & Info.File_Name.all); + return; + end if; + + if not Quiet_Mode then + Put_Line (" " & Info.File_Name.all); + end if; + + Close (FD); + end Write_Unit; + +-- Start of processing for gnatchop + +begin + -- Check presence of required executables + + Gnat_Cmd := Locate_Executable ("gcc"); + + if Gnat_Cmd = null then + goto No_Files_Written; + end if; + + -- Process command line options and initialize global variables + + if not Scan_Arguments then + Set_Exit_Status (Failure); + return; + end if; + + -- First parse all files and read offset information + + for Num in 1 .. File.Last loop + if not Parse_File (Num) then + goto No_Files_Written; + end if; + end loop; + + -- Check if any units have been found (assumes non-empty Unit.Table) + + if Unit.Last = 0 then + if not Write_gnat_adc then + Error_Msg ("no compilation units found"); + end if; + + goto No_Files_Written; + end if; + + Sort_Units; + + -- Check if any duplicate files would be created. If so, emit + -- a warning if Overwrite_Files is true, otherwise generate an error. + + if Report_Duplicate_Units and then not Overwrite_Files then + goto No_Files_Written; + end if; + + -- Check if any files exist, if so do not write anything + -- Because all files have been parsed and checked already, + -- there won't be any duplicates + + if not Overwrite_Files and then Files_Exist then + goto No_Files_Written; + end if; + + -- After this point, all source files are read in succession + -- and chopped into their destination files. + + -- As the Source_File_Name pragmas are handled as logical file 0, + -- write it first. + + for F in 1 .. File.Last loop + if not Write_Chopped_Files (F) then + Set_Exit_Status (Failure); + return; + end if; + end loop; + + if Warning_Count > 0 then + declare + Warnings_Msg : String := Warning_Count'Img & " warning(s)"; + begin + Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last)); + end; + end if; + + return; + +<<No_Files_Written>> + + -- Special error exit for all situations where no files have + -- been written. + + if not Write_gnat_adc then + Error_Msg ("no source files written"); + end if; + + return; + +exception + when Terminate_Program => + null; + +end Gnatchop; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb new file mode 100644 index 00000000000..ac4e302f252 --- /dev/null +++ b/gcc/ada/gnatcmd.adb @@ -0,0 +1,3239 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C M D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.84 $ +-- -- +-- Copyright (C) 1996-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with Osint; use Osint; +with Sdefault; use Sdefault; +with Hostparm; use Hostparm; +-- Used to determine if we are in VMS or not for error message purposes + +with Gnatvsn; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Table; + +procedure GNATCmd is + pragma Ident (Gnatvsn.Gnat_Version_String); + + ------------------ + -- SWITCH TABLE -- + ------------------ + + -- The switch tables contain an entry for each switch recognized by the + -- command processor. The syntax of entries is as follows: + + -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION" + + -- TRANSLATION ::= + -- DIRECT_TRANSLATION + -- | DIRECTORIES_TRANSLATION + -- | FILE_TRANSLATION + -- | NUMERIC_TRANSLATION + -- | STRING_TRANSLATION + -- | OPTIONS_TRANSLATION + -- | COMMANDS_TRANSLATION + -- | ALPHANUMPLUS_TRANSLATION + -- | OTHER_TRANSLATION + + -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES + -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH * + -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH % + -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @ + -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number # + -- STRING_TRANSLATION ::= =" UNIX_SWITCH " + -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION} + -- COMMANDS_TRANSLATION ::= =? ARGS space command-name + -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH | + + -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH} + + -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string' + + -- OPTION ::= option-name space UNIX_SWITCHES + + -- ARGS ::= -cargs | -bargs | -largs + + -- Here command-qual is the name of the switch recognized by the GNATCmd. + -- This is always given in upper case in the templates, although in the + -- actual commands, either upper or lower case is allowed. + + -- The unix-switch-string always starts with a minus, and has no commas + -- or spaces in it. Case is significant in the unix switch string. If a + -- unix switch string is preceded by the not sign (!) it means that the + -- effect of the corresponding command qualifer is to remove any previous + -- occurrence of the given switch in the command line. + + -- The DIRECTORIES_TRANSLATION format is used where a list of directories + -- is given. This possible corresponding formats recognized by GNATCmd are + -- as shown by the following example for the case of PATH + + -- PATH=direc + -- PATH=(direc,direc,direc,direc) + + -- When more than one directory is present for the DIRECTORIES case, then + -- multiple instances of the corresponding unix switch are generated, + -- with the file name being substituted for the occurrence of *. + + -- The FILE_TRANSLATION format is similar except that only a single + -- file is allowed, not a list of files, and only one unix switch is + -- generated as a result. + + -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case + -- except that the parameter is a decimal integer in the range 0 to 999. + + -- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or + -- more options to appear (although only in some cases does the use of + -- multiple options make logical sense). For example, taking the + -- case of ERRORS for GCC, the following are all allowed: + + -- /ERRORS=BRIEF + -- /ERRORS=(FULL,VERBOSE) + -- /ERRORS=(BRIEF IMMEDIATE) + + -- If no option is provided (e.g. just /ERRORS is written), then the + -- first option in the list is the default option. For /ERRORS this + -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL. + + -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond + -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated + -- is one of these three possibilities). The name given by COMMAND is the + -- corresponding command name to be used to interprete the switches to be + -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS + -- sets the mode so that all subsequent switches, up to another switch + -- with COMMANDS_TRANSLATION apply to the corresponding commands issued + -- by the make utility. For example + + -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN + -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX + + -- Clearly these switches must come at the end of the list of switches + -- since all subsequent switches apply to an issued command. + + -- For the DIRECT_TRANSLATION case, an implicit additional entry is + -- created by prepending NO to the name of the qualifer, and then + -- inverting the sense of the UNIX_SWITCHES string. For example, + -- given the entry: + + -- "/LIST -gnatl" + + -- An implicit entry is created: + + -- "/NOLIST !-gnatl" + + -- In the case where, a ! is already present, inverting the sense of the + -- switch means removing it. + + subtype S is String; + -- A synonym to shorten the table + + type String_Ptr is access constant String; + -- String pointer type used throughout + + type Switches is array (Natural range <>) of String_Ptr; + -- Type used for array of swtiches + + type Switches_Ptr is access constant Switches; + + ---------------------------- + -- Switches for GNAT BIND -- + ---------------------------- + + S_Bind_Bind : aliased constant S := "/BIND_FILE=" & + "ADA " & + "-A " & + "C " & + "-C"; + + S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" & + "-L|"; + + S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + + S_Bind_Debug : aliased constant S := "/DEBUG=" & + "TRACEBACK " & + "-g2 " & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "SYMBOLS " & + "-g1 " & + "NOSYMBOLS " & + "!-g1 " & + "LINK " & + "-g3 " & + "NOTRACEBACK " & + "!-g2"; + + S_Bind_DebugX : aliased constant S := "/NODEBUG " & + "!-g"; + + S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " & + "-e"; + + S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" & + "-m#"; + + S_Bind_Full : aliased constant S := "/FULL_ELABORATION " & + "-f"; + + S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" & + "-aO*"; + + S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " & + "-K"; + + S_Bind_Main : aliased constant S := "/MAIN " & + "!-n"; + + S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + + S_Bind_Object : aliased constant S := "/OBJECT_LIST " & + "-O"; + + S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " & + "-l"; + + S_Bind_Output : aliased constant S := "/OUTPUT=@" & + "-o@"; + + S_Bind_OutputX : aliased constant S := "/NOOUTPUT " & + "-c"; + + S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " & + "-p"; + + S_Bind_Read : aliased constant S := "/READ_SOURCES=" & + "ALL " & + "-s " & + "NONE " & + "-x " & + "AVAILABLE " & + "!-x,!-s"; + + S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " & + "-x"; + + S_Bind_Rename : aliased constant S := "/RENAME_MAIN " & + "-r"; + + S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" & + "VERBOSE " & + "-v " & + "BRIEF " & + "-b " & + "DEFAULT " & + "!-b,!-v"; + + S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " & + "!-b,!-v"; + + S_Bind_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + + S_Bind_Shared : aliased constant S := "/SHARED " & + "-shared"; + + S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + + S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " & + "!-t"; + + S_Bind_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + + S_Bind_Warn : aliased constant S := "/WARNINGS=" & + "NORMAL " & + "!-ws,!-we " & + "SUPPRESS " & + "-ws " & + "ERROR " & + "-we"; + + S_Bind_WarnX : aliased constant S := "/NOWARNINGS " & + "-ws"; + + Bind_Switches : aliased constant Switches := ( + S_Bind_Bind 'Access, + S_Bind_Build 'Access, + S_Bind_Current 'Access, + S_Bind_Debug 'Access, + S_Bind_DebugX 'Access, + S_Bind_Elab 'Access, + S_Bind_Error 'Access, + S_Bind_Full 'Access, + S_Bind_Library 'Access, + S_Bind_Linker 'Access, + S_Bind_Main 'Access, + S_Bind_Nostinc 'Access, + S_Bind_Nostlib 'Access, + S_Bind_Object 'Access, + S_Bind_Order 'Access, + S_Bind_Output 'Access, + S_Bind_OutputX 'Access, + S_Bind_Pess 'Access, + S_Bind_Read 'Access, + S_Bind_ReadX 'Access, + S_Bind_Rename 'Access, + S_Bind_Report 'Access, + S_Bind_ReportX 'Access, + S_Bind_Search 'Access, + S_Bind_Shared 'Access, + S_Bind_Source 'Access, + S_Bind_Time 'Access, + S_Bind_Verbose 'Access, + S_Bind_Warn 'Access, + S_Bind_WarnX 'Access); + + ---------------------------- + -- Switches for GNAT CHOP -- + ---------------------------- + + S_Chop_Comp : aliased constant S := "/COMPILATION " & + "-c"; + + S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" & + "-k#"; + + S_Chop_Help : aliased constant S := "/HELP " & + "-h"; + + S_Chop_Over : aliased constant S := "/OVERWRITE " & + "-w"; + + S_Chop_Quiet : aliased constant S := "/QUIET " & + "-q"; + + S_Chop_Ref : aliased constant S := "/REFERENCE " & + "-r"; + + S_Chop_Verb : aliased constant S := "/VERBOSE " & + "-v"; + + Chop_Switches : aliased constant Switches := ( + S_Chop_Comp 'Access, + S_Chop_File 'Access, + S_Chop_Help 'Access, + S_Chop_Over 'Access, + S_Chop_Quiet 'Access, + S_Chop_Ref 'Access, + S_Chop_Verb 'Access); + + ------------------------------- + -- Switches for GNAT COMPILE -- + ------------------------------- + + S_GCC_Ada_83 : aliased constant S := "/83 " & + "-gnat83"; + + S_GCC_Ada_95 : aliased constant S := "/95 " & + "!-gnat83"; + + S_GCC_Asm : aliased constant S := "/ASM " & + "-S,!-c"; + + S_GCC_Checks : aliased constant S := "/CHECKS=" & + "FULL " & + "-gnato,!-gnatE,!-gnatp " & + "OVERFLOW " & + "-gnato " & + "ELABORATION " & + "-gnatE " & + "ASSERTIONS " & + "-gnata " & + "DEFAULT " & + "!-gnato,!-gnatp " & + "SUPPRESS_ALL " & + "-gnatp"; + + S_GCC_ChecksX : aliased constant S := "/NOCHECKS " & + "-gnatp,!-gnato,!-gnatE"; + + S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " & + "-gnatC"; + + S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + + S_GCC_Debug : aliased constant S := "/DEBUG=" & + "SYMBOLS " & + "-g2 " & + "NOSYMBOLS " & + "!-g2 " & + "TRACEBACK " & + "-g1 " & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "NOTRACEBACK " & + "-g0"; + + S_GCC_DebugX : aliased constant S := "/NODEBUG " & + "!-g"; + + S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" & + "RECEIVER " & + "-gnatzr " & + "CALLER " & + "-gnatzc"; + + S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " & + "!-gnatzr,!-gnatzc"; + + S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" & + "-gnatm#"; + + S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " & + "-gnatm999"; + + S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " & + "-gnatG"; + + S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " & + "-gnatX"; + + S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" & + "-gnatk#"; + + S_GCC_Force : aliased constant S := "/FORCE_ALI " & + "-gnatQ"; + + S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" & + "DEFAULT " & + "-gnati1 " & + "1 " & + "-gnati1 " & + "2 " & + "-gnati2 " & + "3 " & + "-gnati3 " & + "4 " & + "-gnati4 " & + "PC " & + "-gnatip " & + "PC850 " & + "-gnati8 " & + "FULL_UPPER " & + "-gnatif " & + "NO_UPPER " & + "-gnatin " & + "WIDE " & + "-gnatiw"; + + S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " & + "-gnati1"; + + S_GCC_Inline : aliased constant S := "/INLINE=" & + "PRAGMA " & + "-gnatn " & + "SUPPRESS " & + "-fno-inline"; + + S_GCC_InlineX : aliased constant S := "/NOINLINE " & + "!-gnatn"; + + S_GCC_List : aliased constant S := "/LIST " & + "-gnatl"; + + S_GCC_Noload : aliased constant S := "/NOLOAD " & + "-gnatc"; + + S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & + "ALL " & + "-O2,!-O0,!-O1,!-O3 " & + "NONE " & + "-O0,!-O1,!-O2,!-O3 " & + "SOME " & + "-O1,!-O0,!-O2,!-O3 " & + "DEVELOPMENT " & + "-O1,!-O0,!-O2,!-O3 " & + "UNROLL_LOOPS " & + "-funroll-loops " & + "INLINING " & + "-O3,!-O0,!-O1,!-O2"; + + S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " & + "-O0,!-O1,!-O2,!-O3"; + + S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" & + "VERBOSE " & + "-gnatv " & + "BRIEF " & + "-gnatb " & + "FULL " & + "-gnatf " & + "IMMEDIATE " & + "-gnate " & + "DEFAULT " & + "!-gnatb,!-gnatv"; + + S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " & + "!-gnatb,!-gnatv"; + + S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" & + "ARRAYS " & + "-gnatR1 " & + "NONE " & + "-gnatR0 " & + "OBJECTS " & + "-gnatR2 " & + "SYMBOLIC " & + "-gnatR3 " & + "DEFAULT " & + "-gnatR"; + + S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " & + "!-gnatR"; + + S_GCC_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + + S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" & + "ALL_BUILTIN " & + "-gnaty " & + "1 " & + "-gnaty1 " & + "2 " & + "-gnaty2 " & + "3 " & + "-gnaty3 " & + "4 " & + "-gnaty4 " & + "5 " & + "-gnaty5 " & + "6 " & + "-gnaty6 " & + "7 " & + "-gnaty7 " & + "8 " & + "-gnaty8 " & + "9 " & + "-gnaty9 " & + "ATTRIBUTE " & + "-gnatya " & + "BLANKS " & + "-gnatyb " & + "COMMENTS " & + "-gnatyc " & + "END " & + "-gnatye " & + "VTABS " & + "-gnatyf " & + "GNAT " & + "-gnatg " & + "HTABS " & + "-gnatyh " & + "IF_THEN " & + "-gnatyi " & + "KEYWORD " & + "-gnatyk " & + "LAYOUT " & + "-gnatyl " & + "LINE_LENGTH " & + "-gnatym " & + "STANDARD_CASING " & + "-gnatyn " & + "ORDERED_SUBPROGRAMS " & + "-gnatyo " & + "NONE " & + "!-gnatg,!-gnatr " & + "PRAGMA " & + "-gnatyp " & + "REFERENCES " & + "-gnatr " & + "SPECS " & + "-gnatys " & + "TOKEN " & + "-gnatyt "; + + S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " & + "!-gnatg,!-gnatr"; + + S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " & + "-gnats"; + + S_GCC_Trace : aliased constant S := "/TRACE_UNITS " & + "-gnatdc"; + + S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " & + "-gnatt"; + + S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " & + "-gnatq"; + + S_GCC_Units : aliased constant S := "/UNITS_LIST " & + "-gnatu"; + + S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " & + "-gnatU"; + + S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " & + "-gnatF"; + + S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" & + "RM " & + "-gnatVd " & + "NONE " & + "-gnatV0 " & + "FULL " & + "-gnatVf"; + + S_GCC_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + + S_GCC_Warn : aliased constant S := "/WARNINGS=" & + "DEFAULT " & + "!-gnatws,!-gnatwe " & + "ALL_GCC " & + "-Wall " & + "CONDITIONALS " & + "-gnatwc " & + "NOCONDITIONALS " & + "-gnatwC " & + "ELABORATION " & + "-gnatwl " & + "NOELABORATION " & + "-gnatwL " & + "ERRORS " & + "-gnatwe " & + "HIDING " & + "-gnatwh " & + "NOHIDING " & + "-gnatwH " & + "IMPLEMENTATION " & + "-gnatwi " & + "NOIMPLEMENTATION " & + "-gnatwI " & + "OPTIONAL " & + "-gnatwa " & + "NOOPTIONAL " & + "-gnatwA " & + "OVERLAYS " & + "-gnatwo " & + "NOOVERLAYS " & + "-gnatwO " & + "REDUNDANT " & + "-gnatwr " & + "NOREDUNDANT " & + "-gnatwR " & + "SUPPRESS " & + "-gnatws " & + "UNINITIALIZED " & + "-Wuninitialized " & + "UNUSED " & + "-gnatwu " & + "NOUNUSED " & + "-gnatwU"; + + S_GCC_WarnX : aliased constant S := "/NOWARNINGS " & + "-gnatws"; + + S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" & + "BRACKETS " & + "-gnatWb " & + "NONE " & + "-gnatWn " & + "HEX " & + "-gnatWh " & + "UPPER " & + "-gnatWu " & + "SHIFT_JIS " & + "-gnatWs " & + "UTF8 " & + "-gnatW8 " & + "EUC " & + "-gnatWe"; + + S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " & + "-gnatWn"; + + S_GCC_Xdebug : aliased constant S := "/XDEBUG " & + "-gnatD"; + + S_GCC_Xref : aliased constant S := "/XREF=" & + "GENERATE " & + "!-gnatx " & + "SUPPRESS " & + "-gnatx"; + + GCC_Switches : aliased constant Switches := ( + S_GCC_Ada_83 'Access, + S_GCC_Ada_95 'Access, + S_GCC_Asm 'Access, + S_GCC_Checks 'Access, + S_GCC_ChecksX 'Access, + S_GCC_Compres 'Access, + S_GCC_Current 'Access, + S_GCC_Debug 'Access, + S_GCC_DebugX 'Access, + S_GCC_Dist 'Access, + S_GCC_DistX 'Access, + S_GCC_Error 'Access, + S_GCC_ErrorX 'Access, + S_GCC_Expand 'Access, + S_GCC_Extend 'Access, + S_GCC_File 'Access, + S_GCC_Force 'Access, + S_GCC_Ident 'Access, + S_GCC_IdentX 'Access, + S_GCC_Inline 'Access, + S_GCC_InlineX 'Access, + S_GCC_List 'Access, + S_GCC_Noload 'Access, + S_GCC_Nostinc 'Access, + S_GCC_Opt 'Access, + S_GCC_OptX 'Access, + S_GCC_Report 'Access, + S_GCC_ReportX 'Access, + S_GCC_Repinfo 'Access, + S_GCC_RepinfX 'Access, + S_GCC_Search 'Access, + S_GCC_Style 'Access, + S_GCC_StyleX 'Access, + S_GCC_Syntax 'Access, + S_GCC_Trace 'Access, + S_GCC_Tree 'Access, + S_GCC_Trys 'Access, + S_GCC_Units 'Access, + S_GCC_Unique 'Access, + S_GCC_Upcase 'Access, + S_GCC_Valid 'Access, + S_GCC_Verbose 'Access, + S_GCC_Warn 'Access, + S_GCC_WarnX 'Access, + S_GCC_Wide 'Access, + S_GCC_WideX 'Access, + S_GCC_Xdebug 'Access, + S_GCC_Xref 'Access); + + ---------------------------- + -- Switches for GNAT ELIM -- + ---------------------------- + + S_Elim_All : aliased constant S := "/ALL " & + "-a"; + + S_Elim_Miss : aliased constant S := "/MISSED " & + "-m"; + + S_Elim_Verb : aliased constant S := "/VERBOSE " & + "-v"; + + Elim_Switches : aliased constant Switches := ( + S_Elim_All 'Access, + S_Elim_Miss 'Access, + S_Elim_Verb 'Access); + + ---------------------------- + -- Switches for GNAT FIND -- + ---------------------------- + + S_Find_All : aliased constant S := "/ALL_FILES " & + "-a"; + + S_Find_Expr : aliased constant S := "/EXPRESSIONS " & + "-e"; + + S_Find_Full : aliased constant S := "/FULL_PATHNAME " & + "-f"; + + S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " & + "-g"; + + S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + + S_Find_Print : aliased constant S := "/PRINT_LINES " & + "-s"; + + S_Find_Project : aliased constant S := "/PROJECT=@" & + "-p@"; + + S_Find_Ref : aliased constant S := "/REFERENCES " & + "-r"; + + S_Find_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + + S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + + Find_Switches : aliased constant Switches := ( + S_Find_All 'Access, + S_Find_Expr 'Access, + S_Find_Full 'Access, + S_Find_Ignore 'Access, + S_Find_Object 'Access, + S_Find_Print 'Access, + S_Find_Project 'Access, + S_Find_Ref 'Access, + S_Find_Search 'Access, + S_Find_Source 'Access); + + ------------------------------ + -- Switches for GNAT KRUNCH -- + ------------------------------ + + S_Krunch_Count : aliased constant S := "/COUNT=#" & + "`#"; + + Krunch_Switches : aliased constant Switches := (1 .. 1 => + S_Krunch_Count 'Access); + + ------------------------------- + -- Switches for GNAT LIBRARY -- + ------------------------------- + + S_Lbr_Config : aliased constant S := "/CONFIG=@" & + "--config=@"; + + S_Lbr_Create : aliased constant S := "/CREATE=%" & + "--create=%"; + + S_Lbr_Delete : aliased constant S := "/DELETE=%" & + "--delete=%"; + + S_Lbr_Set : aliased constant S := "/SET=%" & + "--set=%"; + + Lbr_Switches : aliased constant Switches := ( + S_Lbr_Config 'Access, + S_Lbr_Create 'Access, + S_Lbr_Delete 'Access, + S_Lbr_Set 'Access); + + ---------------------------- + -- Switches for GNAT LINK -- + ---------------------------- + + S_Link_Bind : aliased constant S := "/BIND_FILE=" & + "ADA " & + "-A " & + "C " & + "-C"; + + S_Link_Debug : aliased constant S := "/DEBUG=" & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "TRACEBACK " & + "-g1 " & + "NOTRACEBACK " & + "-g0"; + + S_Link_Execut : aliased constant S := "/EXECUTABLE=@" & + "-o@"; + + S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & + "--for-linker=IDENT=" & + '"'; + + S_Link_Nocomp : aliased constant S := "/NOCOMPILE " & + "-n"; + + S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " & + "-nostartfiles"; + + S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " & + "--for-linker=--noinhibit-exec"; + + S_Link_Static : aliased constant S := "/STATIC " & + "--for-linker=-static"; + + S_Link_Verb : aliased constant S := "/VERBOSE " & + "-v"; + + S_Link_ZZZZZ : aliased constant S := "/<other> " & + "--for-linker="; + + Link_Switches : aliased constant Switches := ( + S_Link_Bind 'Access, + S_Link_Debug 'Access, + S_Link_Execut 'Access, + S_Link_Ident 'Access, + S_Link_Nocomp 'Access, + S_Link_Nofiles 'Access, + S_Link_Noinhib 'Access, + S_Link_Static 'Access, + S_Link_Verb 'Access, + S_Link_ZZZZZ 'Access); + + ---------------------------- + -- Switches for GNAT LIST -- + ---------------------------- + + S_List_All : aliased constant S := "/ALL_UNITS " & + "-a"; + + S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + + S_List_Depend : aliased constant S := "/DEPENDENCIES " & + "-d"; + + S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + + S_List_Output : aliased constant S := "/OUTPUT=" & + "SOURCES " & + "-s " & + "OBJECTS " & + "-o " & + "UNITS " & + "-u " & + "OPTIONS " & + "-h " & + "VERBOSE " & + "-v "; + + S_List_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + + S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + + List_Switches : aliased constant Switches := ( + S_List_All 'Access, + S_List_Current 'Access, + S_List_Depend 'Access, + S_List_Nostinc 'Access, + S_List_Object 'Access, + S_List_Output 'Access, + S_List_Search 'Access, + S_List_Source 'Access); + + ---------------------------- + -- Switches for GNAT MAKE -- + ---------------------------- + + S_Make_All : aliased constant S := "/ALL_FILES " & + "-a"; + + S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" & + "-bargs BIND"; + + S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" & + "-cargs COMPILE"; + + S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" & + "-A*"; + + S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " & + "-k"; + + S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + + S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " & + "-M"; + + S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " & + "-n"; + + S_Make_Execut : aliased constant S := "/EXECUTABLE=@" & + "-o@"; + + S_Make_Force : aliased constant S := "/FORCE_COMPILE " & + "-f"; + + S_Make_Inplace : aliased constant S := "/IN_PLACE " & + "-i"; + + S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & + "-L*"; + + S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" & + "-largs LINK"; + + S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " & + "-m"; + + S_Make_Nolink : aliased constant S := "/NOLINK " & + "-c"; + + S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + + S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + + S_Make_Proc : aliased constant S := "/PROCESSES=#" & + "-j#"; + + S_Make_Nojobs : aliased constant S := "/NOPROCESSES " & + "-j1"; + + S_Make_Quiet : aliased constant S := "/QUIET " & + "-q"; + + S_Make_Reason : aliased constant S := "/REASONS " & + "-v"; + + S_Make_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + + S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" & + "-aL*"; + + S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + + S_Make_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + + Make_Switches : aliased constant Switches := ( + S_Make_All 'Access, + S_Make_Bind 'Access, + S_Make_Comp 'Access, + S_Make_Cond 'Access, + S_Make_Cont 'Access, + S_Make_Current 'Access, + S_Make_Dep 'Access, + S_Make_Doobj 'Access, + S_Make_Execut 'Access, + S_Make_Force 'Access, + S_Make_Inplace 'Access, + S_Make_Library 'Access, + S_Make_Link 'Access, + S_Make_Minimal 'Access, + S_Make_Nolink 'Access, + S_Make_Nostinc 'Access, + S_Make_Nostlib 'Access, + S_Make_Object 'Access, + S_Make_Proc 'Access, + S_Make_Nojobs 'Access, + S_Make_Quiet 'Access, + S_Make_Reason 'Access, + S_Make_Search 'Access, + S_Make_Skip 'Access, + S_Make_Source 'Access, + S_Make_Verbose 'Access); + + ---------------------------------- + -- Switches for GNAT PREPROCESS -- + ---------------------------------- + + S_Prep_Blank : aliased constant S := "/BLANK_LINES " & + "-b"; + + S_Prep_Com : aliased constant S := "/COMMENTS " & + "-c"; + + S_Prep_Ref : aliased constant S := "/REFERENCE " & + "-r"; + + S_Prep_Remove : aliased constant S := "/REMOVE " & + "!-b,!-c"; + + S_Prep_Symbols : aliased constant S := "/SYMBOLS " & + "-s"; + + S_Prep_Undef : aliased constant S := "/UNDEFINED " & + "-u"; + + S_Prep_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + + S_Prep_Version : aliased constant S := "/VERSION " & + "-v"; + + Prep_Switches : aliased constant Switches := ( + S_Prep_Blank 'Access, + S_Prep_Com 'Access, + S_Prep_Ref 'Access, + S_Prep_Remove 'Access, + S_Prep_Symbols 'Access, + S_Prep_Undef 'Access, + S_Prep_Verbose 'Access, + S_Prep_Version 'Access); + + ------------------------------ + -- Switches for GNAT SHARED -- + ------------------------------ + + S_Shared_Debug : aliased constant S := "/DEBUG=" & + "ALL " & + "-g3 " & + "NONE " & + "-g0 " & + "TRACEBACK " & + "-g1 " & + "NOTRACEBACK " & + "-g0"; + + S_Shared_Image : aliased constant S := "/IMAGE=@" & + "-o@"; + + S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & + "--for-linker=IDENT=" & + '"'; + + S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " & + "-nostartfiles"; + + S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " & + "--for-linker=--noinhibit-exec"; + + S_Shared_Verb : aliased constant S := "/VERBOSE " & + "-v"; + + S_Shared_ZZZZZ : aliased constant S := "/<other> " & + "--for-linker="; + + Shared_Switches : aliased constant Switches := ( + S_Shared_Debug 'Access, + S_Shared_Image 'Access, + S_Shared_Ident 'Access, + S_Shared_Nofiles 'Access, + S_Shared_Noinhib 'Access, + S_Shared_Verb 'Access, + S_Shared_ZZZZZ 'Access); + + -------------------------------- + -- Switches for GNAT STANDARD -- + -------------------------------- + + Standard_Switches : aliased constant Switches := (1 .. 0 => null); + + ---------------------------- + -- Switches for GNAT STUB -- + ---------------------------- + + S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " & + "!-I-"; + + S_Stub_Full : aliased constant S := "/FULL " & + "-f"; + + S_Stub_Header : aliased constant S := "/HEADER=" & + "GENERAL " & + "-hg " & + "SPEC " & + "-hs"; + + S_Stub_Indent : aliased constant S := "/INDENTATION=#" & + "-i#"; + + S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" & + "-l#"; + + S_Stub_Quiet : aliased constant S := "/QUIET " & + "-q"; + + S_Stub_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + + S_Stub_Tree : aliased constant S := "/TREE_FILE=" & + "OVERWRITE " & + "-t " & + "SAVE " & + "-k " & + "REUSE " & + "-r"; + + S_Stub_Verbose : aliased constant S := "/VERBOSE " & + "-v"; + + Stub_Switches : aliased constant Switches := ( + S_Stub_Current 'Access, + S_Stub_Full 'Access, + S_Stub_Header 'Access, + S_Stub_Indent 'Access, + S_Stub_Length 'Access, + S_Stub_Quiet 'Access, + S_Stub_Search 'Access, + S_Stub_Tree 'Access, + S_Stub_Verbose 'Access); + + ------------------------------ + -- Switches for GNAT SYSTEM -- + ------------------------------ + + System_Switches : aliased constant Switches := (1 .. 0 => null); + + ---------------------------- + -- Switches for GNAT XREF -- + ---------------------------- + + S_Xref_All : aliased constant S := "/ALL_FILES " & + "-a"; + + S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & + "-f"; + + S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " & + "-g"; + + S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" & + "-aO*"; + + S_Xref_Project : aliased constant S := "/PROJECT=@" & + "-p@"; + + S_Xref_Search : aliased constant S := "/SEARCH=*" & + "-I*"; + + S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" & + "-aI*"; + + S_Xref_Output : aliased constant S := "/UNUSED " & + "-u"; + + Xref_Switches : aliased constant Switches := ( + S_Xref_All 'Access, + S_Xref_Full 'Access, + S_Xref_Global 'Access, + S_Xref_Object 'Access, + S_Xref_Project 'Access, + S_Xref_Search 'Access, + S_Xref_Source 'Access, + S_Xref_Output 'Access); + + ------------------- + -- COMMAND TABLE -- + ------------------- + + -- The command table contains an entry for each command recognized by + -- GNATCmd. The entries are represented by an array of records. + + type Parameter_Type is + -- A parameter is defined as a whitespace bounded string, not begining + -- with a slash. (But see note under FILES_OR_WILDCARD). + (File, + -- A required file or directory parameter. + + Optional_File, + -- An optional file or directory parameter. + + Other_As_Is, + -- A parameter that's passed through as is (not canonicalized) + + Unlimited_Files, + -- An unlimited number of writespace separate file or directory + -- parameters including wildcard specifications. + + Files_Or_Wildcard); + -- A comma separated list of files and/or wildcard file specifications. + -- A comma preceded by or followed by whitespace is considered as a + -- single comma character w/o whitespace. + + type Parameter_Array is array (Natural range <>) of Parameter_Type; + type Parameter_Ref is access all Parameter_Array; + + type Command_Entry is record + Cname : String_Ptr; + -- Command name for GNAT xxx command + + Usage : String_Ptr; + -- A usage string, used for error messages + + Unixcmd : String_Ptr; + -- Corresponding Unix command + + Switches : Switches_Ptr; + -- Pointer to array of switch strings + + Params : Parameter_Ref; + -- Describes the allowable types of parameters. + -- Params (1) is the type of the first parameter, etc. + -- An empty parameter array means this command takes no parameters. + + Defext : String (1 .. 3); + -- Default extension. If non-blank, then this extension is supplied by + -- default as the extension for any file parameter which does not have + -- an extension already. + end record; + + ------------------------- + -- INTERNAL STRUCTURES -- + ------------------------- + + -- The switches and commands are defined by strings in the previous + -- section so that they are easy to modify, but internally, they are + -- kept in a more conveniently accessible form described in this + -- section. + + -- Commands, command qualifers and options have a similar common format + -- so that searching for matching names can be done in a common manner. + + type Item_Id is (Id_Command, Id_Switch, Id_Option); + + type Translation_Type is + ( + T_Direct, + -- A qualifier with no options. + -- Example: GNAT MAKE /VERBOSE + + T_Directories, + -- A qualifier followed by a list of directories + -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR]) + + T_Directory, + -- A qualifier followed by one directory + -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] + + T_File, + -- A quailifier followed by a filename + -- Example: GNAT LINK /EXECUTABLE=FOO.EXE + + T_Numeric, + -- A qualifier followed by a numeric value. + -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 + + T_String, + -- A qualifier followed by a quoted string. Only used by + -- /IDENTIFICATION qualfier. + -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version" + + T_Options, + -- A qualifier followed by a list of options. + -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS) + + T_Commands, + -- A qualifier followed by a list. Only used for + -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS + -- (gnatmake -cargs -bargs -largs ) + -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ + + T_Other, + -- A qualifier passed directly to the linker. Only used + -- for LINK and SHARED if no other match is found. + -- Example: GNAT LINK FOO.ALI /SYSSHR + + T_Alphanumplus + -- A qualifier followed by a legal linker symbol prefix. Only used + -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). + -- Example: GNAT BIND /BUILD_LIBRARY=foobar + ); + + type Item (Id : Item_Id); + type Item_Ptr is access all Item; + + type Item (Id : Item_Id) is record + Name : String_Ptr; + -- Name of the command, switch (with slash) or option + + Next : Item_Ptr; + -- Pointer to next item on list, always has the same Id value + + Unix_String : String_Ptr; + -- Corresponding Unix string. For a command, this is the unix command + -- name and possible default switches. For a switch or option it is + -- the unix switch string. + + case Id is + + when Id_Command => + + Switches : Item_Ptr; + -- Pointer to list of switch items for the command, linked + -- through the Next fields with null terminating the list. + + Usage : String_Ptr; + -- Usage information, used only for errors and the default + -- list of commands output. + + Params : Parameter_Ref; + -- Array of parameters + + Defext : String (1 .. 3); + -- Default extension. If non-blank, then this extension is + -- supplied by default as the extension for any file parameter + -- which does not have an extension already. + + when Id_Switch => + + Translation : Translation_Type; + -- Type of switch translation. For all cases, except Options, + -- this is the only field needed, since the Unix translation + -- is found in Unix_String. + + Options : Item_Ptr; + -- For the Options case, this field is set to point to a list + -- of options item (for this case Unix_String is null in the + -- main switch item). The end of the list is marked by null. + + when Id_Option => + + null; + -- No special fields needed, since Name and Unix_String are + -- sufficient to completely described an option. + + end case; + end record; + + subtype Command_Item is Item (Id_Command); + subtype Switch_Item is Item (Id_Switch); + subtype Option_Item is Item (Id_Option); + + ---------------------------------- + -- Declarations for GNATCMD use -- + ---------------------------------- + + Commands : Item_Ptr; + -- Pointer to head of list of command items, one for each command, with + -- the end of the list marked by a null pointer. + + Last_Command : Item_Ptr; + -- Pointer to last item in Commands list + + Normal_Exit : exception; + -- Raise this exception for normal program termination + + Error_Exit : exception; + -- Raise this exception if error detected + + Errors : Natural := 0; + -- Count errors detected + + Command : Item_Ptr; + -- Pointer to command item for current command + + Make_Commands_Active : Item_Ptr := null; + -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate + -- if a COMMANDS_TRANSLATION switch has been encountered while processing + -- a MAKE Command. + + My_Exit_Status : Exit_Status := Success; + + package Buffer is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 2, + Table_Name => "Buffer"); + + Param_Count : Natural := 0; + -- Number of parameter arguments so far + + Arg_Num : Natural; + -- Argument number + + Display_Command : Boolean := False; + -- Set true if /? switch causes display of generated command + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Init_Object_Dirs return String_Ptr; + + function Invert_Sense (S : String) return String_Ptr; + -- Given a unix switch string S, computes the inverse (adding or + -- removing ! characters as required), and returns a pointer to + -- the allocated result on the heap. + + function Is_Extensionless (F : String) return Boolean; + -- Returns true if the filename has no extension. + + function Match (S1, S2 : String) return Boolean; + -- Determines whether S1 and S2 match. This is a case insensitive match. + + function Match_Prefix (S1, S2 : String) return Boolean; + -- Determines whether S1 matches a prefix of S2. This is also a case + -- insensitive match (for example Match ("AB","abc") is True). + + function Matching_Name + (S : String; + Itm : Item_Ptr; + Quiet : Boolean := False) + return Item_Ptr; + -- Determines if the item list headed by Itm and threaded through the + -- Next fields (with null marking the end of the list), contains an + -- entry that uniquely matches the given string. The match is case + -- insensitive and permits unique abbreviation. If the match succeeds, + -- then a pointer to the matching item is returned. Otherwise, an + -- appropriate error message is written. Note that the discriminant + -- of Itm is used to determine the appropriate form of this message. + -- Quiet is normally False as shown, if it is set to True, then no + -- error message is generated in a not found situation (null is still + -- returned to indicate the not-found situation). + + function OK_Alphanumerplus (S : String) return Boolean; + -- Checks that S is a string of alphanumeric characters, + -- returning True if all alphanumeric characters, + -- False if empty or a non-alphanumeric character is present. + + function OK_Integer (S : String) return Boolean; + -- Checks that S is a string of digits, returning True if all digits, + -- False if empty or a non-digit is present. + + procedure Place (C : Character); + -- Place a single character in the buffer, updating Ptr + + procedure Place (S : String); + -- Place a string character in the buffer, updating Ptr + + procedure Place_Lower (S : String); + -- Place string in buffer, forcing letters to lower case, updating Ptr + + procedure Place_Unix_Switches (S : String_Ptr); + -- Given a unix switch string, place corresponding switches in Buffer, + -- updating Ptr appropriatelly. Note that in the case of use of ! the + -- result may be to remove a previously placed switch. + + procedure Validate_Command_Or_Option (N : String_Ptr); + -- Check that N is a valid command or option name, i.e. that it is of the + -- form of an Ada identifier with upper case letters and underscores. + + procedure Validate_Unix_Switch (S : String_Ptr); + -- Check that S is a valid switch string as described in the syntax for + -- the switch table item UNIX_SWITCH or else begins with a backquote. + + ---------------------- + -- Init_Object_Dirs -- + ---------------------- + + function Init_Object_Dirs return String_Ptr is + Object_Dirs : Integer; + Object_Dir : array (Integer range 1 .. 256) of String_Access; + Object_Dir_Name : String_Access; + + begin + Object_Dirs := 0; + Object_Dir_Name := String_Access (Object_Dir_Default_Name); + Get_Next_Dir_In_Path_Init (Object_Dir_Name); + + loop + declare + Dir : String_Access := String_Access + (Get_Next_Dir_In_Path (Object_Dir_Name)); + begin + exit when Dir = null; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) + := String_Access (Normalize_Directory_Name (Dir.all)); + end; + end loop; + + for Dirs in 1 .. Object_Dirs loop + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := '-'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'L'; + Object_Dir_Name := new String'( + To_Canonical_Dir_Spec + (To_Host_Dir_Spec (Object_Dir (Dirs).all, True).all, True).all); + + for J in Object_Dir_Name'Range loop + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := Object_Dir_Name (J); + end loop; + + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := ' '; + end loop; + + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := '-'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'l'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'g'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'n'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'a'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 't'; + + if Hostparm.OpenVMS then + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := ' '; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := '-'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'l'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'd'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'e'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'c'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'g'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'n'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 'a'; + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := 't'; + end if; + + return new String'(String (Buffer.Table (1 .. Buffer.Last))); + end Init_Object_Dirs; + + ------------------ + -- Invert_Sense -- + ------------------ + + function Invert_Sense (S : String) return String_Ptr is + Sinv : String (1 .. S'Length * 2); + -- Result (for sure long enough) + + Sinvp : Natural := 0; + -- Pointer to output string + + begin + for Sp in S'Range loop + if Sp = S'First or else S (Sp - 1) = ',' then + if S (Sp) = '!' then + null; + else + Sinv (Sinvp + 1) := '!'; + Sinv (Sinvp + 2) := S (Sp); + Sinvp := Sinvp + 2; + end if; + + else + Sinv (Sinvp + 1) := S (Sp); + Sinvp := Sinvp + 1; + end if; + end loop; + + return new String'(Sinv (1 .. Sinvp)); + end Invert_Sense; + + ---------------------- + -- Is_Extensionless -- + ---------------------- + + function Is_Extensionless (F : String) return Boolean is + begin + for J in reverse F'Range loop + if F (J) = '.' then + return False; + elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then + return True; + end if; + end loop; + + return True; + end Is_Extensionless; + + ----------- + -- Match -- + ----------- + + function Match (S1, S2 : String) return Boolean is + Dif : constant Integer := S2'First - S1'First; + + begin + + if S1'Length /= S2'Length then + return False; + + else + for J in S1'Range loop + if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then + return False; + end if; + end loop; + + return True; + end if; + end Match; + + ------------------ + -- Match_Prefix -- + ------------------ + + function Match_Prefix (S1, S2 : String) return Boolean is + begin + if S1'Length > S2'Length then + return False; + else + return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1)); + end if; + end Match_Prefix; + + ------------------- + -- Matching_Name -- + ------------------- + + function Matching_Name + (S : String; + Itm : Item_Ptr; + Quiet : Boolean := False) + return Item_Ptr + is + P1, P2 : Item_Ptr; + + procedure Err; + -- Little procedure to output command/qualifier/option as appropriate + -- and bump error count. + + procedure Err is + begin + if Quiet then + return; + end if; + + Errors := Errors + 1; + + if Itm /= null then + case Itm.Id is + when Id_Command => + Put (Standard_Error, "command"); + + when Id_Switch => + if OpenVMS then + Put (Standard_Error, "qualifier"); + else + Put (Standard_Error, "switch"); + end if; + + when Id_Option => + Put (Standard_Error, "option"); + + end case; + else + Put (Standard_Error, "input"); + + end if; + + Put (Standard_Error, ": "); + Put (Standard_Error, S); + + end Err; + + -- Start of processing for Matching_Name + + begin + -- If exact match, that's the one we want + + P1 := Itm; + while P1 /= null loop + if Match (S, P1.Name.all) then + return P1; + else + P1 := P1.Next; + end if; + end loop; + + -- Now check for prefix matches + + P1 := Itm; + while P1 /= null loop + if P1.Name.all = "/<other>" then + return P1; + + elsif not Match_Prefix (S, P1.Name.all) then + P1 := P1.Next; + + else + -- Here we have found one matching prefix, so see if there is + -- another one (which is an ambiguity) + + P2 := P1.Next; + while P2 /= null loop + if Match_Prefix (S, P2.Name.all) then + if not Quiet then + Put (Standard_Error, "ambiguous "); + Err; + Put (Standard_Error, " (matches "); + Put (Standard_Error, P1.Name.all); + + while P2 /= null loop + if Match_Prefix (S, P2.Name.all) then + Put (Standard_Error, ','); + Put (Standard_Error, P2.Name.all); + end if; + + P2 := P2.Next; + end loop; + + Put_Line (Standard_Error, ")"); + end if; + + return null; + end if; + + P2 := P2.Next; + end loop; + + -- If we fall through that loop, then there was only one match + + return P1; + end if; + end loop; + + -- If we fall through outer loop, there was no match + + if not Quiet then + Put (Standard_Error, "unrecognized "); + Err; + New_Line (Standard_Error); + end if; + + return null; + end Matching_Name; + + ----------------------- + -- OK_Alphanumerplus -- + ----------------------- + + function OK_Alphanumerplus (S : String) return Boolean is + begin + if S'Length = 0 then + return False; + + else + for J in S'Range loop + if not (Is_Alphanumeric (S (J)) or else + S (J) = '_' or else S (J) = '$') + then + return False; + end if; + end loop; + + return True; + end if; + end OK_Alphanumerplus; + + ---------------- + -- OK_Integer -- + ---------------- + + function OK_Integer (S : String) return Boolean is + begin + if S'Length = 0 then + return False; + + else + for J in S'Range loop + if not Is_Digit (S (J)) then + return False; + end if; + end loop; + + return True; + end if; + end OK_Integer; + + ----------- + -- Place -- + ----------- + + procedure Place (C : Character) is + begin + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := C; + end Place; + + procedure Place (S : String) is + begin + for J in S'Range loop + Place (S (J)); + end loop; + end Place; + + ----------------- + -- Place_Lower -- + ----------------- + + procedure Place_Lower (S : String) is + begin + for J in S'Range loop + Place (To_Lower (S (J))); + end loop; + end Place_Lower; + + ------------------------- + -- Place_Unix_Switches -- + ------------------------- + + procedure Place_Unix_Switches (S : String_Ptr) is + P1, P2, P3 : Natural; + Remove : Boolean; + Slen : Natural; + + begin + P1 := S'First; + while P1 <= S'Last loop + if S (P1) = '!' then + P1 := P1 + 1; + Remove := True; + else + Remove := False; + end if; + + P2 := P1; + pragma Assert (S (P1) = '-' or else S (P1) = '`'); + + while P2 < S'Last and then S (P2 + 1) /= ',' loop + P2 := P2 + 1; + end loop; + + -- Switch is now in S (P1 .. P2) + + Slen := P2 - P1 + 1; + + if Remove then + P3 := 2; + while P3 <= Buffer.Last - Slen loop + if Buffer.Table (P3) = ' ' + and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) + = S (P1 .. P2) + and then (P3 + Slen = Buffer.Last + or else + Buffer.Table (P3 + Slen + 1) = ' ') + then + Buffer.Table (P3 .. Buffer.Last - Slen - 1) := + Buffer.Table (P3 + Slen + 1 .. Buffer.Last); + Buffer.Set_Last (Buffer.Last - Slen - 1); + + else + P3 := P3 + 1; + end if; + end loop; + + else + Place (' '); + + if S (P1) = '`' then + P1 := P1 + 1; + end if; + + Place (S (P1 .. P2)); + end if; + + P1 := P2 + 2; + end loop; + end Place_Unix_Switches; + + -------------------------------- + -- Validate_Command_Or_Option -- + -------------------------------- + + procedure Validate_Command_Or_Option (N : String_Ptr) is + begin + pragma Assert (N'Length > 0); + + for J in N'Range loop + if N (J) = '_' then + pragma Assert (N (J - 1) /= '_'); + null; + else + pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); + null; + end if; + end loop; + end Validate_Command_Or_Option; + + -------------------------- + -- Validate_Unix_Switch -- + -------------------------- + + procedure Validate_Unix_Switch (S : String_Ptr) is + begin + if S (S'First) = '`' then + return; + end if; + + pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); + + for J in S'First + 1 .. S'Last loop + pragma Assert (S (J) /= ' '); + + if S (J) = '!' then + pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); + null; + end if; + end loop; + end Validate_Unix_Switch; + + ---------------------- + -- List of Commands -- + ---------------------- + + -- Note that we put this after all the local bodies to avoid + -- some access before elaboration problems. + + Command_List : array (Natural range <>) of Command_Entry := ( + + (Cname => new S'("BIND"), + Usage => new S'("GNAT BIND file[.ali] /qualifiers"), + Unixcmd => new S'("gnatbind"), + Switches => Bind_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => "ali"), + + (Cname => new S'("CHOP"), + Usage => new S'("GNAT CHOP file [directory] /qualifiers"), + Unixcmd => new S'("gnatchop"), + Switches => Chop_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + (Cname => new S'("COMPILE"), + Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), + Unixcmd => new S'("gcc -c -x ada"), + Switches => GCC_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => " "), + + (Cname => new S'("ELIM"), + Usage => new S'("GNAT ELIM name /qualifiers"), + Unixcmd => new S'("gnatelim"), + Switches => Elim_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is), + Defext => "ali"), + + (Cname => new S'("FIND"), + Usage => new S'("GNAT FIND pattern[:sourcefile[:line[:column]]]" & + " filespec[,...] /qualifiers"), + Unixcmd => new S'("gnatfind"), + Switches => Find_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is, + 2 => Files_Or_Wildcard), + Defext => "ali"), + + (Cname => new S'("KRUNCH"), + Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), + Unixcmd => new S'("gnatkr"), + Switches => Krunch_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + (Cname => new S'("LIBRARY"), + Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]=directory" + & " [/CONFIG=file]"), + Unixcmd => new S'("gnatlbr"), + Switches => Lbr_Switches'Access, + Params => new Parameter_Array'(1 .. 0 => File), + Defext => " "), + + (Cname => new S'("LINK"), + Usage => new S'("GNAT LINK file[.ali]" + & " [extra obj_&_lib_&_exe_&_opt files]" + & " /qualifiers"), + Unixcmd => new S'("gnatlink"), + Switches => Link_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ali"), + + (Cname => new S'("LIST"), + Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), + Unixcmd => new S'("gnatls"), + Switches => List_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => "ali"), + + (Cname => new S'("MAKE"), + Usage => + new S'("GNAT MAKE file /qualifiers (includes COMPILE /qualifiers)"), + Unixcmd => new S'("gnatmake"), + Switches => Make_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + (Cname => new S'("PREPROCESS"), + Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), + Unixcmd => new S'("gnatprep"), + Switches => Prep_Switches'Access, + Params => new Parameter_Array'(1 .. 3 => File), + Defext => " "), + + (Cname => new S'("SHARED"), + Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt files]" + & " /qualifiers"), + Unixcmd => new S'("gcc -shared " & Init_Object_Dirs.all), + Switches => Shared_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + (Cname => new S'("STANDARD"), + Usage => new S'("GNAT STANDARD"), + Unixcmd => new S'("gnatpsta"), + Switches => Standard_Switches'Access, + Params => new Parameter_Array'(1 .. 0 => File), + Defext => " "), + + (Cname => new S'("STUB"), + Usage => new S'("GNAT STUB file [directory] /qualifiers"), + Unixcmd => new S'("gnatstub"), + Switches => Stub_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + (Cname => new S'("SYSTEM"), + Usage => new S'("GNAT SYSTEM"), + Unixcmd => new S'("gnatpsys"), + Switches => System_Switches'Access, + Params => new Parameter_Array'(1 .. 0 => File), + Defext => " "), + + (Cname => new S'("XREF"), + Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), + Unixcmd => new S'("gnatxref"), + Switches => Xref_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => "ali") + ); + +------------------------------------- +-- Start of processing for GNATCmd -- +------------------------------------- + +begin + Buffer.Init; + + -- First we must preprocess the string form of the command and options + -- list into the internal form that we use. + + for C in Command_List'Range loop + + declare + Command : Item_Ptr := new Command_Item; + + Last_Switch : Item_Ptr; + -- Last switch in list + + begin + -- Link new command item into list of commands + + if Last_Command = null then + Commands := Command; + else + Last_Command.Next := Command; + end if; + + Last_Command := Command; + + -- Fill in fields of new command item + + Command.Name := Command_List (C).Cname; + Command.Usage := Command_List (C).Usage; + Command.Unix_String := Command_List (C).Unixcmd; + Command.Params := Command_List (C).Params; + Command.Defext := Command_List (C).Defext; + + Validate_Command_Or_Option (Command.Name); + + -- Process the switch list + + for S in Command_List (C).Switches'Range loop + declare + SS : constant String_Ptr := Command_List (C).Switches (S); + + P : Natural := SS'First; + Sw : Item_Ptr := new Switch_Item; + + Last_Opt : Item_Ptr; + -- Pointer to last option + + begin + -- Link new switch item into list of switches + + if Last_Switch = null then + Command.Switches := Sw; + else + Last_Switch.Next := Sw; + end if; + + Last_Switch := Sw; + + -- Process switch string, first get name + + while SS (P) /= ' ' and SS (P) /= '=' loop + P := P + 1; + end loop; + + Sw.Name := new String'(SS (SS'First .. P - 1)); + + -- Direct translation case + + if SS (P) = ' ' then + Sw.Translation := T_Direct; + Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); + Validate_Unix_Switch (Sw.Unix_String); + + if SS (P - 1) = '>' then + Sw.Translation := T_Other; + + elsif SS (P + 1) = '`' then + null; + + -- Create the inverted case (/NO ..) + + elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then + Sw := new Switch_Item; + Last_Switch.Next := Sw; + Last_Switch := Sw; + + Sw.Name := + new String'("/NO" & SS (SS'First + 1 .. P - 1)); + Sw.Translation := T_Direct; + Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); + Validate_Unix_Switch (Sw.Unix_String); + end if; + + -- Directories translation case + + elsif SS (P + 1) = '*' then + pragma Assert (SS (SS'Last) = '*'); + Sw.Translation := T_Directories; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Directory translation case + + elsif SS (P + 1) = '%' then + pragma Assert (SS (SS'Last) = '%'); + Sw.Translation := T_Directory; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- File translation case + + elsif SS (P + 1) = '@' then + pragma Assert (SS (SS'Last) = '@'); + Sw.Translation := T_File; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Numeric translation case + + elsif SS (P + 1) = '#' then + pragma Assert (SS (SS'Last) = '#'); + Sw.Translation := T_Numeric; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Alphanumerplus translation case + + elsif SS (P + 1) = '|' then + pragma Assert (SS (SS'Last) = '|'); + Sw.Translation := T_Alphanumplus; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- String translation case + + elsif SS (P + 1) = '"' then + pragma Assert (SS (SS'Last) = '"'); + Sw.Translation := T_String; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Commands translation case + + elsif SS (P + 1) = '?' then + Sw.Translation := T_Commands; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); + + -- Options translation case + + else + Sw.Translation := T_Options; + Sw.Unix_String := new String'(""); + + P := P + 1; -- bump past = + while P <= SS'Last loop + declare + Opt : Item_Ptr := new Option_Item; + Q : Natural; + + begin + -- Link new option item into options list + + if Last_Opt = null then + Sw.Options := Opt; + else + Last_Opt.Next := Opt; + end if; + + Last_Opt := Opt; + + -- Fill in fields of new option item + + Q := P; + while SS (Q) /= ' ' loop + Q := Q + 1; + end loop; + + Opt.Name := new String'(SS (P .. Q - 1)); + Validate_Command_Or_Option (Opt.Name); + + P := Q + 1; + Q := P; + + while Q <= SS'Last and then SS (Q) /= ' ' loop + Q := Q + 1; + end loop; + + Opt.Unix_String := new String'(SS (P .. Q - 1)); + Validate_Unix_Switch (Opt.Unix_String); + P := Q + 1; + end; + end loop; + end if; + end; + end loop; + end; + end loop; + + -- If no parameters, give complete list of commands + + if Argument_Count = 0 then + Put_Line ("List of available commands"); + New_Line; + + while Commands /= null loop + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + Commands := Commands.Next; + end loop; + + raise Normal_Exit; + end if; + + Arg_Num := 1; + + loop + exit when Arg_Num > Argument_Count; + + declare + Argv : String_Access; + Arg_Idx : Integer; + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) + return Integer; + -- Begins looking at Arg_Idx + 1 and returns the index of the + -- last character before a slash or else the index of the last + -- character in the string Argv. + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) + return Integer + is + begin + for J in Arg_Idx + 1 .. Argv'Last loop + if Argv (J) = '/' then + return J - 1; + end if; + end loop; + + return Argv'Last; + end Get_Arg_End; + + begin + Argv := new String'(Argument (Arg_Num)); + Arg_Idx := Argv'First; + + <<Tryagain_After_Coalesce>> + loop + declare + Next_Arg_Idx : Integer; + Arg : String_Access; + + begin + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + + -- The first one must be a command name + + if Arg_Num = 1 and then Arg_Idx = Argv'First then + + Command := Matching_Name (Arg.all, Commands); + + if Command = null then + raise Error_Exit; + end if; + + -- Give usage information if only command given + + if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last + and then + not (Command.Name.all = "SYSTEM" + or else Command.Name.all = "STANDARD") + then + Put_Line ("List of available qualifiers and options"); + New_Line; + + Put (Command.Usage.all); + Set_Col (53); + Put_Line (Command.Unix_String.all); + + declare + Sw : Item_Ptr := Command.Switches; + + begin + while Sw /= null loop + Put (" "); + Put (Sw.Name.all); + + case Sw.Translation is + + when T_Other => + Set_Col (53); + Put_Line (Sw.Unix_String.all & "/<other>"); + + when T_Direct => + Set_Col (53); + Put_Line (Sw.Unix_String.all); + + when T_Directories => + Put ("=(direc,direc,..direc)"); + Set_Col (53); + Put (Sw.Unix_String.all); + Put (" direc "); + Put (Sw.Unix_String.all); + Put_Line (" direc ..."); + + when T_Directory => + Put ("=directory"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put_Line ("directory "); + + when T_File => + Put ("=file"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put_Line ("file "); + + when T_Numeric => + Put ("=nnn"); + Set_Col (53); + + if Sw.Unix_String (Sw.Unix_String'First) + = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("nnn"); + + when T_Alphanumplus => + Put ("=xyz"); + Set_Col (53); + + if Sw.Unix_String (Sw.Unix_String'First) + = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("xyz"); + + when T_String => + Put ("="); + Put ('"'); + Put ("<string>"); + Put ('"'); + Set_Col (53); + + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put ("<string>"); + New_Line; + + when T_Commands => + Put (" (switches for "); + Put (Sw.Unix_String ( + Sw.Unix_String'First + 7 + .. Sw.Unix_String'Last)); + Put (')'); + Set_Col (53); + Put (Sw.Unix_String ( + Sw.Unix_String'First + .. Sw.Unix_String'First + 5)); + Put_Line (" switches"); + + when T_Options => + declare + Opt : Item_Ptr := Sw.Options; + + begin + Put_Line ("=(option,option..)"); + + while Opt /= null loop + Put (" "); + Put (Opt.Name.all); + + if Opt = Sw.Options then + Put (" (D)"); + end if; + + Set_Col (53); + Put_Line (Opt.Unix_String.all); + Opt := Opt.Next; + end loop; + end; + + end case; + + Sw := Sw.Next; + end loop; + end; + + raise Normal_Exit; + end if; + + Place (Command.Unix_String.all); + + -- Special handling for internal debugging switch /? + + elsif Arg.all = "/?" then + Display_Command := True; + + -- Copy -switch unchanged + + elsif Arg (Arg'First) = '-' then + Place (' '); + Place (Arg.all); + + -- Copy quoted switch with quotes stripped + + elsif Arg (Arg'First) = '"' then + if Arg (Arg'Last) /= '"' then + Put (Standard_Error, "misquoted argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Put (Arg (Arg'First + 1 .. Arg'Last - 1)); + end if; + + -- Parameter Argument + + elsif Arg (Arg'First) /= '/' + and then Make_Commands_Active = null + then + Param_Count := Param_Count + 1; + + if Param_Count <= Command.Params'Length then + + case Command.Params (Param_Count) is + + when File | Optional_File => + declare + Normal_File : String_Access + := To_Canonical_File_Spec (Arg.all); + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + end; + + when Unlimited_Files => + declare + Normal_File : String_Access + := To_Canonical_File_Spec (Arg.all); + + File_Is_Wild : Boolean := False; + File_List : String_Access_List_Access; + begin + for I in Arg'Range loop + if Arg (I) = '*' + or else Arg (I) = '%' + then + File_Is_Wild := True; + end if; + end loop; + + if File_Is_Wild then + File_List := To_Canonical_File_List + (Arg.all, False); + + for I in File_List.all'Range loop + Place (' '); + Place_Lower (File_List.all (I).all); + end loop; + else + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + end if; + + Param_Count := Param_Count - 1; + end; + + when Other_As_Is => + Place (' '); + Place (Arg.all); + + when Files_Or_Wildcard => + + -- Remove spaces from a comma separated list + -- of file names and adjust control variables + -- accordingly. + + while Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + loop + Argv := new String'(Argv.all + & Argument (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := + new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + end loop; + + -- Parse the comma separated list of VMS filenames + -- and place them on the command line as space + -- separated Unix style filenames. Lower case and + -- add default extension as appropriate. + + declare + Arg1_Idx : Integer := Arg'First; + + function Get_Arg1_End + (Arg : String; Arg_Idx : Integer) + return Integer; + -- Begins looking at Arg_Idx + 1 and + -- returns the index of the last character + -- before a comma or else the index of the + -- last character in the string Arg. + + function Get_Arg1_End + (Arg : String; Arg_Idx : Integer) + return Integer + is + begin + for I in Arg_Idx + 1 .. Arg'Last loop + if Arg (I) = ',' then + return I - 1; + end if; + end loop; + + return Arg'Last; + end Get_Arg1_End; + + begin + loop + declare + Next_Arg1_Idx : Integer + := Get_Arg1_End (Arg.all, Arg1_Idx); + + Arg1 : String + := Arg (Arg1_Idx .. Next_Arg1_Idx); + + Normal_File : String_Access + := To_Canonical_File_Spec (Arg1); + + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + + Arg1_Idx := Next_Arg1_Idx + 1; + end; + + exit when Arg1_Idx > Arg'Last; + + -- Don't allow two or more commas in a row + + if Arg (Arg1_Idx) = ',' then + Arg1_Idx := Arg1_Idx + 1; + if Arg1_Idx > Arg'Last or else + Arg (Arg1_Idx) = ',' + then + Put_Line (Standard_Error, + "Malformed Parameter: " & Arg.all); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, + Command.Usage.all); + raise Error_Exit; + end if; + end if; + + end loop; + end; + end case; + end if; + + -- Qualifier argument + + else + declare + Sw : Item_Ptr; + SwP : Natural; + P2 : Natural; + Endp : Natural := 0; -- avoid warning! + Opt : Item_Ptr; + + begin + SwP := Arg'First; + while SwP < Arg'Last and then Arg (SwP + 1) /= '=' loop + SwP := SwP + 1; + end loop; + + -- At this point, the switch name is in + -- Arg (Arg'First..SwP) and if that is not the whole + -- switch, then there is an equal sign at + -- Arg (SwP + 1) and the rest of Arg is what comes + -- after the equal sign. + + -- If make commands are active, see if we have another + -- COMMANDS_TRANSLATION switch belonging to gnatmake. + + if Make_Commands_Active /= null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw /= null and then Sw.Translation = T_Commands then + null; + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Make_Commands_Active.Switches, + Quiet => False); + end if; + + -- For case of GNAT MAKE or CHOP, if we cannot find the + -- switch, then see if it is a recognized compiler switch + -- instead, and if so process the compiler switch. + + elsif Command.Name.all = "MAKE" + or else Command.Name.all = "CHOP" then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw = null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Matching_Name ("COMPILE", Commands).Switches, + Quiet => False); + end if; + + -- For all other cases, just search the relevant command + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => False); + end if; + + if Sw /= null then + case Sw.Translation is + + when T_Direct => + Place_Unix_Switches (Sw.Unix_String); + if Arg (SwP + 1) = '=' then + Put (Standard_Error, + "qualifier options ignored: "); + Put_Line (Standard_Error, Arg.all); + end if; + + when T_Directories => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directories for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + + -- Remove spaces from a comma separated list + -- of file names and adjust control + -- variables accordingly. + + if Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + then + Argv := new String'(Argv.all + & Argument (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx + := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + goto Tryagain_After_Coalesce; + end if; + + Put (Standard_Error, + "incorrectly parenthesized " & + "or malformed argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + + while SwP <= Endp loop + declare + Dir_Is_Wild : Boolean := False; + Dir_Maybe_Is_Wild : Boolean := False; + Dir_List : String_Access_List_Access; + begin + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + + -- A wildcard directory spec on VMS + -- will contain either * or % or ... + + if Arg (P2) = '*' then + Dir_Is_Wild := True; + + elsif Arg (P2) = '%' then + Dir_Is_Wild := True; + + elsif Dir_Maybe_Is_Wild + and then Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Is_Wild := True; + Dir_Maybe_Is_Wild := False; + + elsif Dir_Maybe_Is_Wild then + Dir_Maybe_Is_Wild := False; + + elsif Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Maybe_Is_Wild := True; + + end if; + + P2 := P2 + 1; + end loop; + + if (Dir_Is_Wild) then + Dir_List := To_Canonical_File_List + (Arg (SwP .. P2), True); + + for I in Dir_List.all'Range loop + Place_Unix_Switches (Sw.Unix_String); + Place_Lower (Dir_List.all (I).all); + end loop; + else + Place_Unix_Switches (Sw.Unix_String); + Place_Lower (To_Canonical_Dir_Spec + (Arg (SwP .. P2), False).all); + end if; + + SwP := P2 + 2; + end; + end loop; + + when T_Directory => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directory for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space here + + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), False).all); + end if; + + when T_File => + if SwP + 1 > Arg'Last then + Put (Standard_Error, "missing file for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space here + + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower (To_Canonical_File_Spec + (Arg (SwP + 2 .. Arg'Last)).all); + end if; + + when T_Numeric => + if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); + + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; + + when T_Alphanumplus => + if + OK_Alphanumerplus (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); + + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line (Standard_Error, + " must be alphanumeric"); + Errors := Errors + 1; + end if; + + when T_String => + + -- A String value must be extended to the + -- end of the Argv, otherwise strings like + -- "foo/bar" get split at the slash. + -- + -- The begining and ending of the string + -- are flagged with embedded nulls which + -- are removed when building the Spawn + -- call. Nulls are use because they won't + -- show up in a /? output. Quotes aren't + -- used because that would make it difficult + -- to embed them. + + Place_Unix_Switches (Sw.Unix_String); + if Next_Arg_Idx /= Argv'Last then + Next_Arg_Idx := Argv'Last; + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + + SwP := Arg'First; + while SwP < Arg'Last and then + Arg (SwP + 1) /= '=' loop + SwP := SwP + 1; + end loop; + end if; + Place (ASCII.NUL); + Place (Arg (SwP + 2 .. Arg'Last)); + Place (ASCII.NUL); + + when T_Commands => + + -- Output -largs/-bargs/-cargs + + Place (' '); + Place (Sw.Unix_String + (Sw.Unix_String'First .. + Sw.Unix_String'First + 5)); + + -- Set source of new commands, also setting this + -- non-null indicates that we are in the special + -- commands mode for processing the -xargs case. + + Make_Commands_Active := + Matching_Name + (Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last), + Commands); + + when T_Options => + if SwP + 1 > Arg'Last then + Place_Unix_Switches (Sw.Options.Unix_String); + SwP := Endp + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + Put (Standard_Error, + "incorrectly parenthesized argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + SwP := Endp + 1; + + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + + while SwP <= Endp loop + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + P2 := P2 + 1; + end loop; + + -- Option name is in Arg (SwP .. P2) + + Opt := Matching_Name (Arg (SwP .. P2), + Sw.Options); + + if Opt /= null then + Place_Unix_Switches (Opt.Unix_String); + end if; + + SwP := P2 + 2; + end loop; + + when T_Other => + Place_Unix_Switches + (new String'(Sw.Unix_String.all & Arg.all)); + + end case; + end if; + end; + end if; + + Arg_Idx := Next_Arg_Idx + 1; + end; + + exit when Arg_Idx > Argv'Last; + + end loop; + end; + + Arg_Num := Arg_Num + 1; + end loop; + + if Display_Command then + Put (Standard_Error, "generated command -->"); + Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last))); + Put (Standard_Error, "<--"); + New_Line (Standard_Error); + raise Normal_Exit; + end if; + + -- Gross error checking that the number of parameters is correct. + -- Not applicable to Unlimited_Files parameters. + + if not ((Param_Count = Command.Params'Length - 1 and then + Command.Params (Param_Count + 1) = Unlimited_Files) + or else (Param_Count <= Command.Params'Length)) + then + Put_Line (Standard_Error, + "Parameter count of " + & Integer'Image (Param_Count) + & " not equal to expected " + & Integer'Image (Command.Params'Length)); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, Command.Usage.all); + Errors := Errors + 1; + end if; + + if Errors > 0 then + raise Error_Exit; + else + -- Prepare arguments for a call to spawn, filtering out + -- embedded nulls place there to delineate strings. + + declare + Pname_Ptr : Natural; + Args : Argument_List (1 .. 500); + Nargs : Natural; + P1, P2 : Natural; + Exec_Path : String_Access; + Inside_Nul : Boolean := False; + Arg : String (1 .. 1024); + Arg_Ctr : Natural; + + begin + Pname_Ptr := 1; + + while Pname_Ptr < Buffer.Last + and then Buffer.Table (Pname_Ptr + 1) /= ' ' + loop + Pname_Ptr := Pname_Ptr + 1; + end loop; + + P1 := Pname_Ptr + 2; + Arg_Ctr := 1; + Arg (Arg_Ctr) := Buffer.Table (P1); + + Nargs := 0; + while P1 <= Buffer.Last loop + + if Buffer.Table (P1) = ASCII.NUL then + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + + if Buffer.Table (P1) = ' ' and then not Inside_Nul then + P1 := P1 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := Buffer.Table (P1); + + else + Nargs := Nargs + 1; + P2 := P1; + + while P2 < Buffer.Last + and then (Buffer.Table (P2 + 1) /= ' ' or else + Inside_Nul) + loop + P2 := P2 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := Buffer.Table (P2); + if Buffer.Table (P2) = ASCII.NUL then + Arg_Ctr := Arg_Ctr - 1; + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + end loop; + + Args (Nargs) := new String'(String (Arg (1 .. Arg_Ctr))); + P1 := P2 + 2; + Arg_Ctr := 1; + Arg (Arg_Ctr) := Buffer.Table (P1); + end if; + end loop; + + Exec_Path := Locate_Exec_On_Path + (String (Buffer.Table (1 .. Pname_Ptr))); + + if Exec_Path = null then + Put_Line (Standard_Error, + "Couldn't locate " + & String (Buffer.Table (1 .. Pname_Ptr))); + raise Error_Exit; + end if; + + My_Exit_Status + := Exit_Status (Spawn (Exec_Path.all, Args (1 .. Nargs))); + + end; + + raise Normal_Exit; + end if; + +exception + when Error_Exit => + Set_Exit_Status (Failure); + + when Normal_Exit => + Set_Exit_Status (My_Exit_Status); + +end GNATCmd; diff --git a/gcc/ada/gnatcmd.ads b/gcc/ada/gnatcmd.ads new file mode 100644 index 00000000000..3a1344b8c7e --- /dev/null +++ b/gcc/ada/gnatcmd.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C M D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 1996 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This program provides a simple command interface for using GNAT and its +-- associated utilities. The format of switches accepted is intended to +-- be more familiar in style for VMS and DOS users than the standard Unix +-- style switches that are accepted directly. + +-- The program is typically called GNAT when it is installed and +-- the two possibile styles of use are: + +-- To call gcc: + +-- GNAT filename switches + +-- To call the tool gnatxxx + +-- GNAT xxx filename switches + +-- where xxx is the command name (e.g. MAKE for gnatmake). This command name +-- can be abbreviated by giving a prefix (e.g. GNAT MAK) as long as it +-- remains unique. + +-- In both cases, filename is in the format appropriate to the operating +-- system in use. The individual commands give more details. In some cases +-- a unit name may be given in place of a file name. + +-- The switches start with a slash. Switch names can also be abbreviated +-- where no ambiguity arises. The switches associated with each command +-- are specified by the tables that can be found in the body. + +-- Although by convention we use upper case for command names and switches +-- in the documentation, all command and switch names are case insensitive +-- and may be given in upper case or lower case or a mixture. + +procedure GNATCmd; diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb new file mode 100644 index 00000000000..c83a3975b7a --- /dev/null +++ b/gcc/ada/gnatdll.adb @@ -0,0 +1,545 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T D L L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1997-2000, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- GNATDLL is a Windows specific tool to build DLL. +-- Both relocatable and non-relocatable DLL are supported + +with Ada.Text_IO; +with Ada.Strings.Unbounded; +with Ada.Exceptions; +with Ada.Command_Line; +with GNAT.OS_Lib; +with GNAT.Command_Line; +with Gnatvsn; + +with MDLL.Files; +with MDLL.Tools; + +procedure Gnatdll is + + use GNAT; + use Ada; + use MDLL; + use Ada.Strings.Unbounded; + + use type OS_Lib.Argument_List; + + procedure Syntax; + -- print out usage. + + procedure Check (Filename : in String); + -- check that filename exist. + + procedure Parse_Command_Line; + -- parse the command line arguments of gnatdll. + + procedure Check_Context; + -- check the context before runing any commands to build the library. + + + + Syntax_Error : exception; + Context_Error : exception; + + Help : Boolean := False; + + Version : constant String := Gnatvsn.Gnat_Version_String; + + -- default address for non relocatable DLL (Win32) + + Default_DLL_Address : constant String := "0x11000000"; + + Lib_Filename : Unbounded_String := Null_Unbounded_String; + Def_Filename : Unbounded_String := Null_Unbounded_String; + List_Filename : Unbounded_String := Null_Unbounded_String; + DLL_Address : Unbounded_String := + To_Unbounded_String (Default_DLL_Address); + + -- list of objects to put inside the library + + Objects_Files : Argument_List_Access := Null_Argument_List_Access; + + -- for each Ada files specified we keep record of the corresponding + -- Ali. This list of ali is used to build the binder program. + + Ali_Files : Argument_List_Access := Null_Argument_List_Access; + + -- a list of options set in the command line. + + Options : Argument_List_Access := Null_Argument_List_Access; + + -- gnat linker and binder args options + + Largs_Options : Argument_List_Access := Null_Argument_List_Access; + Bargs_Options : Argument_List_Access := Null_Argument_List_Access; + + + type Build_Mode_State is (Import_Lib, Dynamic_Lib, Nil); + + Build_Mode : Build_Mode_State := Nil; + Must_Build_Relocatable : Boolean := True; + Build_Import : Boolean := True; + + ------------ + -- Syntax -- + ------------ + + procedure Syntax is + use Text_IO; + begin + Put_Line ("Usage : gnatdll [options] [list-of-files]"); + New_Line; + Put_Line + ("[list-of-files] a list of Ada libraries (.ali) and/or " & + "foreign object files"); + New_Line; + Put_Line ("[options] can be"); + Put_Line (" -h help - display this message"); + Put_Line (" -v verbose"); + Put_Line (" -q quiet"); + Put_Line (" -k remove @nn suffix from exported names"); + Put_Line (" -Idir Specify source and object files search path"); + + Put_Line (" -l file " & + "file contains a list-of-files to be added to the library"); + Put_Line (" -e file definition file containing exports"); + Put_Line + (" -d file put objects in the relocatable dynamic library <file>"); + Put_Line (" -a[addr] build non-relocatable DLL at address <addr>"); + Put_Line (" if <addr> is not specified use " & + Default_DLL_Address); + Put_Line (" -n no-import - do not create the import library"); + Put_Line (" -bargs binder option"); + Put_Line (" -largs linker (library builder) option"); + end Syntax; + + ----------- + -- Check -- + ----------- + + procedure Check (Filename : in String) is + begin + if not OS_Lib.Is_Regular_File (Filename) then + Exceptions.Raise_Exception (Context_Error'Identity, + "Error: " & Filename & " not found."); + end if; + end Check; + + ------------------------ + -- Parse_Command_Line -- + ------------------------ + + procedure Parse_Command_Line is + + use GNAT.Command_Line; + + procedure Add_File (Filename : in String); + -- add one file to the list of file to handle + + procedure Add_Files_From_List (List_Filename : in String); + -- add the files listed in List_Filename (one by line) to the list + -- of file to handle + + procedure Ali_To_Object_List; + -- for each ali file in Afiles set put a corresponding object file in + -- Ofiles set. + + -- these are arbitrary limits, a better way will be to use linked list. + + Max_Files : constant := 5_000; + Max_Options : constant := 100; + + -- objects files to put in the library + + Ofiles : OS_Lib.Argument_List (1 .. Max_Files); + O : Positive := Ofiles'First; + + -- ali files. + + Afiles : OS_Lib.Argument_List (1 .. Max_Files); + A : Positive := Afiles'First; + + -- gcc options. + + Gopts : OS_Lib.Argument_List (1 .. Max_Options); + G : Positive := Gopts'First; + + -- largs options + + Lopts : OS_Lib.Argument_List (1 .. Max_Options); + L : Positive := Lopts'First; + + -- bargs options + + Bopts : OS_Lib.Argument_List (1 .. Max_Options); + B : Positive := Bopts'First; + + -------------- + -- Add_File -- + -------------- + + procedure Add_File (Filename : in String) is + begin + -- others files are to be put inside the dynamic library + + if Files.Is_Ali (Filename) then + + Check (Filename); + + -- record it to generate the binder program when + -- building dynamic library + + Afiles (A) := new String'(Filename); + A := A + 1; + + elsif Files.Is_Obj (Filename) then + + Check (Filename); + + -- just record this object file + + Ofiles (O) := new String'(Filename); + O := O + 1; + + else + -- unknown file type + + Exceptions.Raise_Exception + (Syntax_Error'Identity, + "don't know what to do with " & Filename & " !"); + end if; + end Add_File; + + ------------------------- + -- Add_Files_From_List -- + ------------------------- + + procedure Add_Files_From_List (List_Filename : in String) is + File : Text_IO.File_Type; + Buffer : String (1 .. 500); + Last : Natural; + begin + Text_IO.Open (File, Text_IO.In_File, List_Filename); + + while not Text_IO.End_Of_File (File) loop + Text_IO.Get_Line (File, Buffer, Last); + Add_File (Buffer (1 .. Last)); + end loop; + + Text_IO.Close (File); + end Add_Files_From_List; + + ------------------------ + -- Ali_To_Object_List -- + ------------------------ + + procedure Ali_To_Object_List is + begin + for K in 1 .. A - 1 loop + Ofiles (O) := new String'(Files.Ext_To (Afiles (K).all, "o")); + O := O + 1; + end loop; + end Ali_To_Object_List; + + begin + + Initialize_Option_Scan ('-', False, "bargs largs"); + + -- scan gnatdll switches + + loop + case Getopt ("h v q k a? d: e: l: n I:") is + + when ASCII.Nul => + exit; + + when 'h' => + Help := True; + + when 'v' => + -- verbose mode on. + + MDLL.Verbose := True; + if MDLL.Quiet then + Exceptions.Raise_Exception + (Syntax_Error'Identity, + "impossible to use -q and -v together."); + end if; + + when 'q' => + -- quiet mode on. + + MDLL.Quiet := True; + if MDLL.Verbose then + Exceptions.Raise_Exception + (Syntax_Error'Identity, + "impossible to use -v and -q together."); + end if; + + when 'k' => + + MDLL.Kill_Suffix := True; + + when 'a' => + + if Parameter = "" then + + -- default address for a relocatable dynamic library. + -- address for a non relocatable dynamic library. + + DLL_Address := To_Unbounded_String (Default_DLL_Address); + + else + DLL_Address := To_Unbounded_String (Parameter); + end if; + + Must_Build_Relocatable := False; + + when 'e' => + + Def_Filename := To_Unbounded_String (Parameter); + + when 'd' => + + -- build a non relocatable DLL. + + Lib_Filename := To_Unbounded_String (Parameter); + + if Def_Filename = Null_Unbounded_String then + Def_Filename := To_Unbounded_String + (Files.Ext_To (Parameter, "def")); + end if; + + Build_Mode := Dynamic_Lib; + + when 'n' => + + Build_Import := False; + + when 'l' => + List_Filename := To_Unbounded_String (Parameter); + + when 'I' => + Gopts (G) := new String'("-I" & Parameter); + G := G + 1; + + when others => + raise Invalid_Switch; + + end case; + + end loop; + + -- get parameters + + loop + declare + File : constant String := Get_Argument (Do_Expansion => True); + begin + exit when File'Length = 0; + Add_File (File); + end; + end loop; + + -- get largs parameters + + Goto_Section ("largs"); + + loop + case Getopt ("*") is + + when ASCII.Nul => + exit; + + when others => + Lopts (L) := new String'(Full_Switch); + L := L + 1; + + end case; + end loop; + + -- get bargs parameters + + Goto_Section ("bargs"); + + loop + case Getopt ("*") is + + when ASCII.Nul => + exit; + + when others => + Bopts (B) := new String'(Full_Switch); + B := B + 1; + + end case; + end loop; + + -- if list filename has been specified parse it + + if List_Filename /= Null_Unbounded_String then + Add_Files_From_List (To_String (List_Filename)); + end if; + + -- check if the set of parameters are compatible. + + if Build_Mode = Nil and then not Help and then not Verbose then + Exceptions.Raise_Exception + (Syntax_Error'Identity, + "nothing to do."); + end if; + + -- check if we want to build an import library (option -e and no file + -- specified) + + if Build_Mode = Dynamic_Lib + and then A = Afiles'First + and then O = Ofiles'First + then + Build_Mode := Import_Lib; + end if; + + if O /= Ofiles'First then + Objects_Files := new OS_Lib.Argument_List'(Ofiles (1 .. O - 1)); + end if; + + if A /= Afiles'First then + Ali_Files := new OS_Lib.Argument_List'(Afiles (1 .. A - 1)); + end if; + + if G /= Gopts'First then + Options := new OS_Lib.Argument_List'(Gopts (1 .. G - 1)); + end if; + + if L /= Lopts'First then + Largs_Options := new OS_Lib.Argument_List'(Lopts (1 .. L - 1)); + end if; + + if B /= Bopts'First then + Bargs_Options := new OS_Lib.Argument_List'(Bopts (1 .. B - 1)); + end if; + + exception + + when Invalid_Switch => + Exceptions.Raise_Exception + (Syntax_Error'Identity, + Message => "Invalid Switch " & Full_Switch); + + when Invalid_Parameter => + Exceptions.Raise_Exception + (Syntax_Error'Identity, + Message => "No parameter for " & Full_Switch); + + end Parse_Command_Line; + + ------------------- + -- Check_Context -- + ------------------- + + procedure Check_Context is + begin + + Check (To_String (Def_Filename)); + + -- check that each object file specified exist + -- raises Context_Error if it does not. + + for F in Objects_Files'Range loop + Check (Objects_Files (F).all); + end loop; + end Check_Context; + +begin + + if Ada.Command_Line.Argument_Count = 0 then + Help := True; + else + Parse_Command_Line; + end if; + + if MDLL.Verbose or else Help then + Text_IO.New_Line; + Text_IO.Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder"); + Text_IO.New_Line; + end if; + + MDLL.Tools.Locate; + + if Help + or else (MDLL.Verbose and then Ada.Command_Line.Argument_Count = 1) + then + Syntax; + else + Check_Context; + + case Build_Mode is + + when Import_Lib => + MDLL.Build_Import_Library (To_String (Lib_Filename), + To_String (Def_Filename)); + + when Dynamic_Lib => + MDLL.Build_Dynamic_Library + (Objects_Files.all, + Ali_Files.all, + Options.all, + Bargs_Options.all, + Largs_Options.all, + To_String (Lib_Filename), + To_String (Def_Filename), + To_String (DLL_Address), + Build_Import, + Must_Build_Relocatable); + + when Nil => + null; + + end case; + + end if; + + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success); + +exception + + when SE : Syntax_Error => + Text_IO.Put_Line ("Syntax error : " & Exceptions.Exception_Message (SE)); + Text_IO.New_Line; + Syntax; + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + + when E : Tools_Error | Context_Error => + Text_IO.Put_Line (Exceptions.Exception_Message (E)); + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + + when others => + Text_IO.Put_Line ("gnatdll: INTERNAL ERROR. Please report"); + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + +end Gnatdll; diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb new file mode 100644 index 00000000000..f7ebf856a0c --- /dev/null +++ b/gcc/ada/gnatfind.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T F I N D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.26 $ +-- -- +-- Copyright (C) 1998-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Xr_Tabls; +with Xref_Lib; use Xref_Lib; +with Ada.Text_IO; +with GNAT.Command_Line; +with Gnatvsn; +with Osint; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; + +--------------- +-- Gnatfind -- +--------------- + +procedure Gnatfind is + + Output_Ref : Boolean := False; + Pattern : Xref_Lib.Search_Pattern; + Local_Symbols : Boolean := True; + Prj_File : File_Name_String; + Prj_File_Length : Natural := 0; + Nb_File : Natural := 0; + Usage_Error : exception; + Full_Path_Name : Boolean := False; + Have_Entity : Boolean := False; + Wide_Search : Boolean := True; + Glob_Mode : Boolean := True; + Der_Info : Boolean := False; + Type_Tree : Boolean := False; + Read_Only : Boolean := False; + Source_Lines : Boolean := False; + + Has_File_In_Entity : Boolean := False; + -- Will be true if a file name was specified in the entity + + procedure Parse_Cmd_Line; + -- Parse every switch on the command line + + procedure Write_Usage; + -- Print a small help page for program usage + + -------------------- + -- Parse_Cmd_Line -- + -------------------- + + procedure Parse_Cmd_Line is + begin + loop + case GNAT.Command_Line.Getopt ("a aI: aO: d e f g h I: p: r s t") is + when ASCII.NUL => + exit; + + when 'a' => + if GNAT.Command_Line.Full_Switch = "a" then + Read_Only := True; + elsif GNAT.Command_Line.Full_Switch = "aI" then + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + else + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + end if; + + when 'd' => + Der_Info := True; + + when 'e' => + Glob_Mode := False; + + when 'f' => + Full_Path_Name := True; + + when 'g' => + Local_Symbols := False; + + when 'h' => + Write_Usage; + + when 'I' => + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + + when 'p' => + declare + S : constant String := GNAT.Command_Line.Parameter; + begin + Prj_File_Length := S'Length; + Prj_File (1 .. Prj_File_Length) := S; + end; + + when 'r' => + Output_Ref := True; + + when 's' => + Source_Lines := True; + + when 't' => + Type_Tree := True; + + when others => + Write_Usage; + end case; + end loop; + + -- Get the other arguments + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + begin + exit when S'Length = 0; + + -- First argument is the pattern + + if not Have_Entity then + Add_Entity (Pattern, S, Glob_Mode); + Have_Entity := True; + + if not Has_File_In_Entity + and then Index (S, ":") /= 0 + then + Has_File_In_Entity := True; + end if; + + -- Next arguments are the files to search + else + Add_File (S); + Wide_Search := False; + Nb_File := Nb_File + 1; + end if; + end; + end loop; + + exception + when GNAT.Command_Line.Invalid_Switch => + Ada.Text_IO.Put_Line ("Invalid switch : " + & GNAT.Command_Line.Full_Switch); + Write_Usage; + + when GNAT.Command_Line.Invalid_Parameter => + Ada.Text_IO.Put_Line ("Parameter missing for : " + & GNAT.Command_Line.Parameter); + Write_Usage; + + when Xref_Lib.Invalid_Argument => + Ada.Text_IO.Put_Line ("Invalid line or column in the pattern"); + Write_Usage; + end Parse_Cmd_Line; + + ----------------- + -- Write_Usage -- + ----------------- + + procedure Write_Usage is + use Ada.Text_IO; + + begin + Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String + & " Copyright 1998-2001, Ada Core Technologies Inc."); + Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] " + & "[file1 file2 ...]"); + New_Line; + Put_Line (" pattern Name of the entity to look for (can have " + & "wildcards)"); + Put_Line (" sourcefile Only find entities referenced from this " + & "file"); + Put_Line (" line Only find entities referenced from this line " + & "of file"); + Put_Line (" column Only find entities referenced from this columns" + & " of file"); + Put_Line (" file ... Set of Ada source files to search for " + & "references. This parameters are optional"); + New_Line; + Put_Line ("gnatfind switches:"); + Put_Line (" -a Consider all files, even when the ali file is " + & "readonly"); + Put_Line (" -aIdir Specify source files search path"); + Put_Line (" -aOdir Specify library/object files search path"); + Put_Line (" -d Output derived type information"); + Put_Line (" -e Use the full regular expression set for pattern"); + Put_Line (" -f Output full path name"); + Put_Line (" -g Output information only for global symbols"); + Put_Line (" -Idir Like -aIdir -aOdir"); + Put_Line (" -p file Use file as the default project file"); + Put_Line (" -r Find all references (default to find declaration" + & " only)"); + Put_Line (" -s Print source line"); + Put_Line (" -t Print type hierarchy"); + New_Line; + + raise Usage_Error; + end Write_Usage; + +begin + Osint.Initialize (Osint.Compiler); + + Parse_Cmd_Line; + + if not Have_Entity then + Write_Usage; + end if; + + -- Special case to speed things up: if the user has a command line of the + -- form 'gnatfind entity:file', ie has specified a file and only wants the + -- bodies and specs, then we can restrict the search to the .ali file + -- associated with 'file'. + + if Has_File_In_Entity + and then not Output_Ref + then + Wide_Search := False; + end if; + + -- Find the project file + + if Prj_File_Length = 0 then + Xr_Tabls.Create_Project_File (Default_Project_File (".")); + else + Xr_Tabls.Create_Project_File (Prj_File (1 .. Prj_File_Length)); + end if; + + -- Fill up the table + + if Type_Tree and then Nb_File > 1 then + Ada.Text_IO.Put_Line ("Error: for type hierarchy output you must " + & "specify only one file."); + Ada.Text_IO.New_Line; + Write_Usage; + end if; + + Search (Pattern, Local_Symbols, Wide_Search, Read_Only, + Der_Info, Type_Tree); + + if Source_Lines then + Xr_Tabls.Grep_Source_Files; + end if; + + Print_Gnatfind (Output_Ref, Full_Path_Name); + +exception + when Usage_Error => + null; +end Gnatfind; diff --git a/gcc/ada/gnatkr.adb b/gcc/ada/gnatkr.adb new file mode 100644 index 00000000000..7d871585250 --- /dev/null +++ b/gcc/ada/gnatkr.adb @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T K R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Gnatvsn; +with Krunch; +with System.IO; use System.IO; + +procedure Gnatkr is + pragma Ident (Gnatvsn.Gnat_Version_String); + + Count : Natural; + Maxlen : Integer; + Exit_Program : exception; + + function Get_Maximum_File_Name_Length return Integer; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + +begin + Count := Argument_Count; + + if Count < 1 or else Count > 2 then + Put_Line ("Usage: gnatkr filename[.extension] [krunch-count]"); + raise Exit_Program; + + else + -- If the length (krunch-count) argument is omitted use the system + -- default if there is one, otherwise use 8. + + if Count = 1 then + Maxlen := Get_Maximum_File_Name_Length; + + if Maxlen = -1 then + Maxlen := 8; + end if; + + else + Maxlen := 0; + + for J in Argument (2)'Range loop + if Argument (2) (J) /= ' ' then + if Argument (2) (J) not in '0' .. '9' then + Put_Line ("Illegal argument for krunch-count"); + raise Exit_Program; + else + Maxlen := Maxlen * 10 + + Character'Pos (Argument (2) (J)) - Character'Pos ('0'); + end if; + end if; + end loop; + + -- Zero means crunch only system files + + if Maxlen = 0 then + Maxlen := Natural'Last; + end if; + + end if; + + declare + Fname : String := Argument (1); + Klen : Natural := Fname'Length; + + Extp : Boolean := False; + -- True if extension is present + + Ext : Natural := 0; + -- If extension is present, points to it (init to prevent warning) + + begin + -- Remove .adb or .ads extension if present (recognized only if the + -- name is all lower case and contains no other instances of dots) + + if Klen > 4 + and then Fname (Klen - 3 .. Klen - 1) = ".ad" + and then (Fname (Klen) = 's' or else Fname (Klen) = 'b') + then + Extp := True; + + for J in 1 .. Klen - 4 loop + if Is_Upper (Fname (J)) or else Fname (J) = '.' then + Extp := False; + end if; + end loop; + + if Extp then + Klen := Klen - 4; + Ext := Klen + 1; + end if; + + else + Extp := False; + end if; + + -- Fold to lower case and replace dots by dashes + + for J in 1 .. Klen loop + Fname (J) := To_Lower (Fname (J)); + + if Fname (J) = '.' then + Fname (J) := '-'; + end if; + end loop; + + Krunch (Fname, Klen, Maxlen, False); + + Put (Fname (1 .. Klen)); + + if Extp then + Put (Fname (Ext .. Fname'Length)); + end if; + + New_Line; + end; + end if; + + Set_Exit_Status (Success); + +exception + when Exit_Program => + Set_Exit_Status (Failure); + +end Gnatkr; diff --git a/gcc/ada/gnatkr.ads b/gcc/ada/gnatkr.ads new file mode 100644 index 00000000000..771043209a6 --- /dev/null +++ b/gcc/ada/gnatkr.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T K R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1992-1999 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a small utility program that incorporates the file krunching +-- algorithm used by the GNAT compiler (when the -gnatk switch is used) + +-- gnatkr filename length + +-- where length is a decimal value, outputs to standard output the krunched +-- name, followed by the original input file name. The file name has an +-- optional extension, which, if present, is copied unchanged to the output. +-- The length argument is optional and defaults to the system default if +-- there is one, otherwise to 8. + +procedure Gnatkr; +-- Execute above described command. This is an Ada main program which +-- sets an exit status (set to Success or Failure as appropriate) diff --git a/gcc/ada/gnatlbr.adb b/gcc/ada/gnatlbr.adb new file mode 100644 index 00000000000..f4dd7cb2f10 --- /dev/null +++ b/gcc/ada/gnatlbr.adb @@ -0,0 +1,349 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L B R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1997-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Program to create, set, or delete an alternate runtime library. + +-- Works by calling an appropriate target specific Makefile residing +-- in the default library object (e.g. adalib) directory from the context +-- of the new library objects directory. + +-- Command line arguments are: +-- 1st: --[create | set | delete]=<directory_spec> +-- --create : Build a library +-- --set : Set environment variables to point to a library +-- --delete : Delete a library + +-- 2nd: --config=<file_spec> +-- A -gnatg valid file containing desired configuration pragmas + +-- This program is currently used only on Alpha/VMS + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Gnatvsn; use Gnatvsn; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with Osint; use Osint; +with Sdefault; use Sdefault; +with System; + +procedure GnatLbr is + pragma Ident (Gnat_Version_String); + + type Lib_Mode is (None, Create, Set, Delete); + Next_Arg : Integer; + Mode : Lib_Mode := None; + ADC_File : String_Access := null; + Lib_Dir : String_Access := null; + Make : constant String := "make"; + Make_Path : String_Access; + + procedure Create_Directory (Name : System.Address; Mode : Integer); + pragma Import (C, Create_Directory, "mkdir"); + +begin + if Argument_Count = 0 then + Put ("Usage: "); + Put_Line + ("gnatlbr --[create|set|delete]=<directory> [--config=<file>]"); + Exit_Program (E_Fatal); + end if; + + Next_Arg := 1; + + loop + exit when Next_Arg > Argument_Count; + + Process_One_Arg : declare + Arg : String := Argument (Next_Arg); + + begin + + if Arg'Length > 9 and then Arg (1 .. 9) = "--create=" then + if Mode = None then + Mode := Create; + Lib_Dir := new String'(Arg (10 .. Arg'Last)); + else + Put_Line (Standard_Error, "Error: Multiple modes specified"); + Exit_Program (E_Fatal); + end if; + + elsif Arg'Length > 6 and then Arg (1 .. 6) = "--set=" then + if Mode = None then + Mode := Set; + Lib_Dir := new String'(Arg (7 .. Arg'Last)); + else + Put_Line (Standard_Error, "Error: Multiple modes specified"); + Exit_Program (E_Fatal); + end if; + + elsif Arg'Length > 9 and then Arg (1 .. 9) = "--delete=" then + if Mode = None then + Mode := Delete; + Lib_Dir := new String'(Arg (10 .. Arg'Last)); + else + Put_Line (Standard_Error, "Error: Multiple modes specified"); + Exit_Program (E_Fatal); + end if; + + elsif Arg'Length > 9 and then Arg (1 .. 9) = "--config=" then + if ADC_File /= null then + Put_Line (Standard_Error, + "Error: Multiple gnat.adc files specified"); + Exit_Program (E_Fatal); + end if; + + ADC_File := new String'(Arg (10 .. Arg'Last)); + + else + Put_Line (Standard_Error, "Error: Unrecognized option: " & Arg); + Exit_Program (E_Fatal); + + end if; + end Process_One_Arg; + + Next_Arg := Next_Arg + 1; + end loop; + + case Mode is + when Create => + + -- Validate arguments + + if Lib_Dir = null then + Put_Line (Standard_Error, "Error: No library directory specified"); + Exit_Program (E_Fatal); + end if; + + if Is_Directory (Lib_Dir.all) then + Put_Line (Standard_Error, + "Error:" & Lib_Dir.all & " already exists"); + Exit_Program (E_Fatal); + end if; + + if ADC_File = null then + Put_Line (Standard_Error, + "Error: No configuration file specified"); + Exit_Program (E_Fatal); + end if; + + if not Is_Regular_File (ADC_File.all) then + Put_Line (Standard_Error, + "Error: " & ADC_File.all & " doesn't exist"); + Exit_Program (E_Fatal); + end if; + + Create_Block : declare + Success : Boolean; + Make_Args : Argument_List (1 .. 9); + C_Lib_Dir : String := Lib_Dir.all & ASCII.Nul; + C_ADC_File : String := ADC_File.all & ASCII.Nul; + F_ADC_File : String (1 .. max_path_len); + F_ADC_File_Len : Integer := max_path_len; + Include_Dirs : Integer; + Object_Dirs : Integer; + Include_Dir : array (Integer range 1 .. 256) of String_Access; + Object_Dir : array (Integer range 1 .. 256) of String_Access; + Include_Dir_Name : String_Access; + Object_Dir_Name : String_Access; + + begin + -- Create the new top level library directory + + if not Is_Directory (Lib_Dir.all) then + Create_Directory (C_Lib_Dir'Address, 8#755#); + end if; + + full_name (C_ADC_File'Address, F_ADC_File'Address); + + for I in 1 .. max_path_len loop + if F_ADC_File (I) = ASCII.Nul then + F_ADC_File_Len := I - 1; + exit; + end if; + end loop; + + -- + -- Make a list of the default library source and object + -- directories. Usually only one, except on VMS where + -- there are two. + -- + Include_Dirs := 0; + Include_Dir_Name := String_Access (Include_Dir_Default_Name); + Get_Next_Dir_In_Path_Init (String_Access (Include_Dir_Name)); + + loop + declare + Dir : String_Access := String_Access + (Get_Next_Dir_In_Path (String_Access (Include_Dir_Name))); + begin + exit when Dir = null; + Include_Dirs := Include_Dirs + 1; + Include_Dir (Include_Dirs) + := String_Access (Normalize_Directory_Name (Dir.all)); + end; + end loop; + + Object_Dirs := 0; + Object_Dir_Name := String_Access (Object_Dir_Default_Name); + Get_Next_Dir_In_Path_Init (String_Access (Object_Dir_Name)); + + loop + declare + Dir : String_Access := String_Access + (Get_Next_Dir_In_Path (String_Access (Object_Dir_Name))); + begin + exit when Dir = null; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) + := String_Access (Normalize_Directory_Name (Dir.all)); + end; + end loop; + + -- "Make" an alternate sublibrary for each default sublibrary. + + for Dirs in 1 .. Object_Dirs loop + + Make_Args (1) := + new String'("-C"); + + Make_Args (2) := + new String'(Lib_Dir.all); + + -- Resolve /gnu on VMS by converting to host format and then + -- convert resolved path back to canonical format for the + -- make program. This fixes the problem that can occur when + -- GNU: is a search path pointing to multiple versions of GNAT. + + Make_Args (3) := + new String'("ADA_INCLUDE_PATH=" & + To_Canonical_Dir_Spec + (To_Host_Dir_Spec + (Include_Dir (Dirs).all, True).all, True).all); + + Make_Args (4) := + new String'("ADA_OBJECTS_PATH=" & + To_Canonical_Dir_Spec + (To_Host_Dir_Spec + (Object_Dir (Dirs).all, True).all, True).all); + + Make_Args (5) := + new String'("GNAT_ADC_FILE=" + & F_ADC_File (1 .. F_ADC_File_Len)); + + Make_Args (6) := + new String'("LIBRARY_VERSION=" & '"' & Library_Version & '"'); + + Make_Args (7) := + new String'("-f"); + + Make_Args (8) := + new String'(Object_Dir (Dirs).all & "Makefile.lib"); + + Make_Args (9) := + new String'("create"); + + Make_Path := Locate_Exec_On_Path (Make); + Put (Make); + + for I in 1 .. Make_Args'Last loop + Put (" "); + Put (Make_Args (I).all); + end loop; + + New_Line; + Spawn (Make_Path.all, Make_Args, Success); + if not Success then + Put_Line (Standard_Error, "Error: Make failed"); + Exit_Program (E_Fatal); + end if; + end loop; + end Create_Block; + + when Set => + + -- Validate arguments. + + if Lib_Dir = null then + Put_Line (Standard_Error, + "Error: No library directory specified"); + Exit_Program (E_Fatal); + end if; + + if not Is_Directory (Lib_Dir.all) then + Put_Line (Standard_Error, + "Error: " & Lib_Dir.all & " doesn't exist"); + Exit_Program (E_Fatal); + end if; + + if ADC_File = null then + Put_Line (Standard_Error, + "Error: No configuration file specified"); + Exit_Program (E_Fatal); + end if; + + if not Is_Regular_File (ADC_File.all) then + Put_Line (Standard_Error, + "Error: " & ADC_File.all & " doesn't exist"); + Exit_Program (E_Fatal); + end if; + + -- Give instructions. + + Put_Line ("Copy the contents of " + & ADC_File.all & " into your GNAT.ADC file"); + Put_Line ("and use GNAT Make qualifier /OBJECT_SEARCH=(" + & To_Host_Dir_Spec + (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/declib", False).all + & "," + & To_Host_Dir_Spec + (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/adalib", False).all + & ")"); + Put_Line ("or else define ADA_OBJECTS_PATH as " & '"' + & To_Host_Dir_Spec + (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/declib", False).all + & ',' + & To_Host_Dir_Spec + (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/adalib", False).all + & '"'); + + when Delete => + + -- Give instructions. + + Put_Line ("GNAT Librarian DELETE not yet implemented."); + Put_Line ("Use appropriate system tools to remove library"); + + when None => + Put_Line (Standard_Error, + "Error: No mode (create|set|delete) specified"); + Exit_Program (E_Fatal); + + end case; + +end GnatLbr; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb new file mode 100644 index 00000000000..30482a87638 --- /dev/null +++ b/gcc/ada/gnatlink.adb @@ -0,0 +1,1351 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L I N K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.72 $ +-- -- +-- Copyright (C) 1996-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Gnatlink usage: please consult the gnat documentation + +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Osint; use Osint; +with Output; use Output; +with System; use System; +with Table; + +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +procedure Gnatlink is + + pragma Ident (Gnat_Version_String); + + package Gcc_Linker_Options is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Gcc_Linker_Options"); + -- Comments needed ??? + + package Libpath is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 2, + Table_Name => "Gnatlink.Libpath"); + -- Comments needed ??? + + package Linker_Options is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Linker_Options"); + -- Comments needed ??? + + package Linker_Objects is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Linker_Objects"); + -- This table collects the objects file to be passed to the linker. In the + -- case where the linker command line is too long then programs objects + -- are put on the Response_File_Objects table. Note that the binder object + -- file and the user's objects remain in this table. This is very + -- important because on the GNU linker command line the -L switch is not + -- used to look for objects files but -L switch is used to look for + -- objects listed in the response file. This is not a problem with the + -- applications objects as they are specified with a fullname. + + package Response_File_Objects is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Response_File_Objects"); + -- This table collects the objects file that are to be put in the reponse + -- file. Only application objects are collected there (see details in + -- Linker_Objects table comments) + + package Binder_Options is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, -- equals low bound of Argument_List for Spawn + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Binder_Options"); + -- This table collects the arguments to be passed to compile the binder + -- generated file. + + subtype chars_ptr is System.Address; + + Gcc : String_Access := Program_Name ("gcc"); + + Read_Mode : constant String := "r" & ASCII.Nul; + + Begin_Info : String := "-- BEGIN Object file/option list"; + End_Info : String := "-- END Object file/option list "; + -- Note: above lines are modified in C mode, see option processing + + Gcc_Path : String_Access; + Linker_Path : String_Access; + + Output_File_Name : String_Access; + Ali_File_Name : String_Access; + Binder_Spec_Src_File : String_Access; + Binder_Body_Src_File : String_Access; + Binder_Ali_File : String_Access; + Binder_Obj_File : String_Access; + + Tname : Temp_File_Name; + Tname_FD : File_Descriptor := Invalid_FD; + -- Temporary file used by linker to pass list of object files on + -- certain systems with limitations on size of arguments. + + Debug_Flag_Present : Boolean := False; + Verbose_Mode : Boolean := False; + Very_Verbose_Mode : Boolean := False; + + Ada_Bind_File : Boolean := True; + -- Set to True if bind file is generated in Ada + + Compile_Bind_File : Boolean := True; + -- Set to False if bind file is not to be compiled + + Object_List_File_Supported : Boolean; + pragma Import (C, Object_List_File_Supported, "objlist_file_supported"); + -- Predicate indicating whether the linker has an option whereby the + -- names of object files can be passed to the linker in a file. + + Object_List_File_Required : Boolean := False; + -- Set to True to force generation of a response file + + function Base_Name (File_Name : in String) return String; + -- Return just the file name part without the extension (if present). + + procedure Delete (Name : in String); + -- Wrapper to unlink as status is ignored by this application. + + procedure Error_Msg (Message : in String); + -- Output the error or warning Message + + procedure Exit_With_Error (Error : in String); + -- Output Error and exit program with a fatal condition. + + procedure Process_Args; + -- Go through all the arguments and build option tables. + + procedure Process_Binder_File (Name : in String); + -- Reads the binder file and extracts linker arguments. + + function Value (chars : chars_ptr) return String; + -- Return NUL-terminated string chars as an Ada string. + + procedure Write_Usage; + -- Show user the program options. + + --------------- + -- Base_Name -- + --------------- + + function Base_Name (File_Name : in String) return String is + Findex1 : Natural; + Findex2 : Natural; + + begin + Findex1 := File_Name'First; + + -- The file might be specified by a full path name. However, + -- we want the path to be stripped away. + + for J in reverse File_Name'Range loop + if Is_Directory_Separator (File_Name (J)) then + Findex1 := J + 1; + exit; + end if; + end loop; + + Findex2 := File_Name'Last; + while Findex2 > Findex1 + and then File_Name (Findex2) /= '.' + loop + Findex2 := Findex2 - 1; + end loop; + + if Findex2 = Findex1 then + Findex2 := File_Name'Last + 1; + end if; + + return File_Name (Findex1 .. Findex2 - 1); + end Base_Name; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Name : in String) is + Status : int; + + begin + Status := unlink (Name'Address); + end Delete; + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Message : in String) is + begin + Write_Str (Base_Name (Command_Name)); + Write_Str (": "); + Write_Str (Message); + Write_Eol; + end Error_Msg; + + --------------------- + -- Exit_With_Error -- + --------------------- + + procedure Exit_With_Error (Error : in String) is + begin + Error_Msg (Error); + Exit_Program (E_Fatal); + end Exit_With_Error; + + ------------------ + -- Process_Args -- + ------------------ + + procedure Process_Args is + Next_Arg : Integer; + + begin + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-c"); + + -- If the main program is in Ada it is compiled with the following + -- switches: + + -- -gnatA stops reading gnat.adc, since we don't know what + -- pagmas would work, and we do not need it anyway. + + -- -gnatWb allows brackets coding for wide characters + + -- -gnatiw allows wide characters in identifiers. This is needed + -- because bindgen uses brackets encoding for all upper + -- half and wide characters in identifier names. + + if Ada_Bind_File then + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-gnatA"); + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-gnatWb"); + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-gnatiw"); + end if; + + -- Loop through arguments of gnatlink command + + Next_Arg := 1; + loop + exit when Next_Arg > Argument_Count; + + Process_One_Arg : declare + Arg : String := Argument (Next_Arg); + + begin + -- Case of argument which is a switch + + -- We definitely need section by section comments here ??? + + if Arg'Length /= 0 + and then (Arg (1) = Switch_Character or else Arg (1) = '-') + then + if Arg'Length > 4 + and then Arg (2 .. 5) = "gnat" + then + Exit_With_Error + ("invalid switch: """ & Arg & """ (gnat not needed here)"); + end if; + + if Arg (2) = 'g' + and then (Arg'Length < 5 or else Arg (2 .. 5) /= "gnat") + then + Debug_Flag_Present := True; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + elsif Arg'Length = 2 then + case Arg (2) is + when 'A' => + Ada_Bind_File := True; + Begin_Info := "-- BEGIN Object file/option list"; + End_Info := "-- END Object file/option list "; + + when 'b' => + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + Next_Arg := Next_Arg + 1; + + if Next_Arg > Argument_Count then + Exit_With_Error ("Missing argument for -b"); + end if; + + Get_Machine_Name : declare + Name_Arg : String_Access := + new String'(Argument (Next_Arg)); + + begin + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + Name_Arg; + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Name_Arg; + + end Get_Machine_Name; + + when 'C' => + Ada_Bind_File := False; + Begin_Info := "/* BEGIN Object file/option list"; + End_Info := " END Object file/option list */"; + + when 'f' => + if Object_List_File_Supported then + Object_List_File_Required := True; + else + Exit_With_Error + ("Object list file not supported on this target"); + end if; + + when 'n' => + Compile_Bind_File := False; + + when 'o' => + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Next_Arg := Next_Arg + 1; + + if Next_Arg > Argument_Count then + Exit_With_Error ("Missing argument for -o"); + end if; + + Output_File_Name := new String'(Argument (Next_Arg)); + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + Output_File_Name; + + when 'v' => + + -- Support "double" verbose mode. Second -v + -- gets sent to the linker and binder phases. + + if Verbose_Mode then + Very_Verbose_Mode := True; + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + else + Verbose_Mode := True; + + end if; + + when others => + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + end case; + + elsif Arg (2) = 'B' then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + Linker_Options.Table (Linker_Options.Last); + + elsif Arg'Length >= 7 and then Arg (1 .. 7) = "--LINK=" then + + if Arg'Length = 7 then + Exit_With_Error ("Missing argument for --LINK="); + end if; + + Linker_Path := + GNAT.OS_Lib.Locate_Exec_On_Path (Arg (8 .. Arg'Last)); + + if Linker_Path = null then + Exit_With_Error + ("Could not locate linker: " & Arg (8 .. Arg'Last)); + end if; + + elsif Arg'Length > 6 and then Arg (1 .. 6) = "--GCC=" then + declare + Program_Args : Argument_List_Access := + Argument_String_To_List + (Arg (7 .. Arg'Last)); + + begin + Gcc := new String'(Program_Args.all (1).all); + + -- Set appropriate flags for switches passed + + for J in 2 .. Program_Args.all'Last loop + declare + Arg : String := Program_Args.all (J).all; + AF : Integer := Arg'First; + + begin + if Arg'Length /= 0 + and then (Arg (AF) = Switch_Character + or else Arg (AF) = '-') + then + if Arg (AF + 1) = 'g' + and then (Arg'Length = 2 + or else Arg (AF + 2) in '0' .. '3' + or else Arg (AF + 2 .. Arg'Last) = "coff") + then + Debug_Flag_Present := True; + end if; + end if; + + -- Pass to gcc for compiling binder generated file + -- No use passing libraries, it will just generate + -- a warning + + if not (Arg (AF .. AF + 1) = "-l" + or else Arg (AF .. AF + 1) = "-L") + then + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := + new String'(Arg); + end if; + + -- Pass to gcc for linking program. + + Gcc_Linker_Options.Increment_Last; + Gcc_Linker_Options.Table + (Gcc_Linker_Options.Last) := new String'(Arg); + end; + end loop; + end; + + -- Send all multi-character switches not recognized as + -- a special case by gnatlink to the linker/loader stage. + + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + end if; + + -- Here if argument is a file name rather than a switch + + else + if Arg'Length > 4 + and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali" + then + if Ali_File_Name = null then + Ali_File_Name := new String'(Arg); + else + Exit_With_Error ("cannot handle more than one ALI file"); + end if; + + elsif Is_Regular_File (Arg & ".ali") + and then Ali_File_Name = null + then + Ali_File_Name := new String'(Arg & ".ali"); + + elsif Arg'Length > Get_Object_Suffix.all'Length + and then Arg + (Arg'Last - Get_Object_Suffix.all'Length + 1 .. Arg'Last) + = Get_Object_Suffix.all + then + Linker_Objects.Increment_Last; + Linker_Objects.Table (Linker_Objects.Last) := + new String'(Arg); + + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Arg); + end if; + + end if; + + end Process_One_Arg; + + Next_Arg := Next_Arg + 1; + end loop; + + -- If Ada bind file, then compile it with warnings suppressed, because + -- otherwise the with of the main program may cause junk warnings. + + if Ada_Bind_File then + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-gnatws"); + end if; + end Process_Args; + + ------------------------- + -- Process_Binder_File -- + ------------------------- + + procedure Process_Binder_File (Name : in String) is + Fd : FILEs; + Link_Bytes : Integer := 0; + Link_Max : Integer; + pragma Import (C, Link_Max, "link_max"); + + Next_Line : String (1 .. 1000); + Nlast : Integer; + Nfirst : Integer; + Objs_Begin : Integer := 0; + Objs_End : Integer := 0; + + Status : int; + N : Integer; + + GNAT_Static : Boolean := False; + -- Save state of -static option. + + GNAT_Shared : Boolean := False; + -- Save state of -shared option. + + Run_Path_Option_Ptr : Address; + pragma Import (C, Run_Path_Option_Ptr, "run_path_option"); + -- Pointer to string representing the native linker option which + -- specifies the path where the dynamic loader should find shared + -- libraries. Equal to null string if this system doesn't support it. + + Object_Library_Ext_Ptr : Address; + pragma Import (C, Object_Library_Ext_Ptr, "object_library_extension"); + -- Pointer to string specifying the default extension for + -- object libraries, e.g. Unix uses ".a", VMS uses ".olb". + + Object_File_Option_Ptr : Address; + pragma Import (C, Object_File_Option_Ptr, "object_file_option"); + -- Pointer to a string representing the linker option which specifies + -- the response file. + + Using_GNU_Linker : Boolean; + pragma Import (C, Using_GNU_Linker, "using_gnu_linker"); + -- Predicate indicating whether this target uses the GNU linker. In + -- this case we must output a GNU linker compatible response file. + + procedure Get_Next_Line; + -- Read the next line from the binder file without the line + -- terminator. + + function Is_Option_Present (Opt : in String) return Boolean; + -- Return true if the option Opt is already present in + -- Linker_Options table. + + procedure Get_Next_Line is + Fchars : chars; + + begin + Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd); + + if Fchars = System.Null_Address then + Exit_With_Error ("Error reading binder output"); + end if; + + Nfirst := Next_Line'First; + Nlast := Nfirst; + while Nlast <= Next_Line'Last + and then Next_Line (Nlast) /= ASCII.LF + and then Next_Line (Nlast) /= ASCII.CR + loop + Nlast := Nlast + 1; + end loop; + + Nlast := Nlast - 1; + end Get_Next_Line; + + function Is_Option_Present (Opt : in String) return Boolean is + begin + for I in 1 .. Linker_Options.Last loop + + if Linker_Options.Table (I).all = Opt then + return True; + end if; + + end loop; + + return False; + end Is_Option_Present; + + -- Start of processing for Process_Binder_File + + begin + Fd := fopen (Name'Address, Read_Mode'Address); + + if Fd = NULL_Stream then + Exit_With_Error ("Failed to open binder output"); + end if; + + -- Skip up to the Begin Info line + + loop + Get_Next_Line; + exit when Next_Line (Nfirst .. Nlast) = Begin_Info; + end loop; + + loop + Get_Next_Line; + + -- Go to end when end line is reached (this will happen in + -- No_Run_Time mode where no -L switches are generated) + + exit when Next_Line (Nfirst .. Nlast) = End_Info; + + if Ada_Bind_File then + Next_Line (Nfirst .. Nlast - 8) := + Next_Line (Nfirst + 8 .. Nlast); + Nlast := Nlast - 8; + end if; + + -- Go to next section when switches are reached + + exit when Next_Line (1) = '-'; + + -- Otherwise we have another object file to collect + + Linker_Objects.Increment_Last; + + -- Mark the positions of first and last object files in case + -- they need to be placed with a named file on systems having + -- linker line limitations. + + if Objs_Begin = 0 then + Objs_Begin := Linker_Objects.Last; + end if; + + Linker_Objects.Table (Linker_Objects.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + + Link_Bytes := Link_Bytes + Nlast - Nfirst; + end loop; + + Objs_End := Linker_Objects.Last; + + -- On systems that have limitations on handling very long linker lines + -- we make use of the system linker option which takes a list of object + -- file names from a file instead of the command line itself. What we do + -- is to replace the list of object files by the special linker option + -- which then reads the object file list from a file instead. The option + -- to read from a file instead of the command line is only triggered if + -- a conservative threshold is passed. + + if Object_List_File_Required + or else (Object_List_File_Supported + and then Link_Bytes > Link_Max) + then + -- Create a temporary file containing the Ada user object files + -- needed by the link. This list is taken from the bind file + -- and is output one object per line for maximal compatibility with + -- linkers supporting this option. + + Create_Temp_File (Tname_FD, Tname); + + -- If target is using the GNU linker we must add a special header + -- and footer in the response file. + -- The syntax is : INPUT (object1.o object2.o ... ) + + if Using_GNU_Linker then + declare + GNU_Header : aliased constant String := "INPUT ("; + + begin + Status := Write (Tname_FD, GNU_Header'Address, + GNU_Header'Length); + end; + end if; + + for J in Objs_Begin .. Objs_End loop + Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address, + Linker_Objects.Table (J).all'Length); + Status := Write (Tname_FD, ASCII.LF'Address, 1); + + Response_File_Objects.Increment_Last; + Response_File_Objects.Table (Response_File_Objects.Last) := + Linker_Objects.Table (J); + end loop; + + -- handle GNU linker response file footer. + + if Using_GNU_Linker then + declare + GNU_Footer : aliased constant String := ")"; + + begin + Status := Write (Tname_FD, GNU_Footer'Address, + GNU_Footer'Length); + end; + end if; + + Close (Tname_FD); + + -- Add the special objects list file option together with the name + -- of the temporary file (removing the null character) to the objects + -- file table. + + Linker_Objects.Table (Objs_Begin) := + new String'(Value (Object_File_Option_Ptr) & + Tname (Tname'First .. Tname'Last - 1)); + + -- The slots containing these object file names are then removed + -- from the objects table so they do not appear in the link. They + -- are removed by moving up the linker options and non-Ada object + -- files appearing after the Ada object list in the table. + + N := Objs_End - Objs_Begin + 1; + for J in Objs_End + 1 .. Linker_Objects.Last loop + Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J); + end loop; + + Linker_Objects.Set_Last (Linker_Objects.Last - N + 1); + end if; + + -- Process switches and options + + if Next_Line (Nfirst .. Nlast) /= End_Info then + loop + -- Add binder options only if not already set on the command + -- line. This rule is a way to control the linker options order. + + if not Is_Option_Present + (Next_Line (Nfirst .. Nlast)) + then + if Next_Line (Nfirst .. Nlast) = "-static" then + GNAT_Static := True; + + elsif Next_Line (Nfirst .. Nlast) = "-shared" then + GNAT_Shared := True; + + else + if Nlast > Nfirst + 2 and then + Next_Line (Nfirst .. Nfirst + 1) = "-L" + then + -- Construct a library search path for use later + -- to locate static gnatlib libraries. + + if Libpath.Last > 1 then + Libpath.Increment_Last; + Libpath.Table (Libpath.Last) := Path_Separator; + end if; + + for I in Nfirst + 2 .. Nlast loop + Libpath.Increment_Last; + Libpath.Table (Libpath.Last) := Next_Line (I); + end loop; + + Linker_Options.Increment_Last; + + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + + elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" + or else Next_Line (Nfirst .. Nlast) = "-lgnarl" + or else Next_Line (Nfirst .. Nlast) = "-lgnat" + then + -- Given a Gnat standard library, search the + -- library path to find the library location + declare + File_Path : String_Access; + + Object_Lib_Extension : constant String := + Value + (Object_Library_Ext_Ptr); + + File_Name : String := + "lib" & + Next_Line (Nfirst + 2 .. Nlast) & + Object_Lib_Extension; + + begin + File_Path := + Locate_Regular_File + (File_Name, + String (Libpath.Table (1 .. Libpath.Last))); + + if File_Path /= null then + if GNAT_Static then + + -- If static gnatlib found, explicitly + -- specify to overcome possible linker + -- default usage of shared version. + + Linker_Options.Increment_Last; + + Linker_Options.Table (Linker_Options.Last) := + new String'(File_Path.all); + + elsif GNAT_Shared then + + -- If shared gnatlib desired, add the + -- appropriate system specific switch + -- so that it can be located at runtime. + + declare + Run_Path_Opt : constant String := + Value + (Run_Path_Option_Ptr); + + begin + if Run_Path_Opt'Length /= 0 then + + -- Output the system specific linker + -- command that allows the image + -- activator to find the shared library + -- at runtime. + + Linker_Options.Increment_Last; + + Linker_Options.Table + (Linker_Options.Last) := + new String'(Run_Path_Opt + & File_Path + (1 .. File_Path'Length + - File_Name'Length)); + end if; + + Linker_Options.Increment_Last; + + Linker_Options.Table + (Linker_Options.Last) := + new String'(Next_Line + (Nfirst .. Nlast)); + + end; + end if; + + else + -- If gnatlib library not found, then + -- add it anyway in case some other + -- mechanimsm may find it. + + Linker_Options.Increment_Last; + + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + end if; + end; + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); + end if; + end if; + end if; + + Get_Next_Line; + exit when Next_Line (Nfirst .. Nlast) = End_Info; + + if Ada_Bind_File then + Next_Line (Nfirst .. Nlast - 8) := + Next_Line (Nfirst + 8 .. Nlast); + Nlast := Nlast - 8; + end if; + end loop; + end if; + + Status := fclose (Fd); + end Process_Binder_File; + + ----------- + -- Value -- + ----------- + + function Value (chars : chars_ptr) return String is + function Strlen (chars : chars_ptr) return Natural; + pragma Import (C, Strlen); + + begin + if chars = Null_Address then + return ""; + + else + declare + subtype Result_Type is String (1 .. Strlen (chars)); + + Result : Result_Type; + for Result'Address use chars; + + begin + return Result; + end; + end if; + end Value; + + ----------------- + -- Write_Usage -- + ----------------- + + procedure Write_Usage is + begin + Write_Str ("Usage: "); + Write_Str (Base_Name (Command_Name)); + Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]"); + Write_Eol; + Write_Eol; + Write_Line (" mainprog.ali the ALI file of the main program"); + Write_Eol; + Write_Line (" -A Binder generated source file is in Ada (default)"); + Write_Line (" -C Binder generated source file is in C"); + Write_Line (" -f force object file list to be generated"); + Write_Line (" -g Compile binder source file with debug information"); + Write_Line (" -n Do not compile the binder source file"); + Write_Line (" -v verbose mode"); + Write_Line (" -v -v very verbose mode"); + Write_Eol; + Write_Line (" -o nam Use 'nam' as the name of the executable"); + Write_Line (" -b target Compile the binder source to run on target"); + Write_Line (" -Bdir Load compiler executables from dir"); + Write_Line (" --GCC=comp Use comp as the compiler"); + Write_Line (" --LINK=nam Use 'nam' for the linking rather than 'gcc'"); + Write_Eol; + Write_Line (" [non-Ada-objects] list of non Ada object files"); + Write_Line (" [linker-options] other options for the linker"); + end Write_Usage; + +-- Start of processing for Gnatlink + +begin + + if Argument_Count = 0 then + Write_Usage; + Exit_Program (E_Fatal); + end if; + + if Hostparm.Java_VM then + Gcc := new String'("jgnat"); + Ada_Bind_File := True; + Begin_Info := "-- BEGIN Object file/option list"; + End_Info := "-- END Object file/option list "; + end if; + + Process_Args; + + -- Locate all the necessary programs and verify required files are present + + Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); + + if Gcc_Path = null then + Exit_With_Error ("Couldn't locate " & Gcc.all); + end if; + + if Linker_Path = null then + Linker_Path := Gcc_Path; + end if; + + if Ali_File_Name = null then + Exit_With_Error ("Required 'name'.ali not present."); + end if; + + if not Is_Regular_File (Ali_File_Name.all) then + Exit_With_Error (Ali_File_Name.all & " not found."); + end if; + + if Verbose_Mode then + Write_Eol; + Write_Str ("GNATLINK "); + Write_Str (Gnat_Version_String); + Write_Str (" Copyright 1996-2001 Free Software Foundation, Inc."); + Write_Eol; + end if; + + -- If there wasn't an output specified, then use the base name of + -- the .ali file name. + + if Output_File_Name = null then + + Output_File_Name := + new String'(Base_Name (Ali_File_Name.all) + & Get_Debuggable_Suffix.all); + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'("-o"); + + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Output_File_Name.all); + + end if; + + -- Warn if main program is called "test", as that may be a built-in command + -- on Unix. On non-Unix systems executables have a suffix, so the warning + -- will not appear. However, do not warn in the case of a cross compiler. + + -- Assume that if the executable name is not gnatlink, this is a cross + -- tool. + + if Base_Name (Command_Name) = "gnatlink" + and then Output_File_Name.all = "test" + then + Error_Msg ("warning: executable name """ & Output_File_Name.all + & """ may conflict with shell command"); + end if; + + -- Perform consistency checks + + -- Transform the .ali file name into the binder output file name. + + Make_Binder_File_Names : declare + Fname : String := Base_Name (Ali_File_Name.all); + Fname_Len : Integer := Fname'Length; + + function Get_Maximum_File_Name_Length return Integer; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + + Maximum_File_Name_Length : Integer := Get_Maximum_File_Name_Length; + + Second_Char : Character; + -- Second character of name of files + + begin + -- Set proper second character of file name + + if not Ada_Bind_File then + Second_Char := '_'; + + elsif Hostparm.OpenVMS then + Second_Char := '$'; + + else + Second_Char := '~'; + end if; + + -- If the length of the binder file becomes too long due to + -- the addition of the "b?" prefix, then truncate it. + + if Maximum_File_Name_Length > 0 then + while Fname_Len > Maximum_File_Name_Length - 2 loop + Fname_Len := Fname_Len - 1; + end loop; + end if; + + if Ada_Bind_File then + Binder_Spec_Src_File := + new String'('b' + & Second_Char + & Fname (Fname'First .. Fname'First + Fname_Len - 1) + & ".ads"); + Binder_Body_Src_File := + new String'('b' + & Second_Char + & Fname (Fname'First .. Fname'First + Fname_Len - 1) + & ".adb"); + Binder_Ali_File := + new String'('b' + & Second_Char + & Fname (Fname'First .. Fname'First + Fname_Len - 1) + & ".ali"); + + else + Binder_Body_Src_File := + new String'('b' + & Second_Char + & Fname (Fname'First .. Fname'First + Fname_Len - 1) + & ".c"); + end if; + + Binder_Obj_File := + new String'('b' + & Second_Char + & Fname (Fname'First .. Fname'First + Fname_Len - 1) + & Get_Object_Suffix.all); + + if Fname_Len /= Fname'Length then + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-o"); + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := Binder_Obj_File; + end if; + + end Make_Binder_File_Names; + + Process_Binder_File (Binder_Body_Src_File.all & ASCII.NUL); + + -- Compile the binder file. This is fast, so we always do it, unless + -- specifically told not to by the -n switch + + if Compile_Bind_File then + Bind_Step : declare + Success : Boolean; + Args : Argument_List (1 .. Binder_Options.Last + 1); + + begin + for J in Binder_Options.First .. Binder_Options.Last loop + Args (J) := Binder_Options.Table (J); + end loop; + + Args (Args'Last) := Binder_Body_Src_File; + + if Verbose_Mode then + Write_Str (Base_Name (Gcc_Path.all)); + + for J in Args'Range loop + Write_Str (" "); + Write_Str (Args (J).all); + end loop; + + Write_Eol; + end if; + + GNAT.OS_Lib.Spawn (Gcc_Path.all, Args, Success); + + if not Success then + Exit_Program (E_Fatal); + end if; + end Bind_Step; + end if; + + -- Now, actually link the program. + + -- Skip this step for now on the JVM since the Java interpreter will do + -- the actual link at run time. We might consider packing all class files + -- in a .zip file during this step. + + if not Hostparm.Java_VM then + Link_Step : declare + Num_Args : Natural := + (Linker_Options.Last - Linker_Options.First + 1) + + (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) + + (Linker_Objects.Last - Linker_Objects.First + 1); + Stack_Op : Boolean := False; + IDENT_Op : Boolean := False; + + begin + -- Remove duplicate stack size setting from the Linker_Options + -- table. The stack setting option "-Xlinker --stack=R,C" can be + -- found in one line when set by a pragma Linker_Options or in two + -- lines ("-Xlinker" then "--stack=R,C") when set on the command + -- line. We also check for the "-Wl,--stack=R" style option. + + -- We must remove the second stack setting option instance + -- because the one on the command line will always be the first + -- one. And any subsequent stack setting option will overwrite the + -- previous one. This is done especially for GNAT/NT where we set + -- the stack size for tasking programs by a pragma in the NT + -- specific tasking package System.Task_Primitives.Oparations. + + for J in Linker_Options.First .. Linker_Options.Last loop + if Linker_Options.Table (J).all = "-Xlinker" + and then J < Linker_Options.Last + and then Linker_Options.Table (J + 1)'Length > 8 + and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack=" + then + if Stack_Op then + Linker_Options.Table (J .. Linker_Options.Last - 2) := + Linker_Options.Table (J + 2 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 2; + + else + Stack_Op := True; + end if; + end if; + + -- Here we just check for a canonical form that matches the + -- pragma Linker_Options set in the NT runtime. + + if (Linker_Options.Table (J)'Length > 17 + and then Linker_Options.Table (J) (1 .. 17) + = "-Xlinker --stack=") + or else + (Linker_Options.Table (J)'Length > 12 + and then Linker_Options.Table (J) (1 .. 12) + = "-Wl,--stack=") + then + if Stack_Op then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + else + Stack_Op := True; + end if; + end if; + + -- Remove duplicate IDENTIFICATION directives (VMS) + + if Linker_Options.Table (J)'Length > 27 + and then Linker_Options.Table (J) (1 .. 27) + = "--for-linker=IDENTIFICATION=" + then + if IDENT_Op then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + else + IDENT_Op := True; + end if; + end if; + end loop; + + -- Prepare arguments for call to linker + + Call_Linker : declare + Success : Boolean; + Args : Argument_List (1 .. Num_Args + 1); + Index : Integer := Args'First; + + begin + Args (Index) := Binder_Obj_File; + + -- Add the object files and any -largs libraries + + for J in Linker_Objects.First .. Linker_Objects.Last loop + Index := Index + 1; + Args (Index) := Linker_Objects.Table (J); + end loop; + + -- Add the linker options from the binder file + + for J in Linker_Options.First .. Linker_Options.Last loop + Index := Index + 1; + Args (Index) := Linker_Options.Table (J); + end loop; + + -- Finally add the libraries from the --GCC= switch + + for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop + Index := Index + 1; + Args (Index) := Gcc_Linker_Options.Table (J); + end loop; + + if Verbose_Mode then + Write_Str (Linker_Path.all); + + for J in Args'Range loop + Write_Str (" "); + Write_Str (Args (J).all); + end loop; + + Write_Eol; + + -- If we are on very verbose mode (-v -v) and a response file + -- is used we display its content. + + if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then + Write_Eol; + Write_Str ("Response file (" & + Tname (Tname'First .. Tname'Last - 1) & + ") content : "); + Write_Eol; + + for J in + Response_File_Objects.First .. + Response_File_Objects.Last + loop + Write_Str (Response_File_Objects.Table (J).all); + Write_Eol; + end loop; + + Write_Eol; + end if; + end if; + + GNAT.OS_Lib.Spawn (Linker_Path.all, Args, Success); + + -- Delete the temporary file used in conjuction with linking if + -- one was created. See Process_Bind_File for details. + + if Tname_FD /= Invalid_FD then + Delete (Tname); + end if; + + if not Success then + Error_Msg ("cannot call " & Linker_Path.all); + Exit_Program (E_Fatal); + end if; + end Call_Linker; + end Link_Step; + end if; + + -- Only keep the binder output file and it's associated object + -- file if compiling with the -g option. These files are only + -- useful if debugging. + + if not Debug_Flag_Present then + if Binder_Ali_File /= null then + Delete (Binder_Ali_File.all & ASCII.NUL); + end if; + + if Binder_Spec_Src_File /= null then + Delete (Binder_Spec_Src_File.all & ASCII.NUL); + end if; + + Delete (Binder_Body_Src_File.all & ASCII.NUL); + + if not Hostparm.Java_VM then + Delete (Binder_Obj_File.all & ASCII.NUL); + end if; + end if; + + Exit_Program (E_Success); + +exception + when others => + Exit_With_Error ("INTERNAL ERROR. Please report."); +end Gnatlink; diff --git a/gcc/ada/gnatlink.ads b/gcc/ada/gnatlink.ads new file mode 100644 index 00000000000..65e4845a7a0 --- /dev/null +++ b/gcc/ada/gnatlink.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L I N K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1996 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +procedure Gnatlink; +-- The driver for the gnatlink tool. This utility produces an +-- executable program from a set compiled object files and +-- libraries. For more information on gnatlink (its precise usage, +-- flags and algorithm) please refer to the body of gnatlink. diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb new file mode 100644 index 00000000000..b131ddb572f --- /dev/null +++ b/gcc/ada/gnatls.adb @@ -0,0 +1,1157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.37 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with ALI.Util; use ALI.Util; +with Binderr; use Binderr; +with Butil; use Butil; +with Csets; +with Fname; use Fname; +with Gnatvsn; use Gnatvsn; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prj; use Prj; +with Prj.Pars; use Prj.Pars; +with Prj.Env; +with Prj.Ext; use Prj.Ext; +with Prj.Util; use Prj.Util; +with Snames; use Snames; +with Stringt; use Stringt; +with Types; use Types; + +procedure Gnatls is + pragma Ident (Gnat_Version_String); + + Max_Column : constant := 80; + + type File_Status is ( + OK, -- matching timestamp + Checksum_OK, -- only matching checksum + Not_Found, -- file not found on source PATH + Not_Same, -- neither checksum nor timestamp matching + Not_First_On_PATH); -- matching file hidden by Not_Same file on path + + type Dir_Data; + type Dir_Ref is access Dir_Data; + + type Dir_Data is record + Value : String_Access; + Next : Dir_Ref; + end record; + + First_Source_Dir : Dir_Ref; + Last_Source_Dir : Dir_Ref; + -- The list of source directories from the command line. + -- These directories are added using Osint.Add_Src_Search_Dir + -- after those of the GNAT Project File, if any. + + First_Lib_Dir : Dir_Ref; + Last_Lib_Dir : Dir_Ref; + -- The list of object directories from the command line. + -- These directories are added using Osint.Add_Lib_Search_Dir + -- after those of the GNAT Project File, if any. + + Main_File : File_Name_Type; + Ali_File : File_Name_Type; + + Text : Text_Buffer_Ptr; + Id : ALI_Id; + + Next_Arg : Positive; + + Too_Long : Boolean := False; + -- When True, lines are too long for multi-column output and each + -- item of information is on a different line. + + Project_File : String_Access; + Project : Prj.Project_Id; + Current_Verbosity : Prj.Verbosity := Prj.Default; + + Selective_Output : Boolean := False; + Print_Usage : Boolean := False; + Print_Unit : Boolean := True; + Print_Source : Boolean := True; + Print_Object : Boolean := True; + -- Flags controlling the form of the outpout + + Dependable : Boolean := False; -- flag -d + Also_Predef : Boolean := False; + + Unit_Start : Integer; + Unit_End : Integer; + Source_Start : Integer; + Source_End : Integer; + Object_Start : Integer; + Object_End : Integer; + -- Various column starts and ends + + Spaces : constant String (1 .. Max_Column) := (others => ' '); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Lib_Dir (Dir : String; And_Save : Boolean); + -- Add an object directory, using Osint.Add_Lib_Search_Dir + -- if And_Save is False or keeping in the list First_Lib_Dir, + -- Last_Lib_Dir if And_Save is True. + + procedure Add_Source_Dir (Dir : String; And_Save : Boolean); + -- Add a source directory, using Osint.Add_Src_Search_Dir + -- if And_Save is False or keeping in the list First_Source_Dir, + -- Last_Source_Dir if And_Save is True. + + procedure Find_General_Layout; + -- Determine the structure of the output (multi columns or not, etc) + + procedure Find_Status + (FS : in out File_Name_Type; + Stamp : Time_Stamp_Type; + Checksum : Word; + Status : out File_Status); + -- Determine the file status (Status) of the file represented by FS + -- with the expected Stamp and checksum given as argument. FS will be + -- updated to the full file name if available. + + function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id; + -- Give the Sdep entry corresponding to the unit U in ali record A. + + function Index (Char : Character; Str : String) return Natural; + -- Returns the first occurence of Char in Str. + -- Returns 0 if Char is not in Str. + + procedure Output_Object (O : File_Name_Type); + -- Print out the name of the object when requested + + procedure Output_Source (Sdep_I : Sdep_Id); + -- Print out the name and status of the source corresponding to this + -- sdep entry + + procedure Output_Status (FS : File_Status; Verbose : Boolean); + -- Print out FS either in a coded form if verbose is false or in an + -- expanded form otherwise. + + procedure Output_Unit (U_Id : Unit_Id); + -- Print out information on the unit when requested + + procedure Reset_Print; + -- Reset Print flags properly when selective output is chosen + + procedure Scan_Ls_Arg (Argv : String; And_Save : Boolean); + -- Scan and process lser specific arguments. Argv is a single argument. + + procedure Usage; + -- Print usage message. + + ----------------- + -- Add_Lib_Dir -- + ----------------- + + procedure Add_Lib_Dir (Dir : String; And_Save : Boolean) is + begin + if And_Save then + if First_Lib_Dir = null then + First_Lib_Dir := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Lib_Dir := First_Lib_Dir; + + else + Last_Lib_Dir.Next := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Lib_Dir := Last_Lib_Dir.Next; + end if; + + else + Add_Lib_Search_Dir (Dir); + end if; + end Add_Lib_Dir; + + -- ----------------- + -- Add_Source_Dir -- + -------------------- + + procedure Add_Source_Dir (Dir : String; And_Save : Boolean) is + begin + if And_Save then + if First_Source_Dir = null then + First_Source_Dir := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Source_Dir := First_Source_Dir; + + else + Last_Source_Dir.Next := + new Dir_Data' + (Value => new String'(Dir), + Next => null); + Last_Source_Dir := Last_Source_Dir.Next; + end if; + + else + Add_Src_Search_Dir (Dir); + end if; + end Add_Source_Dir; + + ------------------------------ + -- Corresponding_Sdep_Entry -- + ------------------------------ + + function Corresponding_Sdep_Entry + (A : ALI_Id; + U : Unit_Id) + return Sdep_Id + is + begin + for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop + if Sdep.Table (D).Sfile = Units.Table (U).Sfile then + return D; + end if; + end loop; + + Error_Msg_Name_1 := Units.Table (U).Uname; + Error_Msg_Name_2 := ALIs.Table (A).Afile; + Write_Eol; + Error_Msg ("wrong ALI format, can't find dependancy line for & in %"); + Exit_Program (E_Fatal); + + -- Not needed since we exit the program but avoids compiler warning + + raise Program_Error; + end Corresponding_Sdep_Entry; + + ------------------------- + -- Find_General_Layout -- + ------------------------- + + procedure Find_General_Layout is + Max_Unit_Length : Integer := 11; + Max_Src_Length : Integer := 11; + Max_Obj_Length : Integer := 11; + + Len : Integer; + FS : File_Name_Type; + + begin + -- Compute maximum of each column + + for Id in ALIs.First .. ALIs.Last loop + + Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); + if Also_Predef or else not Is_Internal_Unit then + + if Print_Unit then + Len := Name_Len - 1; + Max_Unit_Length := Integer'Max (Max_Unit_Length, Len); + end if; + + if Print_Source then + FS := Full_Source_Name (ALIs.Table (Id).Sfile); + + if FS = No_File then + Get_Name_String (ALIs.Table (Id).Sfile); + Name_Len := Name_Len + 13; + else + Get_Name_String (FS); + end if; + + Max_Src_Length := Integer'Max (Max_Src_Length, Name_Len + 1); + end if; + + if Print_Object then + Get_Name_String (ALIs.Table (Id).Ofile_Full_Name); + Max_Obj_Length := Integer'Max (Max_Obj_Length, Name_Len + 1); + end if; + end if; + end loop; + + -- Verify is output is not wider than maximum number of columns + + Too_Long := Verbose_Mode or else + (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column; + + -- Set start and end of columns. + + Object_Start := 1; + Object_End := Object_Start - 1; + + if Print_Object then + Object_End := Object_Start + Max_Obj_Length; + end if; + + Unit_Start := Object_End + 1; + Unit_End := Unit_Start - 1; + + if Print_Unit then + Unit_End := Unit_Start + Max_Unit_Length; + end if; + + Source_Start := Unit_End + 1; + if Source_Start > Spaces'Last then + Source_Start := Spaces'Last; + end if; + Source_End := Source_Start - 1; + + if Print_Source then + Source_End := Source_Start + Max_Src_Length; + end if; + end Find_General_Layout; + + ----------------- + -- Find_Status -- + ----------------- + + procedure Find_Status + (FS : in out File_Name_Type; + Stamp : Time_Stamp_Type; + Checksum : Word; + Status : out File_Status) + is + Tmp1 : File_Name_Type; + Tmp2 : File_Name_Type; + + begin + Tmp1 := Full_Source_Name (FS); + + if Tmp1 = No_File then + Status := Not_Found; + + elsif File_Stamp (Tmp1) = Stamp then + FS := Tmp1; + Status := OK; + + elsif Get_File_Checksum (FS) = Checksum then + FS := Tmp1; + Status := Checksum_OK; + + else + Tmp2 := Matching_Full_Source_Name (FS, Stamp); + + if Tmp2 = No_File then + Status := Not_Same; + FS := Tmp1; + + else + Status := Not_First_On_PATH; + FS := Tmp2; + end if; + end if; + end Find_Status; + + ----------- + -- Index -- + ----------- + + function Index (Char : Character; Str : String) return Natural is + begin + for Index in Str'Range loop + if Str (Index) = Char then + return Index; + end if; + end loop; + + return 0; + end Index; + + ------------------- + -- Output_Object -- + ------------------- + + procedure Output_Object (O : File_Name_Type) is + Object_Name : String_Access; + begin + if Print_Object then + Get_Name_String (O); + Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); + Write_Str (Object_Name.all); + if Print_Source or else Print_Unit then + if Too_Long then + Write_Eol; + Write_Str (" "); + else + Write_Str (Spaces + (Object_Start + Object_Name'Length .. Object_End)); + end if; + end if; + end if; + end Output_Object; + + ------------------- + -- Output_Source -- + ------------------- + + procedure Output_Source (Sdep_I : Sdep_Id) is + Stamp : constant Time_Stamp_Type := Sdep.Table (Sdep_I).Stamp; + Checksum : constant Word := Sdep.Table (Sdep_I).Checksum; + FS : File_Name_Type := Sdep.Table (Sdep_I).Sfile; + Status : File_Status; + Object_Name : String_Access; + + begin + if Print_Source then + Find_Status (FS, Stamp, Checksum, Status); + Get_Name_String (FS); + + Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); + + if Verbose_Mode then + Write_Str (" Source => "); + Write_Str (Object_Name.all); + + if not Too_Long then + Write_Str + (Spaces (Source_Start + Object_Name'Length .. Source_End)); + end if; + + Output_Status (Status, Verbose => True); + Write_Eol; + Write_Str (" "); + + else + if not Selective_Output then + Output_Status (Status, Verbose => False); + end if; + + Write_Str (Object_Name.all); + end if; + end if; + end Output_Source; + + ------------------- + -- Output_Status -- + ------------------- + + procedure Output_Status (FS : File_Status; Verbose : Boolean) is + begin + if Verbose then + case FS is + when OK => + Write_Str (" unchanged"); + + when Checksum_OK => + Write_Str (" slightly modified"); + + when Not_Found => + Write_Str (" file not found"); + + when Not_Same => + Write_Str (" modified"); + + when Not_First_On_PATH => + Write_Str (" unchanged version not first on PATH"); + end case; + + else + case FS is + when OK => + Write_Str (" OK "); + + when Checksum_OK => + Write_Str (" MOK "); + + when Not_Found => + Write_Str (" ??? "); + + when Not_Same => + Write_Str (" DIF "); + + when Not_First_On_PATH => + Write_Str (" HID "); + end case; + end if; + end Output_Status; + + ----------------- + -- Output_Unit -- + ----------------- + + procedure Output_Unit (U_Id : Unit_Id) is + Kind : Character; + U : Unit_Record renames Units.Table (U_Id); + + begin + if Print_Unit then + Get_Name_String (U.Uname); + Kind := Name_Buffer (Name_Len); + Name_Len := Name_Len - 2; + + if not Verbose_Mode then + Write_Str (Name_Buffer (1 .. Name_Len)); + + else + Write_Str ("Unit => "); + Write_Eol; Write_Str (" Name => "); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; Write_Str (" Kind => "); + + if Units.Table (U_Id).Unit_Kind = 'p' then + Write_Str ("package "); + else + Write_Str ("subprogram "); + end if; + + if Kind = 's' then + Write_Str ("spec"); + else + Write_Str ("body"); + end if; + end if; + + if Verbose_Mode then + if U.Preelab or + U.No_Elab or + U.Pure or + U.Elaborate_Body or + U.Remote_Types or + U.Shared_Passive or + U.RCI or + U.Predefined + then + Write_Eol; Write_Str (" Flags =>"); + + if U.Preelab then + Write_Str (" Preelaborable"); + end if; + + if U.No_Elab then + Write_Str (" No_Elab_Code"); + end if; + + if U.Pure then + Write_Str (" Pure"); + end if; + + if U.Elaborate_Body then + Write_Str (" Elaborate Body"); + end if; + + if U.Remote_Types then + Write_Str (" Remote_Types"); + end if; + + if U.Shared_Passive then + Write_Str (" Shared_Passive"); + end if; + + if U.Predefined then + Write_Str (" Predefined"); + end if; + + if U.RCI then + Write_Str (" Remote_Call_Interface"); + end if; + end if; + end if; + + if Print_Source then + if Too_Long then + Write_Eol; Write_Str (" "); + else + Write_Str (Spaces (Unit_Start + Name_Len + 1 .. Unit_End)); + end if; + end if; + end if; + end Output_Unit; + + ----------------- + -- Reset_Print -- + ----------------- + + procedure Reset_Print is + begin + if not Selective_Output then + Selective_Output := True; + Print_Source := False; + Print_Object := False; + Print_Unit := False; + end if; + end Reset_Print; + + ------------------- + -- Scan_Ls_Arg -- + ------------------- + + procedure Scan_Ls_Arg (Argv : String; And_Save : Boolean) is + begin + pragma Assert (Argv'First = 1); + + if Argv'Length = 0 then + return; + end if; + + if Argv (1) = Switch_Character or else Argv (1) = '-' then + + if Argv'Length = 1 then + Fail ("switch character cannot be followed by a blank"); + + -- -I- + + elsif Argv (2 .. Argv'Last) = "I-" then + Opt.Look_In_Primary_Dir := False; + + -- Forbid -?- or -??- where ? is any character + + elsif (Argv'Length = 3 and then Argv (3) = '-') + or else (Argv'Length = 4 and then Argv (4) = '-') + then + Fail ("Trailing ""-"" at the end of ", Argv, " forbidden."); + + -- -Idir + + elsif Argv (2) = 'I' then + Add_Source_Dir (Argv (3 .. Argv'Last), And_Save); + Add_Lib_Dir (Argv (3 .. Argv'Last), And_Save); + + -- -aIdir (to gcc this is like a -I switch) + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then + Add_Source_Dir (Argv (4 .. Argv'Last), And_Save); + + -- -aOdir + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then + Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); + + -- -aLdir (to gnatbind this is like a -aO switch) + + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then + Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); + + -- -vPx + + elsif Argv'Length = 4 and then Argv (2 .. 3) = "vP" then + case Argv (4) is + when '0' => + Current_Verbosity := Prj.Default; + when '1' => + Current_Verbosity := Prj.Medium; + when '2' => + Current_Verbosity := Prj.High; + when others => + null; + end case; + + -- -Pproject_file + + elsif Argv'Length >= 3 and then Argv (2) = 'P' then + if Project_File /= null then + Fail (Argv & ": second project file forbidden (first is """ & + Project_File.all & """)"); + else + Project_File := new String'(Argv (3 .. Argv'Last)); + end if; + + -- -Xexternal=value + + elsif Argv'Length >= 5 and then Argv (2) = 'X' then + declare + Equal_Pos : constant Natural := + Index ('=', Argv (3 .. Argv'Last)); + begin + if Equal_Pos >= 4 and then + Equal_Pos /= Argv'Last then + Add (External_Name => Argv (3 .. Equal_Pos - 1), + Value => Argv (Equal_Pos + 1 .. Argv'Last)); + else + Fail (Argv & " is not a valid external assignment."); + end if; + end; + + elsif Argv (2 .. Argv'Last) = "nostdinc" then + Opt.No_Stdinc := True; + + elsif Argv'Length = 2 then + case Argv (2) is + when 'a' => Also_Predef := True; + when 'h' => Print_Usage := True; + when 'u' => Reset_Print; Print_Unit := True; + when 's' => Reset_Print; Print_Source := True; + when 'o' => Reset_Print; Print_Object := True; + when 'v' => Verbose_Mode := True; + when 'd' => Dependable := True; + when others => null; + end case; + end if; + + -- If not a switch it must be a file name + + else + Set_Main_File_Name (Argv); + end if; + end Scan_Ls_Arg; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + procedure Write_Switch_Char; + -- Write two spaces followed by appropriate switch character + + procedure Write_Switch_Char is + begin + Write_Str (" "); + Write_Char (Switch_Character); + end Write_Switch_Char; + + -- Start of processing for Usage + + begin + -- Usage line + + Write_Str ("Usage: "); + Osint.Write_Program_Name; + Write_Str (" switches [list of object files]"); + Write_Eol; + Write_Eol; + + -- GNATLS switches + + Write_Str ("switches:"); + Write_Eol; + + -- Line for -a + + Write_Switch_Char; + Write_Str ("a also output relevant predefined units"); + Write_Eol; + + -- Line for -u + + Write_Switch_Char; + Write_Str ("u output only relevant unit names"); + Write_Eol; + + -- Line for -h + + Write_Switch_Char; + Write_Str ("h output this help message"); + Write_Eol; + + -- Line for -s + + Write_Switch_Char; + Write_Str ("s output only relevant source names"); + Write_Eol; + + -- Line for -o + + Write_Switch_Char; + Write_Str ("o output only relevant object names"); + Write_Eol; + + -- Line for -d + + Write_Switch_Char; + Write_Str ("d output sources on which specified units depend"); + Write_Eol; + + -- Line for -v + + Write_Switch_Char; + Write_Str ("v verbose output, full path and unit information"); + Write_Eol; + Write_Eol; + + -- Line for -aI switch + + Write_Switch_Char; + Write_Str ("aIdir specify source files search path"); + Write_Eol; + + -- Line for -aO switch + + Write_Switch_Char; + Write_Str ("aOdir specify object files search path"); + Write_Eol; + + -- Line for -I switch + + Write_Switch_Char; + Write_Str ("Idir like -aIdir -aOdir"); + Write_Eol; + + -- Line for -I- switch + + Write_Switch_Char; + Write_Str ("I- do not look for sources & object files"); + Write_Str (" in the default directory"); + Write_Eol; + + -- Line for -vPx + + Write_Switch_Char; + Write_Str ("vPx verbosity for project file (0, 1 or 2)"); + Write_Eol; + + -- Line for -Pproject_file + + Write_Switch_Char; + Write_Str ("Pprj use a project file prj"); + Write_Eol; + + -- Line for -Xexternal=value + + Write_Switch_Char; + Write_Str ("Xext=val specify an external value."); + Write_Eol; + + -- Line for -nostdinc + + Write_Switch_Char; + Write_Str ("nostdinc do not look for source files"); + Write_Str (" in the system default directory"); + Write_Eol; + + -- File Status explanation + + Write_Eol; + Write_Str (" file status can be:"); + Write_Eol; + + for ST in File_Status loop + Write_Str (" "); + Output_Status (ST, Verbose => False); + Write_Str (" ==> "); + Output_Status (ST, Verbose => True); + Write_Eol; + end loop; + + end Usage; + + -- Start of processing for Gnatls + +begin + Osint.Initialize (Binder); + + Namet.Initialize; + Csets.Initialize; + + Snames.Initialize; + + Prj.Initialize; + + -- Use low level argument routines to avoid dragging in the secondary stack + + Next_Arg := 1; + + Scan_Args : while Next_Arg < Arg_Count loop + declare + Next_Argv : String (1 .. Len_Arg (Next_Arg)); + + begin + Fill_Arg (Next_Argv'Address, Next_Arg); + Scan_Ls_Arg (Next_Argv, And_Save => True); + end; + + Next_Arg := Next_Arg + 1; + end loop Scan_Args; + + -- If a switch -P is used, parse the project file + + if Project_File /= null then + + Prj.Pars.Set_Verbosity (To => Current_Verbosity); + + Prj.Pars.Parse + (Project => Project, + Project_File_Name => Project_File.all); + + if Project = Prj.No_Project then + Fail ("""" & Project_File.all & """ processing failed"); + end if; + + -- Add the source directories and the object directories + -- to the searched directories. + + declare + procedure Register_Source_Dirs is new + Prj.Env.For_All_Source_Dirs (Add_Src_Search_Dir); + + procedure Register_Object_Dirs is new + Prj.Env.For_All_Object_Dirs (Add_Lib_Search_Dir); + + begin + Register_Source_Dirs (Project); + Register_Object_Dirs (Project); + end; + + -- Check if a package gnatls is in the project file and if there is + -- there is one, get the switches, if any, and scan them. + + declare + Data : Prj.Project_Data := Prj.Projects.Table (Project); + Pkg : Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Gnatls, + In_Packages => Data.Decl.Packages); + Element : Package_Element; + Switches : Prj.Variable_Value; + Current : Prj.String_List_Id; + The_String : String_Element; + + begin + if Pkg /= No_Package then + Element := Packages.Table (Pkg); + Switches := + Prj.Util.Value_Of + (Variable_Name => Name_Switches, + In_Variables => Element.Decl.Attributes); + + case Switches.Kind is + when Prj.Undefined => + null; + + when Prj.Single => + if String_Length (Switches.Value) > 0 then + String_To_Name_Buffer (Switches.Value); + Scan_Ls_Arg + (Name_Buffer (1 .. Name_Len), + And_Save => False); + end if; + + when Prj.List => + Current := Switches.Values; + while Current /= Prj.Nil_String loop + The_String := String_Elements.Table (Current); + + if String_Length (The_String.Value) > 0 then + String_To_Name_Buffer (The_String.Value); + Scan_Ls_Arg + (Name_Buffer (1 .. Name_Len), + And_Save => False); + end if; + + Current := The_String.Next; + end loop; + end case; + end if; + end; + end if; + + -- Add the source and object directories specified on the + -- command line, if any, to the searched directories. + + while First_Source_Dir /= null loop + Add_Src_Search_Dir (First_Source_Dir.Value.all); + First_Source_Dir := First_Source_Dir.Next; + end loop; + + while First_Lib_Dir /= null loop + Add_Lib_Search_Dir (First_Lib_Dir.Value.all); + First_Lib_Dir := First_Lib_Dir.Next; + end loop; + + -- Finally, add the default directories. + + Osint.Add_Default_Search_Dirs; + + if Verbose_Mode then + + -- WARNING: the output of gnatls -v is used during the compilation + -- and installation of GLADE to recreate sdefault.adb and locate + -- the libgnat.a to use. Any change in the output of gnatls -v must + -- be synchronized with the GLADE Dist/config.sdefault shell script. + + Write_Eol; + Write_Str ("GNATLS "); + Write_Str (Gnat_Version_String); + Write_Str (" Copyright 1997-2001 Free Software Foundation, Inc."); + Write_Eol; + Write_Eol; + Write_Str ("Source Search Path:"); + Write_Eol; + + for J in 1 .. Nb_Dir_In_Src_Search_Path loop + Write_Str (" "); + + if Dir_In_Src_Search_Path (J)'Length = 0 then + Write_Str ("<Current_Directory>"); + else + Write_Str (To_Host_Dir_Spec + (Dir_In_Src_Search_Path (J).all, True).all); + end if; + + Write_Eol; + end loop; + + Write_Eol; + Write_Eol; + Write_Str ("Object Search Path:"); + Write_Eol; + + for J in 1 .. Nb_Dir_In_Obj_Search_Path loop + Write_Str (" "); + + if Dir_In_Obj_Search_Path (J)'Length = 0 then + Write_Str ("<Current_Directory>"); + else + Write_Str (To_Host_Dir_Spec + (Dir_In_Obj_Search_Path (J).all, True).all); + end if; + + Write_Eol; + end loop; + + Write_Eol; + end if; + + -- Output usage information when requested + + if Print_Usage then + Usage; + end if; + + if not More_Lib_Files then + if not Print_Usage and then not Verbose_Mode then + Usage; + end if; + + Exit_Program (E_Fatal); + end if; + + Initialize_ALI; + Initialize_ALI_Source; + + -- Print out all library for which no ALI files can be located + + while More_Lib_Files loop + Main_File := Next_Main_Lib_File; + Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File)); + + if Ali_File = No_File then + Write_Str ("Can't find library info for "); + Get_Decoded_Name_String (Main_File); + Write_Char ('"'); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Char ('"'); + Write_Eol; + + else + Ali_File := Strip_Directory (Ali_File); + + if Get_Name_Table_Info (Ali_File) = 0 then + Text := Read_Library_Info (Ali_File, True); + Id := + Scan_ALI + (Ali_File, Text, Ignore_ED => False, Err => False); + Free (Text); + end if; + end if; + end loop; + + Find_General_Layout; + for Id in ALIs.First .. ALIs.Last loop + declare + Last_U : Unit_Id; + + begin + Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); + + if Also_Predef or else not Is_Internal_Unit then + Output_Object (ALIs.Table (Id).Ofile_Full_Name); + + -- In verbose mode print all main units in the ALI file, otherwise + -- just print the first one to ease columnwise printout + + if Verbose_Mode then + Last_U := ALIs.Table (Id).Last_Unit; + else + Last_U := ALIs.Table (Id).First_Unit; + end if; + + for U in ALIs.Table (Id).First_Unit .. Last_U loop + if U /= ALIs.Table (Id).First_Unit + and then Selective_Output + and then Print_Unit + then + Write_Eol; + end if; + + Output_Unit (U); + + -- Output source now, unless if it will be done as part of + -- outputing dependancies. + + if not (Dependable and then Print_Source) then + Output_Source (Corresponding_Sdep_Entry (Id, U)); + end if; + end loop; + + -- Print out list of dependable units + + if Dependable and then Print_Source then + if Verbose_Mode then + Write_Str ("depends upon"); + Write_Eol; + Write_Str (" "); + + else + Write_Eol; + end if; + + for D in + ALIs.Table (Id).First_Sdep .. ALIs.Table (Id).Last_Sdep + loop + if Also_Predef + or else not Is_Internal_File_Name (Sdep.Table (D).Sfile) + then + if Verbose_Mode then + Write_Str (" "); + Output_Source (D); + elsif Too_Long then + Write_Str (" "); + Output_Source (D); + Write_Eol; + else + Write_Str (Spaces (1 .. Source_Start - 2)); + Output_Source (D); + Write_Eol; + end if; + end if; + end loop; + end if; + + Write_Eol; + end if; + end; + end loop; + + -- All done. Set proper exit status. + + Namet.Finalize; + Exit_Program (E_Success); + +end Gnatls; diff --git a/gcc/ada/gnatls.ads b/gcc/ada/gnatls.ads new file mode 100644 index 00000000000..fc499abc751 --- /dev/null +++ b/gcc/ada/gnatls.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T L S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 1992-1997 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- GNAT Library browser. + +procedure Gnatls; diff --git a/gcc/ada/gnatmake.adb b/gcc/ada/gnatmake.adb new file mode 100644 index 00000000000..0380b6f8610 --- /dev/null +++ b/gcc/ada/gnatmake.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T M A K E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.19 $ -- +-- -- +-- Copyright (C) 1992-1997 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Gnatmake usage: please consult the gnat documentation + +with Gnatvsn; +with Make; + +procedure Gnatmake is + pragma Ident (Gnatvsn.Gnat_Version_String); + +begin + -- The real work is done in Package Make. Gnatmake used to be a standalone + -- routine. Now Gnatmake's facilities have been placed in a package + -- because a number of gnatmake's services may be useful to others. + + Make.Gnatmake; +end Gnatmake; diff --git a/gcc/ada/gnatmake.ads b/gcc/ada/gnatmake.ads new file mode 100644 index 00000000000..5d46676c38d --- /dev/null +++ b/gcc/ada/gnatmake.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T M A K E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +procedure Gnatmake; +-- The driver for the gnatmake tool. This utility can be used to +-- automatically (re)compile a set of ada sources by giving the name +-- of the root compilation unit or the source file containing it. +-- For more information on gnatmake (its precise usage, flags and algorithm) +-- please refer to the body of gnatmake. diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb new file mode 100644 index 00000000000..b3457118f9a --- /dev/null +++ b/gcc/ada/gnatmem.adb @@ -0,0 +1,1059 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T M E M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.24 $ +-- -- +-- Copyright (C) 1997-2001, Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- GNATMEM is a utility that tracks memory leaks. It is based on a simple +-- idea: +-- - run the application under gdb +-- - set a breakpoint on __gnat_malloc and __gnat_free +-- - record a reference to the allocated memory on each allocation call +-- - suppress this reference on deallocation +-- - at the end of the program, remaining references are potential leaks. +-- sort them out the best possible way in order to locate the root of +-- the leak. +-- +-- GNATMEM can also be used with instrumented allocation/deallocation +-- routine (see a-raise.c with symbol GMEM defined). This is not supported +-- in all platforms, again refer to a-raise.c for further information. +-- In this case the application must be relinked with library libgmem.a: +-- +-- $ gnatmake my_prog -largs -lgmem +-- +-- The running my_prog will produce a file named gmem.out that will be +-- parsed by gnatmem. +-- +-- In order to help finding out the real leaks, the notion of "allocation +-- root" is defined. An allocation root is a specific point in the program +-- execution generating memory allocation where data is collected (such as +-- number of allocations, quantify of memory allocated, high water mark, +-- etc.). + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Text_IO.C_Streams; +with Ada.Float_Text_IO; +with Ada.Integer_Text_IO; +with Gnatvsn; use Gnatvsn; +with GNAT.Heap_Sort_G; +with GNAT.OS_Lib; +with GNAT.HTable; use GNAT.HTable; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +with Memroot; use Memroot; + +procedure Gnatmem is + + ------------------------------------------------ + -- Potentially Target Dependant Subprograms. -- + ------------------------------------------------ + + function Get_Current_TTY return String; + -- Give the current tty on which the program is run. This is needed to + -- separate the output of the debugger from the output of the program. + -- The output of this function will be used to call the gdb command "tty" + -- in the gdb script in order to get the program output on the current tty + -- while the gdb output is redirected and processed by gnatmem. + + function popen (File, Mode : System.Address) return FILEs; + pragma Import (C, popen, "popen"); + -- Execute the program 'File'. If the mode is "r" the standard output + -- of the program is redirected and the FILEs handler of the + -- redirection is returned. + + procedure System_Cmd (X : System.Address); + pragma Import (C, System_Cmd, "system"); + -- Execute the program "X". + + subtype Cstring is String (1 .. Integer'Last); + type Cstring_Ptr is access all Cstring; + + function ttyname (Dec : Integer) return Cstring_Ptr; + pragma Import (C, ttyname, "__gnat_ttyname"); + -- Return a null-terminated string containing the current tty + + Dir_Sep : constant Character := '/'; + + ------------------------ + -- Other Declarations -- + ------------------------ + + type Gdb_Output_Elmt is (Eof, Alloc, Deall); + -- Eof = End of gdb output file + -- Alloc = found a ALLOC mark in the gdb output + -- Deall = found a DEALL mark in the gdb output + Gdb_Output_Format_Error : exception; + + function Read_Next return Gdb_Output_Elmt; + -- Read the output of the debugger till it finds either the end of the + -- output, or the 'ALLOC' mark or the 'DEALL' mark. In the second case, + -- it sets the Tmp_Size and Tmp_Address global variables, in the + -- third case it sets the Tmp_Address variable. + + procedure Create_Gdb_Script; + -- Create the GDB script and save it in a temporary file + + function Mem_Image (X : Storage_Count) return String; + -- X is a size in storage_element. Returns a value + -- in Megabytes, Kiloytes or Bytes as appropriate. + + procedure Process_Arguments; + -- Read command line arguments; + + procedure Usage; + -- Prints out the option help + + function Gmem_Initialize (Dumpname : String) return Boolean; + -- Opens the file represented by Dumpname and prepares it for + -- work. Returns False if the file does not have the correct format, True + -- otherwise. + + procedure Gmem_A2l_Initialize (Exename : String); + -- Initialises the convert_addresses interface by supplying it with + -- the name of the executable file Exename + + procedure Gmem_Read_Next (Buf : out String; Last : out Natural); + -- Reads the next allocation/deallocation entry and its backtrace + -- and prepares in the string Buf (up to the position of Last) the + -- expression compatible with gnatmem parser: + -- Allocation entry produces the expression "ALLOC^[size]^0x[address]^" + -- Deallocation entry produces the expression "DEALLOC^0x[address]^" + + Argc : constant Integer := Argument_Count; + Gnatmem_Tmp : aliased constant String := "gnatmem.tmp"; + + Mode_R : aliased constant String (1 .. 2) := 'r' & ASCII.NUL; + Mode_W : aliased constant String (1 .. 3) := "w+" & ASCII.NUL; + + ----------------------------------- + -- HTable address --> Allocation -- + ----------------------------------- + + type Allocation is record + Root : Root_Id; + Size : Storage_Count; + end record; + + type Address_Range is range 0 .. 4097; + function H (A : Integer_Address) return Address_Range; + No_Alloc : constant Allocation := (No_Root_Id, 0); + + package Address_HTable is new GNAT.HTable.Simple_HTable ( + Header_Num => Address_Range, + Element => Allocation, + No_Element => No_Alloc, + Key => Integer_Address, + Hash => H, + Equal => "="); + + BT_Depth : Integer := 1; + FD : FILEs; + FT : File_Type; + File_Pos : Integer := 0; + Exec_Pos : Integer := 0; + Target_Pos : Integer := 0; + Run_Gdb : Boolean := True; + + Global_Alloc_Size : Storage_Count := 0; + Global_High_Water_Mark : Storage_Count := 0; + Global_Nb_Alloc : Integer := 0; + Global_Nb_Dealloc : Integer := 0; + Nb_Root : Integer := 0; + Nb_Wrong_Deall : Integer := 0; + Target_Name : String (1 .. 80); + Target_Protocol : String (1 .. 80); + Target_Name_Len : Integer; + Target_Protocol_Len : Integer; + Cross_Case : Boolean := False; + + + Tmp_Size : Storage_Count := 0; + Tmp_Address : Integer_Address; + Tmp_Alloc : Allocation; + Quiet_Mode : Boolean := False; + + -------------------------------- + -- GMEM functionality binding -- + -------------------------------- + + function Gmem_Initialize (Dumpname : String) return Boolean is + function Initialize (Dumpname : System.Address) return Boolean; + pragma Import (C, Initialize, "__gnat_gmem_initialize"); + S : aliased String := Dumpname & ASCII.NUL; + begin + return Initialize (S'Address); + end Gmem_Initialize; + + procedure Gmem_A2l_Initialize (Exename : String) is + procedure A2l_Initialize (Exename : System.Address); + pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize"); + S : aliased String := Exename & ASCII.NUL; + begin + A2l_Initialize (S'Address); + end Gmem_A2l_Initialize; + + procedure Gmem_Read_Next (Buf : out String; Last : out Natural) is + procedure Read_Next (buf : System.Address); + pragma Import (C, Read_Next, "__gnat_gmem_read_next"); + function Strlen (str : System.Address) return Natural; + pragma Import (C, Strlen, "strlen"); + + S : String (1 .. 1000); + begin + Read_Next (S'Address); + Last := Strlen (S'Address); + Buf (1 .. Last) := S (1 .. Last); + end Gmem_Read_Next; + + --------------------- + -- Get_Current_TTY -- + --------------------- + + function Get_Current_TTY return String is + Res : Cstring_Ptr; + stdout : constant Integer := 1; + Max_TTY_Name : constant Integer := 500; + + begin + if isatty (stdout) /= 1 then + return ""; + end if; + + Res := ttyname (1); + if Res /= null then + for J in Cstring'First .. Max_TTY_Name loop + if Res (J) = ASCII.NUL then + return Res (Cstring'First .. J - 1); + end if; + end loop; + end if; + + -- if we fall thru the ttyname result was dubious. Just forget it. + + return ""; + end Get_Current_TTY; + + ------- + -- H -- + ------- + + function H (A : Integer_Address) return Address_Range is + begin + return Address_Range (A mod Integer_Address (Address_Range'Last)); + end H; + + ----------------------- + -- Create_Gdb_Script -- + ----------------------- + + procedure Create_Gdb_Script is + FD : File_Type; + + begin + begin + Create (FD, Out_File, Gnatmem_Tmp); + exception + when others => + Put_Line ("Cannot create temporary file : " & Gnatmem_Tmp); + GNAT.OS_Lib.OS_Exit (1); + end; + + declare + TTY : constant String := Get_Current_TTY; + begin + if TTY'Length > 0 then + Put_Line (FD, "tty " & TTY); + end if; + end; + + + if Cross_Case then + Put (FD, "target "); + Put (FD, Target_Protocol (1 .. Target_Protocol_Len)); + Put (FD, " "); + Put (FD, Argument (Target_Pos)); + New_Line (FD); + Put (FD, "load "); + Put_Line (FD, Argument (Exec_Pos)); + + else + -- In the native case, run the program before setting the + -- breakpoints so that gnatmem will also work with shared + -- libraries. + + Put_Line (FD, "set lang c"); + Put_Line (FD, "break main"); + Put_Line (FD, "set lang auto"); + Put (FD, "run"); + for J in Exec_Pos + 1 .. Argc loop + Put (FD, " "); + Put (FD, Argument (J)); + end loop; + New_Line (FD); + + -- At this point, gdb knows about __gnat_malloc and __gnat_free + end if; + + -- Make sure that outputing long backtraces do not pause + + Put_Line (FD, "set height 0"); + Put_Line (FD, "set width 0"); + + if Quiet_Mode then + Put_Line (FD, "break __gnat_malloc"); + Put_Line (FD, "command"); + Put_Line (FD, " silent"); + Put_Line (FD, " set lang c"); + Put_Line (FD, " set print address on"); + Put_Line (FD, " finish"); + Put_Line (FD, " set $gm_addr = $"); + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr"); + Put_Line (FD, " set print address off"); + Put_Line (FD, " set lang auto"); + else + Put_Line (FD, "break __gnat_malloc"); + Put_Line (FD, "command"); + Put_Line (FD, " silent"); + Put_Line (FD, " set lang c"); + Put_Line (FD, " set $gm_size = size"); + Put_Line (FD, " set print address on"); + Put_Line (FD, " finish"); + Put_Line (FD, " set $gm_addr = $"); + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr"); + Put_Line (FD, " set print address off"); + Put_Line (FD, " set lang auto"); + end if; + + Put (FD, " backtrace"); + + if BT_Depth /= 0 then + Put (FD, Integer'Image (BT_Depth)); + end if; + + New_Line (FD); + + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " continue"); + Put_Line (FD, "end"); + Put_Line (FD, "#"); + Put_Line (FD, "#"); + Put_Line (FD, "break __gnat_free"); + Put_Line (FD, "command"); + Put_Line (FD, " silent"); + Put_Line (FD, " set print address on"); + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr"); + Put_Line (FD, " set print address off"); + Put_Line (FD, " finish"); + + Put (FD, " backtrace"); + + if BT_Depth /= 0 then + Put (FD, Integer'Image (BT_Depth)); + end if; + + New_Line (FD); + + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " continue"); + Put_Line (FD, "end"); + Put_Line (FD, "#"); + Put_Line (FD, "#"); + Put_Line (FD, "#"); + + if Cross_Case then + Put (FD, "run "); + Put_Line (FD, Argument (Exec_Pos)); + + if Target_Protocol (1 .. Target_Protocol_Len) = "wtx" then + Put (FD, "unload "); + Put_Line (FD, Argument (Exec_Pos)); + end if; + else + Put_Line (FD, "continue"); + end if; + + Close (FD); + end Create_Gdb_Script; + + --------------- + -- Mem_Image -- + --------------- + + function Mem_Image (X : Storage_Count) return String is + Ks : constant Storage_Count := X / 1024; + Megs : constant Storage_Count := Ks / 1024; + Buff : String (1 .. 7); + + begin + if Megs /= 0 then + Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0); + return Buff & " Megabytes"; + + elsif Ks /= 0 then + Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0); + return Buff & " Kilobytes"; + + else + Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X)); + return Buff (1 .. 4) & " Bytes"; + end if; + end Mem_Image; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + New_Line; + Put ("GNATMEM "); + Put (Gnat_Version_String); + Put_Line (" Copyright 1997-2000 Free Software Foundation, Inc."); + New_Line; + + if Cross_Case then + Put_Line (Command_Name + & " [-q] [n] [-o file] target entry_point ..."); + Put_Line (Command_Name & " [-q] [n] [-i file]"); + + else + Put_Line ("GDB mode"); + Put_Line (" " & Command_Name + & " [-q] [n] [-o file] program arg1 arg2 ..."); + Put_Line (" " & Command_Name + & " [-q] [n] [-i file]"); + New_Line; + Put_Line ("GMEM mode"); + Put_Line (" " & Command_Name + & " [-q] [n] -i gmem.out program arg1 arg2 ..."); + New_Line; + end if; + + Put_Line (" -q quiet, minimum output"); + Put_Line (" n number of frames for allocation root backtraces"); + Put_Line (" default is 1."); + Put_Line (" -o file save gdb output in 'file' and process data"); + Put_Line (" post mortem. also keep the gdb script around"); + Put_Line (" -i file don't run gdb output. Do only post mortem"); + Put_Line (" processing from file"); + GNAT.OS_Lib.OS_Exit (1); + end Usage; + + ----------------------- + -- Process_Arguments -- + ----------------------- + + procedure Process_Arguments is + Arg : Integer; + + procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False); + -- Check that Argument (Arg_Pos) is an existing file if For_Creat is + -- false or if it is possible to create it if For_Creat is true + + procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False) is + Name : aliased constant String := Argument (Arg_Pos) & ASCII.NUL; + X : int; + + begin + if For_Creat then + FD := fopen (Name'Address, Mode_W'Address); + else + FD := fopen (Name'Address, Mode_R'Address); + end if; + + if FD = NULL_Stream then + New_Line; + if For_Creat then + Put_Line ("Cannot create file : " & Argument (Arg_Pos)); + else + Put_Line ("Cannot locate file : " & Argument (Arg_Pos)); + end if; + New_Line; + Usage; + else + X := fclose (FD); + end if; + end Check_File; + + -- Start of processing for Process_Arguments + + begin + + -- Is it a cross version? + + declare + Std_Name : constant String := "gnatmem"; + Name : constant String := Command_Name; + End_Pref : constant Integer := Name'Last - Std_Name'Length; + + begin + if Name'Length > Std_Name'Length + 9 + and then + Name (End_Pref + 1 .. Name'Last) = Std_Name + and then + Name (End_Pref - 8 .. End_Pref) = "-vxworks-" + then + Cross_Case := True; + + Target_Name_Len := End_Pref - 1; + for J in reverse Name'First .. End_Pref - 1 loop + if Name (J) = Dir_Sep then + Target_Name_Len := Target_Name_Len - J; + exit; + end if; + end loop; + + Target_Name (1 .. Target_Name_Len) + := Name (End_Pref - Target_Name_Len .. End_Pref - 1); + + if Target_Name (1 .. 5) = "alpha" then + Target_Protocol (1 .. 7) := "vxworks"; + Target_Protocol_Len := 7; + else + Target_Protocol (1 .. 3) := "wtx"; + Target_Protocol_Len := 3; + end if; + end if; + end; + + Arg := 1; + + if Argc < Arg then + Usage; + end if; + + -- Deal with "-q" + + if Argument (Arg) = "-q" then + + Quiet_Mode := True; + Arg := Arg + 1; + + if Argc < Arg then + Usage; + end if; + end if; + + -- Deal with back trace depth + + if Argument (Arg) (1) in '0' .. '9' then + begin + BT_Depth := Integer'Value (Argument (Arg)); + exception + when others => + Usage; + end; + + Arg := Arg + 1; + + if Argc < Arg then + Usage; + end if; + end if; + + -- Deal with "-o file" or "-i file" + + while Arg <= Argc and then Argument (Arg) (1) = '-' loop + Arg := Arg + 1; + + if Argc < Arg then + Usage; + end if; + + case Argument (Arg - 1) (2) is + when 'o' => + Check_File (Arg, For_Creat => True); + File_Pos := Arg; + + when 'i' => + Check_File (Arg); + File_Pos := Arg; + Run_Gdb := False; + if Gmem_Initialize (Argument (Arg)) then + Gmem_Mode := True; + end if; + + when others => + Put_Line ("Unknown option : " & Argument (Arg)); + Usage; + end case; + + Arg := Arg + 1; + + if Argc < Arg and then Run_Gdb then + Usage; + end if; + end loop; + + -- In the cross case, we first get the target + + if Cross_Case then + Target_Pos := Arg; + Arg := Arg + 1; + + if Argc < Arg and then Run_Gdb then + Usage; + end if; + end if; + + -- Now all the following arguments are to be passed to gdb + + if Run_Gdb then + Exec_Pos := Arg; + Check_File (Exec_Pos); + + elsif Gmem_Mode then + if Arg > Argc then + Usage; + else + Exec_Pos := Arg; + Check_File (Exec_Pos); + Gmem_A2l_Initialize (Argument (Exec_Pos)); + end if; + + -- ... in other cases further arguments are disallowed + + elsif Arg <= Argc then + Usage; + end if; + end Process_Arguments; + + --------------- + -- Read_Next -- + --------------- + + function Read_Next return Gdb_Output_Elmt is + Max_Line : constant Integer := 100; + Line : String (1 .. Max_Line); + Last : Integer := 0; + + Curs1, Curs2 : Integer; + Separator : constant Character := '^'; + + function Next_Separator return Integer; + -- Return the index of the next separator after Curs1 in Line + + function Next_Separator return Integer is + Curs : Integer := Curs1; + + begin + loop + if Curs > Last then + raise Gdb_Output_Format_Error; + + elsif Line (Curs) = Separator then + return Curs; + end if; + + Curs := Curs + 1; + end loop; + end Next_Separator; + + -- Start of processing for Read_Next + + begin + Line (1) := ' '; + + loop + if Gmem_Mode then + Gmem_Read_Next (Line, Last); + else + Get_Line (FT, Line, Last); + end if; + + if Line (1 .. 14) = "Program exited" then + return Eof; + + elsif Line (1 .. 5) = "ALLOC" then + + -- Read the size + + if Quiet_Mode then + Curs2 := 5; + else + Curs1 := 7; + Curs2 := Next_Separator - 1; + Tmp_Size := Storage_Count'Value (Line (Curs1 .. Curs2)); + end if; + + -- Read the address, skip "^0x" + + Curs1 := Curs2 + 4; + Curs2 := Next_Separator - 1; + Tmp_Address := Integer_Address'Value ( + "16#" & Line (Curs1 .. Curs2) & "#"); + return Alloc; + + elsif Line (1 .. 5) = "DEALL" then + + -- Read the address, skip "^0x" + + Curs1 := 9; + Curs2 := Next_Separator - 1; + Tmp_Address := Integer_Address'Value ( + "16#" & Line (Curs1 .. Curs2) & "#"); + return Deall; + end if; + end loop; + exception + when End_Error => + New_Line; + Put_Line ("### incorrect user program termination detected."); + Put_Line (" following data may not be meaningful"); + New_Line; + return Eof; + end Read_Next; + +-- Start of processing for Gnatmem + +begin + Process_Arguments; + + if Run_Gdb then + Create_Gdb_Script; + end if; + + -- Now we start the gdb session using the following syntax + + -- gdb --nx --nw -batch -x gnatmem.tmp + + -- If there is a -o option we redirect the gdb output in the specified + -- file, otherwise we just read directly from a pipe. + + if File_Pos /= 0 then + declare + Name : aliased String := Argument (File_Pos) & ASCII.NUL; + + begin + if Run_Gdb then + if Cross_Case then + declare + Cmd : aliased String := Target_Name (1 .. Target_Name_Len) + & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & " > " + & Name; + begin + System_Cmd (Cmd'Address); + end; + else + + declare + Cmd : aliased String + := "gdb --nx --nw " & Argument (Exec_Pos) + & " -batch -x " & Gnatmem_Tmp & " > " + & Name; + begin + System_Cmd (Cmd'Address); + end; + end if; + end if; + + if not Gmem_Mode then + FD := fopen (Name'Address, Mode_R'Address); + end if; + end; + + else + if Cross_Case then + declare + Cmd : aliased String := Target_Name (1 .. Target_Name_Len) + & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & ASCII.NUL; + begin + FD := popen (Cmd'Address, Mode_R'Address); + end; + else + declare + Cmd : aliased String := "gdb --nx --nw " & Argument (Exec_Pos) + & " -batch -x " & Gnatmem_Tmp & ASCII.NUL; + + begin + FD := popen (Cmd'Address, Mode_R'Address); + end; + end if; + end if; + + -- Open the FD file as a regular Text_IO file + + if not Gmem_Mode then + Ada.Text_IO.C_Streams.Open (FT, In_File, FD); + end if; + + -- Main loop analysing the data generated by the debugger + -- for each allocation, the backtrace is kept and stored in a htable + -- whose entry is the address. Fore ach deallocation, we look for the + -- corresponding allocation and cancel it. + + Main : loop + case Read_Next is + when EOF => + exit Main; + + when Alloc => + + -- Update global counters if the allocated size is meaningful + + if Quiet_Mode then + Tmp_Alloc.Root := Read_BT (BT_Depth, FT); + if Nb_Alloc (Tmp_Alloc.Root) = 0 then + Nb_Root := Nb_Root + 1; + end if; + Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); + Address_HTable.Set (Tmp_Address, Tmp_Alloc); + + elsif Tmp_Size > 0 then + + Global_Alloc_Size := Global_Alloc_Size + Tmp_Size; + Global_Nb_Alloc := Global_Nb_Alloc + 1; + + if Global_High_Water_Mark < Global_Alloc_Size then + Global_High_Water_Mark := Global_Alloc_Size; + end if; + + -- Read the corresponding back trace + + Tmp_Alloc.Root := Read_BT (BT_Depth, FT); + + -- Update the number of allocation root if this is a new one + + if Nb_Alloc (Tmp_Alloc.Root) = 0 then + Nb_Root := Nb_Root + 1; + end if; + + -- Update allocation root specific counters + + Set_Alloc_Size (Tmp_Alloc.Root, + Alloc_Size (Tmp_Alloc.Root) + Tmp_Size); + + Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); + + if High_Water_Mark (Tmp_Alloc.Root) + < Alloc_Size (Tmp_Alloc.Root) + then + Set_High_Water_Mark (Tmp_Alloc.Root, + Alloc_Size (Tmp_Alloc.Root)); + end if; + + -- Associate this allocation root to the allocated address + + Tmp_Alloc.Size := Tmp_Size; + Address_HTable.Set (Tmp_Address, Tmp_Alloc); + + -- non meaninful output, just consumes the backtrace + + else + Tmp_Alloc.Root := Read_BT (BT_Depth, FT); + end if; + + when Deall => + + -- Get the corresponding Dealloc_Size and Root + + Tmp_Alloc := Address_HTable.Get (Tmp_Address); + + if Tmp_Alloc.Root = No_Root_Id then + + -- There was no prior allocation at this address, something is + -- very wrong. Mark this allocation root as problematic a + + Tmp_Alloc.Root := Read_BT (BT_Depth, FT); + + if Nb_Alloc (Tmp_Alloc.Root) = 0 then + Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1); + Nb_Wrong_Deall := Nb_Wrong_Deall + 1; + end if; + + else + -- Update global counters + + if not Quiet_Mode then + Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size; + end if; + Global_Nb_Dealloc := Global_Nb_Dealloc + 1; + + -- Update allocation root specific counters + + if not Quiet_Mode then + Set_Alloc_Size (Tmp_Alloc.Root, + Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size); + end if; + Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1); + + -- update the number of allocation root if this one disappear + + if Nb_Alloc (Tmp_Alloc.Root) = 0 then + Nb_Root := Nb_Root - 1; + end if; + + -- De-associate the deallocated address + + Address_HTable.Remove (Tmp_Address); + end if; + end case; + end loop Main; + + -- We can get rid of the temp file now + + if Run_Gdb and then File_Pos = 0 then + declare + X : int; + begin + X := unlink (Gnatmem_Tmp'Address); + end; + end if; + + -- Print out general information about overall allocation + + if not Quiet_Mode then + Put_Line ("Global information"); + Put_Line ("------------------"); + + Put (" Total number of allocations :"); + Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4); + New_Line; + + Put (" Total number of deallocations :"); + Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4); + New_Line; + + Put_Line (" Final Water Mark (non freed mem) :" + & Mem_Image (Global_Alloc_Size)); + Put_Line (" High Water Mark :" + & Mem_Image (Global_High_Water_Mark)); + New_Line; + end if; + + -- Print out the back traces corresponding to potential leaks in order + -- greatest number of non-deallocated allocations + + Print_Back_Traces : declare + type Root_Array is array (Natural range <>) of Root_Id; + Leaks : Root_Array (0 .. Nb_Root); + Leak_Index : Natural := 0; + + Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall); + Deall_Index : Natural := 0; + + procedure Move (From : Natural; To : Natural); + function Lt (Op1, Op2 : Natural) return Boolean; + package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt); + + procedure Move (From : Natural; To : Natural) is + begin + Leaks (To) := Leaks (From); + end Move; + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + if Nb_Alloc (Leaks (Op1)) > Nb_Alloc (Leaks (Op2)) then + return True; + elsif Nb_Alloc (Leaks (Op1)) = Nb_Alloc (Leaks (Op2)) then + return Alloc_Size (Leaks (Op1)) > Alloc_Size (Leaks (Op2)); + else + return False; + end if; + end Lt; + + -- Start of processing for Print_Back_Traces + + begin + -- Transfer all the relevant Roots in the Leaks and a + -- Bogus_Deall arrays + + Tmp_Alloc.Root := Get_First; + while Tmp_Alloc.Root /= No_Root_Id loop + if Nb_Alloc (Tmp_Alloc.Root) = 0 then + null; + + elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then + Deall_Index := Deall_Index + 1; + Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root; + + else + Leak_Index := Leak_Index + 1; + Leaks (Leak_Index) := Tmp_Alloc.Root; + end if; + + Tmp_Alloc.Root := Get_Next; + end loop; + + -- Print out wrong deallocations + + if Nb_Wrong_Deall > 0 then + Put_Line ("Releasing deallocated memory at :"); + if not Quiet_Mode then + Put_Line ("--------------------------------"); + end if; + + for J in 1 .. Bogus_Dealls'Last loop + Print_BT (Bogus_Dealls (J)); + New_Line; + end loop; + end if; + + -- Print out all allocation Leaks + + if Nb_Root > 0 then + + -- Sort the Leaks so that potentially important leaks appear first + + Root_Sort.Sort (Nb_Root); + + for J in 1 .. Leaks'Last loop + if Quiet_Mode then + if Nb_Alloc (Leaks (J)) = 1 then + Put_Line (Integer'Image (Nb_Alloc (Leaks (J))) + & " leak at :"); + else + Put_Line (Integer'Image (Nb_Alloc (Leaks (J))) + & " leaks at :"); + end if; + else + Put_Line ("Allocation Root #" & Integer'Image (J)); + Put_Line ("-------------------"); + + Put (" Number of non freed allocations :"); + Ada.Integer_Text_IO.Put (Nb_Alloc (Leaks (J)), 4); + New_Line; + + Put_Line (" Final Water Mark (non freed mem) :" + & Mem_Image (Alloc_Size (Leaks (J)))); + + Put_Line (" High Water Mark :" + & Mem_Image (High_Water_Mark (Leaks (J)))); + + Put_Line (" Backtrace :"); + end if; + Print_BT (Leaks (J)); + New_Line; + end loop; + end if; + end Print_Back_Traces; + +end Gnatmem; diff --git a/gcc/ada/gnatprep.adb b/gcc/ada/gnatprep.adb new file mode 100644 index 00000000000..ccff6fc4a3c --- /dev/null +++ b/gcc/ada/gnatprep.adb @@ -0,0 +1,1395 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T P R E P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1996-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Strings.Fixed; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Heap_Sort_G; +with GNAT.Command_Line; + +with Gnatvsn; + +procedure GNATprep is + pragma Ident (Gnatvsn.Gnat_Version_String); + + Version_String : constant String := "$Revision: 1.27 $"; + + type Strptr is access String; + + Usage_Error : exception; + -- Raised if a usage error is detected, causes termination of processing + -- with an appropriate error message and error exit status set. + + Fatal_Error : exception; + -- Exception raised if fatal error detected + + Expression_Error : exception; + -- Exception raised when an invalid boolean expression is found + -- on a preprocessor line + + ------------------------ + -- Argument Line Data -- + ------------------------ + + Infile_Name : Strptr; + Outfile_Name : Strptr; + Deffile_Name : Strptr; + -- Names of files + + Infile : File_Type; + Outfile : File_Type; + Deffile : File_Type; + + Opt_Comment_Deleted_Lines : Boolean := False; -- Set if -c switch set + Blank_Deleted_Lines : Boolean := False; -- Set if -b switch set + List_Symbols : Boolean := False; -- Set if -s switch set + Source_Ref_Pragma : Boolean := False; -- Set if -r switch set + Undefined_Is_False : Boolean := False; -- Set if -u switch set + -- Record command line options + + --------------------------- + -- Definitions File Data -- + --------------------------- + + Num_Syms : Natural := 0; + -- Number of symbols defined in definitions file + + Symbols : array (0 .. 10_000) of Strptr; + Values : array (0 .. 10_000) of Strptr; + -- Symbol names and values. Note that the zero'th element is used only + -- during the call to Sort (to hold a temporary value, as required by + -- the GNAT.Heap_Sort_G interface). + + --------------------- + -- Input File Data -- + --------------------- + + Current_File_Name : Strptr; + -- Holds name of file being read (definitions file or input file) + + Line_Buffer : String (1 .. 20_000); + -- Hold one line + + Line_Length : Natural; + -- Length of line in Line_Buffer + + Line_Num : Natural; + -- Current input file line number + + Ptr : Natural; + -- Input scan pointer for line in Line_Buffer + + type Keyword is (K_Not, K_Then, K_If, K_Else, K_End, K_Elsif, + K_And, K_Or, K_Open_Paren, K_Close_Paren, + K_Defined, K_Andthen, K_Orelse, K_Equal, K_None); + -- Keywords that are recognized on preprocessor lines. K_None indicates + -- that no keyword was present. + + K : Keyword; + -- Scanned keyword + + Start_Sym, End_Sym : Natural; + -- First and last positions of scanned symbol + + Num_Errors : Natural := 0; + -- Number of errors detected + + ----------------------- + -- Preprocessor Data -- + ----------------------- + + -- The following record represents the state of an #if structure: + + type PP_Rec is record + If_Line : Positive; + -- Line number for #if line + + Else_Line : Natural; + -- Line number for #else line, zero = no else seen yet + + Deleting : Boolean; + -- True if lines currently being deleted + + Match_Seen : Boolean; + -- True if either the #if condition or one of the previously seen + -- #elsif lines was true, meaning that any future #elsif sections + -- or the #else section, is to be deleted. + end record; + + PP_Depth : Natural; + -- Preprocessor #if nesting level. A value of zero means that we are + -- outside any #if structure. + + PP : array (0 .. 100) of PP_Rec; + -- Stack of records showing state of #if structures. PP (1) is the + -- outer level entry, and PP (PP_Depth) is the active entry. PP (0) + -- contains a dummy entry whose Deleting flag is always set to False. + + ----------------- + -- Subprograms -- + ----------------- + + function At_End_Of_Line return Boolean; + -- First advances Ptr using Skip_Spaces. Then returns True if Ptr is + -- either at the end of the line, or at a -- comment sequence. + + procedure Error (Msg : String); + -- Post error message with given text. The line number is taken from + -- Line_Num, and the column number from Ptr. + + function Eval_Condition + (Parenthesis : Natural := 0; + Do_Eval : Boolean := True) + return Boolean; + -- Eval the condition found in the current Line. The condition can + -- include any of the 'and', 'or', 'not', and parenthesis subexpressions. + -- If Line is an invalid expression, then Expression_Error is raised, + -- after an error message has been printed. Line can include 'then' + -- followed by a comment, which is automatically ignored. If Do_Eval + -- is False, then the expression is not evaluated at all, and symbols + -- are just skipped. + + function Eval_Symbol (Do_Eval : Boolean) return Boolean; + -- Read and evaluate the next symbol or expression (A, A'Defined, A=...) + -- If it is followed by 'Defined or an equality test, read as many symbols + -- as needed. Do_Eval has the same meaning as in Eval_Condition + + procedure Help_Page; + -- Print a help page to summarize the usage of gnatprep + + function Is_Preprocessor_Line return Boolean; + -- Tests if current line is a preprocessor line, i.e. that its first + -- non-blank character is a # character. If so, then a result of True + -- is returned, and Ptr is set to point to the character following the + -- # character. If not, False is returned and Ptr is undefined. + + procedure No_Junk; + -- Make sure no junk is present on a preprocessor line. Ptr points past + -- the scanned preprocessor syntax. + + function OK_Identifier (S : String) return Boolean; + -- Tests if given referenced string is valid Ada identifier + + function Matching_Strings (S1, S2 : String) return Boolean; + -- Check if S1 and S2 are the same string (this is a case independent + -- comparison, lower and upper case letters are considered to match). + -- Duplicate quotes in S2 are considered as a single quote ("" => ") + + procedure Parse_Def_File; + -- Parse the deffile given by the user + + function Scan_Keyword return Keyword; + -- Advances Ptr to end of line or next non-blank using Skip_Spaces. Then + -- attempts to scan out a recognized keyword. if a recognized keyword is + -- found, sets Ptr past it, and returns the code for the keyword, if not, + -- then Ptr is left unchanged pointing to a non-blank character or to the + -- end of the line. + + function Symbol_Scanned return Boolean; + -- On entry, Start_Sym is set to the first character of an identifier + -- symbol to be scanned out. On return, End_Sym is set to the last + -- character of the identifier, and the result indicates if the scanned + -- symbol is a valid identifier (True = valid). Ptr is not changed. + + procedure Skip_Spaces; + -- Skips Ptr past tabs and spaces to next non-blank, or one character + -- past the end of line. + + function Variable_Index (Name : String) return Natural; + -- Returns the index of the variable in the table. If the variable is not + -- found, returns Natural'Last + + -------------------- + -- At_End_Of_Line -- + -------------------- + + function At_End_Of_Line return Boolean is + begin + Skip_Spaces; + + return Ptr > Line_Length + or else + (Ptr < Line_Length and then Line_Buffer (Ptr .. Ptr + 1) = "--"); + end At_End_Of_Line; + + ----------- + -- Error -- + ----------- + + procedure Error (Msg : String) is + L : constant String := Natural'Image (Line_Num); + C : constant String := Natural'Image (Ptr); + + begin + Put (Standard_Error, Current_File_Name.all); + Put (Standard_Error, ':'); + Put (Standard_Error, L (2 .. L'Length)); + Put (Standard_Error, ':'); + Put (Standard_Error, C (2 .. C'Length)); + Put (Standard_Error, ": "); + + Put_Line (Standard_Error, Msg); + Num_Errors := Num_Errors + 1; + end Error; + + -------------------- + -- Eval_Condition -- + -------------------- + + function Eval_Condition + (Parenthesis : Natural := 0; + Do_Eval : Boolean := True) + return Boolean + is + Symbol_Is_True : Boolean := False; -- init to avoid warning + K : Keyword; + + begin + -- Find the next subexpression + + K := Scan_Keyword; + + case K is + when K_None => + Symbol_Is_True := Eval_Symbol (Do_Eval); + + when K_Not => + + -- Not applies to the next subexpression (either a simple + -- evaluation like A or A'Defined, or a parenthesis expression) + + K := Scan_Keyword; + + if K = K_Open_Paren then + Symbol_Is_True := not Eval_Condition (Parenthesis + 1, Do_Eval); + + elsif K = K_None then + Symbol_Is_True := not Eval_Symbol (Do_Eval); + + else + Ptr := Start_Sym; -- Puts the keyword back + end if; + + when K_Open_Paren => + Symbol_Is_True := Eval_Condition (Parenthesis + 1, Do_Eval); + + when others => + Ptr := Start_Sym; + Error ("invalid syntax in preprocessor line"); + raise Expression_Error; + end case; + + -- Do we have a compound expression with AND, OR, ... + + K := Scan_Keyword; + case K is + when K_None => + if not At_End_Of_Line then + Error ("Invalid Syntax at end of line"); + raise Expression_Error; + end if; + + if Parenthesis /= 0 then + Error ("Unmatched opening parenthesis"); + raise Expression_Error; + end if; + + return Symbol_Is_True; + + when K_Then => + if Parenthesis /= 0 then + Error ("Unmatched opening parenthesis"); + raise Expression_Error; + end if; + + return Symbol_Is_True; + + when K_Close_Paren => + if Parenthesis = 0 then + Error ("Unmatched closing parenthesis"); + raise Expression_Error; + end if; + + return Symbol_Is_True; + + when K_And => + return Symbol_Is_True and Eval_Condition (Parenthesis, Do_Eval); + + when K_Andthen => + if not Symbol_Is_True then + + -- Just skip the symbols for the remaining part + + Symbol_Is_True := Eval_Condition (Parenthesis, False); + return False; + + else + return Eval_Condition (Parenthesis, Do_Eval); + end if; + + when K_Or => + return Symbol_Is_True or Eval_Condition (Parenthesis, Do_Eval); + + when K_Orelse => + if Symbol_Is_True then + + -- Just skip the symbols for the remaining part + + Symbol_Is_True := Eval_Condition (Parenthesis, False); + return True; + + else + return Eval_Condition (Parenthesis, Do_Eval); + end if; + + when others => + Error ("invalid syntax in preprocessor line"); + raise Expression_Error; + end case; + + end Eval_Condition; + + ----------------- + -- Eval_Symbol -- + ----------------- + + function Eval_Symbol (Do_Eval : Boolean) return Boolean is + Sym : constant String := Line_Buffer (Start_Sym .. End_Sym); + K : Keyword; + Index : Natural; + Symbol_Defined : Boolean := False; + Symbol_Is_True : Boolean := False; + + begin + -- Read the symbol + + Skip_Spaces; + Start_Sym := Ptr; + + if not Symbol_Scanned then + Error ("invalid symbol name"); + raise Expression_Error; + end if; + + Ptr := End_Sym + 1; + + -- Test if we have a simple test (A) or a more complicated one + -- (A'Defined) + + K := Scan_Keyword; + + if K /= K_Defined and then K /= K_Equal then + Ptr := Start_Sym; -- Puts the keyword back + end if; + + Index := Variable_Index (Sym); + + case K is + when K_Defined => + Symbol_Defined := Index /= Natural'Last; + Symbol_Is_True := Symbol_Defined; + + when K_Equal => + + -- Read the second part of the statement + Skip_Spaces; + Start_Sym := Ptr; + + if not Symbol_Scanned + and then End_Sym < Start_Sym + then + Error ("No right part for the equality test"); + raise Expression_Error; + end if; + + Ptr := End_Sym + 1; + + -- If the variable was not found + + if Do_Eval then + if Index = Natural'Last then + if not Undefined_Is_False then + Error ("symbol name """ & Sym & + """ is not defined in definitions file"); + end if; + + else + declare + Right : constant String + := Line_Buffer (Start_Sym .. End_Sym); + Index_R : Natural; + begin + if Right (Right'First) = '"' then + Symbol_Is_True := + Matching_Strings + (Values (Index).all, + Right (Right'First + 1 .. Right'Last - 1)); + else + Index_R := Variable_Index (Right); + if Index_R = Natural'Last then + Error ("Variable " & Right & " in test is " + & "not defined"); + raise Expression_Error; + else + Symbol_Is_True := + Matching_Strings (Values (Index).all, + Values (Index_R).all); + end if; + end if; + end; + end if; + end if; + + when others => + + if Index = Natural'Last then + + Symbol_Defined := False; + if Do_Eval and then not Symbol_Defined then + if Undefined_Is_False then + Symbol_Defined := True; + Symbol_Is_True := False; + + else + Error + ("symbol name """ & Sym & + """ is not defined in definitions file"); + end if; + end if; + + elsif not Do_Eval then + Symbol_Is_True := True; + + elsif Matching_Strings (Values (Index).all, "True") then + Symbol_Is_True := True; + + elsif Matching_Strings (Values (Index).all, "False") then + Symbol_Is_True := False; + + else + Error ("symbol value is not True or False"); + Symbol_Is_True := False; + end if; + + end case; + + return Symbol_Is_True; + end Eval_Symbol; + + --------------- + -- Help_Page -- + --------------- + + procedure Help_Page is + begin + Put_Line (Standard_Error, + "GNAT Preprocessor Version " & + Version_String (12 .. 15) & + " Copyright 1996-2001 Free Software Foundation, Inc."); + Put_Line (Standard_Error, + "Usage: gnatprep [-bcrsu] [-Dsymbol=value] infile " & + "outfile [deffile]"); + New_Line (Standard_Error); + Put_Line (Standard_Error, " infile Name of the input file"); + Put_Line (Standard_Error, " outfile Name of the output file"); + Put_Line (Standard_Error, " deffile Name of the definition file"); + New_Line (Standard_Error); + Put_Line (Standard_Error, "gnatprep switches:"); + Put_Line (Standard_Error, " -b Replace preprocessor lines by " & + "blank lines"); + Put_Line (Standard_Error, " -c Keep preprocessor lines as comments"); + Put_Line (Standard_Error, " -D Associate symbol with value"); + Put_Line (Standard_Error, " -r Generate Source_Reference pragma"); + Put_Line (Standard_Error, " -s Print a sorted list of symbol names " & + "and values"); + Put_Line (Standard_Error, " -u Treat undefined symbols as FALSE"); + New_Line (Standard_Error); + end Help_Page; + + -------------------------- + -- Is_Preprocessor_Line -- + -------------------------- + + function Is_Preprocessor_Line return Boolean is + begin + Ptr := 1; + + while Ptr <= Line_Length loop + if Line_Buffer (Ptr) = '#' then + Ptr := Ptr + 1; + return True; + + elsif Line_Buffer (Ptr) > ' ' then + return False; + + else + Ptr := Ptr + 1; + end if; + end loop; + + return False; + end Is_Preprocessor_Line; + + ---------------------- + -- Matching_Strings -- + ---------------------- + + function Matching_Strings (S1, S2 : String) return Boolean is + S2_Index : Integer := S2'First; + + begin + for S1_Index in S1'Range loop + + if To_Upper (S1 (S1_Index)) /= To_Upper (S2 (S2_Index)) then + return False; + + else + if S2 (S2_Index) = '"' + and then S2_Index < S2'Last + and then S2 (S2_Index + 1) = '"' + then + S2_Index := S2_Index + 2; + else + S2_Index := S2_Index + 1; + end if; + + -- If S2 was too short then + + if S2_Index > S2'Last and then S1_Index < S1'Last then + return False; + end if; + end if; + end loop; + + return S2_Index = S2'Last + 1; + end Matching_Strings; + + ------------- + -- No_Junk -- + ------------- + + procedure No_Junk is + begin + Skip_Spaces; + + if Ptr = Line_Length + or else (Ptr < Line_Length + and then Line_Buffer (Ptr .. Ptr + 1) /= "--") + then + Error ("extraneous text on preprocessor line ignored"); + end if; + end No_Junk; + + ------------------- + -- OK_Identifier -- + ------------------- + + function OK_Identifier (S : String) return Boolean is + P : Natural := S'First; + + begin + if S'Length /= 0 and then S (P) = Character'Val (39) then -- ''' + P := P + 1; + end if; + + if S'Length = 0 + or else not Is_Letter (S (P)) + then + return False; + + else + while P <= S'Last loop + if Is_Letter (S (P)) or Is_Digit (S (P)) then + null; + + elsif S (P) = '_' + and then P < S'Last + and then S (P + 1) /= '_' + then + null; + + else + return False; + end if; + + P := P + 1; + end loop; + + return True; + end if; + end OK_Identifier; + + -------------------- + -- Parse_Def_File -- + -------------------- + + procedure Parse_Def_File is + begin + Open (Deffile, In_File, Deffile_Name.all); + + Line_Num := 0; + Current_File_Name := Deffile_Name; + + -- Loop through lines in symbol definitions file + + while not End_Of_File (Deffile) loop + Get_Line (Deffile, Line_Buffer, Line_Length); + Line_Num := Line_Num + 1; + + Ptr := 1; + Skip_Spaces; + + if Ptr > Line_Length + or else (Ptr < Line_Length + and then + Line_Buffer (Ptr .. Ptr + 1) = "--") + then + goto Continue; + end if; + + Start_Sym := Ptr; + + if not Symbol_Scanned then + Error ("invalid symbol identifier """ & + Line_Buffer (Start_Sym .. End_Sym) & + '"'); + goto Continue; + end if; + + Ptr := End_Sym + 1; + Skip_Spaces; + + if Ptr >= Line_Length + or else Line_Buffer (Ptr .. Ptr + 1) /= ":=" + then + Error ("missing "":="" in symbol definition line"); + goto Continue; + end if; + + Ptr := Ptr + 2; + Skip_Spaces; + + Num_Syms := Num_Syms + 1; + Symbols (Num_Syms) := new String'(Line_Buffer (Start_Sym .. End_Sym)); + + Start_Sym := Ptr; + End_Sym := Ptr - 1; + + if At_End_Of_Line then + null; + + elsif Line_Buffer (Start_Sym) = '"' then + End_Sym := End_Sym + 1; + loop + End_Sym := End_Sym + 1; + + if End_Sym > Line_Length then + Error ("no closing quote for string constant"); + goto Continue; + + elsif End_Sym < Line_Length + and then Line_Buffer (End_Sym .. End_Sym + 1) = """""" + then + End_Sym := End_Sym + 1; + + elsif Line_Buffer (End_Sym) = '"' then + exit; + end if; + end loop; + + else + End_Sym := Ptr - 1; + + while End_Sym < Line_Length + and then (Is_Alphanumeric (Line_Buffer (End_Sym + 1)) + or else + Line_Buffer (End_Sym + 1) = '_' + or else + Line_Buffer (End_Sym + 1) = '.') + loop + End_Sym := End_Sym + 1; + end loop; + + Ptr := End_Sym + 1; + + if not At_End_Of_Line then + Error ("incorrect symbol value syntax"); + goto Continue; + end if; + end if; + + Values (Num_Syms) := new String'(Line_Buffer (Start_Sym .. End_Sym)); + + <<Continue>> + null; + end loop; + + exception + -- Could not open the file + + when Name_Error => + Put_Line (Standard_Error, "cannot open " & Deffile_Name.all); + raise Fatal_Error; + end Parse_Def_File; + + ------------------ + -- Scan_Keyword -- + ------------------ + + function Scan_Keyword return Keyword is + Kptr : constant Natural := Ptr; + + begin + Skip_Spaces; + Start_Sym := Ptr; + + if Symbol_Scanned then + + -- If the symbol was the last thing on the line, End_Sym will + -- point too far in Line_Buffer + + if End_Sym > Line_Length then + End_Sym := Line_Length; + end if; + + Ptr := End_Sym + 1; + + declare + Sym : constant String := Line_Buffer (Start_Sym .. End_Sym); + + begin + if Matching_Strings (Sym, "not") then + return K_Not; + + elsif Matching_Strings (Sym, "then") then + return K_Then; + + elsif Matching_Strings (Sym, "if") then + return K_If; + + elsif Matching_Strings (Sym, "else") then + return K_Else; + + elsif Matching_Strings (Sym, "end") then + return K_End; + + elsif Matching_Strings (Sym, "elsif") then + return K_Elsif; + + elsif Matching_Strings (Sym, "and") then + if Scan_Keyword = K_Then then + Start_Sym := Kptr; + return K_Andthen; + else + Ptr := Start_Sym; -- Put back the last keyword read + Start_Sym := Kptr; + return K_And; + end if; + + elsif Matching_Strings (Sym, "or") then + if Scan_Keyword = K_Else then + Start_Sym := Kptr; + return K_Orelse; + else + Ptr := Start_Sym; -- Put back the last keyword read + Start_Sym := Kptr; + return K_Or; + end if; + + elsif Matching_Strings (Sym, "'defined") then + return K_Defined; + + elsif Sym = "(" then + return K_Open_Paren; + + elsif Sym = ")" then + return K_Close_Paren; + + elsif Sym = "=" then + return K_Equal; + end if; + end; + end if; + + Ptr := Kptr; + return K_None; + end Scan_Keyword; + + ----------------- + -- Skip_Spaces -- + ----------------- + + procedure Skip_Spaces is + begin + while Ptr <= Line_Length loop + if Line_Buffer (Ptr) /= ' ' + and then Line_Buffer (Ptr) /= ASCII.HT + then + return; + else + Ptr := Ptr + 1; + end if; + end loop; + end Skip_Spaces; + + -------------------- + -- Symbol_Scanned -- + -------------------- + + function Symbol_Scanned return Boolean is + begin + End_Sym := Start_Sym - 1; + + case Line_Buffer (End_Sym + 1) is + + when '(' | ')' | '=' => + End_Sym := End_Sym + 1; + return True; + + when '"' => + End_Sym := End_Sym + 1; + while End_Sym < Line_Length loop + + if Line_Buffer (End_Sym + 1) = '"' then + + if End_Sym + 2 < Line_Length + and then Line_Buffer (End_Sym + 2) = '"' + then + End_Sym := End_Sym + 2; + else + exit; + end if; + else + End_Sym := End_Sym + 1; + end if; + end loop; + + if End_Sym >= Line_Length then + Error ("Invalid string "); + raise Expression_Error; + end if; + + End_Sym := End_Sym + 1; + return False; + + when ''' => + End_Sym := End_Sym + 1; + + when others => + null; + end case; + + while End_Sym < Line_Length + and then (Is_Alphanumeric (Line_Buffer (End_Sym + 1)) + or else Line_Buffer (End_Sym + 1) = '_') + loop + End_Sym := End_Sym + 1; + end loop; + + return OK_Identifier (Line_Buffer (Start_Sym .. End_Sym)); + end Symbol_Scanned; + + -------------------- + -- Variable_Index -- + -------------------- + + function Variable_Index (Name : String) return Natural is + begin + for J in 1 .. Num_Syms loop + if Matching_Strings (Symbols (J).all, Name) then + return J; + end if; + end loop; + + return Natural'Last; + end Variable_Index; + +-- Start of processing for GNATprep + +begin + + -- Parse the switches + + loop + case GNAT.Command_Line.Getopt ("D: b c r s u") is + when ASCII.NUL => + exit; + + when 'D' => + declare + S : String := GNAT.Command_Line.Parameter; + Index : Natural; + + begin + Index := Ada.Strings.Fixed.Index (S, "="); + + if Index = 0 then + Num_Syms := Num_Syms + 1; + Symbols (Num_Syms) := new String'(S); + Values (Num_Syms) := new String'("True"); + + else + Num_Syms := Num_Syms + 1; + Symbols (Num_Syms) := new String'(S (S'First .. Index - 1)); + Values (Num_Syms) := new String'(S (Index + 1 .. S'Last)); + end if; + end; + + when 'b' => + Blank_Deleted_Lines := True; + + when 'c' => + Opt_Comment_Deleted_Lines := True; + + when 'r' => + Source_Ref_Pragma := True; + + when 's' => + List_Symbols := True; + + when 'u' => + Undefined_Is_False := True; + + when others => + raise Usage_Error; + end case; + end loop; + + -- Get the file names + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + + begin + exit when S'Length = 0; + + if Infile_Name = null then + Infile_Name := new String'(S); + elsif Outfile_Name = null then + Outfile_Name := new String'(S); + elsif Deffile_Name = null then + Deffile_Name := new String'(S); + else + raise Usage_Error; + end if; + end; + end loop; + + -- Test we had all the arguments needed + + if Infile_Name = null + or else Outfile_Name = null + then + raise Usage_Error; + end if; + + if Source_Ref_Pragma and (not Opt_Comment_Deleted_Lines) then + Blank_Deleted_Lines := True; + end if; + + -- Get symbol definitions + + if Deffile_Name /= null then + Parse_Def_File; + end if; + + if Num_Errors > 0 then + raise Fatal_Error; + + elsif List_Symbols and then Num_Syms > 0 then + List_Symbols_Case : declare + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Comparison routine for sort call + + procedure Move (From : Natural; To : Natural); + -- Move routine for sort call + + function Lt (Op1, Op2 : Natural) return Boolean is + L1 : constant Natural := Symbols (Op1)'Length; + L2 : constant Natural := Symbols (Op2)'Length; + MinL : constant Natural := Natural'Min (L1, L2); + + C1, C2 : Character; + + begin + for J in 0 .. MinL - 1 loop + C1 := To_Upper (Symbols (Op1).all (Symbols (Op1)'First + J)); + C2 := To_Upper (Symbols (Op2).all (Symbols (Op2)'First + J)); + + if C1 < C2 then + return True; + + elsif C1 > C2 then + return False; + end if; + end loop; + + return L1 < L2; + end Lt; + + procedure Move (From : Natural; To : Natural) is + begin + Symbols (To) := Symbols (From); + Values (To) := Values (From); + end Move; + + package Sort_Syms is new GNAT.Heap_Sort_G (Move, Lt); + + Max_L : Natural; + -- Maximum length of any symbol + + -- Start of processing for List_Symbols_Case + + begin + Sort_Syms.Sort (Num_Syms); + + Max_L := 7; + for J in 1 .. Num_Syms loop + Max_L := Natural'Max (Max_L, Symbols (J)'Length); + end loop; + + New_Line; + Put ("Symbol"); + + for J in 1 .. Max_L - 5 loop + Put (' '); + end loop; + + Put_Line ("Value"); + + Put ("------"); + + for J in 1 .. Max_L - 5 loop + Put (' '); + end loop; + + Put_Line ("------"); + + for J in 1 .. Num_Syms loop + Put (Symbols (J).all); + + for K in 1 .. Max_L - Symbols (J)'Length + 1 loop + Put (' '); + end loop; + + Put_Line (Values (J).all); + end loop; + + New_Line; + end List_Symbols_Case; + end if; + + -- Open files and initialize preprocessing + + begin + Open (Infile, In_File, Infile_Name.all); + + exception + when Name_Error => + Put_Line (Standard_Error, "cannot open " & Infile_Name.all); + raise Fatal_Error; + end; + + begin + Create (Outfile, Out_File, Outfile_Name.all); + + exception + when Name_Error => + Put_Line (Standard_Error, "cannot create " & Outfile_Name.all); + raise Fatal_Error; + end; + + if Source_Ref_Pragma then + Put_Line + (Outfile, "pragma Source_Reference (1, """ & Infile_Name.all & """);"); + end if; + + Line_Num := 0; + Current_File_Name := Infile_Name; + + PP_Depth := 0; + PP (0).Deleting := False; + + -- Loop through lines in input file + + while not End_Of_File (Infile) loop + Get_Line (Infile, Line_Buffer, Line_Length); + Line_Num := Line_Num + 1; + + -- Handle preprocessor line + + if Is_Preprocessor_Line then + K := Scan_Keyword; + + case K is + + -- If/Elsif processing + + when K_If | K_Elsif => + + -- If differs from elsif only in that an initial stack entry + -- must be made for the new if range. We set the match seen + -- entry to a copy of the deleting status in the range above + -- us. If we are deleting in the range above us, then we want + -- all the branches of the nested #if to delete. + + if K = K_If then + PP_Depth := PP_Depth + 1; + PP (PP_Depth) := + (If_Line => Line_Num, + Else_Line => 0, + Deleting => False, + Match_Seen => PP (PP_Depth - 1).Deleting); + + elsif PP_Depth = 0 then + Error ("no matching #if for this #elsif"); + goto Output; + + end if; + + PP (PP_Depth).Deleting := True; + + if not PP (PP_Depth).Match_Seen + and then Eval_Condition = True + then + + -- Case of match and no match yet in this #if + + PP (PP_Depth).Deleting := False; + PP (PP_Depth).Match_Seen := True; + No_Junk; + end if; + + -- Processing for #else + + when K_Else => + + if PP_Depth = 0 then + Error ("no matching #if for this #else"); + + elsif PP (PP_Depth).Else_Line /= 0 then + Error ("duplicate #else line (previous was on line" & + Natural'Image (PP (PP_Depth).Else_Line) & + ")"); + + else + PP (PP_Depth).Else_Line := Line_Num; + PP (PP_Depth).Deleting := PP (PP_Depth).Match_Seen; + end if; + + No_Junk; + + -- Process for #end + + when K_End => + + if PP_Depth = 0 then + Error ("no matching #if for this #end"); + + else + Skip_Spaces; + + if Scan_Keyword /= K_If then + Error ("expected if after #end"); + Ptr := Line_Length + 1; + end if; + + Skip_Spaces; + + if Ptr > Line_Length + or else Line_Buffer (Ptr) /= ';' + then + Error ("missing semicolon after #end if"); + else + Ptr := Ptr + 1; + end if; + + No_Junk; + + PP_Depth := PP_Depth - 1; + end if; + + when others => + Error ("invalid preprocessor keyword syntax"); + + end case; + + -- Handle symbol substitution + + -- Substitution is not allowed in string (which we simply skip), + -- but is allowed inside character constants. The last case is + -- because there is no way to know whether the user want to + -- substitute the name of an attribute ('Min or 'Max for instance) + -- or actually meant to substitue a character ('$name' is probably + -- a character constant, but my_type'$name'Min is probably an + -- attribute, with $name=Base) + + else + Ptr := 1; + + while Ptr < Line_Length loop + exit when At_End_Of_Line; + + case Line_Buffer (Ptr) is + + when ''' => + + -- Two special cases here: + -- '"' => we don't want the " sign to appear as belonging + -- to a string. + -- '$' => this is obviously not a substitution, just skip it + + if Ptr < Line_Length - 1 + and then Line_Buffer (Ptr + 1) = '"' + then + Ptr := Ptr + 2; + elsif Ptr < Line_Length - 2 + and then Line_Buffer (Ptr + 1 .. Ptr + 2) = "$'" + then + Ptr := Ptr + 2; + end if; + + when '"' => + + -- The special case of "" inside the string is easy to + -- handle: just ignore them. The second one will be seen + -- as the beginning of a second string + + Ptr := Ptr + 1; + while Ptr < Line_Length + and then Line_Buffer (Ptr) /= '"' + loop + Ptr := Ptr + 1; + end loop; + + when '$' => + + -- $ found, so scan out possible following symbol + + Start_Sym := Ptr + 1; + + if Symbol_Scanned then + + -- Look up symbol in table and if found do replacement + + for J in 1 .. Num_Syms loop + if Matching_Strings + (Symbols (J).all, Line_Buffer (Start_Sym .. End_Sym)) + then + declare + OldL : constant Positive := + End_Sym - Start_Sym + 2; + NewL : constant Positive := Values (J)'Length; + AdjL : constant Integer := NewL - OldL; + NewP : constant Positive := Ptr + NewL - 1; + + begin + Line_Buffer (NewP + 1 .. Line_Length + AdjL) := + Line_Buffer (End_Sym + 1 .. Line_Length); + Line_Buffer (Ptr .. NewP) := Values (J).all; + + Ptr := NewP; + Line_Length := Line_Length + AdjL; + end; + + exit; + end if; + end loop; + end if; + + when others => + null; + + end case; + Ptr := Ptr + 1; + end loop; + end if; + + -- Here after dealing with preprocessor line, output current line + + <<Output>> + + if Is_Preprocessor_Line or else PP (PP_Depth).Deleting then + if Blank_Deleted_Lines then + New_Line (Outfile); + + elsif Opt_Comment_Deleted_Lines then + if Line_Length = 0 then + Put_Line (Outfile, "--!"); + else + Put (Outfile, "--! "); + Put_Line (Outfile, Line_Buffer (1 .. Line_Length)); + end if; + end if; + + else + Put_Line (Outfile, Line_Buffer (1 .. Line_Length)); + end if; + end loop; + + for J in 1 .. PP_Depth loop + Error ("no matching #end for #if at line" & + Natural'Image (PP (J).If_Line)); + end loop; + + if Num_Errors = 0 then + Close (Outfile); + Set_Exit_Status (0); + else + Delete (Outfile); + Set_Exit_Status (1); + end if; + +exception + when Usage_Error => + Help_Page; + Set_Exit_Status (1); + + when GNAT.Command_Line.Invalid_Parameter => + Put_Line (Standard_Error, "No parameter given for -" + & GNAT.Command_Line.Full_Switch); + Help_Page; + Set_Exit_Status (1); + + when GNAT.Command_Line.Invalid_Switch => + Put_Line (Standard_Error, "Invalid Switch: -" + & GNAT.Command_Line.Full_Switch); + Help_Page; + Set_Exit_Status (1); + + when Fatal_Error => + Set_Exit_Status (1); + + when Expression_Error => + Set_Exit_Status (1); + +end GNATprep; diff --git a/gcc/ada/gnatprep.ads b/gcc/ada/gnatprep.ads new file mode 100644 index 00000000000..7e8fbd82e7b --- /dev/null +++ b/gcc/ada/gnatprep.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T P R E P -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- Copyright (C) 1992-1998, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This program provides a simple preprocessing capability for Ada programs. +-- It is designed for use with GNAT, but is not dependent on any special +-- features of GNAT. + +-- To call gnatprep use + +-- gnatprep infile outfile [deffile] [-c] [-b] [-r] [-s] [-u] +-- [-Dsymbol=value] + +-- where + +-- infile is the full name of the input file, which is an Ada source +-- file containing preprocessor directives. + +-- outfile is the full name of the output file, which is an Ada source +-- in standard Ada form. When used with GNAT, this file name will +-- normally have an ads or adb suffix. + +-- deffile is the full name of a text file containing definitions of +-- symbols to be referenced by the preprocessor. This argument is optional + +-- The -c switch, causes both preprocessor lines and the lines deleted +-- by preprocessing to be retained in the output source as comments marked +-- with the special string "--! ". This option will result in line numbers +-- being preserved in the output file. + +-- The -b switch causes both preprocessor lines and the lines deleted by +-- preprocessing to be replaced by blank lines in the output source file, +-- thus preserving line numbers in the output file. + +-- The -r switch causes a Source_Reference pragma to be generated that +-- references the original input file, so that error messages will use +-- the file name of this original file. + +-- The -u switch causes gnatprep to treat any undefined symbol that it +-- encounters as having the value False. Otherwise an undefined symbol +-- is a fatal error. + +-- The -s switch causes a sorted list of symbol names and values to be +-- listed on the standard output file. + +-- The -D switch causes symbol 'symbol' to be associated with 'value'. +-- This symbols can then be referenced by the preprocessor + +-- Note: if neither -b nor -c is present, then preprocessor lines and +-- deleted lines are completely removed from the output, unless -r is +-- specified, in which case -b is assumed. + +-- The definitions file contains lines of the form + +-- symbol := value + +-- where symbol is an identifier, following normal Ada (case-insensitive) +-- rules for its syntax, and value is one of the following: + +-- Empty, corresponding to a null substitution + +-- A string literal using normal Ada syntax + +-- Any sequence of characters from the set +-- (letters, digits, period, underline) + +-- Comment lines may also appear in the definitions file, starting with +-- the usual --, and comments may be added to the definitions lines. + +-- The input text may contain preprocessor conditional inclusion lines, +-- and also general symbol substitution sequences. + +-- The preprocessor conditional inclusion commands have the form + +-- #if <expression> [then] +-- lines +-- #elsif <expression> [then] +-- lines +-- #elsif <expression> [then] +-- lines +-- ... +-- #else +-- lines +-- #end if; +-- +-- Where expression is defined by the following grammar : +-- expression ::= <symbol> +-- expression ::= <symbol> = "<value>" +-- expression ::= <symbol> = <symbol> +-- expression ::= <symbol> 'Defined +-- expression ::= not <expression> +-- expression ::= <expression> and <expression> +-- expression ::= <expression> or <expression> +-- expression ::= <expression> and then <expression> +-- expression ::= <expression> or else <expression> +-- expression ::= ( <expression> ) + +-- For these Boolean tests, the symbol must have either the value True or +-- False. If the value is True, then the corresponding lines are included, +-- and if the value is False, they are excluded. It is an error to +-- reference a symbol not defined in the symbol definitions file, or +-- to reference a symbol that has a value other than True or False. + +-- The use of the not operator inverts the sense of this logical test, so +-- that the lines are included only if the symbol is not defined. + +-- The THEN keyword is optional as shown + +-- Spaces or tabs may appear between the # and the keyword. The keywords +-- and the symbols are case insensitive as in normal Ada code. Comments +-- may be used on a preprocessor line, but other than that, no other +-- tokens may appear on a preprocessor line. + +-- Any number of #elsif clauses can be present, including none at all. + +-- The #else is optional, as in Ada. + +-- The # marking the start of a preprocessor line must be the first +-- non-blank character on the line, i.e. it must be preceded only by +-- spaces or horizontal tabs. + +-- Symbol substitution is obtained by using the sequence + +-- $symbol + +-- anywhere within a source line, except in a comment. The identifier +-- following the $ must match one of the symbols defined in the symbol +-- definition file, and the result is to substitute the value of the +-- symbol in place of $symbol in the output file. + +procedure GNATprep; diff --git a/gcc/ada/gnatpsta.adb b/gcc/ada/gnatpsta.adb new file mode 100644 index 00000000000..08dae2e0fe7 --- /dev/null +++ b/gcc/ada/gnatpsta.adb @@ -0,0 +1,375 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- G N A T P S T A -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 1997-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Program to print out listing of Standard package for the target (not +-- the host) with all constants appearing explicitly. This is not really +-- valid Ada, since one cannot really define new base types, but it is a +-- helpful listing from a documentation point of view. + +-- Note that special care has been taken to use the host parameters for +-- integer and floating point sizes. + +with Ada.Text_IO; use Ada.Text_IO; +with Gnatvsn; +with Ttypef; use Ttypef; +with Ttypes; use Ttypes; +with Types; use Types; + +procedure GnatPsta is + pragma Ident (Gnatvsn.Gnat_Version_String); + + procedure P (Item : String) renames Ada.Text_IO.Put_Line; + + procedure P_Int_Range (Size : Pos; Put_First : Boolean := True); + -- Prints the range of an integer based on its Size. If Put_First is + -- False, then skip the first bound. + + procedure P_Float_Range (Nb_Digits : Pos); + -- Prints the maximum range of a Float whose 'Digits is given by Nb_Digits + + ------------------- + -- P_Float_Range -- + ------------------- + + procedure P_Float_Range (Nb_Digits : Pos) is + begin + -- This routine assumes only IEEE floats. + -- ??? Should the following be adapted for OpenVMS ? + + case Nb_Digits is + when IEEES_Digits => + P (" range " & IEEES_First'Universal_Literal_String & " .. " & + IEEES_Last'Universal_Literal_String & ";"); + when IEEEL_Digits => + P (" range " & IEEEL_First'Universal_Literal_String & " .. " & + IEEEL_Last'Universal_Literal_String & ";"); + when IEEEX_Digits => + P (" range " & IEEEX_First'Universal_Literal_String & " .. " & + IEEEX_Last'Universal_Literal_String & ";"); + + when others => + P (";"); + end case; + + -- If one of the floating point types of the host computer has the + -- same digits as the target float we are processing, then print out + -- the float range using the host computer float type. + + if Nb_Digits = Short_Float'Digits then + P (" -- " & + Short_Float'First'Img & " .. " & Short_Float'Last'Img); + + elsif Nb_Digits = Float'Digits then + P (" -- " & + Float'First'Img & " .. " & Float'Last'Img); + + elsif Nb_Digits = Long_Float'Digits then + P (" -- " & + Long_Float'First'Img & " .. " & Long_Float'Last'Img); + + elsif Nb_Digits = Long_Long_Float'Digits then + P (" -- " & + Long_Long_Float'First'Img & " .. " & Long_Long_Float'Last'Img); + end if; + + New_Line; + end P_Float_Range; + + ----------------- + -- P_Int_Range -- + ----------------- + + procedure P_Int_Range (Size : Pos; Put_First : Boolean := True) is + begin + if Put_First then + Put (" is range -(2 **" & Pos'Image (Size - 1) & ")"); + end if; + P (" .. +(2 **" & Pos'Image (Size - 1) & " - 1);"); + end P_Int_Range; + +-- Start of processing for GnatPsta + +begin + P ("package Standard is"); + P ("pragma Pure(Standard);"); + New_Line; + + P (" type Boolean is (False, True);"); + New_Line; + + -- Integer types + + Put (" type Integer"); + P_Int_Range (Standard_Integer_Size); + New_Line; + + Put (" subtype Natural is Integer range 0"); + P_Int_Range (Standard_Integer_Size, Put_First => False); + + Put (" subtype Positive is Integer range 1"); + P_Int_Range (Standard_Integer_Size, Put_First => False); + New_Line; + + Put (" type Short_Short_Integer"); + P_Int_Range (Standard_Short_Short_Integer_Size); + + Put (" type Short_Integer "); + P_Int_Range (Standard_Short_Integer_Size); + + Put (" type Long_Integer "); + P_Int_Range (Standard_Long_Integer_Size); + + Put (" type Long_Long_Integer "); + P_Int_Range (Standard_Long_Long_Integer_Size); + New_Line; + + -- Floating point types + + P (" type Short_Float is digits" + & Standard_Short_Float_Digits'Img); + P_Float_Range (Standard_Short_Float_Digits); + + P (" type Float is digits" + & Standard_Float_Digits'Img); + P_Float_Range (Standard_Float_Digits); + + P (" type Long_Float is digits" + & Standard_Long_Float_Digits'Img); + P_Float_Range (Standard_Long_Float_Digits); + + P (" type Long_Long_Float is digits" + & Standard_Long_Long_Float_Digits'Img); + P_Float_Range (Standard_Long_Long_Float_Digits); + + P (" -- function ""*"" (Left : root_integer; Right : root_real)"); + P (" -- return root_real;"); + New_Line; + + P (" -- function ""*"" (Left : root_real; Right : root_integer)"); + P (" -- return root_real;"); + New_Line; + + P (" -- function ""/"" (Left : root_real; Right : root_integer)"); + P (" -- return root_real;"); + New_Line; + + P (" -- function ""*"" (Left : universal_fixed; " & + "Right : universal_fixed)"); + P (" -- return universal_fixed;"); + New_Line; + + P (" -- function ""/"" (Left : universal_fixed; " & + "Right : universal_fixed)"); + P (" -- return universal_fixed;"); + New_Line; + + P (" -- The declaration of type Character is based on the standard"); + P (" -- ISO 8859-1 character set."); + New_Line; + + P (" -- There are no character literals corresponding to the positions"); + P (" -- for control characters. They are indicated by lower case"); + P (" -- identifiers in the following list."); + New_Line; + + P (" -- Note: this type cannot be represented accurately in Ada"); + New_Line; + + P (" -- type Character is"); + New_Line; + + P (" -- (nul, soh, stx, etx, eot, enq, ack, bel,"); + P (" -- bs, ht, lf, vt, ff, cr, so, si,"); + New_Line; + + P (" -- dle, dc1, dc2, dc3, dc4, nak, syn, etb,"); + P (" -- can, em, sub, esc, fs, gs, rs, us,"); + New_Line; + + P (" -- ' ', '!', '""', '#', '$', '%', '&', ''',"); + P (" -- '(', ')', '*', '+', ',', '-', '.', '/',"); + New_Line; + + P (" -- '0', '1', '2', '3', '4', '5', '6', '7',"); + P (" -- '8', '9', ':', ';', '<', '=', '>', '?',"); + New_Line; + + P (" -- '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',"); + P (" -- 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',"); + New_Line; + + P (" -- 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',"); + P (" -- 'X', 'Y', 'Z', '[', '\', ']', '^', '_',"); + New_Line; + + P (" -- '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',"); + P (" -- 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',"); + New_Line; + + P (" -- 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',"); + P (" -- 'x', 'y', 'z', '{', '|', '}', '~', del,"); + New_Line; + + P (" -- reserved_128, reserved_129, bph, nbh,"); + P (" -- reserved_132, nel, ssa, esa,"); + New_Line; + + P (" -- hts, htj, vts, pld, plu, ri, ss2, ss3,"); + New_Line; + + P (" -- dcs, pu1, pu2, sts, cch, mw, spa, epa,"); + New_Line; + + P (" -- sos, reserved_153, sci, csi,"); + P (" -- st, osc, pm, apc,"); + New_Line; + + P (" -- ... );"); + New_Line; + + P (" -- The declaration of type Wide_Character is based " & + "on the standard"); + P (" -- ISO 10646 BMP character set."); + New_Line; + + P (" -- Note: this type cannot be represented accurately in Ada"); + New_Line; + + P (" -- The first 256 positions have the same contents as " & + "type Character"); + New_Line; + + P (" -- type Wide_Character is (nul, soh ... FFFE, FFFF);"); + New_Line; + + P (" package ASCII is"); + New_Line; + + P (" -- Control characters:"); + New_Line; + + P (" NUL : constant Character := Character'Val (16#00#);"); + P (" SOH : constant Character := Character'Val (16#01#);"); + P (" STX : constant Character := Character'Val (16#02#);"); + P (" ETX : constant Character := Character'Val (16#03#);"); + P (" EOT : constant Character := Character'Val (16#04#);"); + P (" ENQ : constant Character := Character'Val (16#05#);"); + P (" ACK : constant Character := Character'Val (16#06#);"); + P (" BEL : constant Character := Character'Val (16#07#);"); + P (" BS : constant Character := Character'Val (16#08#);"); + P (" HT : constant Character := Character'Val (16#09#);"); + P (" LF : constant Character := Character'Val (16#0A#);"); + P (" VT : constant Character := Character'Val (16#0B#);"); + P (" FF : constant Character := Character'Val (16#0C#);"); + P (" CR : constant Character := Character'Val (16#0D#);"); + P (" SO : constant Character := Character'Val (16#0E#);"); + P (" SI : constant Character := Character'Val (16#0F#);"); + P (" DLE : constant Character := Character'Val (16#10#);"); + P (" DC1 : constant Character := Character'Val (16#11#);"); + P (" DC2 : constant Character := Character'Val (16#12#);"); + P (" DC3 : constant Character := Character'Val (16#13#);"); + P (" DC4 : constant Character := Character'Val (16#14#);"); + P (" NAK : constant Character := Character'Val (16#15#);"); + P (" SYN : constant Character := Character'Val (16#16#);"); + P (" ETB : constant Character := Character'Val (16#17#);"); + P (" CAN : constant Character := Character'Val (16#18#);"); + P (" EM : constant Character := Character'Val (16#19#);"); + P (" SUB : constant Character := Character'Val (16#1A#);"); + P (" ESC : constant Character := Character'Val (16#1B#);"); + P (" FS : constant Character := Character'Val (16#1C#);"); + P (" GS : constant Character := Character'Val (16#1D#);"); + P (" RS : constant Character := Character'Val (16#1E#);"); + P (" US : constant Character := Character'Val (16#1F#);"); + P (" DEL : constant Character := Character'Val (16#7F#);"); + New_Line; + + P (" -- Other characters:"); + New_Line; + + P (" Exclam : constant Character := '!';"); + P (" Quotation : constant Character := '""';"); + P (" Sharp : constant Character := '#';"); + P (" Dollar : constant Character := '$';"); + P (" Percent : constant Character := '%';"); + P (" Ampersand : constant Character := '&';"); + P (" Colon : constant Character := ':';"); + P (" Semicolon : constant Character := ';';"); + P (" Query : constant Character := '?';"); + P (" At_Sign : constant Character := '@';"); + P (" L_Bracket : constant Character := '[';"); + P (" Back_Slash : constant Character := '\';"); + P (" R_Bracket : constant Character := ']';"); + P (" Circumflex : constant Character := '^';"); + P (" Underline : constant Character := '_';"); + P (" Grave : constant Character := '`';"); + P (" L_Brace : constant Character := '{';"); + P (" Bar : constant Character := '|';"); + P (" R_Brace : constant Character := '}';"); + P (" Tilde : constant Character := '~';"); + New_Line; + + P (" -- Lower case letters:"); + New_Line; + + for C in Character range 'a' .. 'z' loop + P (" LC_" & Character'Val (Character'Pos (C) - 32) & + " : constant Character := '" & C & "';"); + end loop; + New_Line; + + P (" end ASCII;"); + New_Line; + + P (" type String is array (Positive range <>) of Character;"); + P (" pragma Pack (String);"); + New_Line; + + P (" type Wide_String is array (Positive range <>) of Wide_Character;"); + P (" pragma Pack (Wide_String);"); + New_Line; + + -- Here it's OK to use the Duration type of the host compiler since + -- the implementation of Duration in GNAT is target independent. + + P (" type Duration is delta" & + Duration'Image (Duration'Delta)); + P (" range -((2 **" & Natural'Image (Duration'Size - 1) & + " - 1) *" & Duration'Image (Duration'Delta) & ") .."); + P (" +((2 **" & Natural'Image (Duration'Size - 1) & + " - 1) *" & Duration'Image (Duration'Delta) & ");"); + P (" for Duration'Small use" & Duration'Image (Duration'Small) & ";"); + New_Line; + + P (" Constraint_Error : exception;"); + P (" Program_Error : exception;"); + P (" Storage_Error : exception;"); + P (" Tasking_Error : exception;"); + New_Line; + + P ("end Standard;"); +end GnatPsta; diff --git a/gcc/ada/gnatpsys.adb b/gcc/ada/gnatpsys.adb new file mode 100644 index 00000000000..9e65c2a2537 --- /dev/null +++ b/gcc/ada/gnatpsys.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- G N A T P S Y S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1997 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Program to print out listing of System package with all constants +-- appearing explicitly. + +with Ada.Text_IO; +with System; use System; +with Gnatvsn; + +procedure GnatPsys is + pragma Ident (Gnatvsn.Gnat_Version_String); + + procedure P (Item : String) renames Ada.Text_IO.Put_Line; + +begin + P ("package System is"); + + P ("pragma Pure (System);"); + + P (""); + + P (" type Name is (SYSTEM_NAME_GNAT);"); + + P (" System_Name : constant Name := SYSTEM_NAME_GNAT;"); + + P (""); + + P (" -- System-Dependent Named Numbers"); + + P (""); + + P (" Min_Int : constant := -(2 **" & + Long_Long_Integer'Image (Long_Long_Integer'Size - 1) & ");"); + + P (" Max_Int : constant := 2 **" & + Long_Long_Integer'Image (Long_Long_Integer'Size - 1) & " - 1;"); + + P (""); + + P (" Max_Binary_Modulus : constant := 2 **" & + Long_Long_Integer'Image (Long_Long_Integer'Size) & ";"); + + P (" Max_Nonbinary_Modulus : constant :=" & + Integer'Image (Integer'Last) & ";"); + + P (""); + + P (" Max_Base_Digits : constant :=" & + Natural'Image (Long_Long_Float'Digits) & ";"); + + P (" Max_Digits : constant :=" & + Natural'Image (Long_Long_Float'Digits) & ";"); + + P (""); + + P (" Max_Mantissa : constant := 63;"); + + P (" Fine_Delta : constant := 2.0 ** (-Max_Mantissa);"); + + P (""); + + P (" Tick : constant :=" & + Duration'Image (Duration (Standard'Tick)) & ";"); + + P (""); + + P (" -- Storage-related Declarations"); + + P (""); + + P (" type Address is private;"); + + P (" Null_Address : constant Address;"); + + P (""); + + P (" Storage_Unit : constant :=" & + Natural'Image (Standard'Storage_Unit) & ";"); + + P (" Word_Size : constant :=" & + Natural'Image (Standard'Word_Size) & ";"); + + P (" Memory_Size : constant := 2 **" & + Natural'Image (Standard'Address_Size) & ";"); + + P (""); + P (" -- Address comparison"); + P (""); + P (" function ""<"" (Left, Right : Address) return Boolean;"); + P (" function ""<="" (Left, Right : Address) return Boolean;"); + P (" function "">"" (Left, Right : Address) return Boolean;"); + P (" function "">="" (Left, Right : Address) return Boolean;"); + P (" function ""="" (Left, Right : Address) return Boolean;"); + P (""); + P (" pragma Import (Intrinsic, ""<""); "); + P (" pragma Import (Intrinsic, ""<="");"); + P (" pragma Import (Intrinsic, "">""); "); + P (" pragma Import (Intrinsic, "">="");"); + P (" pragma Import (Intrinsic, ""=""); "); + P (""); + P (" -- Other System-Dependent Declarations"); + P (""); + P (" type Bit_Order is (High_Order_First, Low_Order_First);"); + P (" Default_Bit_Order : constant Bit_Order;"); + P (""); + P (" -- Priority-related Declarations (RM D.1)"); + P (""); + P (" subtype Any_Priority is Integer range 0 .." & + Natural'Image (Standard'Max_Interrupt_Priority) & ";"); + + P (""); + + P (" subtype Priority is Any_Priority range 0 .." & + Natural'Image (Standard'Max_Priority) & ";"); + + P (""); + + P (" subtype Interrupt_Priority is Any_Priority range" & + Natural'Image (Standard'Max_Priority + 1) & " .." & + Natural'Image (Standard'Max_Interrupt_Priority) & ";"); + + P (""); + + P (" Default_Priority : constant Priority :=" & + Natural'Image ((Priority'First + Priority'Last) / 2) & ";"); + + P (""); + + P ("private"); + + P (""); + + P (" type Address is mod Memory_Size; "); + + P (" Null_Address : constant Address := 0; "); + + P (" "); + + P (" Default_Bit_Order : constant Bit_Order := " & + Bit_Order'Image (Bit_Order'Val (Standard'Default_Bit_Order)) & ";"); + + P (""); + + P ("end System;"); +end GnatPsys; diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads new file mode 100644 index 00000000000..a6f27cdbf16 --- /dev/null +++ b/gcc/ada/gnatvsn.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T V S N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2068 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package spec holds version information for GNAT, GNATBIND and +-- GNATMAKE. It is updated whenever the release number is changed. + +package Gnatvsn is + + Gnat_Version_String : constant String := "5.00w (20010924)"; + -- Version output when GNAT (compiler), or its related tools, including + -- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run + -- (with appropriate verbose option switch set). + -- + -- WARNING: some gnatmail scripts (at least make-bin and corcs) rely on + -- the format of this string. Any change must be coordinated with + -- a gnatmail maintainer. + + Ver_Len_Max : constant := 32; + -- 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 := "GNAT Lib v3.15 "; + -- 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. + -- + -- Note: Makefile.in relies on the precise format of the library version + -- string in order to correctly construct the soname value. + +end Gnatvsn; diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb new file mode 100644 index 00000000000..6e44ddcdde7 --- /dev/null +++ b/gcc/ada/gnatxref.adb @@ -0,0 +1,210 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T X R E F -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1998-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Xr_Tabls; +with Xref_Lib; use Xref_Lib; +with Ada.Text_IO; +with Ada.Strings.Fixed; +with GNAT.Command_Line; +with Gnatvsn; +with Osint; + +procedure Gnatxref is + + Search_Unused : Boolean := False; + Local_Symbols : Boolean := True; + Prj_File : File_Name_String; + Prj_File_Length : Natural := 0; + Usage_Error : exception; + Full_Path_Name : Boolean := False; + Vi_Mode : Boolean := False; + Read_Only : Boolean := False; + Have_File : Boolean := False; + Der_Info : Boolean := False; + + procedure Parse_Cmd_Line; + -- Parse every switch on the command line + + procedure Write_Usage; + -- Print a small help page for program usage + + -------------------- + -- Parse_Cmd_Line -- + -------------------- + + procedure Parse_Cmd_Line is + begin + loop + case GNAT.Command_Line.Getopt ("a aI: aO: d f g h I: p: u v") is + when ASCII.NUL => + exit; + + when 'a' => + if GNAT.Command_Line.Full_Switch = "a" then + Read_Only := True; + elsif GNAT.Command_Line.Full_Switch = "aI" then + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + else + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + end if; + + when 'd' => + Der_Info := True; + + when 'f' => + Full_Path_Name := True; + + when 'g' => + Local_Symbols := False; + + when 'h' => + Write_Usage; + + when 'I' => + Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + + when 'p' => + declare + S : constant String := GNAT.Command_Line.Parameter; + + begin + Prj_File_Length := S'Length; + Prj_File (1 .. Prj_File_Length) := S; + end; + + when 'u' => + Search_Unused := True; + Vi_Mode := False; + + when 'v' => + Vi_Mode := True; + Search_Unused := False; + + when others => + Write_Usage; + end case; + end loop; + + -- Get the other arguments + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + + begin + exit when S'Length = 0; + + if Ada.Strings.Fixed.Index (S, ":") /= 0 then + Ada.Text_IO.Put_Line + ("Only file names are allowed on the command line"); + Write_Usage; + end if; + + Add_File (S); + Have_File := True; + end; + end loop; + + exception + when GNAT.Command_Line.Invalid_Switch => + Ada.Text_IO.Put_Line ("Invalid switch : " + & GNAT.Command_Line.Full_Switch); + Write_Usage; + + when GNAT.Command_Line.Invalid_Parameter => + Ada.Text_IO.Put_Line ("Parameter missing for : " + & GNAT.Command_Line.Parameter); + Write_Usage; + end Parse_Cmd_Line; + + ----------------- + -- Write_Usage -- + ----------------- + + procedure Write_Usage is + use Ada.Text_IO; + + begin + Put_Line ("GNATXREF " & Gnatvsn.Gnat_Version_String + & " Copyright 1998-2001, Ada Core Technologies Inc."); + Put_Line ("Usage: gnatxref [switches] file1 file2 ..."); + New_Line; + Put_Line (" file ... list of source files to xref, " & + "including with'ed units"); + New_Line; + Put_Line ("gnatxref switches:"); + Put_Line (" -a Consider all files, even when the ali file is" + & " readonly"); + Put_Line (" -aIdir Specify source files search path"); + Put_Line (" -aOdir Specify library/object files search path"); + Put_Line (" -d Output derived type information"); + Put_Line (" -f Output full path name"); + Put_Line (" -g Output information only for global symbols"); + Put_Line (" -Idir Like -aIdir -aOdir"); + Put_Line (" -p file Use file as the default project file"); + Put_Line (" -u List unused entities"); + Put_Line (" -v Print a 'tags' file for vi"); + New_Line; + + raise Usage_Error; + end Write_Usage; + +begin + Parse_Cmd_Line; + + if not Have_File then + Write_Usage; + end if; + + Xr_Tabls.Set_Default_Match (True); + + -- Find the project file + + if Prj_File_Length = 0 then + Xr_Tabls.Create_Project_File + (Default_Project_File (Osint.To_Host_Dir_Spec (".", False).all)); + else + Xr_Tabls.Create_Project_File (Prj_File (1 .. Prj_File_Length)); + end if; + + -- Fill up the table + + Search_Xref (Local_Symbols, Read_Only, Der_Info); + + if Search_Unused then + Print_Unused (Full_Path_Name); + elsif Vi_Mode then + Print_Vi (Full_Path_Name); + else + Print_Xref (Full_Path_Name); + end if; + +exception + when Usage_Error => + null; +end Gnatxref; diff --git a/gcc/ada/hlo.adb b/gcc/ada/hlo.adb new file mode 100644 index 00000000000..86fe3bd3282 --- /dev/null +++ b/gcc/ada/hlo.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- H L O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 1998 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Output; use Output; + +package body HLO is + + ------------------------- + -- High_Level_Optimize -- + ------------------------- + + procedure High_Level_Optimize (N : Node_Id) is + begin + Write_Str ("High level optimizer activated"); + Write_Eol; + Write_Str ("High level optimizer completed"); + Write_Eol; + end High_Level_Optimize; + +end HLO; diff --git a/gcc/ada/hlo.ads b/gcc/ada/hlo.ads new file mode 100644 index 00000000000..22d37e5d17f --- /dev/null +++ b/gcc/ada/hlo.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- H L O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 1998 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package HLO is + + procedure High_Level_Optimize (N : Node_Id); + -- This procedure activates the high level optimizer. At the time it is + -- called, the tree for compilation unit N has been fully analyzed, but + -- not expanded, but the Analyzed flags have been reset. On return, the + -- tree may be modified (and will be reanalyzed and expanded as required). + +end HLO; diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads new file mode 100644 index 00000000000..b076f99bd69 --- /dev/null +++ b/gcc/ada/hostparm.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- H O S T P A R M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines some system dependent parameters for GNAT. These +-- are parameters that are relevant to the host machine on which the +-- compiler is running, and thus this package is part of the compiler. + +package Hostparm is +pragma Preelaborate (Hostparm); + + ----------------------- + -- TARGET Parameters -- + ----------------------- + + -- ??? The following should really be moved to a Target package + + Java_VM : constant Boolean := False; + -- Set true when compiling the JGNAT tool chain (compiler, gnatmake, etc) + + --------------------- + -- HOST Parameters -- + --------------------- + + OpenVMS : Boolean := False; + -- Set True for OpenVMS host. See also OpenVMS target boolean in + -- 5vsystem.ads and OpenVMS_On_Target boolean in Targparm. This is + -- not a constant, because it can be modified by -gnatdm. + + Normalized_CWD : constant String := "./"; + -- Normalized string to access current directory + + Max_Line_Length : constant := 255; + -- Maximum source line length. This can be set to any value up to + -- 2**15 - 1, a limit imposed by the assumption that column numbers + -- can be stored in 16 bits (see Types.Column_Number). A value of + -- 200 is the minimum value required (RM 2.2(15)), but we use 255 + -- for most GNAT targets since this is DEC Ada compatible. + + Max_Name_Length : constant := 1024; + -- Maximum length of unit name (including all dots, and " (spec)") and + -- of file names in the library, must be at least Max_Line_Length, but + -- can be larger. + + Max_Instantiations : constant := 4000; + -- Maximum number of instantiations permitted (to stop runaway cases + -- of nested instantiations). These situations probably only occur in + -- specially concocted test cases. + + Tag_Errors : constant Boolean := False; + -- If set to true, then brief form error messages will be prefaced by + -- the string "error:". Used as default for Opt.Unique_Error_Tag. + + Exclude_Missing_Objects : constant Boolean := True; + -- If set to true, gnatbind will exclude from consideration all + -- non-existent .o files. + + Max_Debug_Name_Length : constant := 256; + -- If a generated qualified debug name exceeds this length, then it + -- is automatically compressed, regardless of the setting of the + -- Compress_Debug_Names switch controlled by -gnatC. + +end Hostparm; diff --git a/gcc/ada/i-c.adb b/gcc/ada/i-c.adb new file mode 100644 index 00000000000..33410de2941 --- /dev/null +++ b/gcc/ada/i-c.adb @@ -0,0 +1,453 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.C is + + ----------------------- + -- Is_Nul_Terminated -- + ----------------------- + + -- Case of char_array + + function Is_Nul_Terminated (Item : char_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of wchar_array + + function Is_Nul_Terminated (Item : wchar_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = wide_nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + ------------ + -- To_Ada -- + ------------ + + -- Convert char to Character + + function To_Ada (Item : char) return Character is + begin + return Character'Val (char'Pos (Item)); + end To_Ada; + + -- Convert char_array to String (function form) + + function To_Ada + (Item : char_array; + Trim_Nul : Boolean := True) + return String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char_array to String (procedure form) + + procedure To_Ada + (Item : char_array; + Target : out String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := Character (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + + end To_Ada; + + -- Convert wchar_t to Wide_Character + + function To_Ada (Item : wchar_t) return Wide_Character is + begin + return Wide_Character (Item); + end To_Ada; + + -- Convert wchar_array to Wide_String (function form) + + function To_Ada + (Item : wchar_array; + Trim_Nul : Boolean := True) + return Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : Wide_String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert wchar_array to Wide_String (procedure form) + + procedure To_Ada + (Item : wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + + end To_Ada; + + ---------- + -- To_C -- + ---------- + + -- Convert Character to char + + function To_C (Item : Character) return char is + begin + return char'Val (Character'Pos (Item)); + end To_C; + + -- Convert String to char_array (function form) + + function To_C + (Item : String; + Append_Nul : Boolean := True) + return char_array + is + begin + if Append_Nul then + declare + R : char_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := nul; + return R; + end; + + else -- Append_Nul is False + + -- A nasty case, if the string is null, we must return + -- a null char_array. The lower bound of this array is + -- required to be zero (RM B.3(50)) but that is of course + -- impossible given that size_t is unsigned. This needs + -- ARG resolution, but for now GNAT returns bounds 1 .. 0 + + if Item'Length = 0 then + declare + R : char_array (1 .. 0); + + begin + return R; + end; + + else + declare + R : char_array (0 .. Item'Length - 1); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert String to char_array (procedure form) + + procedure To_C + (Item : String; + Target : out char_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := char (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to wchar_t + + function To_C (Item : Wide_Character) return wchar_t is + begin + return wchar_t (Item); + end To_C; + + -- Convert Wide_String to wchar_array (function form) + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) + return wchar_array + is + begin + if Append_Nul then + declare + R : wchar_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := wide_nul; + return R; + end; + + else + -- A nasty case, if the string is null, we must return + -- a null char_array. The lower bound of this array is + -- required to be zero (RM B.3(50)) but that is of course + -- impossible given that size_t is unsigned. This needs + -- ARG resolution, but for now GNAT returns bounds 1 .. 0 + + if Item'Length = 0 then + declare + R : wchar_array (1 .. 0); + + begin + return R; + end; + + else + declare + R : wchar_array (0 .. Item'Length - 1); + + begin + for J in size_t range 0 .. Item'Length - 1 loop + R (J) := To_C (Item (Integer (J) + Item'First)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_String to wchar_array (procedure form) + + procedure To_C + (Item : Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := wide_nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + +end Interfaces.C; diff --git a/gcc/ada/i-c.ads b/gcc/ada/i-c.ads new file mode 100644 index 00000000000..848c5247cc3 --- /dev/null +++ b/gcc/ada/i-c.ads @@ -0,0 +1,140 @@ +----------------------------------------------------------------------------- +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.19 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System.Parameters; + +package Interfaces.C is +pragma Pure (C); + + -- Declaration's based on C's <limits.h> + + CHAR_BIT : constant := 8; + SCHAR_MIN : constant := -128; + SCHAR_MAX : constant := 127; + UCHAR_MAX : constant := 255; + + -- Signed and Unsigned Integers. Note that in GNAT, we have ensured that + -- the standard predefined Ada types correspond to the standard C types + + type int is new Integer; + type short is new Short_Integer; + type long is range -(2 ** (System.Parameters.long_bits - 1)) + .. +(2 ** (System.Parameters.long_bits - 1)) - 1; + + type signed_char is range SCHAR_MIN .. SCHAR_MAX; + for signed_char'Size use CHAR_BIT; + + type unsigned is mod 2 ** int'Size; + type unsigned_short is mod 2 ** short'Size; + type unsigned_long is mod 2 ** long'Size; + + type unsigned_char is mod (UCHAR_MAX + 1); + for unsigned_char'Size use CHAR_BIT; + + subtype plain_char is unsigned_char; -- ??? should be parametrized + + type ptrdiff_t is + range -(2 ** (Standard'Address_Size - 1)) .. + +(2 ** (Standard'Address_Size - 1) - 1); + + type size_t is mod 2 ** Standard'Address_Size; + + -- Floating-Point + + type C_float is new Float; + type double is new Standard.Long_Float; + type long_double is new Standard.Long_Long_Float; + + ---------------------------- + -- Characters and Strings -- + ---------------------------- + + type char is new Character; + + nul : constant char := char'First; + + function To_C (Item : Character) return char; + function To_Ada (Item : char) return Character; + + type char_array is array (size_t range <>) of aliased char; + for char_array'Component_Size use CHAR_BIT; + + function Is_Nul_Terminated (Item : in char_array) return Boolean; + + function To_C + (Item : in String; + Append_Nul : in Boolean := True) + return char_array; + + function To_Ada + (Item : in char_array; + Trim_Nul : in Boolean := True) + return String; + + procedure To_C + (Item : in String; + Target : out char_array; + Count : out size_t; + Append_Nul : in Boolean := True); + + procedure To_Ada + (Item : in char_array; + Target : out String; + Count : out Natural; + Trim_Nul : in Boolean := True); + + ------------------------------------ + -- Wide Character and Wide String -- + ------------------------------------ + + type wchar_t is new Wide_Character; + for wchar_t'Size use Standard'Wchar_T_Size; + + wide_nul : constant wchar_t := wchar_t'First; + + function To_C (Item : in Wide_Character) return wchar_t; + function To_Ada (Item : in wchar_t) return Wide_Character; + + type wchar_array is array (size_t range <>) of aliased wchar_t; + + function Is_Nul_Terminated (Item : in wchar_array) return Boolean; + + function To_C + (Item : in Wide_String; + Append_Nul : in Boolean := True) + return wchar_array; + + function To_Ada + (Item : in wchar_array; + Trim_Nul : in Boolean := True) + return Wide_String; + + procedure To_C + (Item : in Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : in Boolean := True); + + procedure To_Ada + (Item : in wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : in Boolean := True); + + Terminator_Error : exception; + +end Interfaces.C; diff --git a/gcc/ada/i-cexten.ads b/gcc/ada/i-cexten.ads new file mode 100644 index 00000000000..85506195bce --- /dev/null +++ b/gcc/ada/i-cexten.ads @@ -0,0 +1,253 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . E X T E N S I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains additional C-related definitions, intended for use +-- with either manually or automatically generated bindings to C libraries. + +with System; + +package Interfaces.C.Extensions is + + subtype void is System.Address; + subtype void_ptr is System.Address; + + subtype opaque_structure_def is System.Address; + type opaque_structure_def_ptr is access opaque_structure_def; + + subtype incomplete_class_def is System.Address; + type incomplete_class_def_ptr is access incomplete_class_def; + + -- + -- 64bit integer types + -- + + subtype long_long is Long_Long_Integer; + type unsigned_long_long is mod 2 ** 64; + + -- + -- Types for bitfields + -- + + type Unsigned_1 is mod 2 ** 1; + for Unsigned_1'Size use 1; + + type Unsigned_2 is mod 2 ** 2; + for Unsigned_2'Size use 2; + + type Unsigned_3 is mod 2 ** 3; + for Unsigned_3'Size use 3; + + type Unsigned_4 is mod 2 ** 4; + for Unsigned_4'Size use 4; + + type Unsigned_5 is mod 2 ** 5; + for Unsigned_5'Size use 5; + + type Unsigned_6 is mod 2 ** 6; + for Unsigned_6'Size use 6; + + type Unsigned_7 is mod 2 ** 7; + for Unsigned_7'Size use 7; + + type Unsigned_8 is mod 2 ** 8; + for Unsigned_8'Size use 8; + + type Unsigned_9 is mod 2 ** 9; + for Unsigned_9'Size use 9; + + type Unsigned_10 is mod 2 ** 10; + for Unsigned_10'Size use 10; + + type Unsigned_11 is mod 2 ** 11; + for Unsigned_11'Size use 11; + + type Unsigned_12 is mod 2 ** 12; + for Unsigned_12'Size use 12; + + type Unsigned_13 is mod 2 ** 13; + for Unsigned_13'Size use 13; + + type Unsigned_14 is mod 2 ** 14; + for Unsigned_14'Size use 14; + + type Unsigned_15 is mod 2 ** 15; + for Unsigned_15'Size use 15; + + type Unsigned_16 is mod 2 ** 16; + for Unsigned_16'Size use 16; + + type Unsigned_17 is mod 2 ** 17; + for Unsigned_17'Size use 17; + + type Unsigned_18 is mod 2 ** 18; + for Unsigned_18'Size use 18; + + type Unsigned_19 is mod 2 ** 19; + for Unsigned_19'Size use 19; + + type Unsigned_20 is mod 2 ** 20; + for Unsigned_20'Size use 20; + + type Unsigned_21 is mod 2 ** 21; + for Unsigned_21'Size use 21; + + type Unsigned_22 is mod 2 ** 22; + for Unsigned_22'Size use 22; + + type Unsigned_23 is mod 2 ** 23; + for Unsigned_23'Size use 23; + + type Unsigned_24 is mod 2 ** 24; + for Unsigned_24'Size use 24; + + type Unsigned_25 is mod 2 ** 25; + for Unsigned_25'Size use 25; + + type Unsigned_26 is mod 2 ** 26; + for Unsigned_26'Size use 26; + + type Unsigned_27 is mod 2 ** 27; + for Unsigned_27'Size use 27; + + type Unsigned_28 is mod 2 ** 28; + for Unsigned_28'Size use 28; + + type Unsigned_29 is mod 2 ** 29; + for Unsigned_29'Size use 29; + + type Unsigned_30 is mod 2 ** 30; + for Unsigned_30'Size use 30; + + type Unsigned_31 is mod 2 ** 31; + for Unsigned_31'Size use 31; + + type Unsigned_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type Signed_2 is range -2 ** 1 .. 2 ** 1 - 1; + for Signed_2'Size use 2; + + type Signed_3 is range -2 ** 2 .. 2 ** 2 - 1; + for Signed_3'Size use 3; + + type Signed_4 is range -2 ** 3 .. 2 ** 3 - 1; + for Signed_4'Size use 4; + + type Signed_5 is range -2 ** 4 .. 2 ** 4 - 1; + for Signed_5'Size use 5; + + type Signed_6 is range -2 ** 5 .. 2 ** 5 - 1; + for Signed_6'Size use 6; + + type Signed_7 is range -2 ** 6 .. 2 ** 6 - 1; + for Signed_7'Size use 7; + + type Signed_8 is range -2 ** 7 .. 2 ** 7 - 1; + for Signed_8'Size use 8; + + type Signed_9 is range -2 ** 8 .. 2 ** 8 - 1; + for Signed_9'Size use 9; + + type Signed_10 is range -2 ** 9 .. 2 ** 9 - 1; + for Signed_10'Size use 10; + + type Signed_11 is range -2 ** 10 .. 2 ** 10 - 1; + for Signed_11'Size use 11; + + type Signed_12 is range -2 ** 11 .. 2 ** 11 - 1; + for Signed_12'Size use 12; + + type Signed_13 is range -2 ** 12 .. 2 ** 12 - 1; + for Signed_13'Size use 13; + + type Signed_14 is range -2 ** 13 .. 2 ** 13 - 1; + for Signed_14'Size use 14; + + type Signed_15 is range -2 ** 14 .. 2 ** 14 - 1; + for Signed_15'Size use 15; + + type Signed_16 is range -2 ** 15 .. 2 ** 15 - 1; + for Signed_16'Size use 16; + + type Signed_17 is range -2 ** 16 .. 2 ** 16 - 1; + for Signed_17'Size use 17; + + type Signed_18 is range -2 ** 17 .. 2 ** 17 - 1; + for Signed_18'Size use 18; + + type Signed_19 is range -2 ** 18 .. 2 ** 18 - 1; + for Signed_19'Size use 19; + + type Signed_20 is range -2 ** 19 .. 2 ** 19 - 1; + for Signed_20'Size use 20; + + type Signed_21 is range -2 ** 20 .. 2 ** 20 - 1; + for Signed_21'Size use 21; + + type Signed_22 is range -2 ** 21 .. 2 ** 21 - 1; + for Signed_22'Size use 22; + + type Signed_23 is range -2 ** 22 .. 2 ** 22 - 1; + for Signed_23'Size use 23; + + type Signed_24 is range -2 ** 23 .. 2 ** 23 - 1; + for Signed_24'Size use 24; + + type Signed_25 is range -2 ** 24 .. 2 ** 24 - 1; + for Signed_25'Size use 25; + + type Signed_26 is range -2 ** 25 .. 2 ** 25 - 1; + for Signed_26'Size use 26; + + type Signed_27 is range -2 ** 26 .. 2 ** 26 - 1; + for Signed_27'Size use 27; + + type Signed_28 is range -2 ** 27 .. 2 ** 27 - 1; + for Signed_28'Size use 28; + + type Signed_29 is range -2 ** 28 .. 2 ** 28 - 1; + for Signed_29'Size use 29; + + type Signed_30 is range -2 ** 29 .. 2 ** 29 - 1; + for Signed_30'Size use 30; + + type Signed_31 is range -2 ** 30 .. 2 ** 30 - 1; + for Signed_31'Size use 31; + + type Signed_32 is range -2 ** 31 .. 2 ** 31 - 1; + for Signed_32'Size use 32; + + +end Interfaces.C.Extensions; diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb new file mode 100644 index 00000000000..74b65b9e457 --- /dev/null +++ b/gcc/ada/i-cobol.adb @@ -0,0 +1,1024 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . C O B O L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1992-1999 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- The body of Interfaces.COBOL is implementation independent (i.e. the +-- same version is used with all versions of GNAT). The specialization +-- to a particular COBOL format is completely contained in the private +-- part ot the spec. + +with Interfaces; use Interfaces; +with System; use System; +with Unchecked_Conversion; + +package body Interfaces.COBOL is + + ----------------------------------------------- + -- Declarations for External Binary Handling -- + ----------------------------------------------- + + subtype B1 is Byte_Array (1 .. 1); + subtype B2 is Byte_Array (1 .. 2); + subtype B4 is Byte_Array (1 .. 4); + subtype B8 is Byte_Array (1 .. 8); + -- Representations for 1,2,4,8 byte binary values + + function To_B1 is new Unchecked_Conversion (Integer_8, B1); + function To_B2 is new Unchecked_Conversion (Integer_16, B2); + function To_B4 is new Unchecked_Conversion (Integer_32, B4); + function To_B8 is new Unchecked_Conversion (Integer_64, B8); + -- Conversions from native binary to external binary + + function From_B1 is new Unchecked_Conversion (B1, Integer_8); + function From_B2 is new Unchecked_Conversion (B2, Integer_16); + function From_B4 is new Unchecked_Conversion (B4, Integer_32); + function From_B8 is new Unchecked_Conversion (B8, Integer_64); + -- Conversions from external binary to signed native binary + + function From_B1U is new Unchecked_Conversion (B1, Unsigned_8); + function From_B2U is new Unchecked_Conversion (B2, Unsigned_16); + function From_B4U is new Unchecked_Conversion (B4, Unsigned_32); + function From_B8U is new Unchecked_Conversion (B8, Unsigned_64); + -- Conversions from external binary to unsigned native binary + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Binary_To_Decimal + (Item : Byte_Array; + Format : Binary_Format) + return Integer_64; + -- This function converts a numeric value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + function Numeric_To_Decimal + (Item : Numeric; + Format : Display_Format) + return Integer_64; + -- This function converts a numeric value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + function Packed_To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) + return Integer_64; + -- This function converts a packed value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + procedure Swap (B : in out Byte_Array; F : Binary_Format); + -- Swaps the bytes if required by the binary format F + + function To_Display + (Item : Integer_64; + Format : Display_Format; + Length : Natural) + return Numeric; + -- This function converts the given integer value into display format, + -- using the given format, with the length in bytes of the result given + -- by the last parameter. This is the non-generic implementation of + -- Decimal_Conversions.To_Display. The conversion of the item from its + -- original decimal format to Integer_64 is done by the generic routine. + + function To_Packed + (Item : Integer_64; + Format : Packed_Format; + Length : Natural) + return Packed_Decimal; + -- This function converts the given integer value into packed format, + -- using the given format, with the length in digits of the result given + -- by the last parameter. This is the non-generic implementation of + -- Decimal_Conversions.To_Display. The conversion of the item from its + -- original decimal format to Integer_64 is done by the generic routine. + + function Valid_Numeric + (Item : Numeric; + Format : Display_Format) + return Boolean; + -- This is the non-generic implementation of Decimal_Conversions.Valid + -- for the display case. + + function Valid_Packed + (Item : Packed_Decimal; + Format : Packed_Format) + return Boolean; + -- This is the non-generic implementation of Decimal_Conversions.Valid + -- for the packed case. + + ----------------------- + -- Binary_To_Decimal -- + ----------------------- + + function Binary_To_Decimal + (Item : Byte_Array; + Format : Binary_Format) + return Integer_64 + is + Len : constant Natural := Item'Length; + + begin + if Len = 1 then + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B1U (Item)); + else + return Integer_64 (From_B1 (Item)); + end if; + + elsif Len = 2 then + declare + R : B2 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B2U (R)); + else + return Integer_64 (From_B2 (R)); + end if; + end; + + elsif Len = 4 then + declare + R : B4 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B4U (R)); + else + return Integer_64 (From_B4 (R)); + end if; + end; + + elsif Len = 8 then + declare + R : B8 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B8U (R)); + else + return Integer_64 (From_B8 (R)); + end if; + end; + + -- Length is not 1, 2, 4 or 8 + + else + raise Conversion_Error; + end if; + end Binary_To_Decimal; + + ------------------------ + -- Numeric_To_Decimal -- + ------------------------ + + -- The following assumptions are made in the coding of this routine + + -- The range of COBOL_Digits is compact and the ten values + -- represent the digits 0-9 in sequence + + -- The range of COBOL_Plus_Digits is compact and the ten values + -- represent the digits 0-9 in sequence with a plus sign. + + -- The range of COBOL_Minus_Digits is compact and the ten values + -- represent the digits 0-9 in sequence with a minus sign. + + -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits + + -- These assumptions are true for all COBOL representations we know of. + + function Numeric_To_Decimal + (Item : Numeric; + Format : Display_Format) + return Integer_64 + is + pragma Unsuppress (Range_Check); + Sign : COBOL_Character := COBOL_Plus; + Result : Integer_64 := 0; + + begin + if not Valid_Numeric (Item, Format) then + raise Conversion_Error; + end if; + + for J in Item'Range loop + declare + K : constant COBOL_Character := Item (J); + + begin + if K in COBOL_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Digits'First)); + + elsif K in COBOL_Plus_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Plus_Digits'First)); + + elsif K in COBOL_Minus_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Minus_Digits'First)); + Sign := COBOL_Minus; + + -- Only remaining possibility is COBOL_Plus or COBOL_Minus + + else + Sign := K; + end if; + end; + end loop; + + if Sign = COBOL_Plus then + return Result; + else + return -Result; + end if; + + exception + when Constraint_Error => + raise Conversion_Error; + + end Numeric_To_Decimal; + + ----------------------- + -- Packed_To_Decimal -- + ----------------------- + + function Packed_To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) + return Integer_64 + is + pragma Unsuppress (Range_Check); + Result : Integer_64 := 0; + Sign : constant Decimal_Element := Item (Item'Last); + + begin + if not Valid_Packed (Item, Format) then + raise Conversion_Error; + end if; + + case Packed_Representation is + when IBM => + for J in Item'First .. Item'Last - 1 loop + Result := Result * 10 + Integer_64 (Item (J)); + end loop; + + if Sign = 16#0B# or else Sign = 16#0D# then + return -Result; + else + return +Result; + end if; + end case; + + exception + when Constraint_Error => + raise Conversion_Error; + end Packed_To_Decimal; + + ---------- + -- Swap -- + ---------- + + procedure Swap (B : in out Byte_Array; F : Binary_Format) is + Little_Endian : constant Boolean := + System.Default_Bit_Order = System.Low_Order_First; + + begin + -- Return if no swap needed + + case F is + when H | HU => + if not Little_Endian then + return; + end if; + + when L | LU => + if Little_Endian then + return; + end if; + + when N | NU => + return; + end case; + + -- Here a swap is needed + + declare + Len : constant Natural := B'Length; + + begin + for J in 1 .. Len / 2 loop + declare + Temp : constant Byte := B (J); + + begin + B (J) := B (Len + 1 - J); + B (Len + 1 - J) := Temp; + end; + end loop; + end; + end Swap; + + ----------------------- + -- To_Ada (function) -- + ----------------------- + + function To_Ada (Item : Alphanumeric) return String is + Result : String (Item'Range); + + begin + for J in Item'Range loop + Result (J) := COBOL_To_Ada (Item (J)); + end loop; + + return Result; + end To_Ada; + + ------------------------ + -- To_Ada (procedure) -- + ------------------------ + + procedure To_Ada + (Item : Alphanumeric; + Target : out String; + Last : out Natural) + is + Last_Val : Integer; + + begin + if Item'Length > Target'Length then + raise Constraint_Error; + end if; + + Last_Val := Target'First - 1; + for J in Item'Range loop + Last_Val := Last_Val + 1; + Target (Last_Val) := COBOL_To_Ada (Item (J)); + end loop; + + Last := Last_Val; + end To_Ada; + + ------------------------- + -- To_COBOL (function) -- + ------------------------- + + function To_COBOL (Item : String) return Alphanumeric is + Result : Alphanumeric (Item'Range); + + begin + for J in Item'Range loop + Result (J) := Ada_To_COBOL (Item (J)); + end loop; + + return Result; + end To_COBOL; + + -------------------------- + -- To_COBOL (procedure) -- + -------------------------- + + procedure To_COBOL + (Item : String; + Target : out Alphanumeric; + Last : out Natural) + is + Last_Val : Integer; + + begin + if Item'Length > Target'Length then + raise Constraint_Error; + end if; + + Last_Val := Target'First - 1; + for J in Item'Range loop + Last_Val := Last_Val + 1; + Target (Last_Val) := Ada_To_COBOL (Item (J)); + end loop; + + Last := Last_Val; + end To_COBOL; + + ---------------- + -- To_Display -- + ---------------- + + function To_Display + (Item : Integer_64; + Format : Display_Format; + Length : Natural) + return Numeric + is + Result : Numeric (1 .. Length); + Val : Integer_64 := Item; + + procedure Convert (First, Last : Natural); + -- Convert the number in Val into COBOL_Digits, storing the result + -- in Result (First .. Last). Raise Conversion_Error if too large. + + procedure Embed_Sign (Loc : Natural); + -- Used for the nonseparate formats to embed the appropriate sign + -- at the specified location (i.e. at Result (Loc)) + + procedure Convert (First, Last : Natural) is + J : Natural := Last; + + begin + while J >= First loop + Result (J) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Digits'First) + + Integer (Val mod 10)); + Val := Val / 10; + + if Val = 0 then + for K in First .. J - 1 loop + Result (J) := COBOL_Digits'First; + end loop; + + return; + + else + J := J - 1; + end if; + end loop; + + raise Conversion_Error; + end Convert; + + procedure Embed_Sign (Loc : Natural) is + Digit : Natural range 0 .. 9; + + begin + Digit := COBOL_Character'Pos (Result (Loc)) - + COBOL_Character'Pos (COBOL_Digits'First); + + if Item >= 0 then + Result (Loc) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit); + else + Result (Loc) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit); + end if; + end Embed_Sign; + + -- Start of processing for To_Display + + begin + case Format is + when Unsigned => + if Val < 0 then + raise Conversion_Error; + else + Convert (1, Length); + end if; + + when Leading_Separate => + if Val < 0 then + Result (1) := COBOL_Minus; + Val := -Val; + else + Result (1) := COBOL_Plus; + end if; + + Convert (2, Length); + + when Trailing_Separate => + if Val < 0 then + Result (Length) := COBOL_Minus; + Val := -Val; + else + Result (Length) := COBOL_Plus; + end if; + + Convert (1, Length - 1); + + when Leading_Nonseparate => + Val := abs Val; + Convert (1, Length); + Embed_Sign (1); + + when Trailing_Nonseparate => + Val := abs Val; + Convert (1, Length); + Embed_Sign (Length); + + end case; + + return Result; + end To_Display; + + --------------- + -- To_Packed -- + --------------- + + function To_Packed + (Item : Integer_64; + Format : Packed_Format; + Length : Natural) + return Packed_Decimal + is + Result : Packed_Decimal (1 .. Length); + Val : Integer_64; + + procedure Convert (First, Last : Natural); + -- Convert the number in Val into a sequence of Decimal_Element values, + -- storing the result in Result (First .. Last). Raise Conversion_Error + -- if the value is too large to fit. + + procedure Convert (First, Last : Natural) is + J : Natural := Last; + + begin + while J >= First loop + Result (J) := Decimal_Element (Val mod 10); + + Val := Val / 10; + + if Val = 0 then + for K in First .. J - 1 loop + Result (K) := 0; + end loop; + + return; + + else + J := J - 1; + end if; + end loop; + + raise Conversion_Error; + end Convert; + + -- Start of processing for To_Packed + + begin + case Packed_Representation is + when IBM => + if Format = Packed_Unsigned then + if Item < 0 then + raise Conversion_Error; + else + Result (Length) := 16#F#; + Val := Item; + end if; + + elsif Item >= 0 then + Result (Length) := 16#C#; + Val := Item; + + else -- Item < 0 + Result (Length) := 16#D#; + Val := -Item; + end if; + + Convert (1, Length - 1); + return Result; + end case; + end To_Packed; + + ------------------- + -- Valid_Numeric -- + ------------------- + + function Valid_Numeric + (Item : Numeric; + Format : Display_Format) + return Boolean + is + begin + -- All character positions except first and last must be Digits. + -- This is true for all the formats. + + for J in Item'First + 1 .. Item'Last - 1 loop + if Item (J) not in COBOL_Digits then + return False; + end if; + end loop; + + case Format is + when Unsigned => + return Item (Item'First) in COBOL_Digits + and then Item (Item'Last) in COBOL_Digits; + + when Leading_Separate => + return (Item (Item'First) = COBOL_Plus or else + Item (Item'First) = COBOL_Minus) + and then Item (Item'Last) in COBOL_Digits; + + when Trailing_Separate => + return Item (Item'First) in COBOL_Digits + and then + (Item (Item'Last) = COBOL_Plus or else + Item (Item'Last) = COBOL_Minus); + + when Leading_Nonseparate => + return (Item (Item'First) in COBOL_Plus_Digits or else + Item (Item'First) in COBOL_Minus_Digits) + and then Item (Item'Last) in COBOL_Digits; + + when Trailing_Nonseparate => + return Item (Item'First) in COBOL_Digits + and then + (Item (Item'Last) in COBOL_Plus_Digits or else + Item (Item'Last) in COBOL_Minus_Digits); + + end case; + end Valid_Numeric; + + ------------------ + -- Valid_Packed -- + ------------------ + + function Valid_Packed + (Item : Packed_Decimal; + Format : Packed_Format) + return Boolean + is + begin + case Packed_Representation is + when IBM => + for J in Item'First .. Item'Last - 1 loop + if Item (J) > 9 then + return False; + end if; + end loop; + + -- For unsigned, sign digit must be F + + if Format = Packed_Unsigned then + return Item (Item'Last) = 16#F#; + + + -- For signed, accept all standard and non-standard signs + + else + return Item (Item'Last) in 16#A# .. 16#F#; + end if; + end case; + end Valid_Packed; + + ------------------------- + -- Decimal_Conversions -- + ------------------------- + + package body Decimal_Conversions is + + --------------------- + -- Length (binary) -- + --------------------- + + -- Note that the tests here are all compile time tests + + function Length (Format : Binary_Format) return Natural is + begin + if Num'Digits <= 2 then + return 1; + + elsif Num'Digits <= 4 then + return 2; + + elsif Num'Digits <= 9 then + return 4; + + else -- Num'Digits in 10 .. 18 + return 8; + end if; + end Length; + + ---------------------- + -- Length (display) -- + ---------------------- + + function Length (Format : Display_Format) return Natural is + begin + if Format = Leading_Separate or else Format = Trailing_Separate then + return Num'Digits + 1; + else + return Num'Digits; + end if; + end Length; + + --------------------- + -- Length (packed) -- + --------------------- + + -- Note that the tests here are all compile time checks + + function Length + (Format : Packed_Format) + return Natural + is + begin + case Packed_Representation is + when IBM => + return (Num'Digits + 2) / 2 * 2; + end case; + end Length; + + --------------- + -- To_Binary -- + --------------- + + function To_Binary + (Item : Num; + Format : Binary_Format) + return Byte_Array + is + begin + -- Note: all these tests are compile time tests + + if Num'Digits <= 2 then + return To_B1 (Integer_8'Integer_Value (Item)); + + elsif Num'Digits <= 4 then + declare + R : B2 := To_B2 (Integer_16'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + + elsif Num'Digits <= 9 then + declare + R : B4 := To_B4 (Integer_32'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + + else -- Num'Digits in 10 .. 18 + declare + R : B8 := To_B8 (Integer_64'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + end if; + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Binary; + + --------------------------------- + -- To_Binary (internal binary) -- + --------------------------------- + + function To_Binary (Item : Num) return Binary is + pragma Unsuppress (Range_Check); + begin + return Binary'Integer_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Binary; + + ------------------------- + -- To_Decimal (binary) -- + ------------------------- + + function To_Decimal + (Item : Byte_Array; + Format : Binary_Format) + return Num + is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Binary_To_Decimal (Item, Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ---------------------------------- + -- To_Decimal (internal binary) -- + ---------------------------------- + + function To_Decimal (Item : Binary) return Num is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + -------------------------- + -- To_Decimal (display) -- + -------------------------- + + function To_Decimal + (Item : Numeric; + Format : Display_Format) + return Num + is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Numeric_To_Decimal (Item, Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + --------------------------------------- + -- To_Decimal (internal long binary) -- + --------------------------------------- + + function To_Decimal (Item : Long_Binary) return Num is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ------------------------- + -- To_Decimal (packed) -- + ------------------------- + + function To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) + return Num + is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Packed_To_Decimal (Item, Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ---------------- + -- To_Display -- + ---------------- + + function To_Display + (Item : Num; + Format : Display_Format) + return Numeric + is + pragma Unsuppress (Range_Check); + + begin + return + To_Display + (Integer_64'Integer_Value (Item), + Format, + Length (Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Display; + + -------------------- + -- To_Long_Binary -- + -------------------- + + function To_Long_Binary (Item : Num) return Long_Binary is + pragma Unsuppress (Range_Check); + + begin + return Long_Binary'Integer_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Long_Binary; + + --------------- + -- To_Packed -- + --------------- + + function To_Packed + (Item : Num; + Format : Packed_Format) + return Packed_Decimal + is + pragma Unsuppress (Range_Check); + + begin + return + To_Packed + (Integer_64'Integer_Value (Item), + Format, + Length (Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Packed; + + -------------------- + -- Valid (binary) -- + -------------------- + + function Valid + (Item : Byte_Array; + Format : Binary_Format) + return Boolean + is + Val : Num; + + begin + Val := To_Decimal (Item, Format); + return True; + + exception + when Conversion_Error => + return False; + end Valid; + + --------------------- + -- Valid (display) -- + --------------------- + + function Valid + (Item : Numeric; + Format : Display_Format) + return Boolean + is + begin + return Valid_Numeric (Item, Format); + end Valid; + + -------------------- + -- Valid (packed) -- + -------------------- + + function Valid + (Item : Packed_Decimal; + Format : Packed_Format) + return Boolean + is + begin + return Valid_Packed (Item, Format); + end Valid; + + end Decimal_Conversions; + +end Interfaces.COBOL; diff --git a/gcc/ada/i-cobol.ads b/gcc/ada/i-cobol.ads new file mode 100644 index 00000000000..cbb3c350dec --- /dev/null +++ b/gcc/ada/i-cobol.ads @@ -0,0 +1,566 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C O B O L -- +-- -- +-- S p e c -- +-- (ASCII Version) -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 1993-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This version of the COBOL interfaces package assumes that the COBOL +-- compiler uses ASCII as its internal representation of characters, i.e. +-- that the type COBOL_Character has the same representation as the Ada +-- type Standard.Character. + +package Interfaces.COBOL is + + ------------------------------------------------------------ + -- Types And Operations For Internal Data Representations -- + ------------------------------------------------------------ + + type Floating is new Float; + type Long_Floating is new Long_Float; + + type Binary is new Integer; + type Long_Binary is new Long_Long_Integer; + + Max_Digits_Binary : constant := 9; + Max_Digits_Long_Binary : constant := 18; + + type Decimal_Element is mod 16; + type Packed_Decimal is array (Positive range <>) of Decimal_Element; + pragma Pack (Packed_Decimal); + + type COBOL_Character is new Character; + + Ada_To_COBOL : array (Standard.Character) of COBOL_Character := ( + COBOL_Character'Val (000), COBOL_Character'Val (001), + COBOL_Character'Val (002), COBOL_Character'Val (003), + COBOL_Character'Val (004), COBOL_Character'Val (005), + COBOL_Character'Val (006), COBOL_Character'Val (007), + COBOL_Character'Val (008), COBOL_Character'Val (009), + COBOL_Character'Val (010), COBOL_Character'Val (011), + COBOL_Character'Val (012), COBOL_Character'Val (013), + COBOL_Character'Val (014), COBOL_Character'Val (015), + COBOL_Character'Val (016), COBOL_Character'Val (017), + COBOL_Character'Val (018), COBOL_Character'Val (019), + COBOL_Character'Val (020), COBOL_Character'Val (021), + COBOL_Character'Val (022), COBOL_Character'Val (023), + COBOL_Character'Val (024), COBOL_Character'Val (025), + COBOL_Character'Val (026), COBOL_Character'Val (027), + COBOL_Character'Val (028), COBOL_Character'Val (029), + COBOL_Character'Val (030), COBOL_Character'Val (031), + COBOL_Character'Val (032), COBOL_Character'Val (033), + COBOL_Character'Val (034), COBOL_Character'Val (035), + COBOL_Character'Val (036), COBOL_Character'Val (037), + COBOL_Character'Val (038), COBOL_Character'Val (039), + COBOL_Character'Val (040), COBOL_Character'Val (041), + COBOL_Character'Val (042), COBOL_Character'Val (043), + COBOL_Character'Val (044), COBOL_Character'Val (045), + COBOL_Character'Val (046), COBOL_Character'Val (047), + COBOL_Character'Val (048), COBOL_Character'Val (049), + COBOL_Character'Val (050), COBOL_Character'Val (051), + COBOL_Character'Val (052), COBOL_Character'Val (053), + COBOL_Character'Val (054), COBOL_Character'Val (055), + COBOL_Character'Val (056), COBOL_Character'Val (057), + COBOL_Character'Val (058), COBOL_Character'Val (059), + COBOL_Character'Val (060), COBOL_Character'Val (061), + COBOL_Character'Val (062), COBOL_Character'Val (063), + COBOL_Character'Val (064), COBOL_Character'Val (065), + COBOL_Character'Val (066), COBOL_Character'Val (067), + COBOL_Character'Val (068), COBOL_Character'Val (069), + COBOL_Character'Val (070), COBOL_Character'Val (071), + COBOL_Character'Val (072), COBOL_Character'Val (073), + COBOL_Character'Val (074), COBOL_Character'Val (075), + COBOL_Character'Val (076), COBOL_Character'Val (077), + COBOL_Character'Val (078), COBOL_Character'Val (079), + COBOL_Character'Val (080), COBOL_Character'Val (081), + COBOL_Character'Val (082), COBOL_Character'Val (083), + COBOL_Character'Val (084), COBOL_Character'Val (085), + COBOL_Character'Val (086), COBOL_Character'Val (087), + COBOL_Character'Val (088), COBOL_Character'Val (089), + COBOL_Character'Val (090), COBOL_Character'Val (091), + COBOL_Character'Val (092), COBOL_Character'Val (093), + COBOL_Character'Val (094), COBOL_Character'Val (095), + COBOL_Character'Val (096), COBOL_Character'Val (097), + COBOL_Character'Val (098), COBOL_Character'Val (099), + COBOL_Character'Val (100), COBOL_Character'Val (101), + COBOL_Character'Val (102), COBOL_Character'Val (103), + COBOL_Character'Val (104), COBOL_Character'Val (105), + COBOL_Character'Val (106), COBOL_Character'Val (107), + COBOL_Character'Val (108), COBOL_Character'Val (109), + COBOL_Character'Val (110), COBOL_Character'Val (111), + COBOL_Character'Val (112), COBOL_Character'Val (113), + COBOL_Character'Val (114), COBOL_Character'Val (115), + COBOL_Character'Val (116), COBOL_Character'Val (117), + COBOL_Character'Val (118), COBOL_Character'Val (119), + COBOL_Character'Val (120), COBOL_Character'Val (121), + COBOL_Character'Val (122), COBOL_Character'Val (123), + COBOL_Character'Val (124), COBOL_Character'Val (125), + COBOL_Character'Val (126), COBOL_Character'Val (127), + COBOL_Character'Val (128), COBOL_Character'Val (129), + COBOL_Character'Val (130), COBOL_Character'Val (131), + COBOL_Character'Val (132), COBOL_Character'Val (133), + COBOL_Character'Val (134), COBOL_Character'Val (135), + COBOL_Character'Val (136), COBOL_Character'Val (137), + COBOL_Character'Val (138), COBOL_Character'Val (139), + COBOL_Character'Val (140), COBOL_Character'Val (141), + COBOL_Character'Val (142), COBOL_Character'Val (143), + COBOL_Character'Val (144), COBOL_Character'Val (145), + COBOL_Character'Val (146), COBOL_Character'Val (147), + COBOL_Character'Val (148), COBOL_Character'Val (149), + COBOL_Character'Val (150), COBOL_Character'Val (151), + COBOL_Character'Val (152), COBOL_Character'Val (153), + COBOL_Character'Val (154), COBOL_Character'Val (155), + COBOL_Character'Val (156), COBOL_Character'Val (157), + COBOL_Character'Val (158), COBOL_Character'Val (159), + COBOL_Character'Val (160), COBOL_Character'Val (161), + COBOL_Character'Val (162), COBOL_Character'Val (163), + COBOL_Character'Val (164), COBOL_Character'Val (165), + COBOL_Character'Val (166), COBOL_Character'Val (167), + COBOL_Character'Val (168), COBOL_Character'Val (169), + COBOL_Character'Val (170), COBOL_Character'Val (171), + COBOL_Character'Val (172), COBOL_Character'Val (173), + COBOL_Character'Val (174), COBOL_Character'Val (175), + COBOL_Character'Val (176), COBOL_Character'Val (177), + COBOL_Character'Val (178), COBOL_Character'Val (179), + COBOL_Character'Val (180), COBOL_Character'Val (181), + COBOL_Character'Val (182), COBOL_Character'Val (183), + COBOL_Character'Val (184), COBOL_Character'Val (185), + COBOL_Character'Val (186), COBOL_Character'Val (187), + COBOL_Character'Val (188), COBOL_Character'Val (189), + COBOL_Character'Val (190), COBOL_Character'Val (191), + COBOL_Character'Val (192), COBOL_Character'Val (193), + COBOL_Character'Val (194), COBOL_Character'Val (195), + COBOL_Character'Val (196), COBOL_Character'Val (197), + COBOL_Character'Val (198), COBOL_Character'Val (199), + COBOL_Character'Val (200), COBOL_Character'Val (201), + COBOL_Character'Val (202), COBOL_Character'Val (203), + COBOL_Character'Val (204), COBOL_Character'Val (205), + COBOL_Character'Val (206), COBOL_Character'Val (207), + COBOL_Character'Val (208), COBOL_Character'Val (209), + COBOL_Character'Val (210), COBOL_Character'Val (211), + COBOL_Character'Val (212), COBOL_Character'Val (213), + COBOL_Character'Val (214), COBOL_Character'Val (215), + COBOL_Character'Val (216), COBOL_Character'Val (217), + COBOL_Character'Val (218), COBOL_Character'Val (219), + COBOL_Character'Val (220), COBOL_Character'Val (221), + COBOL_Character'Val (222), COBOL_Character'Val (223), + COBOL_Character'Val (224), COBOL_Character'Val (225), + COBOL_Character'Val (226), COBOL_Character'Val (227), + COBOL_Character'Val (228), COBOL_Character'Val (229), + COBOL_Character'Val (230), COBOL_Character'Val (231), + COBOL_Character'Val (232), COBOL_Character'Val (233), + COBOL_Character'Val (234), COBOL_Character'Val (235), + COBOL_Character'Val (236), COBOL_Character'Val (237), + COBOL_Character'Val (238), COBOL_Character'Val (239), + COBOL_Character'Val (240), COBOL_Character'Val (241), + COBOL_Character'Val (242), COBOL_Character'Val (243), + COBOL_Character'Val (244), COBOL_Character'Val (245), + COBOL_Character'Val (246), COBOL_Character'Val (247), + COBOL_Character'Val (248), COBOL_Character'Val (249), + COBOL_Character'Val (250), COBOL_Character'Val (251), + COBOL_Character'Val (252), COBOL_Character'Val (253), + COBOL_Character'Val (254), COBOL_Character'Val (255)); + + COBOL_To_Ada : array (COBOL_Character) of Standard.Character := ( + Standard.Character'Val (000), Standard.Character'Val (001), + Standard.Character'Val (002), Standard.Character'Val (003), + Standard.Character'Val (004), Standard.Character'Val (005), + Standard.Character'Val (006), Standard.Character'Val (007), + Standard.Character'Val (008), Standard.Character'Val (009), + Standard.Character'Val (010), Standard.Character'Val (011), + Standard.Character'Val (012), Standard.Character'Val (013), + Standard.Character'Val (014), Standard.Character'Val (015), + Standard.Character'Val (016), Standard.Character'Val (017), + Standard.Character'Val (018), Standard.Character'Val (019), + Standard.Character'Val (020), Standard.Character'Val (021), + Standard.Character'Val (022), Standard.Character'Val (023), + Standard.Character'Val (024), Standard.Character'Val (025), + Standard.Character'Val (026), Standard.Character'Val (027), + Standard.Character'Val (028), Standard.Character'Val (029), + Standard.Character'Val (030), Standard.Character'Val (031), + Standard.Character'Val (032), Standard.Character'Val (033), + Standard.Character'Val (034), Standard.Character'Val (035), + Standard.Character'Val (036), Standard.Character'Val (037), + Standard.Character'Val (038), Standard.Character'Val (039), + Standard.Character'Val (040), Standard.Character'Val (041), + Standard.Character'Val (042), Standard.Character'Val (043), + Standard.Character'Val (044), Standard.Character'Val (045), + Standard.Character'Val (046), Standard.Character'Val (047), + Standard.Character'Val (048), Standard.Character'Val (049), + Standard.Character'Val (050), Standard.Character'Val (051), + Standard.Character'Val (052), Standard.Character'Val (053), + Standard.Character'Val (054), Standard.Character'Val (055), + Standard.Character'Val (056), Standard.Character'Val (057), + Standard.Character'Val (058), Standard.Character'Val (059), + Standard.Character'Val (060), Standard.Character'Val (061), + Standard.Character'Val (062), Standard.Character'Val (063), + Standard.Character'Val (064), Standard.Character'Val (065), + Standard.Character'Val (066), Standard.Character'Val (067), + Standard.Character'Val (068), Standard.Character'Val (069), + Standard.Character'Val (070), Standard.Character'Val (071), + Standard.Character'Val (072), Standard.Character'Val (073), + Standard.Character'Val (074), Standard.Character'Val (075), + Standard.Character'Val (076), Standard.Character'Val (077), + Standard.Character'Val (078), Standard.Character'Val (079), + Standard.Character'Val (080), Standard.Character'Val (081), + Standard.Character'Val (082), Standard.Character'Val (083), + Standard.Character'Val (084), Standard.Character'Val (085), + Standard.Character'Val (086), Standard.Character'Val (087), + Standard.Character'Val (088), Standard.Character'Val (089), + Standard.Character'Val (090), Standard.Character'Val (091), + Standard.Character'Val (092), Standard.Character'Val (093), + Standard.Character'Val (094), Standard.Character'Val (095), + Standard.Character'Val (096), Standard.Character'Val (097), + Standard.Character'Val (098), Standard.Character'Val (099), + Standard.Character'Val (100), Standard.Character'Val (101), + Standard.Character'Val (102), Standard.Character'Val (103), + Standard.Character'Val (104), Standard.Character'Val (105), + Standard.Character'Val (106), Standard.Character'Val (107), + Standard.Character'Val (108), Standard.Character'Val (109), + Standard.Character'Val (110), Standard.Character'Val (111), + Standard.Character'Val (112), Standard.Character'Val (113), + Standard.Character'Val (114), Standard.Character'Val (115), + Standard.Character'Val (116), Standard.Character'Val (117), + Standard.Character'Val (118), Standard.Character'Val (119), + Standard.Character'Val (120), Standard.Character'Val (121), + Standard.Character'Val (122), Standard.Character'Val (123), + Standard.Character'Val (124), Standard.Character'Val (125), + Standard.Character'Val (126), Standard.Character'Val (127), + Standard.Character'Val (128), Standard.Character'Val (129), + Standard.Character'Val (130), Standard.Character'Val (131), + Standard.Character'Val (132), Standard.Character'Val (133), + Standard.Character'Val (134), Standard.Character'Val (135), + Standard.Character'Val (136), Standard.Character'Val (137), + Standard.Character'Val (138), Standard.Character'Val (139), + Standard.Character'Val (140), Standard.Character'Val (141), + Standard.Character'Val (142), Standard.Character'Val (143), + Standard.Character'Val (144), Standard.Character'Val (145), + Standard.Character'Val (146), Standard.Character'Val (147), + Standard.Character'Val (148), Standard.Character'Val (149), + Standard.Character'Val (150), Standard.Character'Val (151), + Standard.Character'Val (152), Standard.Character'Val (153), + Standard.Character'Val (154), Standard.Character'Val (155), + Standard.Character'Val (156), Standard.Character'Val (157), + Standard.Character'Val (158), Standard.Character'Val (159), + Standard.Character'Val (160), Standard.Character'Val (161), + Standard.Character'Val (162), Standard.Character'Val (163), + Standard.Character'Val (164), Standard.Character'Val (165), + Standard.Character'Val (166), Standard.Character'Val (167), + Standard.Character'Val (168), Standard.Character'Val (169), + Standard.Character'Val (170), Standard.Character'Val (171), + Standard.Character'Val (172), Standard.Character'Val (173), + Standard.Character'Val (174), Standard.Character'Val (175), + Standard.Character'Val (176), Standard.Character'Val (177), + Standard.Character'Val (178), Standard.Character'Val (179), + Standard.Character'Val (180), Standard.Character'Val (181), + Standard.Character'Val (182), Standard.Character'Val (183), + Standard.Character'Val (184), Standard.Character'Val (185), + Standard.Character'Val (186), Standard.Character'Val (187), + Standard.Character'Val (188), Standard.Character'Val (189), + Standard.Character'Val (190), Standard.Character'Val (191), + Standard.Character'Val (192), Standard.Character'Val (193), + Standard.Character'Val (194), Standard.Character'Val (195), + Standard.Character'Val (196), Standard.Character'Val (197), + Standard.Character'Val (198), Standard.Character'Val (199), + Standard.Character'Val (200), Standard.Character'Val (201), + Standard.Character'Val (202), Standard.Character'Val (203), + Standard.Character'Val (204), Standard.Character'Val (205), + Standard.Character'Val (206), Standard.Character'Val (207), + Standard.Character'Val (208), Standard.Character'Val (209), + Standard.Character'Val (210), Standard.Character'Val (211), + Standard.Character'Val (212), Standard.Character'Val (213), + Standard.Character'Val (214), Standard.Character'Val (215), + Standard.Character'Val (216), Standard.Character'Val (217), + Standard.Character'Val (218), Standard.Character'Val (219), + Standard.Character'Val (220), Standard.Character'Val (221), + Standard.Character'Val (222), Standard.Character'Val (223), + Standard.Character'Val (224), Standard.Character'Val (225), + Standard.Character'Val (226), Standard.Character'Val (227), + Standard.Character'Val (228), Standard.Character'Val (229), + Standard.Character'Val (230), Standard.Character'Val (231), + Standard.Character'Val (232), Standard.Character'Val (233), + Standard.Character'Val (234), Standard.Character'Val (235), + Standard.Character'Val (236), Standard.Character'Val (237), + Standard.Character'Val (238), Standard.Character'Val (239), + Standard.Character'Val (240), Standard.Character'Val (241), + Standard.Character'Val (242), Standard.Character'Val (243), + Standard.Character'Val (244), Standard.Character'Val (245), + Standard.Character'Val (246), Standard.Character'Val (247), + Standard.Character'Val (248), Standard.Character'Val (249), + Standard.Character'Val (250), Standard.Character'Val (251), + Standard.Character'Val (252), Standard.Character'Val (253), + Standard.Character'Val (254), Standard.Character'Val (255)); + + type Alphanumeric is array (Positive range <>) of COBOL_Character; + -- pragma Pack (Alphanumeric); + + function To_COBOL (Item : String) return Alphanumeric; + function To_Ada (Item : Alphanumeric) return String; + + procedure To_COBOL + (Item : String; + Target : out Alphanumeric; + Last : out Natural); + + procedure To_Ada + (Item : Alphanumeric; + Target : out String; + Last : out Natural); + + type Numeric is array (Positive range <>) of COBOL_Character; + -- pragma Pack (Numeric); + + -------------------------------------------- + -- Formats For COBOL Data Representations -- + -------------------------------------------- + + type Display_Format is private; + + Unsigned : constant Display_Format; + Leading_Separate : constant Display_Format; + Trailing_Separate : constant Display_Format; + Leading_Nonseparate : constant Display_Format; + Trailing_Nonseparate : constant Display_Format; + + type Binary_Format is private; + + High_Order_First : constant Binary_Format; + Low_Order_First : constant Binary_Format; + Native_Binary : constant Binary_Format; + High_Order_First_Unsigned : constant Binary_Format; + Low_Order_First_Unsigned : constant Binary_Format; + Native_Binary_Unsigned : constant Binary_Format; + + type Packed_Format is private; + + Packed_Unsigned : constant Packed_Format; + Packed_Signed : constant Packed_Format; + + ------------------------------------------------------------ + -- Types For External Representation Of COBOL Binary Data -- + ------------------------------------------------------------ + + type Byte is mod 2 ** COBOL_Character'Size; + type Byte_Array is array (Positive range <>) of Byte; + -- pragma Pack (Byte_Array); + + Conversion_Error : exception; + + generic + type Num is delta <> digits <>; + + package Decimal_Conversions is + + -- Display Formats: data values are represented as Numeric + + function Valid + (Item : Numeric; + Format : Display_Format) + return Boolean; + + function Length + (Format : Display_Format) + return Natural; + + function To_Decimal + (Item : Numeric; + Format : Display_Format) + return Num; + + function To_Display + (Item : Num; + Format : Display_Format) + return Numeric; + + -- Packed Formats: data values are represented as Packed_Decimal + + function Valid + (Item : Packed_Decimal; + Format : Packed_Format) + return Boolean; + + function Length + (Format : Packed_Format) + return Natural; + + function To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) + return Num; + + function To_Packed + (Item : Num; + Format : Packed_Format) + return Packed_Decimal; + + -- Binary Formats: external data values are represented as Byte_Array + + function Valid + (Item : Byte_Array; + Format : Binary_Format) + return Boolean; + + function Length + (Format : Binary_Format) + return Natural; + + function To_Decimal + (Item : Byte_Array; + Format : Binary_Format) return Num; + + function To_Binary + (Item : Num; + Format : Binary_Format) + return Byte_Array; + + -- Internal Binary formats: data values are of type Binary/Long_Binary + + function To_Decimal (Item : Binary) return Num; + function To_Decimal (Item : Long_Binary) return Num; + + function To_Binary (Item : Num) return Binary; + function To_Long_Binary (Item : Num) return Long_Binary; + + private + pragma Inline (Length); + pragma Inline (To_Binary); + pragma Inline (To_Decimal); + pragma Inline (To_Display); + pragma Inline (To_Decimal); + pragma Inline (To_Long_Binary); + pragma Inline (Valid); + + end Decimal_Conversions; + + ------------------------------------------ + -- Implementation Dependent Definitions -- + ------------------------------------------ + + -- The implementation dependent definitions are wholly contained in the + -- private part of this spec (the body is implementation independent) + +private + ------------------- + -- Binary Format -- + ------------------- + + type Binary_Format is (H, L, N, HU, LU, NU); + + subtype Binary_Unsigned_Format is Binary_Format range HU .. NU; + + High_Order_First : constant Binary_Format := H; + Low_Order_First : constant Binary_Format := L; + Native_Binary : constant Binary_Format := N; + High_Order_First_Unsigned : constant Binary_Format := HU; + Low_Order_First_Unsigned : constant Binary_Format := LU; + Native_Binary_Unsigned : constant Binary_Format := NU; + + --------------------------- + -- Packed Decimal Format -- + --------------------------- + + -- Packed decimal numbers use the IBM mainframe format: + + -- dd dd ... dd dd ds + + -- where d are the Digits, in natural left to right order, and s is + -- the sign digit. If the number of Digits os even, then the high + -- order (leftmost) Digits is always a 0. For example, a six digit + -- number has the format: + + -- 0d dd dd ds + + -- The sign digit has the possible values + + -- 16#0A# non-standard plus sign + -- 16#0B# non-standard minus sign + -- 16#0C# standard plus sign + -- 16#0D# standard minus sign + -- 16#0E# non-standard plus sign + -- 16#0F# standard unsigned sign + + -- The non-standard signs are recognized on input, but never generated + -- for output numbers. The 16#0F# distinguishes unsigned numbers from + -- signed positive numbers, but is treated as positive for computational + -- purposes. This format provides distinguished positive and negative + -- zero values, which behave the same in all operations. + + type Packed_Format is (U, S); + + Packed_Unsigned : constant Packed_Format := U; + Packed_Signed : constant Packed_Format := S; + + type Packed_Representation_Type is (IBM); + -- Indicator for format used for packed decimal + + Packed_Representation : constant Packed_Representation_Type := IBM; + -- This version of the spec uses IBM internal format, as described above. + + ----------------------------- + -- Display Decimal Formats -- + ----------------------------- + + -- Display numbers are stored in standard ASCII format, as ASCII strings. + -- For the embedded signs, the following codes are used: + + -- 0-9 positive: 16#30# .. 16#39# (i.e. natural ASCII digit code) + -- 0-9 negative: 16#20# .. 16#29# (ASCII digit code - 16#10#) + + type Display_Format is (U, LS, TS, LN, TN); + + Unsigned : constant Display_Format := U; + Leading_Separate : constant Display_Format := LS; + Trailing_Separate : constant Display_Format := TS; + Leading_Nonseparate : constant Display_Format := LN; + Trailing_Nonseparate : constant Display_Format := TN; + + subtype COBOL_Digits is COBOL_Character range '0' .. '9'; + -- Digit values in display decimal + + COBOL_Space : constant COBOL_Character := ' '; + COBOL_Plus : constant COBOL_Character := '+'; + COBOL_Minus : constant COBOL_Character := '-'; + -- Sign values for Leading_Separate and Trailing_Separate formats + + subtype COBOL_Plus_Digits is COBOL_Character + range COBOL_Character'Val (16#30#) .. COBOL_Character'Val (16#39#); + -- Values used for embedded plus signs in nonseparate formats + + subtype COBOL_Minus_Digits is COBOL_Character + range COBOL_Character'Val (16#20#) .. COBOL_Character'Val (16#29#); + -- Values used for embedded minus signs in nonseparate formats + +end Interfaces.COBOL; diff --git a/gcc/ada/i-cpoint.adb b/gcc/ada/i-cpoint.adb new file mode 100644 index 00000000000..7d4cbc8143a --- /dev/null +++ b/gcc/ada/i-cpoint.adb @@ -0,0 +1,284 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . P O I N T E R S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System; use System; + +with Unchecked_Conversion; + +package body Interfaces.C.Pointers is + + type Addr is mod Memory_Size; + + function To_Pointer is new Unchecked_Conversion (Addr, Pointer); + function To_Addr is new Unchecked_Conversion (Pointer, Addr); + function To_Addr is new Unchecked_Conversion (ptrdiff_t, Addr); + function To_Ptrdiff is new Unchecked_Conversion (Addr, ptrdiff_t); + + Elmt_Size : constant ptrdiff_t := + (Element_Array'Component_Size + + Storage_Unit - 1) / Storage_Unit; + + subtype Index_Base is Index'Base; + + --------- + -- "+" -- + --------- + + function "+" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is + begin + if Left = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right)); + end "+"; + + function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer is + begin + if Right = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is + begin + if Left = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size)); + end "-"; + + function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t is + begin + if Left = null or else Right = null then + raise Pointer_Error; + end if; + + return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size; + end "-"; + + ---------------- + -- Copy_Array -- + ---------------- + + procedure Copy_Array + (Source : in Pointer; + Target : in Pointer; + Length : in ptrdiff_t) + is + T : Pointer := Target; + S : Pointer := Source; + + begin + if S = null or else T = null then + raise Dereference_Error; + + else + for J in 1 .. Length loop + T.all := S.all; + Increment (T); + Increment (S); + end loop; + end if; + end Copy_Array; + + --------------------------- + -- Copy_Terminated_Array -- + --------------------------- + + procedure Copy_Terminated_Array + (Source : in Pointer; + Target : in Pointer; + Limit : in ptrdiff_t := ptrdiff_t'Last; + Terminator : in Element := Default_Terminator) + is + S : Pointer := Source; + T : Pointer := Target; + L : ptrdiff_t := Limit; + + begin + if S = null or else T = null then + raise Dereference_Error; + + else + while L > 0 loop + T.all := S.all; + exit when T.all = Terminator; + Increment (T); + Increment (S); + L := L - 1; + end loop; + end if; + end Copy_Terminated_Array; + + --------------- + -- Decrement -- + --------------- + + procedure Decrement (Ref : in out Pointer) is + begin + Ref := Ref - 1; + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Ref : in out Pointer) is + begin + Ref := Ref + 1; + end Increment; + + ----------- + -- Value -- + ----------- + + function Value + (Ref : in Pointer; + Terminator : in Element := Default_Terminator) + return Element_Array + is + P : Pointer; + L : constant Index_Base := Index'First; + H : Index_Base; + + begin + if Ref = null then + raise Dereference_Error; + + else + H := L; + P := Ref; + + loop + exit when P.all = Terminator; + H := Index_Base'Succ (H); + Increment (P); + end loop; + + declare + subtype A is Element_Array (L .. H); + + type PA is access A; + function To_PA is new Unchecked_Conversion (Pointer, PA); + + begin + return To_PA (Ref).all; + end; + end if; + end Value; + + function Value + (Ref : in Pointer; + Length : in ptrdiff_t) + return Element_Array + is + L : Index_Base; + H : Index_Base; + + begin + if Ref = null then + raise Dereference_Error; + + -- For length zero, we need to return a null slice, but we can't make + -- the bounds of this slice Index'First, since this could cause a + -- Constraint_Error if Index'First = Index'Base'First. + + elsif Length <= 0 then + declare + pragma Warnings (Off); -- kill warnings since X not assigned + X : Element_Array (Index'Succ (Index'First) .. Index'First); + pragma Warnings (On); + + begin + return X; + end; + + -- Normal case (length non-zero) + + else + L := Index'First; + H := Index'Val (Index'Pos (Index'First) + Length - 1); + + declare + subtype A is Element_Array (L .. H); + + type PA is access A; + function To_PA is new Unchecked_Conversion (Pointer, PA); + + begin + return To_PA (Ref).all; + end; + end if; + end Value; + + -------------------- + -- Virtual_Length -- + -------------------- + + function Virtual_Length + (Ref : in Pointer; + Terminator : in Element := Default_Terminator) + return ptrdiff_t + is + P : Pointer; + C : ptrdiff_t; + + begin + if Ref = null then + raise Dereference_Error; + + else + C := 0; + P := Ref; + + while P.all /= Terminator loop + C := C + 1; + Increment (P); + end loop; + + return C; + end if; + end Virtual_Length; + +end Interfaces.C.Pointers; diff --git a/gcc/ada/i-cpoint.ads b/gcc/ada/i-cpoint.ads new file mode 100644 index 00000000000..728643a2a5f --- /dev/null +++ b/gcc/ada/i-cpoint.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . P O I N T E R S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1993-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +generic + type Index is (<>); + type Element is private; + type Element_Array is array (Index range <>) of aliased Element; + Default_Terminator : Element; + +package Interfaces.C.Pointers is +pragma Preelaborate (Pointers); + + type Pointer is access all Element; + + function Value + (Ref : in Pointer; + Terminator : in Element := Default_Terminator) + return Element_Array; + + function Value + (Ref : in Pointer; + Length : in ptrdiff_t) + return Element_Array; + + Pointer_Error : exception; + + -------------------------------- + -- C-style Pointer Arithmetic -- + -------------------------------- + + function "+" (Left : in Pointer; Right : in ptrdiff_t) return Pointer; + function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer; + function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer; + function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t; + + procedure Increment (Ref : in out Pointer); + procedure Decrement (Ref : in out Pointer); + + pragma Convention (Intrinsic, "+"); + pragma Convention (Intrinsic, "-"); + pragma Convention (Intrinsic, Increment); + pragma Convention (Intrinsic, Decrement); + + function Virtual_Length + (Ref : in Pointer; + Terminator : in Element := Default_Terminator) + return ptrdiff_t; + + procedure Copy_Terminated_Array + (Source : in Pointer; + Target : in Pointer; + Limit : in ptrdiff_t := ptrdiff_t'Last; + Terminator : in Element := Default_Terminator); + + procedure Copy_Array + (Source : in Pointer; + Target : in Pointer; + Length : in ptrdiff_t); + +private + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline (Decrement); + pragma Inline (Increment); + +end Interfaces.C.Pointers; diff --git a/gcc/ada/i-cpp.adb b/gcc/ada/i-cpp.adb new file mode 100644 index 00000000000..3aed957b943 --- /dev/null +++ b/gcc/ada/i-cpp.adb @@ -0,0 +1,347 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . C P P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Tags; use Ada.Tags; +with Interfaces.C; use Interfaces.C; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; +with Unchecked_Conversion; + +package body Interfaces.CPP is + + subtype Cstring is String (Positive); + type Cstring_Ptr is access all Cstring; + type Tag_Table is array (Natural range <>) of Vtable_Ptr; + pragma Suppress_Initialization (Tag_Table); + + type Type_Specific_Data is record + Idepth : Natural; + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag; + Ancestor_Tags : Tag_Table (Natural); + end record; + + type Vtable_Entry is record + Pfn : System.Address; + end record; + + type Type_Specific_Data_Ptr is access all Type_Specific_Data; + type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry; + + type VTable is record + Unused1 : C.short; + Unused2 : C.short; + TSD : Type_Specific_Data_Ptr; + Prims_Ptr : Vtable_Entry_Array (Positive); + end record; + + -------------------------------------------------------- + -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD -- + -------------------------------------------------------- + + function To_Type_Specific_Data_Ptr is + new Unchecked_Conversion (Address, Type_Specific_Data_Ptr); + + function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address); + function To_Address is + new Unchecked_Conversion (Type_Specific_Data_Ptr, Address); + + function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr); + function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag); + + --------------------------------------------- + -- Unchecked Conversions for String Fields -- + --------------------------------------------- + + function To_Cstring_Ptr is + new Unchecked_Conversion (Address, Cstring_Ptr); + + function To_Address is + new Unchecked_Conversion (Cstring_Ptr, Address); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Length (Str : Cstring_Ptr) return Natural; + -- Length of string represented by the given pointer (treating the + -- string as a C-style string, which is Nul terminated). + + ----------------------- + -- CPP_CW_Membership -- + ----------------------- + + function CPP_CW_Membership + (Obj_Tag : Vtable_Ptr; + Typ_Tag : Vtable_Ptr) + return Boolean + is + Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth; + begin + return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag; + end CPP_CW_Membership; + + --------------------------- + -- CPP_Get_Expanded_Name -- + --------------------------- + + function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is + begin + return To_Address (T.TSD.Expanded_Name); + end CPP_Get_Expanded_Name; + + -------------------------- + -- CPP_Get_External_Tag -- + -------------------------- + + function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is + begin + return To_Address (T.TSD.External_Tag); + end CPP_Get_External_Tag; + + ------------------------------- + -- CPP_Get_Inheritance_Depth -- + ------------------------------- + + function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is + begin + return T.TSD.Idepth; + end CPP_Get_Inheritance_Depth; + + ------------------------- + -- CPP_Get_Prim_Op_Address -- + ------------------------- + + function CPP_Get_Prim_Op_Address + (T : Vtable_Ptr; + Position : Positive) + return Address is + begin + return T.Prims_Ptr (Position).Pfn; + end CPP_Get_Prim_Op_Address; + + ----------------------- + -- CPP_Get_RC_Offset -- + ----------------------- + + function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is + begin + return 0; + end CPP_Get_RC_Offset; + + ------------------------------- + -- CPP_Get_Remotely_Callable -- + ------------------------------- + + function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is + begin + return True; + end CPP_Get_Remotely_Callable; + + ----------------- + -- CPP_Get_TSD -- + ----------------- + + function CPP_Get_TSD (T : Vtable_Ptr) return Address is + begin + return To_Address (T.TSD); + end CPP_Get_TSD; + + -------------------- + -- CPP_Inherit_DT -- + -------------------- + + procedure CPP_Inherit_DT + (Old_T : Vtable_Ptr; + New_T : Vtable_Ptr; + Entry_Count : Natural) + is + begin + if Old_T /= null then + New_T.Prims_Ptr (1 .. Entry_Count) + := Old_T.Prims_Ptr (1 .. Entry_Count); + end if; + end CPP_Inherit_DT; + + --------------------- + -- CPP_Inherit_TSD -- + --------------------- + + procedure CPP_Inherit_TSD + (Old_TSD : Address; + New_Tag : Vtable_Ptr) + is + TSD : constant Type_Specific_Data_Ptr + := To_Type_Specific_Data_Ptr (Old_TSD); + + New_TSD : Type_Specific_Data renames New_Tag.TSD.all; + + begin + if TSD /= null then + New_TSD.Idepth := TSD.Idepth + 1; + New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth) + := TSD.Ancestor_Tags (0 .. TSD.Idepth); + else + New_TSD.Idepth := 0; + end if; + + New_TSD.Ancestor_Tags (0) := New_Tag; + end CPP_Inherit_TSD; + + --------------------------- + -- CPP_Set_Expanded_Name -- + --------------------------- + + procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is + begin + T.TSD.Expanded_Name := To_Cstring_Ptr (Value); + end CPP_Set_Expanded_Name; + + -------------------------- + -- CPP_Set_External_Tag -- + -------------------------- + + procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is + begin + T.TSD.External_Tag := To_Cstring_Ptr (Value); + end CPP_Set_External_Tag; + + ------------------------------- + -- CPP_Set_Inheritance_Depth -- + ------------------------------- + + procedure CPP_Set_Inheritance_Depth + (T : Vtable_Ptr; + Value : Natural) + is + begin + T.TSD.Idepth := Value; + end CPP_Set_Inheritance_Depth; + + ----------------------------- + -- CPP_Set_Prim_Op_Address -- + ----------------------------- + + procedure CPP_Set_Prim_Op_Address + (T : Vtable_Ptr; + Position : Positive; + Value : Address) + is + begin + T.Prims_Ptr (Position).Pfn := Value; + end CPP_Set_Prim_Op_Address; + + ----------------------- + -- CPP_Set_RC_Offset -- + ----------------------- + + procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is + begin + null; + end CPP_Set_RC_Offset; + + ------------------------------- + -- CPP_Set_Remotely_Callable -- + ------------------------------- + + procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is + begin + null; + end CPP_Set_Remotely_Callable; + + ----------------- + -- CPP_Set_TSD -- + ----------------- + + procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is + begin + T.TSD := To_Type_Specific_Data_Ptr (Value); + end CPP_Set_TSD; + + -------------------- + -- Displaced_This -- + -------------------- + + function Displaced_This + (Current_This : System.Address; + Vptr : Vtable_Ptr; + Position : Positive) + return System.Address + is + begin + return Current_This; + + -- why is the following here commented out ??? + -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1); + end Displaced_This; + + ------------------- + -- Expanded_Name -- + ------------------- + + function Expanded_Name (T : Vtable_Ptr) return String is + Result : Cstring_Ptr := T.TSD.Expanded_Name; + + begin + return Result (1 .. Length (Result)); + end Expanded_Name; + + ------------------ + -- External_Tag -- + ------------------ + + function External_Tag (T : Vtable_Ptr) return String is + Result : Cstring_Ptr := T.TSD.External_Tag; + + begin + return Result (1 .. Length (Result)); + end External_Tag; + + ------------ + -- Length -- + ------------ + + function Length (Str : Cstring_Ptr) return Natural is + Len : Integer := 1; + + begin + while Str (Len) /= ASCII.Nul loop + Len := Len + 1; + end loop; + + return Len - 1; + end Length; +end Interfaces.CPP; diff --git a/gcc/ada/i-cpp.ads b/gcc/ada/i-cpp.ads new file mode 100644 index 00000000000..86d6673c431 --- /dev/null +++ b/gcc/ada/i-cpp.ads @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . C P P -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1992-2000, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Definitions for interfacing to C++ classes + +with System; +with System.Storage_Elements; + +package Interfaces.CPP is + + package S renames System; + package SSE renames System.Storage_Elements; + + -- This package corresponds to Ada.Tags but applied to tagged types + -- which are 'imported' from C++ and correspond to exactly to a C++ + -- Class. GNAT doesn't know about the structure od the C++ dispatch + -- table (Vtable) but always access it through the procedural interface + -- defined below, thus the implementation of this package (the body) can + -- be customized to another C++ compiler without any change in the + -- compiler code itself as long as this procedural interface is + -- respected. Note that Ada.Tags defines a very similar procedural + -- interface to the regular Ada Dispatch Table. + + type Vtable_Ptr is private; + + function Expanded_Name (T : Vtable_Ptr) return String; + function External_Tag (T : Vtable_Ptr) return String; + +private + + procedure CPP_Set_Prim_Op_Address + (T : Vtable_Ptr; + Position : Positive; + Value : S.Address); + -- Given a pointer to a dispatch Table (T) and a position in the + -- dispatch Table put the address of the virtual function in it + -- (used for overriding) + + function CPP_Get_Prim_Op_Address + (T : Vtable_Ptr; + Position : Positive) + return S.Address; + -- Given a pointer to a dispatch Table (T) and a position in the DT + -- this function returns the address of the virtual function stored + -- in it (used for dispatching calls) + + procedure CPP_Set_Inheritance_Depth + (T : Vtable_Ptr; + Value : Natural); + -- Given a pointer to a dispatch Table, stores the value representing + -- the depth in the inheritance tree. Used during elaboration of the + -- tagged type. + + function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural; + -- Given a pointer to a dispatch Table, retreives the value representing + -- the depth in the inheritance tree. Used for membership. + + procedure CPP_Set_TSD (T : Vtable_Ptr; Value : S.Address); + -- Given a pointer T to a dispatch Table, stores the address of the + -- record containing the Type Specific Data generated by GNAT + + function CPP_Get_TSD (T : Vtable_Ptr) return S.Address; + -- Given a pointer T to a dispatch Table, retreives the address of the + -- record containing the Type Specific Data generated by GNAT + + CPP_DT_Prologue_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (2 * (Standard'Address_Size / S.Storage_Unit)); + -- Size of the first part of the dispatch table + + CPP_DT_Entry_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / S.Storage_Unit)); + -- Size of each primitive operation entry in the Dispatch Table. + + CPP_TSD_Prologue_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (4 * (Standard'Address_Size / S.Storage_Unit)); + -- Size of the first part of the type specific data + + CPP_TSD_Entry_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (Standard'Address_Size / S.Storage_Unit); + -- Size of each ancestor tag entry in the TSD + + procedure CPP_Inherit_DT + (Old_T : Vtable_Ptr; + New_T : Vtable_Ptr; + Entry_Count : Natural); + -- Entry point used to initialize the DT of a type knowing the + -- tag of the direct ancestor and the number of primitive ops that are + -- inherited (Entry_Count). + + procedure CPP_Inherit_TSD + (Old_TSD : S.Address; + New_Tag : Vtable_Ptr); + -- Entry point used to initialize the TSD of a type knowing the + -- TSD of the direct ancestor. + + function CPP_CW_Membership (Obj_Tag, Typ_Tag : Vtable_Ptr) return Boolean; + -- Given the tag of an object and the tag associated to a type, return + -- true if Obj is in Typ'Class. + + procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : S.Address); + -- Set the address of the string containing the external tag + -- in the Dispatch table + + function CPP_Get_External_Tag (T : Vtable_Ptr) return S.Address; + -- Retrieve the address of a null terminated string containing + -- the external name + + procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : S.Address); + -- Set the address of the string containing the expanded name + -- in the Dispatch table + + function CPP_Get_Expanded_Name (T : Vtable_Ptr) return S.Address; + -- Retrieve the address of a null terminated string containing + -- the expanded name + + procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean); + -- Since the notions of spec/body distinction and categorized packages + -- do not exist in C, this procedure will do nothing + + function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean; + -- This function will always return True for the reason explained above + + procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset); + -- Sets the Offset of the implicit record controller when the object + -- has controlled components. Set to O otherwise. + + function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset; + -- Return the Offset of the implicit record controller when the object + -- has controlled components. O otherwise. + + function Displaced_This + (Current_This : S.Address; + Vptr : Vtable_Ptr; + Position : Positive) + return S.Address; + -- Compute the displacement on the "this" pointer in order to be + -- compatible with MI. + -- (used for virtual function calls) + + type Vtable; + type Vtable_Ptr is access all Vtable; + + pragma Inline (CPP_Set_Prim_Op_Address); + pragma Inline (CPP_Get_Prim_Op_Address); + pragma Inline (CPP_Set_Inheritance_Depth); + pragma Inline (CPP_Get_Inheritance_Depth); + pragma Inline (CPP_Set_TSD); + pragma Inline (CPP_Get_TSD); + pragma Inline (CPP_Inherit_DT); + pragma Inline (CPP_CW_Membership); + pragma Inline (CPP_Set_External_Tag); + pragma Inline (CPP_Get_External_Tag); + pragma Inline (CPP_Set_Expanded_Name); + pragma Inline (CPP_Get_Expanded_Name); + pragma Inline (CPP_Set_Remotely_Callable); + pragma Inline (CPP_Get_Remotely_Callable); + pragma Inline (Displaced_This); + +end Interfaces.CPP; diff --git a/gcc/ada/i-cstrea.adb b/gcc/ada/i-cstrea.adb new file mode 100644 index 00000000000..00057dc33f1 --- /dev/null +++ b/gcc/ada/i-cstrea.adb @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1996-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version which just calls the C versions directly +-- Note: the reason that we provide for specialization here is that on +-- some systems, notably VMS, we may need to worry about buffering. + +with Unchecked_Conversion; + +package body Interfaces.C_Streams is + + ------------ + -- fread -- + ------------ + + function fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t + is + function C_fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + pragma Import (C, C_fread, "fread"); + + begin + return C_fread (buffer, size, count, stream); + end fread; + + ------------ + -- fread -- + ------------ + + function fread + (buffer : voids; + index : size_t; + size : size_t; + count : size_t; + stream : FILEs) + return size_t + is + function C_fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + pragma Import (C, C_fread, "fread"); + + type Byte_Buffer is array (0 .. size_t'Last / 2 - 1) of Unsigned_8; + -- This should really be 0 .. size_t'last, but there is a problem + -- in gigi in handling such types (introduced in GCC 3 Sep 2001) + -- since the size in bytes of this array overflows ??? + + type Acc_Bytes is access all Byte_Buffer; + + function To_Acc_Bytes is new Unchecked_Conversion (voids, Acc_Bytes); + + begin + return C_fread + (To_Acc_Bytes (buffer) (index * size)'Address, size, count, stream); + end fread; + + ------------ + -- fwrite -- + ------------ + + function fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t + is + function C_fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + pragma Import (C, C_fwrite, "fwrite"); + + begin + return C_fwrite (buffer, size, count, stream); + end fwrite; + + ------------- + -- setvbuf -- + ------------- + + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) + return int + is + function C_setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) + return int; + pragma Import (C, C_setvbuf, "setvbuf"); + + begin + return C_setvbuf (stream, buffer, mode, size); + end setvbuf; + +end Interfaces.C_Streams; diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads new file mode 100644 index 00000000000..220b215e78f --- /dev/null +++ b/gcc/ada/i-cstrea.ads @@ -0,0 +1,346 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.26 $ +-- -- +-- Copyright (C) 1995-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + + +-- This package is a thin binding to selected functions in the C +-- library that provide a complete interface for handling C streams. + +with Unchecked_Conversion; +with System.Parameters; + +package Interfaces.C_Streams is +pragma Elaborate_Body (C_Streams); + + -- Note: the reason we do not use the types that are in Interfaces.C is + -- that we want to avoid dragging in the code in this unit if possible. + + subtype chars is System.Address; + -- Pointer to null-terminated array of characters + + subtype FILEs is System.Address; + -- Corresponds to the C type FILE* + + subtype voids is System.Address; + -- Corresponds to the C type void* + + subtype int is Integer; + -- Note: the above type is a subtype deliberately, and it is part of + -- this spec that the above correspondence is guaranteed. This means + -- that it is legitimate to, for example, use Integer instead of int. + -- We provide this synonym for clarity, but in some cases it may be + -- convenient to use the underlying types (for example to avoid an + -- unnecessary dependency of a spec on the spec of this unit). + + type long is range -(2 ** (System.Parameters.long_bits - 1)) + .. +(2 ** (System.Parameters.long_bits - 1)) - 1; + -- Note: the above type also used to be a subtype, but the correspondence + -- was unused so it was made into a parameterized type to avoid having + -- multiple versions of this spec for systems where long /= Long_Integer. + + type size_t is mod 2 ** Standard'Address_Size; + + NULL_Stream : constant FILEs; + -- Value returned (NULL in C) to indicate an fdopen/fopen/tmpfile error + + ---------------------------------- + -- Constants Defined in stdio.h -- + ---------------------------------- + + EOF : constant int; + -- Used by a number of routines to indicate error or end of file + + IOFBF : constant int; + IOLBF : constant int; + IONBF : constant int; + -- Used to indicate buffering mode for setvbuf call + + L_tmpnam : constant int; + -- Maximum length of file name that can be returned by tmpnam + + SEEK_CUR : constant int; + SEEK_END : constant int; + SEEK_SET : constant int; + -- Used to indicate origin for fseek call + + function stdin return FILEs; + function stdout return FILEs; + function stderr return FILEs; + -- Streams associated with standard files + + -------------------------- + -- Standard C functions -- + -------------------------- + + -- The functions selected below are ones that are available in DOS, + -- OS/2, UNIX and Xenix (but not necessarily in ANSI C). These are + -- very thin interfaces which copy exactly the C headers. For more + -- documentation on these functions, see the Microsoft C "Run-Time + -- Library Reference" (Microsoft Press, 1990, ISBN 1-55615-225-6), + -- which includes useful information on system compatibility. + + procedure clearerr (stream : FILEs); + + function fclose (stream : FILEs) return int; + + function fdopen (handle : int; mode : chars) return FILEs; + + function feof (stream : FILEs) return int; + + function ferror (stream : FILEs) return int; + + function fflush (stream : FILEs) return int; + + function fgetc (stream : FILEs) return int; + + function fgets (strng : chars; n : int; stream : FILEs) return chars; + + function fileno (stream : FILEs) return int; + + function fopen (filename : chars; Mode : chars) return FILEs; + -- Note: to maintain target independence, use text_translation_required, + -- a boolean variable defined in a-sysdep.c to deal with the target + -- dependent text translation requirement. If this variable is set, + -- then b/t should be appended to the standard mode argument to set + -- the text translation mode off or on as required. + + function fputc (C : int; stream : FILEs) return int; + + function fputs (Strng : chars; Stream : FILEs) return int; + + function fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function fread + (buffer : voids; + index : size_t; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + -- Same as normal fread, but has a parameter 'index' that indicates + -- the starting index for the read within 'buffer' (which must be the + -- address of the beginning of a whole array object with an assumed + -- zero base). This is needed for systems that do not support taking + -- the address of an element within an array. + + function freopen + (filename : chars; + mode : chars; + stream : FILEs) + return FILEs; + + function fseek + (stream : FILEs; + offset : long; + origin : int) + return int; + + function ftell (stream : FILEs) return long; + + function fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function isatty (handle : int) return int; + + procedure mktemp (template : chars); + -- The return value (which is just a pointer to template) is discarded + + procedure rewind (stream : FILEs); + + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) + return int; + + procedure tmpnam (string : chars); + -- The parameter must be a pointer to a string buffer of at least L_tmpnam + -- bytes (the call with a null parameter is not supported). The returned + -- value, which is just a copy of the input argument, is discarded. + + function tmpfile return FILEs; + + function ungetc (c : int; stream : FILEs) return int; + + function unlink (filename : chars) return int; + + --------------------- + -- Extra functions -- + --------------------- + + -- These functions supply slightly thicker bindings than those above. + -- They are derived from functions in the C Run-Time Library, but may + -- do a bit more work than just directly calling one of the Library + -- functions. + + function file_exists (name : chars) return int; + -- Tests if given name corresponds to an existing file. + + function is_regular_file (handle : int) return int; + -- Tests if given handle is for a regular file (result 1) or for + -- a non-regular file (pipe or device, result 0). + + --------------------------------- + -- Control of Text/Binary Mode -- + --------------------------------- + + -- If text_translation_required is true, then the following functions may + -- be used to dynamically switch a file from binary to text mode or vice + -- versa. These functions have no effect if text_translation_required is + -- false (i.e. in normal unix mode). Use fileno to get a stream handle. + + procedure set_binary_mode (handle : int); + procedure set_text_mode (handle : int); + + ---------------------------- + -- Full Path Name support -- + ---------------------------- + + procedure full_name (nam : chars; buffer : chars); + -- Given a NUL terminated string representing a file name, returns in + -- buffer a NUL terminated string representing the full path name for + -- the file name. On systems where it is relevant the drive is also part + -- of the full path name. It is the responsibility of the caller to + -- pass an actual parameter for buffer that is big enough for any full + -- path name. Use max_path_len given below as the size of buffer. + + max_path_len : Integer; + -- Maximum length of an allowable full path name on the system, + -- including a terminating NUL character. + +private + -- The following functions are specialized in the body depending on the + -- operating system. + + pragma Inline (fread); + pragma Inline (fwrite); + pragma Inline (setvbuf); + + -- The following routines are always functions in C, and thus can be + -- imported directly into Ada without any intermediate C needed + + pragma Import (C, clearerr); + pragma Import (C, fclose); + pragma Import (C, fdopen); + pragma Import (C, fflush); + pragma Import (C, fgetc); + pragma Import (C, fgets); + pragma Import (C, fopen); + pragma Import (C, fputc); + pragma Import (C, fputs); + pragma Import (C, freopen); + pragma Import (C, fseek); + pragma Import (C, ftell); + pragma Import (C, isatty); + pragma Import (C, mktemp); + pragma Import (C, rewind); + pragma Import (C, tmpnam); + pragma Import (C, tmpfile); + pragma Import (C, ungetc); + pragma Import (C, unlink); + + pragma Import (C, file_exists, "__gnat_file_exists"); + pragma Import (C, is_regular_file, "__gnat_is_regular_file_fd"); + + pragma Import (C, set_binary_mode, "__gnat_set_binary_mode"); + pragma Import (C, set_text_mode, "__gnat_set_text_mode"); + + pragma Import (C, max_path_len, "max_path_len"); + pragma Import (C, full_name, "__gnat_full_name"); + + -- The following may be implemented as macros, and so are supported + -- via an interface function in the a-stdio.c file. + + pragma Import (C, feof, "__gnat_feof"); + pragma Import (C, ferror, "__gnat_ferror"); + pragma Import (C, fileno, "__gnat_fileno"); + + -- Constants in stdio are provided via imported variables that are + -- defined in a-cstrea.c using the stdio.h header. It would be cleaner + -- if we could import constant directly, but GNAT does not support + -- pragma Import for constants ??? + + c_constant_EOF : int; + + c_constant_IOFBF : int; + c_constant_IOLBF : int; + c_constant_IONBF : int; + + c_constant_SEEK_CUR : int; + c_constant_SEEK_END : int; + c_constant_SEEK_SET : int; + + c_constant_L_tmpnam : int; + + pragma Import (C, c_constant_EOF, "__gnat_constant_eof"); + pragma Import (C, c_constant_IOFBF, "__gnat_constant_iofbf"); + pragma Import (C, c_constant_IOLBF, "__gnat_constant_iolbf"); + pragma Import (C, c_constant_IONBF, "__gnat_constant_ionbf"); + pragma Import (C, c_constant_SEEK_CUR, "__gnat_constant_seek_cur"); + pragma Import (C, c_constant_SEEK_END, "__gnat_constant_seek_end"); + pragma Import (C, c_constant_SEEK_SET, "__gnat_constant_seek_set"); + pragma Import (C, c_constant_L_tmpnam, "__gnat_constant_l_tmpnam"); + + pragma Import (C, stderr, "__gnat_constant_stderr"); + pragma Import (C, stdin, "__gnat_constant_stdin"); + pragma Import (C, stdout, "__gnat_constant_stdout"); + + EOF : constant int := c_constant_EOF; + IOFBF : constant int := c_constant_IOFBF; + IOLBF : constant int := c_constant_IOLBF; + IONBF : constant int := c_constant_IONBF; + SEEK_CUR : constant int := c_constant_SEEK_CUR; + SEEK_END : constant int := c_constant_SEEK_END; + SEEK_SET : constant int := c_constant_SEEK_SET; + L_tmpnam : constant int := c_constant_L_tmpnam; + + type Dummy is access Integer; + function To_Address is new Unchecked_Conversion (Dummy, System.Address); + -- Used to concoct the null address below + + NULL_Stream : constant FILEs := To_Address (Dummy'(null)); + -- Value returned (NULL in C) to indicate an fdopen/fopen/tmpfile error + +end Interfaces.C_Streams; diff --git a/gcc/ada/i-cstrin.adb b/gcc/ada/i-cstrin.adb new file mode 100644 index 00000000000..4c0f166ce67 --- /dev/null +++ b/gcc/ada/i-cstrin.adb @@ -0,0 +1,329 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . S T R I N G S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1992-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Address_To_Access_Conversions; + +package body Interfaces.C.Strings is + + package Char_Access is new Address_To_Access_Conversions (char); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Peek (From : chars_ptr) return char; + pragma Inline (Peek); + -- Given a chars_ptr value, obtain referenced character + + procedure Poke (Value : char; Into : chars_ptr); + pragma Inline (Poke); + -- Given a chars_ptr, modify referenced Character value + + function "+" (Left : chars_ptr; Right : size_t) return chars_ptr; + pragma Inline ("+"); + -- Address arithmetic on chars_ptr value + + function Position_Of_Nul (Into : char_array) return size_t; + -- Returns position of the first Nul in Into or Into'Last + 1 if none + + function C_Malloc (Size : size_t) return chars_ptr; + pragma Import (C, C_Malloc, "__gnat_malloc"); + + procedure C_Free (Address : chars_ptr); + pragma Import (C, C_Free, "__gnat_free"); + + --------- + -- "+" -- + --------- + + function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is + begin + return Left + chars_ptr (Right); + end "+"; + + ---------- + -- Free -- + ---------- + + procedure Free (Item : in out chars_ptr) is + begin + if Item = Null_Ptr then + return; + end if; + + C_Free (Item); + Item := Null_Ptr; + end Free; + + -------------------- + -- New_Char_Array -- + -------------------- + + function New_Char_Array (Chars : in char_array) return chars_ptr is + Index : size_t; + Pointer : chars_ptr; + + begin + -- Get index of position of null. If Index > Chars'last, + -- nul is absent and must be added explicitly. + + Index := Position_Of_Nul (Into => Chars); + Pointer := C_Malloc ((Index - Chars'First + 1)); + + -- If nul is present, transfer string up to and including it. + + if Index <= Chars'Last then + Update (Item => Pointer, + Offset => 0, + Chars => Chars (Chars'First .. Index), + Check => False); + else + -- If original string has no nul, transfer whole string and add + -- terminator explicitly. + + Update (Item => Pointer, + Offset => 0, + Chars => Chars, + Check => False); + Poke (nul, into => Pointer + size_t '(Chars'Length)); + end if; + + return Pointer; + end New_Char_Array; + + ---------------- + -- New_String -- + ---------------- + + function New_String (Str : in String) return chars_ptr is + begin + return New_Char_Array (To_C (Str)); + end New_String; + + ---------- + -- Peek -- + ---------- + + function Peek (From : chars_ptr) return char is + use Char_Access; + begin + return To_Pointer (Address (To_Address (From))).all; + end Peek; + + ---------- + -- Poke -- + ---------- + + procedure Poke (Value : char; Into : chars_ptr) is + use Char_Access; + begin + To_Pointer (Address (To_Address (Into))).all := Value; + end Poke; + + --------------------- + -- Position_Of_Nul -- + --------------------- + + function Position_Of_Nul (Into : char_array) return size_t is + begin + for J in Into'Range loop + if Into (J) = nul then + return J; + end if; + end loop; + + return Into'Last + 1; + end Position_Of_Nul; + + ------------ + -- Strlen -- + ------------ + + function Strlen (Item : in chars_ptr) return size_t is + Item_Index : size_t := 0; + + begin + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + loop + if Peek (Item + Item_Index) = nul then + return Item_Index; + end if; + + Item_Index := Item_Index + 1; + end loop; + end Strlen; + + ------------------ + -- To_Chars_Ptr -- + ------------------ + + function To_Chars_Ptr + (Item : in char_array_access; + Nul_Check : in Boolean := False) + return chars_ptr + is + begin + if Item = null then + return Null_Ptr; + elsif Nul_Check + and then Position_Of_Nul (Into => Item.all) > Item'Last + then + raise Terminator_Error; + else + return To_Integer (Item (Item'First)'Address); + end if; + end To_Chars_Ptr; + + ------------ + -- Update -- + ------------ + + procedure Update + (Item : in chars_ptr; + Offset : in size_t; + Chars : in char_array; + Check : Boolean := True) + is + Index : chars_ptr := Item + Offset; + + begin + if Check and then Offset + Chars'Length > Strlen (Item) then + raise Update_Error; + end if; + + for J in Chars'Range loop + Poke (Chars (J), Into => Index); + Index := Index + size_t'(1); + end loop; + end Update; + + procedure Update + (Item : in chars_ptr; + Offset : in size_t; + Str : in String; + Check : in Boolean := True) + is + begin + Update (Item, Offset, To_C (Str), Check); + end Update; + + ----------- + -- Value -- + ----------- + + function Value (Item : in chars_ptr) return char_array is + Result : char_array (0 .. Strlen (Item)); + + begin + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + -- Note that the following loop will also copy the terminating Nul + + for J in Result'Range loop + Result (J) := Peek (Item + J); + end loop; + + return Result; + end Value; + + function Value + (Item : in chars_ptr; + Length : in size_t) + return char_array + is + begin + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + -- ACATS cxb3010 checks that Constraint_Error gets raised when Length + -- is 0. Seems better to check that Length is not null before declaring + -- an array with size_t bounds of 0 .. Length - 1 anyway. + + if Length = 0 then + raise Constraint_Error; + end if; + + declare + Result : char_array (0 .. Length - 1); + + begin + for J in Result'Range loop + Result (J) := Peek (Item + J); + + if Result (J) = nul then + return Result (0 .. J); + end if; + end loop; + + return Result; + end; + end Value; + + function Value (Item : in chars_ptr) return String is + begin + return To_Ada (Value (Item)); + end Value; + + -- As per AI-00177, this is equivalent to + -- To_Ada (Value (Item, Length) & nul); + + function Value (Item : in chars_ptr; Length : in size_t) return String is + Result : char_array (0 .. Length); + + begin + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + for J in 0 .. Length - 1 loop + Result (J) := Peek (Item + J); + + if Result (J) = nul then + return To_Ada (Result (0 .. J)); + end if; + end loop; + + Result (Length) := nul; + return To_Ada (Result); + end Value; + +end Interfaces.C.Strings; diff --git a/gcc/ada/i-cstrin.ads b/gcc/ada/i-cstrin.ads new file mode 100644 index 00000000000..308b6000146 --- /dev/null +++ b/gcc/ada/i-cstrin.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . S T R I N G S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 1993-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; + +package Interfaces.C.Strings is +pragma Preelaborate (Strings); + + type char_array_access is access all char_array; + + type chars_ptr is private; + + type chars_ptr_array is array (size_t range <>) of chars_ptr; + + Null_Ptr : constant chars_ptr; + + function To_Chars_Ptr + (Item : in char_array_access; + Nul_Check : in Boolean := False) + return chars_ptr; + + function New_Char_Array (Chars : in char_array) return chars_ptr; + + function New_String (Str : in String) return chars_ptr; + + procedure Free (Item : in out chars_ptr); + + Dereference_Error : exception; + + function Value (Item : in chars_ptr) return char_array; + + function Value + (Item : in chars_ptr; + Length : in size_t) + return char_array; + + function Value (Item : in chars_ptr) return String; + + function Value + (Item : in chars_ptr; + Length : in size_t) + return String; + + function Strlen (Item : in chars_ptr) return size_t; + + procedure Update + (Item : in chars_ptr; + Offset : in size_t; + Chars : in char_array; + Check : Boolean := True); + + procedure Update + (Item : in chars_ptr; + Offset : in size_t; + Str : in String; + Check : in Boolean := True); + + Update_Error : exception; + +private + type chars_ptr is new System.Storage_Elements.Integer_Address; + + Null_Ptr : constant chars_ptr := 0; + -- A little cleaner might be To_Integer (System.Null_Address) but this is + -- non-preelaborable, and in fact we jolly well know this value is zero. + -- Indeed, given the C interface nature, it is probably more correct to + -- write zero here (even if Null_Address were non-zero). + +end Interfaces.C.Strings; diff --git a/gcc/ada/i-fortra.adb b/gcc/ada/i-fortra.adb new file mode 100644 index 00000000000..cc18578431d --- /dev/null +++ b/gcc/ada/i-fortra.adb @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- Copyright (C) 1992,1993,1994 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.Fortran is + + ------------ + -- To_Ada -- + ------------ + + -- Single character case + + function To_Ada (Item : in Character_Set) return Character is + begin + return Character (Item); + end To_Ada; + + -- String case (function returning converted result) + + function To_Ada (Item : in Fortran_Character) return String is + T : String (1 .. Item'Length); + + begin + for J in T'Range loop + T (J) := Character (Item (J - 1 + Item'First)); + end loop; + + return T; + end To_Ada; + + -- String case (procedure copying converted string to given buffer) + + procedure To_Ada + (Item : in Fortran_Character; + Target : out String; + Last : out Natural) + is + begin + if Item'Length = 0 then + Last := 0; + return; + + elsif Target'Length = 0 then + raise Constraint_Error; + + else + Last := Target'First - 1; + + for J in Item'Range loop + Last := Last + 1; + + if Last > Target'Last then + raise Constraint_Error; + else + Target (Last) := Character (Item (J)); + end if; + end loop; + end if; + end To_Ada; + + ---------------- + -- To_Fortran -- + ---------------- + + -- Character case + + function To_Fortran (Item : in Character) return Character_Set is + begin + return Character_Set (Item); + end To_Fortran; + + -- String case (function returning converted result) + + function To_Fortran (Item : in String) return Fortran_Character is + T : Fortran_Character (1 .. Item'Length); + + begin + for J in T'Range loop + T (J) := Character_Set (Item (J - 1 + Item'First)); + end loop; + + return T; + end To_Fortran; + + -- String case (procedure copying converted string to given buffer) + + procedure To_Fortran + (Item : in String; + Target : out Fortran_Character; + Last : out Natural) + is + begin + if Item'Length = 0 then + Last := 0; + return; + + elsif Target'Length = 0 then + raise Constraint_Error; + + else + Last := Target'First - 1; + + for J in Item'Range loop + Last := Last + 1; + + if Last > Target'Last then + raise Constraint_Error; + else + Target (Last) := Character_Set (Item (J)); + end if; + end loop; + end if; + end To_Fortran; + +end Interfaces.Fortran; diff --git a/gcc/ada/i-fortra.ads b/gcc/ada/i-fortra.ads new file mode 100644 index 00000000000..9a9262cd904 --- /dev/null +++ b/gcc/ada/i-fortra.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; +pragma Elaborate_All (Ada.Numerics.Generic_Complex_Types); + +package Interfaces.Fortran is +pragma Pure (Fortran); + + type Fortran_Integer is new Integer; + type Real is new Float; + type Double_Precision is new Long_Float; + + type Logical is new Boolean; + for Logical'Size use Integer'Size; + pragma Convention (Fortran, Logical); + -- As required by Fortran standard, stand alone logical allocates same + -- space as integer (but what about the array case???). The convention + -- is important, since in Fortran, Booleans have zero/non-zero semantics + -- for False/True, and the pragma Convention (Fortran) activates the + -- special handling required in this case. + + package Single_Precision_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Real); + + type Complex is new Single_Precision_Complex_Types.Complex; + + subtype Imaginary is Single_Precision_Complex_Types.Imaginary; + i : Imaginary renames Single_Precision_Complex_Types.i; + j : Imaginary renames Single_Precision_Complex_Types.j; + + type Character_Set is new Character; + + type Fortran_Character is array (Positive range <>) of Character_Set; + + function To_Fortran (Item : in Character) return Character_Set; + function To_Ada (Item : in Character_Set) return Character; + + function To_Fortran (Item : in String) return Fortran_Character; + function To_Ada (Item : in Fortran_Character) return String; + + procedure To_Fortran + (Item : in String; + Target : out Fortran_Character; + Last : out Natural); + + procedure To_Ada + (Item : in Fortran_Character; + Target : out String; + Last : out Natural); + +end Interfaces.Fortran; diff --git a/gcc/ada/i-os2err.ads b/gcc/ada/i-os2err.ads new file mode 100644 index 00000000000..12d80f7de77 --- /dev/null +++ b/gcc/ada/i-os2err.ads @@ -0,0 +1,657 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . O S 2 L I B . E R R O R S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1993,1994,1995 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Definition of values for OS/2 error returns + +package Interfaces.OS2Lib.Errors is +pragma Preelaborate (Errors); + + NO_ERROR : constant := 0; + ERROR_INVALID_FUNCTION : constant := 1; + ERROR_FILE_NOT_FOUND : constant := 2; + ERROR_PATH_NOT_FOUND : constant := 3; + ERROR_TOO_MANY_OPEN_FILES : constant := 4; + ERROR_ACCESS_DENIED : constant := 5; + ERROR_INVALID_HANDLE : constant := 6; + ERROR_ARENA_TRASHED : constant := 7; + ERROR_NOT_ENOUGH_MEMORY : constant := 8; + ERROR_INVALID_BLOCK : constant := 9; + ERROR_BAD_ENVIRONMENT : constant := 10; + ERROR_BAD_FORMAT : constant := 11; + ERROR_INVALID_ACCESS : constant := 12; + ERROR_INVALID_DATA : constant := 13; + ERROR_INVALID_DRIVE : constant := 15; + ERROR_CURRENT_DIRECTORY : constant := 16; + ERROR_NOT_SAME_DEVICE : constant := 17; + ERROR_NO_MORE_FILES : constant := 18; + ERROR_WRITE_PROTECT : constant := 19; + ERROR_BAD_UNIT : constant := 20; + ERROR_NOT_READY : constant := 21; + ERROR_BAD_COMMAND : constant := 22; + ERROR_CRC : constant := 23; + ERROR_BAD_LENGTH : constant := 24; + ERROR_SEEK : constant := 25; + ERROR_NOT_DOS_DISK : constant := 26; + ERROR_SECTOR_NOT_FOUND : constant := 27; + ERROR_OUT_OF_PAPER : constant := 28; + ERROR_WRITE_FAULT : constant := 29; + ERROR_READ_FAULT : constant := 30; + ERROR_GEN_FAILURE : constant := 31; + ERROR_SHARING_VIOLATION : constant := 32; + ERROR_LOCK_VIOLATION : constant := 33; + ERROR_WRONG_DISK : constant := 34; + ERROR_FCB_UNAVAILABLE : constant := 35; + ERROR_SHARING_BUFFER_EXCEEDED : constant := 36; + ERROR_CODE_PAGE_MISMATCHED : constant := 37; + ERROR_HANDLE_EOF : constant := 38; + ERROR_HANDLE_DISK_FULL : constant := 39; + ERROR_NOT_SUPPORTED : constant := 50; + ERROR_REM_NOT_LIST : constant := 51; + ERROR_DUP_NAME : constant := 52; + ERROR_BAD_NETPATH : constant := 53; + ERROR_NETWORK_BUSY : constant := 54; + ERROR_DEV_NOT_EXIST : constant := 55; + ERROR_TOO_MANY_CMDS : constant := 56; + ERROR_ADAP_HDW_ERR : constant := 57; + ERROR_BAD_NET_RESP : constant := 58; + ERROR_UNEXP_NET_ERR : constant := 59; + ERROR_BAD_REM_ADAP : constant := 60; + ERROR_PRINTQ_FULL : constant := 61; + ERROR_NO_SPOOL_SPACE : constant := 62; + ERROR_PRINT_CANCELLED : constant := 63; + ERROR_NETNAME_DELETED : constant := 64; + ERROR_NETWORK_ACCESS_DENIED : constant := 65; + ERROR_BAD_DEV_TYPE : constant := 66; + ERROR_BAD_NET_NAME : constant := 67; + ERROR_TOO_MANY_NAMES : constant := 68; + ERROR_TOO_MANY_SESS : constant := 69; + ERROR_SHARING_PAUSED : constant := 70; + ERROR_REQ_NOT_ACCEP : constant := 71; + ERROR_REDIR_PAUSED : constant := 72; + ERROR_SBCS_ATT_WRITE_PROT : constant := 73; + ERROR_SBCS_GENERAL_FAILURE : constant := 74; + ERROR_XGA_OUT_MEMORY : constant := 75; + ERROR_FILE_EXISTS : constant := 80; + ERROR_DUP_FCB : constant := 81; + ERROR_CANNOT_MAKE : constant := 82; + ERROR_FAIL_I24 : constant := 83; + ERROR_OUT_OF_STRUCTURES : constant := 84; + ERROR_ALREADY_ASSIGNED : constant := 85; + ERROR_INVALID_PASSWORD : constant := 86; + ERROR_INVALID_PARAMETER : constant := 87; + ERROR_NET_WRITE_FAULT : constant := 88; + ERROR_NO_PROC_SLOTS : constant := 89; + ERROR_NOT_FROZEN : constant := 90; + ERROR_SYS_COMP_NOT_LOADED : constant := 90; + ERR_TSTOVFL : constant := 91; + ERR_TSTDUP : constant := 92; + ERROR_NO_ITEMS : constant := 93; + ERROR_INTERRUPT : constant := 95; + ERROR_DEVICE_IN_USE : constant := 99; + ERROR_TOO_MANY_SEMAPHORES : constant := 100; + ERROR_EXCL_SEM_ALREADY_OWNED : constant := 101; + ERROR_SEM_IS_SET : constant := 102; + ERROR_TOO_MANY_SEM_REQUESTS : constant := 103; + ERROR_INVALID_AT_INTERRUPT_TIME : constant := 104; + ERROR_SEM_OWNER_DIED : constant := 105; + ERROR_SEM_USER_LIMIT : constant := 106; + ERROR_DISK_CHANGE : constant := 107; + ERROR_DRIVE_LOCKED : constant := 108; + ERROR_BROKEN_PIPE : constant := 109; + ERROR_OPEN_FAILED : constant := 110; + ERROR_BUFFER_OVERFLOW : constant := 111; + ERROR_DISK_FULL : constant := 112; + ERROR_NO_MORE_SEARCH_HANDLES : constant := 113; + ERROR_INVALID_TARGET_HANDLE : constant := 114; + ERROR_PROTECTION_VIOLATION : constant := 115; + ERROR_VIOKBD_REQUEST : constant := 116; + ERROR_INVALID_CATEGORY : constant := 117; + ERROR_INVALID_VERIFY_SWITCH : constant := 118; + ERROR_BAD_DRIVER_LEVEL : constant := 119; + ERROR_CALL_NOT_IMPLEMENTED : constant := 120; + ERROR_SEM_TIMEOUT : constant := 121; + ERROR_INSUFFICIENT_BUFFER : constant := 122; + ERROR_INVALID_NAME : constant := 123; + ERROR_INVALID_LEVEL : constant := 124; + ERROR_NO_VOLUME_LABEL : constant := 125; + ERROR_MOD_NOT_FOUND : constant := 126; + ERROR_PROC_NOT_FOUND : constant := 127; + ERROR_WAIT_NO_CHILDREN : constant := 128; + ERROR_CHILD_NOT_COMPLETE : constant := 129; + ERROR_DIRECT_ACCESS_HANDLE : constant := 130; + ERROR_NEGATIVE_SEEK : constant := 131; + ERROR_SEEK_ON_DEVICE : constant := 132; + ERROR_IS_JOIN_TARGET : constant := 133; + ERROR_IS_JOINED : constant := 134; + ERROR_IS_SUBSTED : constant := 135; + ERROR_NOT_JOINED : constant := 136; + ERROR_NOT_SUBSTED : constant := 137; + ERROR_JOIN_TO_JOIN : constant := 138; + ERROR_SUBST_TO_SUBST : constant := 139; + ERROR_JOIN_TO_SUBST : constant := 140; + ERROR_SUBST_TO_JOIN : constant := 141; + ERROR_BUSY_DRIVE : constant := 142; + ERROR_SAME_DRIVE : constant := 143; + ERROR_DIR_NOT_ROOT : constant := 144; + ERROR_DIR_NOT_EMPTY : constant := 145; + ERROR_IS_SUBST_PATH : constant := 146; + ERROR_IS_JOIN_PATH : constant := 147; + ERROR_PATH_BUSY : constant := 148; + ERROR_IS_SUBST_TARGET : constant := 149; + ERROR_SYSTEM_TRACE : constant := 150; + ERROR_INVALID_EVENT_COUNT : constant := 151; + ERROR_TOO_MANY_MUXWAITERS : constant := 152; + ERROR_INVALID_LIST_FORMAT : constant := 153; + ERROR_LABEL_TOO_LONG : constant := 154; + ERROR_TOO_MANY_TCBS : constant := 155; + ERROR_SIGNAL_REFUSED : constant := 156; + ERROR_DISCARDED : constant := 157; + ERROR_NOT_LOCKED : constant := 158; + ERROR_BAD_THREADID_ADDR : constant := 159; + ERROR_BAD_ARGUMENTS : constant := 160; + ERROR_BAD_PATHNAME : constant := 161; + ERROR_SIGNAL_PENDING : constant := 162; + ERROR_UNCERTAIN_MEDIA : constant := 163; + ERROR_MAX_THRDS_REACHED : constant := 164; + ERROR_MONITORS_NOT_SUPPORTED : constant := 165; + ERROR_UNC_DRIVER_NOT_INSTALLED : constant := 166; + ERROR_LOCK_FAILED : constant := 167; + ERROR_SWAPIO_FAILED : constant := 168; + ERROR_SWAPIN_FAILED : constant := 169; + ERROR_BUSY : constant := 170; + ERROR_CANCEL_VIOLATION : constant := 173; + ERROR_ATOMIC_LOCK_NOT_SUPPORTED : constant := 174; + ERROR_READ_LOCKS_NOT_SUPPORTED : constant := 175; + ERROR_INVALID_SEGMENT_NUMBER : constant := 180; + ERROR_INVALID_CALLGATE : constant := 181; + ERROR_INVALID_ORDINAL : constant := 182; + ERROR_ALREADY_EXISTS : constant := 183; + ERROR_NO_CHILD_PROCESS : constant := 184; + ERROR_CHILD_ALIVE_NOWAIT : constant := 185; + ERROR_INVALID_FLAG_NUMBER : constant := 186; + ERROR_SEM_NOT_FOUND : constant := 187; + ERROR_INVALID_STARTING_CODESEG : constant := 188; + ERROR_INVALID_STACKSEG : constant := 189; + ERROR_INVALID_MODULETYPE : constant := 190; + ERROR_INVALID_EXE_SIGNATURE : constant := 191; + ERROR_EXE_MARKED_INVALID : constant := 192; + ERROR_BAD_EXE_FORMAT : constant := 193; + ERROR_ITERATED_DATA_EXCEEDS_64k : constant := 194; + ERROR_INVALID_MINALLOCSIZE : constant := 195; + ERROR_DYNLINK_FROM_INVALID_RING : constant := 196; + ERROR_IOPL_NOT_ENABLED : constant := 197; + ERROR_INVALID_SEGDPL : constant := 198; + ERROR_AUTODATASEG_EXCEEDS_64k : constant := 199; + ERROR_RING2SEG_MUST_BE_MOVABLE : constant := 200; + ERROR_RELOC_CHAIN_XEEDS_SEGLIM : constant := 201; + ERROR_INFLOOP_IN_RELOC_CHAIN : constant := 202; + ERROR_ENVVAR_NOT_FOUND : constant := 203; + ERROR_NOT_CURRENT_CTRY : constant := 204; + ERROR_NO_SIGNAL_SENT : constant := 205; + ERROR_FILENAME_EXCED_RANGE : constant := 206; + ERROR_RING2_STACK_IN_USE : constant := 207; + ERROR_META_EXPANSION_TOO_LONG : constant := 208; + ERROR_INVALID_SIGNAL_NUMBER : constant := 209; + ERROR_THREAD_1_INACTIVE : constant := 210; + ERROR_INFO_NOT_AVAIL : constant := 211; + ERROR_LOCKED : constant := 212; + ERROR_BAD_DYNALINK : constant := 213; + ERROR_TOO_MANY_MODULES : constant := 214; + ERROR_NESTING_NOT_ALLOWED : constant := 215; + ERROR_CANNOT_SHRINK : constant := 216; + ERROR_ZOMBIE_PROCESS : constant := 217; + ERROR_STACK_IN_HIGH_MEMORY : constant := 218; + ERROR_INVALID_EXITROUTINE_RING : constant := 219; + ERROR_GETBUF_FAILED : constant := 220; + ERROR_FLUSHBUF_FAILED : constant := 221; + ERROR_TRANSFER_TOO_LONG : constant := 222; + ERROR_FORCENOSWAP_FAILED : constant := 223; + ERROR_SMG_NO_TARGET_WINDOW : constant := 224; + ERROR_NO_CHILDREN : constant := 228; + ERROR_INVALID_SCREEN_GROUP : constant := 229; + ERROR_BAD_PIPE : constant := 230; + ERROR_PIPE_BUSY : constant := 231; + ERROR_NO_DATA : constant := 232; + ERROR_PIPE_NOT_CONNECTED : constant := 233; + ERROR_MORE_DATA : constant := 234; + ERROR_VC_DISCONNECTED : constant := 240; + ERROR_CIRCULARITY_REQUESTED : constant := 250; + ERROR_DIRECTORY_IN_CDS : constant := 251; + ERROR_INVALID_FSD_NAME : constant := 252; + ERROR_INVALID_PATH : constant := 253; + ERROR_INVALID_EA_NAME : constant := 254; + ERROR_EA_LIST_INCONSISTENT : constant := 255; + ERROR_EA_LIST_TOO_LONG : constant := 256; + ERROR_NO_META_MATCH : constant := 257; + ERROR_FINDNOTIFY_TIMEOUT : constant := 258; + ERROR_NO_MORE_ITEMS : constant := 259; + ERROR_SEARCH_STRUC_REUSED : constant := 260; + ERROR_CHAR_NOT_FOUND : constant := 261; + ERROR_TOO_MUCH_STACK : constant := 262; + ERROR_INVALID_ATTR : constant := 263; + ERROR_INVALID_STARTING_RING : constant := 264; + ERROR_INVALID_DLL_INIT_RING : constant := 265; + ERROR_CANNOT_COPY : constant := 266; + ERROR_DIRECTORY : constant := 267; + ERROR_OPLOCKED_FILE : constant := 268; + ERROR_OPLOCK_THREAD_EXISTS : constant := 269; + ERROR_VOLUME_CHANGED : constant := 270; + ERROR_FINDNOTIFY_HANDLE_IN_USE : constant := 271; + ERROR_FINDNOTIFY_HANDLE_CLOSED : constant := 272; + ERROR_NOTIFY_OBJECT_REMOVED : constant := 273; + ERROR_ALREADY_SHUTDOWN : constant := 274; + ERROR_EAS_DIDNT_FIT : constant := 275; + ERROR_EA_FILE_CORRUPT : constant := 276; + ERROR_EA_TABLE_FULL : constant := 277; + ERROR_INVALID_EA_HANDLE : constant := 278; + ERROR_NO_CLUSTER : constant := 279; + ERROR_CREATE_EA_FILE : constant := 280; + ERROR_CANNOT_OPEN_EA_FILE : constant := 281; + ERROR_EAS_NOT_SUPPORTED : constant := 282; + ERROR_NEED_EAS_FOUND : constant := 283; + ERROR_DUPLICATE_HANDLE : constant := 284; + ERROR_DUPLICATE_NAME : constant := 285; + ERROR_EMPTY_MUXWAIT : constant := 286; + ERROR_MUTEX_OWNED : constant := 287; + ERROR_NOT_OWNER : constant := 288; + ERROR_PARAM_TOO_SMALL : constant := 289; + ERROR_TOO_MANY_HANDLES : constant := 290; + ERROR_TOO_MANY_OPENS : constant := 291; + ERROR_WRONG_TYPE : constant := 292; + ERROR_UNUSED_CODE : constant := 293; + ERROR_THREAD_NOT_TERMINATED : constant := 294; + ERROR_INIT_ROUTINE_FAILED : constant := 295; + ERROR_MODULE_IN_USE : constant := 296; + ERROR_NOT_ENOUGH_WATCHPOINTS : constant := 297; + ERROR_TOO_MANY_POSTS : constant := 298; + ERROR_ALREADY_POSTED : constant := 299; + ERROR_ALREADY_RESET : constant := 300; + ERROR_SEM_BUSY : constant := 301; + ERROR_INVALID_PROCID : constant := 303; + ERROR_INVALID_PDELTA : constant := 304; + ERROR_NOT_DESCENDANT : constant := 305; + ERROR_NOT_SESSION_MANAGER : constant := 306; + ERROR_INVALID_PCLASS : constant := 307; + ERROR_INVALID_SCOPE : constant := 308; + ERROR_INVALID_THREADID : constant := 309; + ERROR_DOSSUB_SHRINK : constant := 310; + ERROR_DOSSUB_NOMEM : constant := 311; + ERROR_DOSSUB_OVERLAP : constant := 312; + ERROR_DOSSUB_BADSIZE : constant := 313; + ERROR_DOSSUB_BADFLAG : constant := 314; + ERROR_DOSSUB_BADSELECTOR : constant := 315; + ERROR_MR_MSG_TOO_LONG : constant := 316; + MGS_MR_MSG_TOO_LONG : constant := 316; + ERROR_MR_MID_NOT_FOUND : constant := 317; + ERROR_MR_UN_ACC_MSGF : constant := 318; + ERROR_MR_INV_MSGF_FORMAT : constant := 319; + ERROR_MR_INV_IVCOUNT : constant := 320; + ERROR_MR_UN_PERFORM : constant := 321; + ERROR_TS_WAKEUP : constant := 322; + ERROR_TS_SEMHANDLE : constant := 323; + ERROR_TS_NOTIMER : constant := 324; + ERROR_TS_HANDLE : constant := 326; + ERROR_TS_DATETIME : constant := 327; + ERROR_SYS_INTERNAL : constant := 328; + ERROR_QUE_CURRENT_NAME : constant := 329; + ERROR_QUE_PROC_NOT_OWNED : constant := 330; + ERROR_QUE_PROC_OWNED : constant := 331; + ERROR_QUE_DUPLICATE : constant := 332; + ERROR_QUE_ELEMENT_NOT_EXIST : constant := 333; + ERROR_QUE_NO_MEMORY : constant := 334; + ERROR_QUE_INVALID_NAME : constant := 335; + ERROR_QUE_INVALID_PRIORITY : constant := 336; + ERROR_QUE_INVALID_HANDLE : constant := 337; + ERROR_QUE_LINK_NOT_FOUND : constant := 338; + ERROR_QUE_MEMORY_ERROR : constant := 339; + ERROR_QUE_PREV_AT_END : constant := 340; + ERROR_QUE_PROC_NO_ACCESS : constant := 341; + ERROR_QUE_EMPTY : constant := 342; + ERROR_QUE_NAME_NOT_EXIST : constant := 343; + ERROR_QUE_NOT_INITIALIZED : constant := 344; + ERROR_QUE_UNABLE_TO_ACCESS : constant := 345; + ERROR_QUE_UNABLE_TO_ADD : constant := 346; + ERROR_QUE_UNABLE_TO_INIT : constant := 347; + ERROR_VIO_INVALID_MASK : constant := 349; + ERROR_VIO_PTR : constant := 350; + ERROR_VIO_APTR : constant := 351; + ERROR_VIO_RPTR : constant := 352; + ERROR_VIO_CPTR : constant := 353; + ERROR_VIO_LPTR : constant := 354; + ERROR_VIO_MODE : constant := 355; + ERROR_VIO_WIDTH : constant := 356; + ERROR_VIO_ATTR : constant := 357; + ERROR_VIO_ROW : constant := 358; + ERROR_VIO_COL : constant := 359; + ERROR_VIO_TOPROW : constant := 360; + ERROR_VIO_BOTROW : constant := 361; + ERROR_VIO_RIGHTCOL : constant := 362; + ERROR_VIO_LEFTCOL : constant := 363; + ERROR_SCS_CALL : constant := 364; + ERROR_SCS_VALUE : constant := 365; + ERROR_VIO_WAIT_FLAG : constant := 366; + ERROR_VIO_UNLOCK : constant := 367; + ERROR_SGS_NOT_SESSION_MGR : constant := 368; + ERROR_SMG_INVALID_SGID : constant := 369; + ERROR_SMG_INVALID_SESSION_ID : constant := 369; + ERROR_SMG_NOSG : constant := 370; + ERROR_SMG_NO_SESSIONS : constant := 370; + ERROR_SMG_GRP_NOT_FOUND : constant := 371; + ERROR_SMG_SESSION_NOT_FOUND : constant := 371; + ERROR_SMG_SET_TITLE : constant := 372; + ERROR_KBD_PARAMETER : constant := 373; + ERROR_KBD_NO_DEVICE : constant := 374; + ERROR_KBD_INVALID_IOWAIT : constant := 375; + ERROR_KBD_INVALID_LENGTH : constant := 376; + ERROR_KBD_INVALID_ECHO_MASK : constant := 377; + ERROR_KBD_INVALID_INPUT_MASK : constant := 378; + ERROR_MON_INVALID_PARMS : constant := 379; + ERROR_MON_INVALID_DEVNAME : constant := 380; + ERROR_MON_INVALID_HANDLE : constant := 381; + ERROR_MON_BUFFER_TOO_SMALL : constant := 382; + ERROR_MON_BUFFER_EMPTY : constant := 383; + ERROR_MON_DATA_TOO_LARGE : constant := 384; + ERROR_MOUSE_NO_DEVICE : constant := 385; + ERROR_MOUSE_INV_HANDLE : constant := 386; + ERROR_MOUSE_INV_PARMS : constant := 387; + ERROR_MOUSE_CANT_RESET : constant := 388; + ERROR_MOUSE_DISPLAY_PARMS : constant := 389; + ERROR_MOUSE_INV_MODULE : constant := 390; + ERROR_MOUSE_INV_ENTRY_PT : constant := 391; + ERROR_MOUSE_INV_MASK : constant := 392; + NO_ERROR_MOUSE_NO_DATA : constant := 393; + NO_ERROR_MOUSE_PTR_DRAWN : constant := 394; + ERROR_INVALID_FREQUENCY : constant := 395; + ERROR_NLS_NO_COUNTRY_FILE : constant := 396; + ERROR_NLS_OPEN_FAILED : constant := 397; + ERROR_NLS_NO_CTRY_CODE : constant := 398; + ERROR_NO_COUNTRY_OR_CODEPAGE : constant := 398; + ERROR_NLS_TABLE_TRUNCATED : constant := 399; + ERROR_NLS_BAD_TYPE : constant := 400; + ERROR_NLS_TYPE_NOT_FOUND : constant := 401; + ERROR_VIO_SMG_ONLY : constant := 402; + ERROR_VIO_INVALID_ASCIIZ : constant := 403; + ERROR_VIO_DEREGISTER : constant := 404; + ERROR_VIO_NO_POPUP : constant := 405; + ERROR_VIO_EXISTING_POPUP : constant := 406; + ERROR_KBD_SMG_ONLY : constant := 407; + ERROR_KBD_INVALID_ASCIIZ : constant := 408; + ERROR_KBD_INVALID_MASK : constant := 409; + ERROR_KBD_REGISTER : constant := 410; + ERROR_KBD_DEREGISTER : constant := 411; + ERROR_MOUSE_SMG_ONLY : constant := 412; + ERROR_MOUSE_INVALID_ASCIIZ : constant := 413; + ERROR_MOUSE_INVALID_MASK : constant := 414; + ERROR_MOUSE_REGISTER : constant := 415; + ERROR_MOUSE_DEREGISTER : constant := 416; + ERROR_SMG_BAD_ACTION : constant := 417; + ERROR_SMG_INVALID_CALL : constant := 418; + ERROR_SCS_SG_NOTFOUND : constant := 419; + ERROR_SCS_NOT_SHELL : constant := 420; + ERROR_VIO_INVALID_PARMS : constant := 421; + ERROR_VIO_FUNCTION_OWNED : constant := 422; + ERROR_VIO_RETURN : constant := 423; + ERROR_SCS_INVALID_FUNCTION : constant := 424; + ERROR_SCS_NOT_SESSION_MGR : constant := 425; + ERROR_VIO_REGISTER : constant := 426; + ERROR_VIO_NO_MODE_THREAD : constant := 427; + ERROR_VIO_NO_SAVE_RESTORE_THD : constant := 428; + ERROR_VIO_IN_BG : constant := 429; + ERROR_VIO_ILLEGAL_DURING_POPUP : constant := 430; + ERROR_SMG_NOT_BASESHELL : constant := 431; + ERROR_SMG_BAD_STATUSREQ : constant := 432; + ERROR_QUE_INVALID_WAIT : constant := 433; + ERROR_VIO_LOCK : constant := 434; + ERROR_MOUSE_INVALID_IOWAIT : constant := 435; + ERROR_VIO_INVALID_HANDLE : constant := 436; + ERROR_VIO_ILLEGAL_DURING_LOCK : constant := 437; + ERROR_VIO_INVALID_LENGTH : constant := 438; + ERROR_KBD_INVALID_HANDLE : constant := 439; + ERROR_KBD_NO_MORE_HANDLE : constant := 440; + ERROR_KBD_CANNOT_CREATE_KCB : constant := 441; + ERROR_KBD_CODEPAGE_LOAD_INCOMPL : constant := 442; + ERROR_KBD_INVALID_CODEPAGE_ID : constant := 443; + ERROR_KBD_NO_CODEPAGE_SUPPORT : constant := 444; + ERROR_KBD_FOCUS_REQUIRED : constant := 445; + ERROR_KBD_FOCUS_ALREADY_ACTIVE : constant := 446; + ERROR_KBD_KEYBOARD_BUSY : constant := 447; + ERROR_KBD_INVALID_CODEPAGE : constant := 448; + ERROR_KBD_UNABLE_TO_FOCUS : constant := 449; + ERROR_SMG_SESSION_NON_SELECT : constant := 450; + ERROR_SMG_SESSION_NOT_FOREGRND : constant := 451; + ERROR_SMG_SESSION_NOT_PARENT : constant := 452; + ERROR_SMG_INVALID_START_MODE : constant := 453; + ERROR_SMG_INVALID_RELATED_OPT : constant := 454; + ERROR_SMG_INVALID_BOND_OPTION : constant := 455; + ERROR_SMG_INVALID_SELECT_OPT : constant := 456; + ERROR_SMG_START_IN_BACKGROUND : constant := 457; + ERROR_SMG_INVALID_STOP_OPTION : constant := 458; + ERROR_SMG_BAD_RESERVE : constant := 459; + ERROR_SMG_PROCESS_NOT_PARENT : constant := 460; + ERROR_SMG_INVALID_DATA_LENGTH : constant := 461; + ERROR_SMG_NOT_BOUND : constant := 462; + ERROR_SMG_RETRY_SUB_ALLOC : constant := 463; + ERROR_KBD_DETACHED : constant := 464; + ERROR_VIO_DETACHED : constant := 465; + ERROR_MOU_DETACHED : constant := 466; + ERROR_VIO_FONT : constant := 467; + ERROR_VIO_USER_FONT : constant := 468; + ERROR_VIO_BAD_CP : constant := 469; + ERROR_VIO_NO_CP : constant := 470; + ERROR_VIO_NA_CP : constant := 471; + ERROR_INVALID_CODE_PAGE : constant := 472; + ERROR_CPLIST_TOO_SMALL : constant := 473; + ERROR_CP_NOT_MOVED : constant := 474; + ERROR_MODE_SWITCH_INIT : constant := 475; + ERROR_CODE_PAGE_NOT_FOUND : constant := 476; + ERROR_UNEXPECTED_SLOT_RETURNED : constant := 477; + ERROR_SMG_INVALID_TRACE_OPTION : constant := 478; + ERROR_VIO_INTERNAL_RESOURCE : constant := 479; + ERROR_VIO_SHELL_INIT : constant := 480; + ERROR_SMG_NO_HARD_ERRORS : constant := 481; + ERROR_CP_SWITCH_INCOMPLETE : constant := 482; + ERROR_VIO_TRANSPARENT_POPUP : constant := 483; + ERROR_CRITSEC_OVERFLOW : constant := 484; + ERROR_CRITSEC_UNDERFLOW : constant := 485; + ERROR_VIO_BAD_RESERVE : constant := 486; + ERROR_INVALID_ADDRESS : constant := 487; + ERROR_ZERO_SELECTORS_REQUESTED : constant := 488; + ERROR_NOT_ENOUGH_SELECTORS_AVA : constant := 489; + ERROR_INVALID_SELECTOR : constant := 490; + ERROR_SMG_INVALID_PROGRAM_TYPE : constant := 491; + ERROR_SMG_INVALID_PGM_CONTROL : constant := 492; + ERROR_SMG_INVALID_INHERIT_OPT : constant := 493; + ERROR_VIO_EXTENDED_SG : constant := 494; + ERROR_VIO_NOT_PRES_MGR_SG : constant := 495; + ERROR_VIO_SHIELD_OWNED : constant := 496; + ERROR_VIO_NO_MORE_HANDLES : constant := 497; + ERROR_VIO_SEE_ERROR_LOG : constant := 498; + ERROR_VIO_ASSOCIATED_DC : constant := 499; + ERROR_KBD_NO_CONSOLE : constant := 500; + ERROR_MOUSE_NO_CONSOLE : constant := 501; + ERROR_MOUSE_INVALID_HANDLE : constant := 502; + ERROR_SMG_INVALID_DEBUG_PARMS : constant := 503; + ERROR_KBD_EXTENDED_SG : constant := 504; + ERROR_MOU_EXTENDED_SG : constant := 505; + ERROR_SMG_INVALID_ICON_FILE : constant := 506; + ERROR_TRC_PID_NON_EXISTENT : constant := 507; + ERROR_TRC_COUNT_ACTIVE : constant := 508; + ERROR_TRC_SUSPENDED_BY_COUNT : constant := 509; + ERROR_TRC_COUNT_INACTIVE : constant := 510; + ERROR_TRC_COUNT_REACHED : constant := 511; + ERROR_NO_MC_TRACE : constant := 512; + ERROR_MC_TRACE : constant := 513; + ERROR_TRC_COUNT_ZERO : constant := 514; + ERROR_SMG_TOO_MANY_DDS : constant := 515; + ERROR_SMG_INVALID_NOTIFICATION : constant := 516; + ERROR_LF_INVALID_FUNCTION : constant := 517; + ERROR_LF_NOT_AVAIL : constant := 518; + ERROR_LF_SUSPENDED : constant := 519; + ERROR_LF_BUF_TOO_SMALL : constant := 520; + ERROR_LF_BUFFER_CORRUPTED : constant := 521; + ERROR_LF_BUFFER_FULL : constant := 521; + ERROR_LF_INVALID_DAEMON : constant := 522; + ERROR_LF_INVALID_RECORD : constant := 522; + ERROR_LF_INVALID_TEMPL : constant := 523; + ERROR_LF_INVALID_SERVICE : constant := 523; + ERROR_LF_GENERAL_FAILURE : constant := 524; + ERROR_LF_INVALID_ID : constant := 525; + ERROR_LF_INVALID_HANDLE : constant := 526; + ERROR_LF_NO_ID_AVAIL : constant := 527; + ERROR_LF_TEMPLATE_AREA_FULL : constant := 528; + ERROR_LF_ID_IN_USE : constant := 529; + ERROR_MOU_NOT_INITIALIZED : constant := 530; + ERROR_MOUINITREAL_DONE : constant := 531; + ERROR_DOSSUB_CORRUPTED : constant := 532; + ERROR_MOUSE_CALLER_NOT_SUBSYS : constant := 533; + ERROR_ARITHMETIC_OVERFLOW : constant := 534; + ERROR_TMR_NO_DEVICE : constant := 535; + ERROR_TMR_INVALID_TIME : constant := 536; + ERROR_PVW_INVALID_ENTITY : constant := 537; + ERROR_PVW_INVALID_ENTITY_TYPE : constant := 538; + ERROR_PVW_INVALID_SPEC : constant := 539; + ERROR_PVW_INVALID_RANGE_TYPE : constant := 540; + ERROR_PVW_INVALID_COUNTER_BLK : constant := 541; + ERROR_PVW_INVALID_TEXT_BLK : constant := 542; + ERROR_PRF_NOT_INITIALIZED : constant := 543; + ERROR_PRF_ALREADY_INITIALIZED : constant := 544; + ERROR_PRF_NOT_STARTED : constant := 545; + ERROR_PRF_ALREADY_STARTED : constant := 546; + ERROR_PRF_TIMER_OUT_OF_RANGE : constant := 547; + ERROR_PRF_TIMER_RESET : constant := 548; + ERROR_VDD_LOCK_USEAGE_DENIED : constant := 639; + ERROR_TIMEOUT : constant := 640; + ERROR_VDM_DOWN : constant := 641; + ERROR_VDM_LIMIT : constant := 642; + ERROR_VDD_NOT_FOUND : constant := 643; + ERROR_INVALID_CALLER : constant := 644; + ERROR_PID_MISMATCH : constant := 645; + ERROR_INVALID_VDD_HANDLE : constant := 646; + ERROR_VLPT_NO_SPOOLER : constant := 647; + ERROR_VCOM_DEVICE_BUSY : constant := 648; + ERROR_VLPT_DEVICE_BUSY : constant := 649; + ERROR_NESTING_TOO_DEEP : constant := 650; + ERROR_VDD_MISSING : constant := 651; + ERROR_BIDI_INVALID_LENGTH : constant := 671; + ERROR_BIDI_INVALID_INCREMENT : constant := 672; + ERROR_BIDI_INVALID_COMBINATION : constant := 673; + ERROR_BIDI_INVALID_RESERVED : constant := 674; + ERROR_BIDI_INVALID_EFFECT : constant := 675; + ERROR_BIDI_INVALID_CSDREC : constant := 676; + ERROR_BIDI_INVALID_CSDSTATE : constant := 677; + ERROR_BIDI_INVALID_LEVEL : constant := 678; + ERROR_BIDI_INVALID_TYPE_SUPPORT : constant := 679; + ERROR_BIDI_INVALID_ORIENTATION : constant := 680; + ERROR_BIDI_INVALID_NUM_SHAPE : constant := 681; + ERROR_BIDI_INVALID_CSD : constant := 682; + ERROR_BIDI_NO_SUPPORT : constant := 683; + NO_ERROR_BIDI_RW_INCOMPLETE : constant := 684; + ERROR_IMP_INVALID_PARM : constant := 691; + ERROR_IMP_INVALID_LENGTH : constant := 692; + MSG_HPFS_DISK_ERROR_WARN : constant := 693; + ERROR_MON_BAD_BUFFER : constant := 730; + ERROR_MODULE_CORRUPTED : constant := 731; + ERROR_SM_OUTOF_SWAPFILE : constant := 1477; + ERROR_LF_TIMEOUT : constant := 2055; + ERROR_LF_SUSPEND_SUCCESS : constant := 2057; + ERROR_LF_RESUME_SUCCESS : constant := 2058; + ERROR_LF_REDIRECT_SUCCESS : constant := 2059; + ERROR_LF_REDIRECT_FAILURE : constant := 2060; + ERROR_SWAPPER_NOT_ACTIVE : constant := 32768; + ERROR_INVALID_SWAPID : constant := 32769; + ERROR_IOERR_SWAP_FILE : constant := 32770; + ERROR_SWAP_TABLE_FULL : constant := 32771; + ERROR_SWAP_FILE_FULL : constant := 32772; + ERROR_CANT_INIT_SWAPPER : constant := 32773; + ERROR_SWAPPER_ALREADY_INIT : constant := 32774; + ERROR_PMM_INSUFFICIENT_MEMORY : constant := 32775; + ERROR_PMM_INVALID_FLAGS : constant := 32776; + ERROR_PMM_INVALID_ADDRESS : constant := 32777; + ERROR_PMM_LOCK_FAILED : constant := 32778; + ERROR_PMM_UNLOCK_FAILED : constant := 32779; + ERROR_PMM_MOVE_INCOMPLETE : constant := 32780; + ERROR_UCOM_DRIVE_RENAMED : constant := 32781; + ERROR_UCOM_FILENAME_TRUNCATED : constant := 32782; + ERROR_UCOM_BUFFER_LENGTH : constant := 32783; + ERROR_MON_CHAIN_HANDLE : constant := 32784; + ERROR_MON_NOT_REGISTERED : constant := 32785; + ERROR_SMG_ALREADY_TOP : constant := 32786; + ERROR_PMM_ARENA_MODIFIED : constant := 32787; + ERROR_SMG_PRINTER_OPEN : constant := 32788; + ERROR_PMM_SET_FLAGS_FAILED : constant := 32789; + ERROR_INVALID_DOS_DD : constant := 32790; + ERROR_BLOCKED : constant := 32791; + ERROR_NOBLOCK : constant := 32792; + ERROR_INSTANCE_SHARED : constant := 32793; + ERROR_NO_OBJECT : constant := 32794; + ERROR_PARTIAL_ATTACH : constant := 32795; + ERROR_INCACHE : constant := 32796; + ERROR_SWAP_IO_PROBLEMS : constant := 32797; + ERROR_CROSSES_OBJECT_BOUNDARY : constant := 32798; + ERROR_LONGLOCK : constant := 32799; + ERROR_SHORTLOCK : constant := 32800; + ERROR_UVIRTLOCK : constant := 32801; + ERROR_ALIASLOCK : constant := 32802; + ERROR_ALIAS : constant := 32803; + ERROR_NO_MORE_HANDLES : constant := 32804; + ERROR_SCAN_TERMINATED : constant := 32805; + ERROR_TERMINATOR_NOT_FOUND : constant := 32806; + ERROR_NOT_DIRECT_CHILD : constant := 32807; + ERROR_DELAY_FREE : constant := 32808; + ERROR_GUARDPAGE : constant := 32809; + ERROR_SWAPERROR : constant := 32900; + ERROR_LDRERROR : constant := 32901; + ERROR_NOMEMORY : constant := 32902; + ERROR_NOACCESS : constant := 32903; + ERROR_NO_DLL_TERM : constant := 32904; + ERROR_CPSIO_CODE_PAGE_INVALID : constant := 65026; + ERROR_CPSIO_NO_SPOOLER : constant := 65027; + ERROR_CPSIO_FONT_ID_INVALID : constant := 65028; + ERROR_CPSIO_INTERNAL_ERROR : constant := 65033; + ERROR_CPSIO_INVALID_PTR_NAME : constant := 65034; + ERROR_CPSIO_NOT_ACTIVE : constant := 65037; + ERROR_CPSIO_PID_FULL : constant := 65039; + ERROR_CPSIO_PID_NOT_FOUND : constant := 65040; + ERROR_CPSIO_READ_CTL_SEQ : constant := 65043; + ERROR_CPSIO_READ_FNT_DEF : constant := 65045; + ERROR_CPSIO_WRITE_ERROR : constant := 65047; + ERROR_CPSIO_WRITE_FULL_ERROR : constant := 65048; + ERROR_CPSIO_WRITE_HANDLE_BAD : constant := 65049; + ERROR_CPSIO_SWIT_LOAD : constant := 65074; + ERROR_CPSIO_INV_COMMAND : constant := 65077; + ERROR_CPSIO_NO_FONT_SWIT : constant := 65078; + ERROR_ENTRY_IS_CALLGATE : constant := 65079; + +end Interfaces.OS2Lib.Errors; diff --git a/gcc/ada/i-os2lib.adb b/gcc/ada/i-os2lib.adb new file mode 100644 index 00000000000..0e5446bb5cd --- /dev/null +++ b/gcc/ada/i-os2lib.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . O S 2 L I B -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1993-1999 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.OS2Lib.Errors; + +package body Interfaces.OS2Lib is + + pragma Warnings (Off, Errors); + package IOE renames Interfaces.OS2Lib.Errors; + + ------------------- + -- Must_Not_Fail -- + ------------------- + + procedure Must_Not_Fail (Return_Code : APIRET) is + begin + pragma Assert (Return_Code = IOE.NO_ERROR); + null; + end Must_Not_Fail; + + ----------------------- + -- Sem_Must_Not_Fail -- + ----------------------- + + procedure Sem_Must_Not_Fail (Return_Code : OS2Lib.APIRET) is + begin + pragma Assert + (Return_Code = IOE.NO_ERROR + or else + Return_Code = IOE.ERROR_ALREADY_POSTED + or else + Return_Code = IOE.ERROR_ALREADY_RESET); + null; + end Sem_Must_Not_Fail; + +end Interfaces.OS2Lib; diff --git a/gcc/ada/i-os2lib.ads b/gcc/ada/i-os2lib.ads new file mode 100644 index 00000000000..45bc8e94b96 --- /dev/null +++ b/gcc/ada/i-os2lib.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . O S 2 L I B -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.14 $ -- +-- -- +-- Copyright (C) 1993-1997 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package (and children) provide interface definitions to the standard +-- OS/2 Library. They are merely a translation of the various <bse*.h> files. + +-- It is intended that higher level interfaces (with better names, and +-- stronger typing!) be built on top of this one for Ada (i.e. clean) +-- programming. + +-- We have chosen to keep names, types, etc. as close as possible to the +-- C definition to provide easier reference to the documentation. The main +-- exception is when a formal and its type (in C) differed only by the case +-- of letters (like in HMUX hmux). In this case, we have prepended "F_" to +-- the formal (i.e. F_hmux : HMUX). + +with Interfaces.C; +with Interfaces.C.Strings; +with System; + +package Interfaces.OS2Lib is +pragma Preelaborate (OS2Lib); + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + + ------------------- + -- General Types -- + ------------------- + + type APIRET is new IC.unsigned_long; + type APIRET16 is new IC.unsigned_short; + subtype APIRET32 is APIRET; + + subtype PSZ is ICS.chars_ptr; + subtype PCHAR is ICS.chars_ptr; + subtype PVOID is System.Address; + type PPVOID is access all PVOID; + + type BOOL32 is new IC.unsigned_long; + False32 : constant BOOL32 := 0; + True32 : constant BOOL32 := 1; + + type UCHAR is new IC.unsigned_char; + type USHORT is new IC.unsigned_short; + type ULONG is new IC.unsigned_long; + type PULONG is access all ULONG; + + -- Coprocessor stack register element. + + type FPREG is record + losig : ULONG; -- Low 32-bits of the mantissa + hisig : ULONG; -- High 32-bits of the mantissa + signexp : USHORT; -- Sign and exponent + end record; + pragma Convention (C, FPREG); + + type AULONG is array (IC.size_t range <>) of ULONG; + type AFPREG is array (IC.size_t range <>) of FPREG; + + type LHANDLE is new IC.unsigned_long; + + NULLHANDLE : constant := 0; + + --------------------- + -- Time Management -- + --------------------- + + function DosSleep (How_long : ULONG) return APIRET; + pragma Import (C, DosSleep, "DosSleep"); + + type DATETIME is record + hours : UCHAR; + minutes : UCHAR; + seconds : UCHAR; + hundredths : UCHAR; + day : UCHAR; + month : UCHAR; + year : USHORT; + timezone : IC.short; + weekday : UCHAR; + end record; + + type PDATETIME is access all DATETIME; + + function DosGetDateTime (pdt : PDATETIME) return APIRET; + pragma Import (C, DosGetDateTime, "DosGetDateTime"); + + function DosSetDateTime (pdt : PDATETIME) return APIRET; + pragma Import (C, DosSetDateTime, "DosSetDateTime"); + + ---------------------------- + -- Miscelleneous Features -- + ---------------------------- + + -- Features which do not fit any child + + function DosBeep (Freq : ULONG; Dur : ULONG) return APIRET; + pragma Import (C, DosBeep, "DosBeep"); + + procedure Must_Not_Fail (Return_Code : OS2Lib.APIRET); + pragma Inline (Must_Not_Fail); + -- Many OS/2 functions return APIRET and are not supposed to fail. In C + -- style, these would be called as procedures, disregarding the returned + -- value. This procedure can be used to achieve the same effect with a + -- call of the form: Must_Not_Fail (Some_OS2_Function (...)); + + procedure Sem_Must_Not_Fail (Return_Code : OS2Lib.APIRET); + pragma Inline (Sem_Must_Not_Fail); + -- Similar to Must_Not_Fail, but used in the case of DosPostEventSem, + -- where the "error" code ERROR_ALREADY_POSTED is not really an error. + +end Interfaces.OS2Lib; diff --git a/gcc/ada/i-os2syn.ads b/gcc/ada/i-os2syn.ads new file mode 100644 index 00000000000..331fff326e9 --- /dev/null +++ b/gcc/ada/i-os2syn.ads @@ -0,0 +1,269 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . O S 2 L I B . S Y N C H R O N I Z A T I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.17 $ -- +-- -- +-- Copyright (C) 1993-1998 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.OS2Lib.Threads; + +package Interfaces.OS2Lib.Synchronization is +pragma Preelaborate (Synchronization); + + package IC renames Interfaces.C; + package IOT renames Interfaces.OS2Lib.Threads; + package S renames System; + + -- Semaphore Attributes + + DC_SEM_SHARED : constant := 16#01#; + -- DosCreateMutex, DosCreateEvent, and DosCreateMuxWait use it to indicate + -- whether the semaphore is shared or private when the PSZ is null + + SEM_INDEFINITE_WAIT : constant ULONG := -1; + SEM_IMMEDIATE_RETURN : constant ULONG := 0; + + type HSEM is new LHANDLE; + type PHSEM is access all HSEM; + + type SEMRECORD is record + hsemCur : HSEM; + ulUser : ULONG; + end record; + + type PSEMRECORD is access all SEMRECORD; + + -- Quad word structure + + -- Originally QWORD is defined as a record containing two ULONGS, + -- the first containing low word and the second for the high word, + -- but it is cleaner to define it as follows: + + type QWORD is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; + type PQWORD is access all QWORD; + + type HEV is new HSEM; + type PHEV is access all HEV; + + type HMTX is new HSEM; + type PHMTX is access all HMTX; + + type HMUX is new HSEM; + type PHMUX is access all HMUX; + + type HTIMER is new LHANDLE; + type PHTIMER is access all HTIMER; + + ----------------------- + -- Critical sections -- + ----------------------- + + function DosEnterCritSec return APIRET; + pragma Import (C, DosEnterCritSec, "DosEnterCritSec"); + + function DosExitCritSec return APIRET; + pragma Import (C, DosExitCritSec, "DosExitCritSec"); + + -------------- + -- EventSem -- + -------------- + + function DosCreateEventSem + (pszName : PSZ; + f_phev : PHEV; + flAttr : ULONG; + fState : BOOL32) + return APIRET; + pragma Import (C, DosCreateEventSem, "DosCreateEventSem"); + + function DosOpenEventSem + (pszName : PSZ; + F_phev : PHEV) + return APIRET; + pragma Import (C, DosOpenEventSem, "DosOpenEventSem"); + + function DosCloseEventSem + (F_hev : HEV) + return APIRET; + pragma Import (C, DosCloseEventSem, "DosCloseEventSem"); + + function DosResetEventSem + (F_hev : HEV; + pulPostCt : PULONG) + return APIRET; + pragma Import (C, DosResetEventSem, "DosResetEventSem"); + + function DosPostEventSem + (F_hev : HEV) + return APIRET; + pragma Import (C, DosPostEventSem, "DosPostEventSem"); + + function DosWaitEventSem + (F_hev : HEV; + ulTimeout : ULONG) + return APIRET; + pragma Import (C, DosWaitEventSem, "DosWaitEventSem"); + + function DosQueryEventSem + (F_hev : HEV; + pulPostCt : PULONG) + return APIRET; + pragma Import (C, DosQueryEventSem, "DosQueryEventSem"); + + -------------- + -- MutexSem -- + -------------- + + function DosCreateMutexSem + (pszName : PSZ; + F_phmtx : PHMTX; + flAttr : ULONG; + fState : BOOL32) + return APIRET; + pragma Import (C, DosCreateMutexSem, "DosCreateMutexSem"); + + function DosOpenMutexSem + (pszName : PSZ; + F_phmtx : PHMTX) + return APIRET; + pragma Import (C, DosOpenMutexSem, "DosOpenMutexSem"); + + function DosCloseMutexSem + (F_hmtx : HMTX) + return APIRET; + pragma Import (C, DosCloseMutexSem, "DosCloseMutexSem"); + + function DosRequestMutexSem + (F_hmtx : HMTX; + ulTimeout : ULONG) + return APIRET; + pragma Import (C, DosRequestMutexSem, "DosRequestMutexSem"); + + function DosReleaseMutexSem + (F_hmtx : HMTX) + return APIRET; + pragma Import (C, DosReleaseMutexSem, "DosReleaseMutexSem"); + + function DosQueryMutexSem + (F_hmtx : HMTX; + F_ppid : IOT.PPID; + F_ptid : IOT.PTID; + pulCount : PULONG) + return APIRET; + pragma Import (C, DosQueryMutexSem, "DosQueryMutexSem"); + + ---------------- + -- MuxWaitSem -- + ---------------- + + function DosCreateMuxWaitSem + (pszName : PSZ; + F_phmux : PHMUX; + cSemRec : ULONG; + pSemRec : PSEMRECORD; + flAttr : ULONG) + return APIRET; + pragma Import (C, DosCreateMuxWaitSem, "DosCreateMuxWaitSem"); + + DCMW_WAIT_ANY : constant := 16#02#; -- wait on any event/mutex to occur + DCMW_WAIT_ALL : constant := 16#04#; -- wait on all events/mutexes to occur + -- Values for "flAttr" parameter in DosCreateMuxWaitSem call + + function DosOpenMuxWaitSem + (pszName : PSZ; + F_phmux : PHMUX) + return APIRET; + pragma Import (C, DosOpenMuxWaitSem, "DosOpenMuxWaitSem"); + + function DosCloseMuxWaitSem + (F_hmux : HMUX) + return APIRET; + pragma Import (C, DosCloseMuxWaitSem, "DosCloseMuxWaitSem"); + + function DosWaitMuxWaitSem + (F_hmux : HMUX; + ulTimeout : ULONG; + pulUser : PULONG) + return APIRET; + pragma Import (C, DosWaitMuxWaitSem, "DosWaitMuxWaitSem"); + + function DosAddMuxWaitSem + (F_hmux : HMUX; + pSemRec : PSEMRECORD) + return APIRET; + pragma Import (C, DosAddMuxWaitSem, "DosAddMuxWaitSem"); + + function DosDeleteMuxWaitSem + (F_hmux : HMUX; + F_hsem : HSEM) + return APIRET; + pragma Import (C, DosDeleteMuxWaitSem, "DosDeleteMuxWaitSem"); + + function DosQueryMuxWaitSem + (F_hmux : HMUX; + pcSemRec : PULONG; + pSemRec : PSEMRECORD; + pflAttr : PULONG) + return APIRET; + pragma Import (C, DosQueryMuxWaitSem, "DosQueryMuxWaitSem"); + + ----------- + -- Timer -- + ----------- + + function DosAsyncTimer + (msec : ULONG; + F_hsem : HSEM; + F_phtimer : PHTIMER) + return APIRET; + pragma Import (C, DosAsyncTimer, "DosAsyncTimer"); + + function DosStartTimer + (msec : ULONG; + F_hsem : HSEM; + F_phtimer : PHTIMER) + return APIRET; + pragma Import (C, DosStartTimer, "DosStartTimer"); + + function DosStopTimer + (F_htimer : HTIMER) + return APIRET; + pragma Import (C, DosStopTimer, "DosStopTimer"); + + -- DosTmrQueryTime provides a snapshot of the time + -- from the IRQ0 high resolution timer (Intel 8254) + + function DosTmrQueryTime + (pqwTmrTime : access QWORD) -- Time in 8254 ticks (1_192_755.2 Hz) + return APIRET; + pragma Import (C, DosTmrQueryTime, "DosTmrQueryTime"); + +end Interfaces.OS2Lib.Synchronization; diff --git a/gcc/ada/i-os2thr.ads b/gcc/ada/i-os2thr.ads new file mode 100644 index 00000000000..383c6e560c8 --- /dev/null +++ b/gcc/ada/i-os2thr.ads @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . O S 2 L I B . T H R E A D S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- Copyright (C) 1993-1997 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; + +package Interfaces.OS2Lib.Threads is +pragma Preelaborate (Threads); + + package IC renames Interfaces.C; + + type PID is new IC.unsigned_long; + type PPID is access all PID; + -- Process ID, and pointer to process ID + + type TID is new IC.unsigned_long; + type PTID is access all TID; + -- Thread ID, and pointer to thread ID + + ------------------------------------------------------------- + -- Thread Creation, Activation, Suspension And Termination -- + ------------------------------------------------------------- + + -- Note: <bsedos.h> defines the "Informations" and "param" parameter below + -- as a ULONG, but everyone knows that in general an address will be passed + -- to it. We declared it here with type PVOID (which it should have had) + -- because Ada is a bit more sensitive to mixing integers and addresses. + + type PFNTHREAD is access procedure (Informations : System.Address); + -- TBSL should use PVOID instead of Address as per above node ??? + + function DosCreateThread + (F_ptid : PTID; + pfn : PFNTHREAD; + param : PVOID; + flag : ULONG; + cbStack : ULONG) + return APIRET; + pragma Import (C, DosCreateThread, "DosCreateThread"); + + Block_Child : constant := 1; + No_Block_Child : constant := 0; + Commit_Stack : constant := 2; + No_Commit_Stack : constant := 0; + -- Values for "flag" parameter in DosCreateThread call + + procedure DosExit (Action : ULONG; Result : ULONG); + pragma Import (C, DosExit, "DosExit"); + + EXIT_THREAD : constant := 0; + EXIT_PROCESS : constant := 1; + -- Values for "Action" parameter in Dos_Exit call + + function DosResumeThread (Id : TID) return APIRET; + pragma Import (C, DosResumeThread, "DosResumeThread"); + + function DosSuspendThread (Id : TID) return APIRET; + pragma Import (C, DosSuspendThread, "DosSuspendThread"); + + procedure DosWaitThread (Thread_Ptr : PTID; Option : ULONG); + pragma Import (C, DosWaitThread, "DosWaitThread"); + + function DosKillThread (Id : TID) return APIRET; + pragma Import (C, DosKillThread, "DosKillThread"); + + + DCWW_WAIT : constant := 0; + DCWW_NOWAIT : constant := 1; + -- Values for "Option" parameter in DosWaitThread call + + --------------------------------------------------- + -- Accessing properties of Threads and Processes -- + --------------------------------------------------- + + -- Structures translated from BSETIB.H + + -- Thread Information Block (TIB) + -- Need documentation clarifying distinction between TIB, TIB2 ??? + + -- GB970409: Changed TIB2 structure, because the tib2_ulprio field + -- is not the actual priority but contains two byte fields + -- that hold the priority class and rank respectively. + -- A proper Ada style record with explicit representation + -- avoids this kind of errors. + + type TIB2 is record + Thread_ID : TID; + Prio_Rank : UCHAR; + Prio_Class : UCHAR; + Version : ULONG; -- Version number for this structure + Must_Complete_Count : USHORT; -- Must Complete count + Must_Complete_Force : USHORT; -- Must Complete force flag + end record; + + type PTIB2 is access all TIB2; + + -- Thread Information Block (TIB) + + type TIB is record + tib_pexchain : PVOID; -- Head of exception handler chain + tib_pstack : PVOID; -- Pointer to base of stack + tib_pstacklimit : PVOID; -- Pointer to end of stack + System : PTIB2; -- Pointer to system specific TIB + tib_version : ULONG; -- Version number for this TIB structure + tib_ordinal : ULONG; -- Thread ordinal number + end record; + + type PTIB is access all TIB; + + -- Process Information Block (PIB) + + type PIB is record + pib_ulpid : ULONG; -- Process I.D. + pib_ulppid : ULONG; -- Parent process I.D. + pib_hmte : ULONG; -- Program (.EXE) module handle + pib_pchcmd : PCHAR; -- Command line pointer + pib_pchenv : PCHAR; -- Environment pointer + pib_flstatus : ULONG; -- Process' status bits + pib_ultype : ULONG; -- Process' type code + end record; + + type PPIB is access all PIB; + + function DosGetInfoBlocks + (Pptib : access PTIB; + Pppib : access PPIB) + return APIRET; + pragma Import (C, DosGetInfoBlocks, "DosGetInfoBlocks"); + + -- Thread local memory + + -- This function allocates a block of memory that is unique, or local, to + -- a thread. + + function DosAllocThreadLocalMemory + (cb : ULONG; -- Number of 4-byte DWORDs to allocate + p : access PVOID) -- Address of the memory block + return + APIRET; -- Return Code (rc) + pragma Import + (Convention => C, + Entity => DosAllocThreadLocalMemory, + Link_Name => "_DosAllocThreadLocalMemory"); + + ----------------- + -- Priorities -- + ----------------- + + function DosSetPriority + (Scope : ULONG; + Class : ULONG; + Delta_P : IC.long; + PorTid : TID) + return APIRET; + pragma Import (C, DosSetPriority, "DosSetPriority"); + + PRTYS_PROCESS : constant := 0; + PRTYS_PROCESSTREE : constant := 1; + PRTYS_THREAD : constant := 2; + -- Values for "Scope" parameter in DosSetPriority call + + PRTYC_NOCHANGE : constant := 0; + PRTYC_IDLETIME : constant := 1; + PRTYC_REGULAR : constant := 2; + PRTYC_TIMECRITICAL : constant := 3; + PRTYC_FOREGROUNDSERVER : constant := 4; + -- Values for "class" parameter in DosSetPriority call + +end Interfaces.OS2Lib.Threads; diff --git a/gcc/ada/i-pacdec.adb b/gcc/ada/i-pacdec.adb new file mode 100644 index 00000000000..81f805120a5 --- /dev/null +++ b/gcc/ada/i-pacdec.adb @@ -0,0 +1,352 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . P A C K E D _ D E C I M A L -- +-- -- +-- B o d y -- +-- (Version for IBM Mainframe Packed Decimal Format) -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with Unchecked_Conversion; + +package body Interfaces.Packed_Decimal is + + type Packed is array (Byte_Length) of Unsigned_8; + -- The type used internally to represent packed decimal + + type Packed_Ptr is access Packed; + function To_Packed_Ptr is new Unchecked_Conversion (Address, Packed_Ptr); + + -- The following array is used to convert a value in the range 0-99 to + -- a packed decimal format with two hexadecimal nibbles. It is worth + -- using table look up in this direction because divides are expensive. + + Packed_Byte : constant array (00 .. 99) of Unsigned_8 := + (16#00#, 16#01#, 16#02#, 16#03#, 16#04#, + 16#05#, 16#06#, 16#07#, 16#08#, 16#09#, + 16#10#, 16#11#, 16#12#, 16#13#, 16#14#, + 16#15#, 16#16#, 16#17#, 16#18#, 16#19#, + 16#20#, 16#21#, 16#22#, 16#23#, 16#24#, + 16#25#, 16#26#, 16#27#, 16#28#, 16#29#, + 16#30#, 16#31#, 16#32#, 16#33#, 16#34#, + 16#35#, 16#36#, 16#37#, 16#38#, 16#39#, + 16#40#, 16#41#, 16#42#, 16#43#, 16#44#, + 16#45#, 16#46#, 16#47#, 16#48#, 16#49#, + 16#50#, 16#51#, 16#52#, 16#53#, 16#54#, + 16#55#, 16#56#, 16#57#, 16#58#, 16#59#, + 16#60#, 16#61#, 16#62#, 16#63#, 16#64#, + 16#65#, 16#66#, 16#67#, 16#68#, 16#69#, + 16#70#, 16#71#, 16#72#, 16#73#, 16#74#, + 16#75#, 16#76#, 16#77#, 16#78#, 16#79#, + 16#80#, 16#81#, 16#82#, 16#83#, 16#84#, + 16#85#, 16#86#, 16#87#, 16#88#, 16#89#, + 16#90#, 16#91#, 16#92#, 16#93#, 16#94#, + 16#95#, 16#96#, 16#97#, 16#98#, 16#99#); + + --------------------- + -- Int32_To_Packed -- + --------------------- + + procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D rem 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + VV : Integer_32 := V; + + begin + -- Deal with sign byte first + + if VV >= 0 then + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#; + VV := VV / 10; + + else + VV := -VV; + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#; + end if; + + for J in reverse B - 1 .. 2 loop + if VV = 0 then + for K in 1 .. J loop + PP (K) := 16#00#; + end loop; + + return; + + else + PP (J) := Packed_Byte (Integer (VV rem 100)); + VV := VV / 100; + end if; + end loop; + + -- Deal with leading byte + + if Empty_Nibble then + if VV > 9 then + raise Constraint_Error; + else + PP (1) := Unsigned_8 (VV); + end if; + + else + if VV > 99 then + raise Constraint_Error; + else + PP (1) := Packed_Byte (Integer (VV)); + end if; + end if; + + end Int32_To_Packed; + + --------------------- + -- Int64_To_Packed -- + --------------------- + + procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D rem 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + VV : Integer_64 := V; + + begin + -- Deal with sign byte first + + if VV >= 0 then + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#; + VV := VV / 10; + + else + VV := -VV; + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#; + end if; + + for J in reverse B - 1 .. 2 loop + if VV = 0 then + for K in 1 .. J loop + PP (K) := 16#00#; + end loop; + + return; + + else + PP (J) := Packed_Byte (Integer (VV rem 100)); + VV := VV / 100; + end if; + end loop; + + -- Deal with leading byte + + if Empty_Nibble then + if VV > 9 then + raise Constraint_Error; + else + PP (1) := Unsigned_8 (VV); + end if; + + else + if VV > 99 then + raise Constraint_Error; + else + PP (1) := Packed_Byte (Integer (VV)); + end if; + end if; + + end Int64_To_Packed; + + --------------------- + -- Packed_To_Int32 -- + --------------------- + + function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D mod 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + V : Integer_32; + Dig : Unsigned_8; + Sign : Unsigned_8; + J : Positive; + + begin + -- Cases where there is an unused (zero) nibble in the first byte. + -- Deal with the single digit nibble at the right of this byte + + if Empty_Nibble then + V := Integer_32 (PP (1)); + J := 2; + + if V > 9 then + raise Constraint_Error; + end if; + + -- Cases where all nibbles are used + + else + J := 1; + end if; + + -- Loop to process bytes containing two digit nibbles + + while J < B loop + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_32 (Dig); + end if; + + Dig := PP (J) and 16#0F#; + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_32 (Dig); + end if; + + J := J + 1; + end loop; + + -- Deal with digit nibble in sign byte + + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_32 (Dig); + end if; + + Sign := PP (J) and 16#0F#; + + -- Process sign nibble (deal with most common cases first) + + if Sign = 16#C# then + return V; + + elsif Sign = 16#D# then + return -V; + + elsif Sign = 16#B# then + return -V; + + elsif Sign >= 16#A# then + return V; + + else + raise Constraint_Error; + end if; + end Packed_To_Int32; + + --------------------- + -- Packed_To_Int64 -- + --------------------- + + function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D mod 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + V : Integer_64; + Dig : Unsigned_8; + Sign : Unsigned_8; + J : Positive; + + begin + -- Cases where there is an unused (zero) nibble in the first byte. + -- Deal with the single digit nibble at the right of this byte + + if Empty_Nibble then + V := Integer_64 (PP (1)); + J := 2; + + if V > 9 then + raise Constraint_Error; + end if; + + -- Cases where all nibbles are used + + else + J := 1; + end if; + + -- Loop to process bytes containing two digit nibbles + + while J < B loop + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_64 (Dig); + end if; + + Dig := PP (J) and 16#0F#; + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_64 (Dig); + end if; + + J := J + 1; + end loop; + + -- Deal with digit nibble in sign byte + + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_64 (Dig); + end if; + + Sign := PP (J) and 16#0F#; + + -- Process sign nibble (deal with most common cases first) + + if Sign = 16#C# then + return V; + + elsif Sign = 16#D# then + return -V; + + elsif Sign = 16#B# then + return -V; + + elsif Sign >= 16#A# then + return V; + + else + raise Constraint_Error; + end if; + end Packed_To_Int64; + +end Interfaces.Packed_Decimal; diff --git a/gcc/ada/i-pacdec.ads b/gcc/ada/i-pacdec.ads new file mode 100644 index 00000000000..79f1e0db7c0 --- /dev/null +++ b/gcc/ada/i-pacdec.ads @@ -0,0 +1,152 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . P A C K E D _ D E C I M A L -- +-- -- +-- S p e c -- +-- (Version for IBM Mainframe Packed Decimal Format) -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- + +-- This unit defines the packed decimal format used by GNAT in response to +-- a specication of Machine_Radix 10 for a decimal fixed-point type. The +-- format and operations are completely encapsulated in this unit, so all +-- that is necessary to compile using different packed decimal formats is +-- to replace this single unit. + +-- Note that the compiler access the spec of this unit during compilation +-- to obtain the data length that needs allocating, so the correct version +-- of the spec must be available to the compiler, and must correspond to +-- the spec and body made available to the linker, and all units of a given +-- program must be compiled with the same version of the spec and body. +-- This consistency will be enforced automatically using the normal binder +-- consistency checking, since any unit declaring Machine_Radix 10 types or +-- containing operations on such data will implicitly with Packed_Decimal. + +with System; + +package Interfaces.Packed_Decimal is + + ------------------------ + -- Format Description -- + ------------------------ + + -- IBM Mainframe packed decimal format uses a byte string of length one + -- to 10 bytes, with the most significant byte first. Each byte contains + -- two decimal digits (with the high order digit in the left nibble, and + -- the low order four bits contain the sign, using the following code: + + -- 16#A# 2#1010# positive + -- 16#B# 2#1011# negative + -- 16#C# 2#1100# positive (preferred representation) + -- 16#D# 2#1101# negative (preferred representation) + -- 16#E# 2#1110# positive + -- 16#F# 2#1011# positive + + -- In this package, all six sign representations are interpreted as + -- shown above when an operand is read, when an operand is written, + -- the preferred representations are always used. Constraint_Error + -- is raised if any other bit pattern is found in the sign nibble, + -- or if a digit nibble contains an invalid digit code. + + -- Some examples follow: + + -- 05 76 3C +5763 + -- 00 01 1D -11 + -- 00 04 4E +44 (non-standard sign) + -- 00 00 00 invalid (incorrect sign nibble) + -- 0A 01 1C invalid (bad digit) + + ------------------ + -- Length Array -- + ------------------ + + -- The following array must be declared in exactly the form shown, since + -- the compiler accesses the associated tree to determine the size to be + -- allocated to a machine radix 10 type, depending on the number of digits. + + subtype Byte_Length is Positive range 1 .. 10; + -- Range of possible byte lengths + + Packed_Size : constant array (1 .. 18) of Byte_Length := + (01 => 01, -- Length in bytes for digits 1 + 02 => 02, -- Length in bytes for digits 2 + 03 => 02, -- Length in bytes for digits 2 + 04 => 03, -- Length in bytes for digits 2 + 05 => 03, -- Length in bytes for digits 2 + 06 => 04, -- Length in bytes for digits 2 + 07 => 04, -- Length in bytes for digits 2 + 08 => 05, -- Length in bytes for digits 2 + 09 => 05, -- Length in bytes for digits 2 + 10 => 06, -- Length in bytes for digits 2 + 11 => 06, -- Length in bytes for digits 2 + 12 => 07, -- Length in bytes for digits 2 + 13 => 07, -- Length in bytes for digits 2 + 14 => 08, -- Length in bytes for digits 2 + 15 => 08, -- Length in bytes for digits 2 + 16 => 09, -- Length in bytes for digits 2 + 17 => 09, -- Length in bytes for digits 2 + 18 => 10); -- Length in bytes for digits 2 + + ------------------------- + -- Conversion Routines -- + ------------------------- + + subtype D32 is Positive range 1 .. 9; + -- Used to represent number of digits in a packed decimal value that + -- can be represented in a 32-bit binary signed integer form. + + subtype D64 is Positive range 10 .. 18; + -- Used to represent number of digits in a packed decimal value that + -- requires a 64-bit signed binary integer for representing all values. + + function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32; + -- The argument P is the address of a packed decimal value and D is the + -- number of digits (in the range 1 .. 9, as implied by the subtype). + -- The returned result is the corresponding signed binary value. The + -- exception Constraint_Error is raised if the input is invalid. + + function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64; + -- The argument P is the address of a packed decimal value and D is the + -- number of digits (in the range 10 .. 18, as implied by the subtype). + -- The returned result is the corresponding signed binary value. The + -- exception Constraint_Error is raised if the input is invalid. + + procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32); + -- The argument V is a signed binary integer, which is converted to + -- packed decimal format and stored using P, the address of a packed + -- decimal item of D digits (D is in the range 1-9). Constraint_Error + -- is raised if V is out of range of this number of digits. + + procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64); + -- The argument V is a signed binary integer, which is converted to + -- packed decimal format and stored using P, the address of a packed + -- decimal item of D digits (D is in the range 10-18). Constraint_Error + -- is raised if V is out of range of this number of digits. + +end Interfaces.Packed_Decimal; diff --git a/gcc/ada/i-vxwork.ads b/gcc/ada/i-vxwork.ads new file mode 100644 index 00000000000..edd61d027ca --- /dev/null +++ b/gcc/ada/i-vxwork.ads @@ -0,0 +1,207 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1999 - 2001 Ada Core Technologies, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a limited binding to the VxWorks API +-- In particular, it interfaces with the VxWorks hardware interrupt +-- facilities, allowing the use of low-latency direct-vectored +-- interrupt handlers. Note that such handlers have a variety of +-- restrictions regarding system calls. Less restrictive, but higher- +-- latency handlers can be written using Ada protected procedures, +-- Ada 83 style interrupt entries, or by signalling an Ada task +-- from within an interrupt handler using a binary semaphore as +-- described in the VxWorks Programmer's Manual +-- +-- For complete documentation of the operations in this package, please +-- consult the VxWorks Programmer's Manual and VxWorks Reference Manual + +with System.VxWorks; + +package Interfaces.VxWorks is + pragma Preelaborate (VxWorks); + + ------------------------------------------------------------------------ + -- Here is a complete example that shows how to handle the Interrupt 0x14 + -- with a direct-vectored interrupt handler in Ada using this package: + + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with System; + -- + -- package P is + -- + -- Count : Integer; + -- pragma Atomic (Count); + -- + -- Level : constant := 1; + -- -- Interrupt level used by this example + -- + -- procedure Handler (parameter : System.Address); + -- + -- end P; + -- + -- package body P is + -- + -- procedure Handler (parameter : System.Address) is + -- S : STATUS; + -- begin + -- Count := Count + 1; + -- logMsg ("received an interrupt" & ASCII.LF & ASCII.Nul); + -- + -- -- Acknowledge VME interrupt + -- S := sysBusIntAck (intLevel => Level); + -- end Handler; + -- end P; + -- + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with Ada.Text_IO; use Ada.Text_IO; + -- + -- with P; use P; + -- procedure Useint is + -- -- Be sure to use a reasonable interrupt number for the target + -- -- board! + -- -- This one is the unused VME graphics interrupt on the PPC MV2604 + -- Interrupt : constant := 16#14#; + -- + -- task T; + -- + -- S : STATUS; + -- + -- task body T is + -- begin + -- loop + -- Put_Line ("Generating an interrupt..."); + -- delay 1.0; + -- + -- -- Generate VME interrupt, using interrupt number + -- S := sysBusIntGen (1, Interrupt); + -- end loop; + -- end T; + -- + -- begin + -- S := sysIntEnable (intLevel => Level); + -- S := intConnect (INUM_TO_IVEC (Interrupt), handler'Access); + -- + -- loop + -- delay 2.0; + -- Put_Line ("value of count:" & P.Count'Img); + -- end loop; + -- end Useint; + ------------------------------------- + + subtype int is Integer; + + type STATUS is new int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := -1; + + type VOIDFUNCPTR is access procedure (parameter : System.Address); + type Interrupt_Vector is new System.Address; + type Exception_Vector is new System.Address; + + function intConnect + (vector : Interrupt_Vector; + handler : VOIDFUNCPTR; + parameter : System.Address := System.Null_Address) return STATUS; + -- Binding to the C routine intConnect. Use this to set up an + -- user handler. The routine generates a wrapper around the user + -- handler to save and restore context + + function intVecGet + (Vector : Interrupt_Vector) return VOIDFUNCPTR; + -- Binding to the C routine intVecGet. Use this to get the + -- existing handler for later restoral + + procedure intVecSet + (Vector : Interrupt_Vector; + Handler : VOIDFUNCPTR); + -- Binding to the C routine intVecSet. Use this to restore a + -- handler obtained using intVecGet + + function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; + -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt + -- number to an interrupt vector + + function sysIntEnable (intLevel : int) return STATUS; + -- Binding to the C routine sysIntEnable + + function sysIntDisable (intLevel : int) return STATUS; + -- Binding to the C routine sysIntDisable + + function sysBusIntAck (intLevel : int) return STATUS; + -- Binding to the C routine sysBusIntAck + + function sysBusIntGen (intLevel : int; Intnum : int) return STATUS; + -- Binding to the C routine sysBusIntGen. Note that the T2 + -- documentation implies that a vector address is the proper + -- argument - it's not. The interrupt number in the range + -- 0 .. 255 (for 68K and PPC) is the correct agument. + + procedure logMsg + (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); + -- Binding to the C routine logMsg. Note that it is the caller's + -- responsibility to ensure that fmt is a null-terminated string + -- (e.g logMsg ("Interrupt" & ASCII.NUL)) + + type FP_CONTEXT is private; + -- Floating point context save and restore. Handlers using floating + -- point must be bracketed with these calls. The pFpContext parameter + -- should be an object of type FP_CONTEXT that is + -- declared local to the handler. + + procedure fppRestore (pFpContext : in out FP_CONTEXT); + -- Restore floating point context + + procedure fppSave (pFpContext : in out FP_CONTEXT); + -- Save floating point context + +private + + type FP_CONTEXT is new System.VxWorks.FP_CONTEXT; + -- Target-dependent floating point context type + + pragma Import (C, intConnect, "intConnect"); + pragma Import (C, intVecGet, "intVecGet"); + pragma Import (C, intVecSet, "intVecSet"); + pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); + pragma Import (C, sysIntEnable, "sysIntEnable"); + pragma Import (C, sysIntDisable, "sysIntDisable"); + pragma Import (C, sysBusIntAck, "sysBusIntAck"); + pragma Import (C, sysBusIntGen, "sysBusIntGen"); + pragma Import (C, logMsg, "logMsg"); + pragma Import (C, fppRestore, "fppRestore"); + pragma Import (C, fppSave, "fppSave"); +end Interfaces.VxWorks; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb new file mode 100644 index 00000000000..46cc84408b6 --- /dev/null +++ b/gcc/ada/impunit.adb @@ -0,0 +1,371 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I M P U N I T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; + +package body Impunit is + + subtype File_Name_8 is String (1 .. 8); + type File_List is array (Nat range <>) of File_Name_8; + + -- The following is a giant string containing the concenated names + -- of all non-implementation internal files, i.e. the complete list + -- of files for internal units which a program may legitimately WITH. + + -- Note that this list should match the list of units documented in + -- the "GNAT Library" section of the GNAT Reference Manual. + + Non_Imp_File_Names : File_List := ( + + ----------------------------------------------- + -- Ada Hierarchy Units from Reference Manual -- + ----------------------------------------------- + + "a-astaco", -- Ada.Asynchronous_Task_Control + "a-calend", -- Ada.Calendar + "a-chahan", -- Ada.Characters.Handling + "a-charac", -- Ada.Characters + "a-chlat1", -- Ada.Characters.Latin_1 + "a-comlin", -- Ada.Command_Line + "a-decima", -- Ada.Decimal + "a-direio", -- Ada.Direct_IO + "a-dynpri", -- Ada.Dynamic_Priorities + "a-except", -- Ada.Exceptions + "a-finali", -- Ada.Finalization + "a-flteio", -- Ada.Float_Text_IO + "a-fwteio", -- Ada.Float_Wide_Text_IO + "a-inteio", -- Ada.Integer_Text_IO + "a-interr", -- Ada.Interrupts + "a-intnam", -- Ada.Interrupts.Names + "a-ioexce", -- Ada.IO_Exceptions + "a-iwteio", -- Ada.Integer_Wide_Text_IO + "a-ncelfu", -- Ada.Numerics.Complex_Elementary_Functions + "a-ngcefu", -- Ada.Numerics.Generic_Complex_Elementary_Functions + "a-ngcoty", -- Ada.Numerics.Generic_Complex_Types + "a-ngelfu", -- Ada.Numerics.Generic_Elementary_Functions + "a-nucoty", -- Ada.Numerics.Complex_Types + "a-nudira", -- Ada.Numerics.Discrete_Random + "a-nuelfu", -- Ada.Numerics.Elementary_Functions + "a-nuflra", -- Ada.Numerics.Float_Random + "a-numeri", -- Ada.Numerics + "a-reatim", -- Ada.Real_Time + "a-sequio", -- Ada.Sequential_IO + "a-stmaco", -- Ada.Strings.Maps.Constants + "a-storio", -- Ada.Storage_IO + "a-strbou", -- Ada.Strings.Bounded + "a-stream", -- Ada.Streams + "a-strfix", -- Ada.Strings.Fixed + "a-string", -- Ada.Strings + "a-strmap", -- Ada.Strings.Maps + "a-strunb", -- Ada.Strings.Unbounded + "a-ststio", -- Ada.Streams.Stream_IO + "a-stwibo", -- Ada.Strings.Wide_Bounded + "a-stwifi", -- Ada.Strings.Wide_Fixed + "a-stwima", -- Ada.Strings.Wide_Maps + "a-stwiun", -- Ada.Strings.Wide_Unbounded + "a-swmwco", -- Ada.Strings.Wide_Maps.Wide_Constants + "a-sytaco", -- Ada.Synchronous_Task_Control + "a-tags ", -- Ada.Tags + "a-tasatt", -- Ada.Task_Attributes + "a-taside", -- Ada.Task_Identification + "a-teioed", -- Ada.Text_IO.Editing + "a-textio", -- Ada.Text_IO + "a-ticoio", -- Ada.Text_IO.Complex_IO + "a-titest", -- Ada.Text_IO.Text_Streams + "a-unccon", -- Ada.Unchecked_Conversion + "a-uncdea", -- Ada.Unchecked_Deallocation + "a-witeio", -- Ada.Wide_Text_IO + "a-wtcoio", -- Ada.Wide_Text_IO.Complex_IO + "a-wtedit", -- Ada.Wide_Text_IO.Editing + "a-wttest", -- Ada.Wide_Text_IO.Text_Streams + + ------------------------------------------------- + -- RM Required Additions to Ada for GNAT Types -- + ------------------------------------------------- + + "a-lfteio", -- Ada.Long_Float_Text_IO + "a-lfwtio", -- Ada.Long_Float_Wide_Text_IO + "a-liteio", -- Ada.Long_Integer_Text_IO + "a-liwtio", -- Ada.Long_Integer_Wide_Text_IO + "a-llftio", -- Ada.Long_Long_Float_Text_IO + "a-llfwti", -- Ada.Long_Long_Float_Wide_Text_IO + "a-llitio", -- Ada.Long_Long_Integer_Text_IO + "a-lliwti", -- Ada.Long_Long_Integer_Wide_Text_IO + "a-nlcefu", -- Ada.Long_Complex_Elementary_Functions + "a-nlcoty", -- Ada.Numerics.Long_Complex_Types + "a-nlelfu", -- Ada.Numerics.Long_Elementary_Functions + "a-nllcef", -- Ada.Long_Long_Complex_Elementary_Functions + "a-nllefu", -- Ada.Numerics.Long_Long_Elementary_Functions + "a-nltcty", -- Ada.Numerics.Long_Long_Complex_Types + "a-nscefu", -- Ada.Short_Complex_Elementary_Functions + "a-nscoty", -- Ada.Numerics.Short_Complex_Types + "a-nselfu", -- Ada.Numerics.Short_Elementary_Functions + "a-sfteio", -- Ada.Short_Float_Text_IO + "a-sfwtio", -- Ada.Short_Float_Wide_Text_IO + "a-siteio", -- Ada.Short_Integer_Text_IO + "a-siwtio", -- Ada.Short_Integer_Wide_Text_IO + "a-ssitio", -- Ada.Short_Short_Integer_Text_IO + "a-ssiwti", -- Ada.Short_Short_Integer_Wide_Text_IO + + ----------------------------------- + -- GNAT Defined Additions to Ada -- + ----------------------------------- + + "a-colire", -- Ada.Command_Line.Remove + "a-cwila1", -- Ada.Characters.Wide_Latin_1 + "a-diocst", -- Ada.Direct_IO.C_Streams + "a-einuoc", -- Ada.Exceptions.Is_Null_Occurrence + "a-siocst", -- Ada.Sequential_IO.C_Streams + "a-ssicst", -- Ada.Streams.Stream_IO.C_Streams + "a-suteio", -- Ada.Strings.Unbounded.Text_IO + "a-swuwti", -- Ada.Strings.Wide_Unbounded.Wide_Text_IO + "a-taidim", -- Ada.Task_Identification.Image + "a-tiocst", -- Ada.Text_IO.C_Streams + "a-wtcstr", -- Ada.Wide_Text_IO.C_Streams + + --------------------------- + -- GNAT Special IO Units -- + --------------------------- + + -- As further explained elsewhere (see Sem_Ch10), the internal + -- packages of Text_IO and Wide_Text_IO are actually implemented + -- as separate children, but this fact is intended to be hidden + -- from the user completely. Any attempt to WITH one of these + -- units will be diagnosed as an error later on, but for now we + -- do not consider these internal implementation units (if we did, + -- then we would get a junk warning which would be confusing and + -- unecessary, given that we generate a clear error message). + + "a-tideio", -- Ada.Text_IO.Decimal_IO + "a-tienio", -- Ada.Text_IO.Enumeration_IO + "a-tifiio", -- Ada.Text_IO.Fixed_IO + "a-tiflio", -- Ada.Text_IO.Float_IO + "a-tiinio", -- Ada.Text_IO.Integer_IO + "a-tiinio", -- Ada.Text_IO.Integer_IO + "a-timoio", -- Ada.Text_IO.Modular_IO + "a-wtdeio", -- Ada.Wide_Text_IO.Decimal_IO + "a-wtenio", -- Ada.Wide_Text_IO.Enumeration_IO + "a-wtfiio", -- Ada.Wide_Text_IO.Fixed_IO + "a-wtflio", -- Ada.Wide_Text_IO.Float_IO + "a-wtinio", -- Ada.Wide_Text_IO.Integer_IO + "a-wtmoio", -- Ada.Wide_Text_IO.Modular_IO + + ------------------------ + -- GNAT Library Units -- + ------------------------ + + "g-awk ", -- GNAT.AWK + "g-busora", -- GNAT.Bubble_Sort_A + "g-busorg", -- GNAT.Bubble_Sort_G + "g-calend", -- GNAT.Calendar + "g-catiio", -- GNAT.Calendar.Time_IO + "g-casuti", -- GNAT.Case_Util + "g-cgi ", -- GNAT.CGI + "g-cgicoo", -- GNAT.CGI.Cookie + "g-cgideb", -- GNAT.CGI.Debug + "g-comlin", -- GNAT.Command_Line + "g-curexc", -- GNAT.Current_Exception + "g-debpoo", -- GNAT.Debug_Pools + "g-debuti", -- GNAT.Debug_Utilities + "g-dirope", -- GNAT.Directory_Operations + "g-dyntab", -- GNAT.Dynamic_Tables + "g-exctra", -- GNAT.Exception_Traces + "g-expect", -- GNAT.Expect + "g-flocon", -- GNAT.Float_Control + "g-htable", -- GNAT.Htable + "g-hesora", -- GNAT.Heap_Sort_A + "g-hesorg", -- GNAT.Heap_Sort_G + "g-io ", -- GNAT.IO + "g-io_aux", -- GNAT.IO_Aux + "g-locfil", -- GNAT.Lock_Files + "g-moreex", -- GNAT.Most_Recent_Exception + "g-os_lib", -- GNAT.Os_Lib + "g-regexp", -- GNAT.Regexp + "g-regist", -- GNAT.Registry + "g-regpat", -- GNAT.Regpat + "g-socket", -- GNAT.Sockets + "g-sptabo", -- GNAT.Spitbol.Table_Boolean + "g-sptain", -- GNAT.Spitbol.Table_Integer + "g-sptavs", -- GNAT.Spitbol.Table_Vstring + "g-souinf", -- GNAT.Source_Info + "g-speche", -- GNAT.Spell_Checker + "g-spitbo", -- GNAT.Spitbol + "g-spipat", -- GNAT.Spitbol.Patterns + "g-table ", -- GNAT.Table + "g-tasloc", -- GNAT.Task_Lock + "g-thread", -- GNAT.Threads + "g-traceb", -- GNAT.Traceback + "g-trasym", -- GNAT.Traceback.Symbolic + + ----------------------------------------------------- + -- Interface Hierarchy Units from Reference Manual -- + ----------------------------------------------------- + + "i-c ", -- Interfaces.C + "i-cobol ", -- Interfaces.Cobol + "i-cpoint", -- Interfaces.C.Pointers + "i-cstrin", -- Interfaces.C.Strings + "i-fortra", -- Interfaces.Fortran + + ------------------------------------------ + -- GNAT Defined Additions to Interfaces -- + ------------------------------------------ + + "i-cexten", -- Interfaces.C.Extensions + "i-csthre", -- Interfaces.C.Sthreads + "i-cstrea", -- Interfaces.C.Streams + "i-cpp ", -- Interfaces.CPP + "i-java ", -- Interfaces.Java + "i-javlan", -- Interfaces.Java.Lang + "i-jalaob", -- Interfaces.Java.Lang.Object + "i-jalasy", -- Interfaces.Java.Lang.System + "i-jalath", -- Interfaces.Java.Lang.Thread + "i-os2err", -- Interfaces.Os2lib.Errors + "i-os2lib", -- Interfaces.Os2lib + "i-os2syn", -- Interfaces.Os2lib.Synchronization + "i-os2thr", -- Interfaces.Os2lib.Threads + "i-pacdec", -- Interfaces.Packed_Decimal + "i-vxwork", -- Interfaces.Vxworks + + -------------------------------------------------- + -- System Hierarchy Units from Reference Manual -- + -------------------------------------------------- + + "s-atacco", -- System.Address_To_Access_Conversions + "s-maccod", -- System.Machine_Code + "s-rpc ", -- System.Rpc + "s-stoele", -- System.Storage_Elements + "s-stopoo", -- System.Storage_Pools + + -------------------------------------- + -- GNAT Defined Additions to System -- + -------------------------------------- + + "s-addima", -- System.Address_Image + "s-assert", -- System.Assertions + "s-parint", -- System.Partition_Interface + "s-tasinf", -- System.Task_Info + "s-wchcnv", -- System.Wch_Cnv + "s-wchcon"); -- System.Wch_Con + + ------------------------- + -- Implementation_Unit -- + ------------------------- + + function Implementation_Unit (U : Unit_Number_Type) return Boolean is + Fname : constant File_Name_Type := Unit_File_Name (U); + + begin + -- All units are OK in GNAT mode + + if GNAT_Mode then + return False; + end if; + + -- If length of file name is greater than 12, definitely OK! + -- The value 12 here is an 8 char name with extension .ads. + + if Length_Of_Name (Fname) > 12 then + return False; + end if; + + -- Otherwise test file name + + Get_Name_String (Fname); + + -- Definitely OK if file name does not start with a- g- s- i- + + if Name_Len < 3 + or else Name_Buffer (2) /= '-' + or else (Name_Buffer (1) /= 'a' + and then + Name_Buffer (1) /= 'g' + and then + Name_Buffer (1) /= 'i' + and then + Name_Buffer (1) /= 's') + then + return False; + end if; + + -- Definitely OK if file name does not end in .ads. This can + -- happen when non-standard file names are being used. + + if Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" then + return False; + end if; + + -- Otherwise normalize file name to 8 characters + + Name_Len := Name_Len - 4; + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + -- Definitely OK if name is in list + + for J in Non_Imp_File_Names'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names (J) then + return False; + end if; + end loop; + + -- Only remaining special possibilities are children of + -- System.RPC and System.Garlic and special files of the + -- form System.Aux... + + Get_Name_String (Unit_Name (U)); + + if Name_Len > 12 + and then Name_Buffer (1 .. 11) = "system.rpc." + then + return False; + end if; + + if Name_Len > 15 + and then Name_Buffer (1 .. 14) = "system.garlic." + then + return False; + end if; + + if Name_Len > 11 + and then Name_Buffer (1 .. 10) = "system.aux" + then + return False; + end if; + + -- All tests failed, this is definitely an implementation unit + + return True; + + end Implementation_Unit; + +end Impunit; diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads new file mode 100644 index 00000000000..99cf2af8bf0 --- /dev/null +++ b/gcc/ada/impunit.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I M P U N I T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains data and functions used to determine if a given +-- unit is an internal unit intended only for use by the implementation +-- and which should not be directly WITH'ed by user code. + +with Types; use Types; + +package Impunit is + + function Implementation_Unit (U : Unit_Number_Type) return Boolean; + -- Given the unit number of a unit, this function determines if it is a + -- unit that is intended to be used only internally by the implementation. + -- This is used for posting warnings for improper WITH's of such units + -- (such WITH's are allowed without warnings only in GNAT_Mode set by + -- the use of -gnatg). True is returned if a warning should be posted. + +end Impunit; diff --git a/gcc/ada/init.c b/gcc/ada/init.c new file mode 100644 index 00000000000..77d0d6f967e --- /dev/null +++ b/gcc/ada/init.c @@ -0,0 +1,2027 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * I N I T * + * * + * $Revision: 1.1 $ + * * + * C Implementation File * + * * + * Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion 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. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This unit contains initialization circuits that are system dependent. A + major part of the functionality involved involves stack overflow checking. + The GCC backend generates probe instructions to test for stack overflow. + For details on the exact approach used to generate these probes, see the + "Using and Porting GCC" manual, in particular the "Stack Checking" section + and the subsection "Specifying How Stack Checking is Done". The handlers + installed by this file are used to handle resulting signals that come + from these probes failing (i.e. touching protected pages) */ + +/* The following include is here to meet the published VxWorks requirement + that the __vxworks header appear before any other include. */ +#ifdef __vxworks +#include "vxWorks.h" +#endif + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include <sys/stat.h> +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" +#include "raise.h" + +extern void __gnat_raise_program_error (const char *, int); + +/* Addresses of exception data blocks for predefined exceptions. */ +extern struct Exception_Data constraint_error; +extern struct Exception_Data numeric_error; +extern struct Exception_Data program_error; +extern struct Exception_Data storage_error; +extern struct Exception_Data tasking_error; +extern struct Exception_Data _abort_signal; + +#define Lock_Task system__soft_links__lock_task +extern void (*Lock_Task) PARAMS ((void)); + +#define Unlock_Task system__soft_links__unlock_task +extern void (*Unlock_Task) PARAMS ((void)); + +#define Get_Machine_State_Addr \ + system__soft_links__get_machine_state_addr +extern struct Machine_State *(*Get_Machine_State_Addr) PARAMS ((void)); + +#define Check_Abort_Status \ + system__soft_links__check_abort_status +extern int (*Check_Abort_Status) PARAMS ((void)); + +#define Raise_From_Signal_Handler \ + ada__exceptions__raise_from_signal_handler +extern void Raise_From_Signal_Handler PARAMS ((struct Exception_Data *, + char *)); + +#define Propagate_Signal_Exception \ + __gnat_propagate_sig_exc +extern void Propagate_Signal_Exception + PARAMS ((struct Machine_State *, struct Exception_Data *, char *)); + + +/* Copies of global values computed by the binder */ +int __gl_main_priority = -1; +int __gl_time_slice_val = -1; +char __gl_wc_encoding = 'n'; +char __gl_locking_policy = ' '; +char __gl_queuing_policy = ' '; +char __gl_task_dispatching_policy = ' '; +int __gl_unreserve_all_interrupts = 0; +int __gl_exception_tracebacks = 0; + +/* Indication of whether synchronous signal handler has already been + installed by a previous call to adainit */ +int __gnat_handler_installed = 0; + +/* HAVE_GNAT_INIT_FLOAT must be set on every targets where a __gnat_init_float + is defined. If this is not set them a void implementation will be defined + at the end of this unit. */ +#undef HAVE_GNAT_INIT_FLOAT + +/**********************/ +/* __gnat_set_globals */ +/**********************/ + +/* This routine is called from the binder generated main program. It copies + the values for global quantities computed by the binder into the following + global locations. The reason that we go through this copy, rather than just + define the global locations in the binder generated file, is that they are + referenced from the runtime, which may be in a shared library, and the + binder file is not in the shared library. Global references across library + boundaries like this are not handled correctly in all systems. */ + +void +__gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy, + queuing_policy, task_dispatching_policy, adafinal_ptr, + unreserve_all_interrupts, exception_tracebacks) + int main_priority; + int time_slice_val; + int wc_encoding; + int locking_policy, queuing_policy, task_dispatching_policy; + void (*adafinal_ptr) PARAMS ((void)) ATTRIBUTE_UNUSED; + int unreserve_all_interrupts, exception_tracebacks; +{ + static int already_called = 0; + + /* If this procedure has been already called once, check that the + arguments in this call are consistent with the ones in the previous + calls. Otherwise, raise a Program_Error exception. + + We do not check for consistency of the wide character encoding + method. This default affects only Wide_Text_IO where no explicit + coding method is given, and there is no particular reason to let + this default be affected by the source representation of a library + in any case. + + The value of main_priority is meaningful only when we are invoked + from the main program elaboration routine of an Ada application. + Checking the consistency of this parameter should therefore not be + done. Since it is assured that the main program elaboration will + always invoke this procedure before any library elaboration + routine, only the value of main_priority during the first call + should be taken into account and all the subsequent ones should be + ignored. Note that the case where the main program is not written + in Ada is also properly handled, since the default value will then + be used for this parameter. + + For identical reasons, the consistency of time_slice_val should not + be checked. */ + + if (already_called) + { + if (__gl_locking_policy != locking_policy || + __gl_queuing_policy != queuing_policy || + __gl_task_dispatching_policy != task_dispatching_policy || + __gl_unreserve_all_interrupts != unreserve_all_interrupts || + __gl_exception_tracebacks != exception_tracebacks) + { + __gnat_raise_program_error (__FILE__, __LINE__); + } + return; + } + already_called = 1; + + __gl_main_priority = main_priority; + __gl_time_slice_val = time_slice_val; + __gl_wc_encoding = wc_encoding; + __gl_locking_policy = locking_policy; + __gl_queuing_policy = queuing_policy; + __gl_task_dispatching_policy = task_dispatching_policy; + __gl_unreserve_all_interrupts = unreserve_all_interrupts; + __gl_exception_tracebacks = exception_tracebacks; +} + +/*********************/ +/* __gnat_initialize */ +/*********************/ + +/* __gnat_initialize is called at the start of execution of an Ada program + (the call is generated by the binder). The standard routine does nothing + at all; the intention is that this be replaced by system specific + code where initialization is required. */ + +/***********************************/ +/* __gnat_initialize (AIX version) */ +/***********************************/ + +#if defined (_AIX) + +/* AiX doesn't have SA_NODEFER */ + +#define SA_NODEFER 0 + +#include <sys/time.h> + +/* AiX doesn't have nanosleep, but provides nsleep instead */ + +extern int nanosleep PARAMS ((struct timestruc_t *, struct timestruc_t *)); +static void __gnat_error_handler PARAMS ((int)); + +int +nanosleep (Rqtp, Rmtp) + struct timestruc_t *Rqtp, *Rmtp; +{ + return nsleep (Rqtp, Rmtp); +} + +#include <signal.h> + +static void +__gnat_error_handler (sig) + int sig; +{ + struct Exception_Data *exception; + char *msg; + + switch (sig) + { + case SIGSEGV: + /* FIXME: we need to detect the case of a *real* SIGSEGV */ + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGABRT, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ +} + +/****************************************/ +/* __gnat_initialize (Dec Unix version) */ +/****************************************/ + +#elif defined(__alpha__) && defined(__osf__) && ! defined(__alpha_vxworks) + +/* Note: it seems that __osf__ is defined for the Alpha VXWorks case. Not + clear that this is reasonable, but in any case we have to be sure to + exclude this case in the above test. */ + +#include <signal.h> +#include <sys/siginfo.h> + +static void __gnat_error_handler PARAMS ((int, siginfo_t *, + struct sigcontext *)); +extern char *__gnat_get_code_loc PARAMS ((struct sigcontext *)); +extern void __gnat_enter_handler PARAMS ((struct sigcontext *, char *)); +extern size_t __gnat_machine_state_length PARAMS ((void)); + +extern long exc_lookup_gp PARAMS ((char *)); +extern void exc_resume PARAMS ((struct sigcontext *)); + +static void +__gnat_error_handler (sig, sip, context) + int sig; + siginfo_t *sip; + struct sigcontext *context; +{ + struct Exception_Data *exception; + static int recurse = 0; + struct sigcontext *mstate; + const char *msg; + + /* If this was an explicit signal from a "kill", just resignal it. */ + if (SI_FROMUSER (sip)) + { + signal (sig, SIG_DFL); + kill (getpid(), sig); + } + + /* Otherwise, treat it as something we handle. */ + switch (sig) + { + case SIGSEGV: + /* If the problem was permissions, this is a constraint error. + Likewise if the failing address isn't maximally aligned or if + we've recursed. + + ??? Using a static variable here isn't task-safe, but it's + much too hard to do anything else and we're just determining + which exception to raise. */ + if (sip->si_code == SEGV_ACCERR + || (((long) sip->si_addr) & 3) != 0 + || recurse) + { + exception = &constraint_error; + msg = "SIGSEGV"; + } + else + { + /* See if the page before the faulting page is accessable. Do that + by trying to access it. We'd like to simply try to access + 4096 + the faulting address, but it's not guaranteed to be + the actual address, just to be on the same page. */ + recurse++; + ((volatile char *) + ((long) sip->si_addr & - getpagesize ()))[getpagesize ()]; + msg = "stack overflow (or erroneous memory access)"; + exception = &storage_error; + } + break; + + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + recurse = 0; + mstate = (struct sigcontext *) (*Get_Machine_State_Addr) (); + if (mstate != 0) + *mstate = *context; + + Raise_From_Signal_Handler (exception, (char *) msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Setup signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = (void (*) PARAMS ((int))) __gnat_error_handler; + act.sa_flags = SA_ONSTACK | SA_RESTART | SA_NODEFER | SA_SIGINFO; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGABRT, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ +} + +/* Routines called by 5amastop.adb. */ + +#define SC_GP 29 + +char * +__gnat_get_code_loc (context) + struct sigcontext *context; +{ + return (char *) context->sc_pc; +} + +void +__gnat_enter_handler (context, pc) + struct sigcontext *context; + char *pc; +{ + context->sc_pc = (long) pc; + context->sc_regs[SC_GP] = exc_lookup_gp (pc); + exc_resume (context); +} + +size_t +__gnat_machine_state_length () +{ + return sizeof (struct sigcontext); +} + +/***********************************/ +/* __gnat_initialize (HPUX version) */ +/***********************************/ + +#elif defined (hpux) + +#include <signal.h> + +static void __gnat_error_handler PARAMS ((int)); + +static void +__gnat_error_handler (sig) + int sig; +{ + struct Exception_Data *exception; + char *msg; + + switch (sig) + { + case SIGSEGV: + /* FIXME: we need to detect the case of a *real* SIGSEGV */ + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! Also setup an alternate + stack region for the handler execution so that stack overflows can be + handled properly, avoiding a SEGV generation from stack usage by the + handler itself. */ + + static char handler_stack [SIGSTKSZ]; + + stack_t stack; + + stack.ss_sp = handler_stack; + stack.ss_size = SIGSTKSZ; + stack.ss_flags = 0; + + (void) sigaltstack (&stack, NULL); + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_ONSTACK; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGABRT, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ +} + + +/*************************************/ +/* __gnat_initialize (Linux version) */ +/*************************************/ + +#elif defined (linux) && defined (i386) && !defined (__RT__) + +#include <signal.h> +#include <asm/sigcontext.h> + +/* Linux with GNU libc does not define NULL in included header files */ + +#if !defined (NULL) +#define NULL ((void *) 0) +#endif + +struct Machine_State +{ + unsigned long eip; + unsigned long ebx; + unsigned long esp; + unsigned long ebp; + unsigned long esi; + unsigned long edi; +}; + +static void __gnat_error_handler PARAMS ((int)); + +static void +__gnat_error_handler (sig) + int sig; +{ + struct Exception_Data *exception; + char *msg; + static int recurse = 0; + + struct sigcontext *info + = (struct sigcontext *) (((char *) &sig) + sizeof (int)); + /* Linux does not document how to get the machine state in a signal handler, + but in fact the necessary data is in a sigcontext_struct value that is + on the stack immediately above the signal number parameter, and the + above messing accesses this value on the stack. */ + + struct Machine_State *mstate; + + switch (sig) + { + case SIGSEGV: + /* If the problem was permissions, this is a constraint error. + Likewise if the failing address isn't maximally aligned or if + we've recursed. + + ??? Using a static variable here isn't task-safe, but it's + much too hard to do anything else and we're just determining + which exception to raise. */ + if (recurse) + { + exception = &constraint_error; + msg = "SIGSEGV"; + } + else + { + /* Here we would like a discrimination test to see whether the + page before the faulting address is accessible. Unfortunately + Linux seems to have no way of giving us the faulting address. + + In versions of a-init.c before 1.95, we had a test of the page + before the stack pointer using: + + recurse++; + ((volatile char *) + ((long) info->esp_at_signal & - getpagesize ()))[getpagesize ()]; + + but that's wrong, since it tests the stack pointer location, and + the current stack probe code does not move the stack pointer + until all probes succeed. + + For now we simply do not attempt any discrimination at all. Note + that this is quite acceptable, since a "real" SIGSEGV can only + occur as the result of an erroneous program */ + + msg = "stack overflow (or erroneous memory access)"; + exception = &storage_error; + } + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + mstate = (*Get_Machine_State_Addr)(); + if (mstate) + { + mstate->eip = info->eip; + mstate->ebx = info->ebx; + mstate->esp = info->esp_at_signal; + mstate->ebp = info->ebp; + mstate->esi = info->esi; + mstate->edi = info->edi; + } + + recurse = 0; + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGABRT, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ +} + +/******************************************/ +/* __gnat_initialize (NT-mingw32 version) */ +/******************************************/ + +#elif defined (__MINGW32__) +#include <windows.h> + +static LONG __gnat_error_handler PARAMS ((PEXCEPTION_POINTERS)); + +/* __gnat_initialize (mingw32). */ + +static LONG +__gnat_error_handler (info) + PEXCEPTION_POINTERS info; +{ + static int recurse; + struct Exception_Data *exception; + char *msg; + + switch (info->ExceptionRecord->ExceptionCode) + { + case EXCEPTION_ACCESS_VIOLATION: + /* If the failing address isn't maximally-aligned or if we've + recursed, this is a program error. */ + if ((info->ExceptionRecord->ExceptionInformation[1] & 3) != 0 + || recurse) + { + exception = &program_error; + msg = "EXCEPTION_ACCESS_VIOLATION"; + } + else + { + /* See if the page before the faulting page is accessable. Do that + by trying to access it. */ + recurse++; + * ((volatile char *) (info->ExceptionRecord->ExceptionInformation[1] + + 4096)); + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + } + break; + + case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: + exception = &constraint_error; + msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED"; + break; + + case EXCEPTION_DATATYPE_MISALIGNMENT: + exception = &constraint_error; + msg = "EXCEPTION_DATATYPE_MISALIGNMENT"; + break; + + case EXCEPTION_FLT_DENORMAL_OPERAND: + exception = &constraint_error; + msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; + break; + + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + exception = &constraint_error; + msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; + break; + + case EXCEPTION_FLT_INVALID_OPERATION: + exception = &constraint_error; + msg = "EXCEPTION_FLT_INVALID_OPERATION"; + break; + + case EXCEPTION_FLT_OVERFLOW: + exception = &constraint_error; + msg = "EXCEPTION_FLT_OVERFLOW"; + break; + + case EXCEPTION_FLT_STACK_CHECK: + exception = &program_error; + msg = "EXCEPTION_FLT_STACK_CHECK"; + break; + + case EXCEPTION_FLT_UNDERFLOW: + exception = &constraint_error; + msg = "EXCEPTION_FLT_UNDERFLOW"; + break; + + case EXCEPTION_INT_DIVIDE_BY_ZERO: + exception = &constraint_error; + msg = "EXCEPTION_INT_DIVIDE_BY_ZERO"; + break; + + case EXCEPTION_INT_OVERFLOW: + exception = &constraint_error; + msg = "EXCEPTION_INT_OVERFLOW"; + break; + + case EXCEPTION_INVALID_DISPOSITION: + exception = &program_error; + msg = "EXCEPTION_INVALID_DISPOSITION"; + break; + + case EXCEPTION_NONCONTINUABLE_EXCEPTION: + exception = &program_error; + msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION"; + break; + + case EXCEPTION_PRIV_INSTRUCTION: + exception = &program_error; + msg = "EXCEPTION_PRIV_INSTRUCTION"; + break; + + case EXCEPTION_SINGLE_STEP: + exception = &program_error; + msg = "EXCEPTION_SINGLE_STEP"; + break; + + case EXCEPTION_STACK_OVERFLOW: + exception = &storage_error; + msg = "EXCEPTION_STACK_OVERFLOW"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + recurse = 0; + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + SetUnhandledExceptionFilter (__gnat_error_handler); + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ + + /* Initialize floating-point coprocessor. This call is needed because + the MS libraries default to 64-bit precision instead of 80-bit + precision, and we require the full precision for proper operation, + given that we have set Max_Digits etc with this in mind */ + + __gnat_init_float (); + + /* initialize a lock for a process handle list - see a-adaint.c for the + implementation of __gnat_portable_no_block_spawn, __gnat_portable_wait */ + __gnat_plist_init(); +} + +/**************************************/ +/* __gnat_initialize (Interix version) */ +/**************************************/ + +#elif defined (__INTERIX) + +#include <signal.h> + +static void __gnat_error_handler PARAMS ((int)); + +static void +__gnat_error_handler (sig) + int sig; +{ + struct Exception_Data *exception; + char *msg; + + switch (sig) + { + case SIGSEGV: + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = 0; + (void) sigemptyset (&act.sa_mask); + + /* Handlers for signals besides SIGSEGV cause c974013 to hang */ +/* (void) sigaction (SIGILL, &act, NULL); */ +/* (void) sigaction (SIGABRT, &act, NULL); */ +/* (void) sigaction (SIGFPE, &act, NULL); */ +/* (void) sigaction (SIGBUS, &act, NULL); */ + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGSEGV, &act, NULL); + } + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ + __gnat_init_float (); +} + +/**************************************/ +/* __gnat_initialize (LynxOS version) */ +/**************************************/ + +#elif defined (__Lynx__) + +void +__gnat_initialize () +{ + __gnat_init_float (); +} + +/*********************************/ +/* __gnat_install_handler (Lynx) */ +/*********************************/ + +void +__gnat_install_handler () +{ + __gnat_handler_installed = 1; +} + +/****************************/ +/* __gnat_initialize (OS/2) */ +/****************************/ + +#elif defined (__EMX__) /* OS/2 dependent initialization */ + +void +__gnat_initialize () +{ +} + +/*********************************/ +/* __gnat_install_handler (OS/2) */ +/*********************************/ + +void +__gnat_install_handler () +{ + __gnat_handler_installed = 1; +} + +/***********************************/ +/* __gnat_initialize (SGI version) */ +/***********************************/ + +#elif defined (sgi) + +#include <signal.h> +#include <siginfo.h> + +#ifndef NULL +#define NULL 0 +#endif + +#define SIGADAABORT 48 +#define SIGNAL_STACK_SIZE 4096 +#define SIGNAL_STACK_ALIGNMENT 64 + +struct Machine_State +{ + sigcontext_t context; +}; + +static void __gnat_error_handler PARAMS ((int, int, sigcontext_t *)); + +static void +__gnat_error_handler (sig, code, sc) + int sig; + int code; + sigcontext_t *sc; +{ + struct Machine_State *mstate; + struct Exception_Data *exception; + char *msg; + + int i; + + switch (sig) + { + case SIGSEGV: + if (code == EFAULT) + { + exception = &program_error; + msg = "SIGSEGV: (Invalid virtual address)"; + } + else if (code == ENXIO) + { + exception = &program_error; + msg = "SIGSEGV: (Read beyond mapped object)"; + } + else if (code == ENOSPC) + { + exception = &program_error; /* ??? storage_error ??? */ + msg = "SIGSEGV: (Autogrow for file failed)"; + } + else if (code == EACCES) + { + /* ??? Re-add smarts to further verify that we launched + the stack into a guard page, not an attempt to + write to .text or something */ + exception = &storage_error; + msg = "SIGSEGV: (stack overflow or erroneous memory access)"; + } + else + { + /* Just in case the OS guys did it to us again. Sometimes + they fail to document all of the valid codes that are + passed to signal handlers, just in case someone depends + on knowing all the codes */ + exception = &program_error; + msg = "SIGSEGV: (Undocumented reason)"; + } + break; + + case SIGBUS: + /* Map all bus errors to Program_Error. */ + exception = &program_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + /* Map all fpe errors to Constraint_Error. */ + exception = &constraint_error; + msg = "SIGFPE"; + break; + + case SIGADAABORT: + if ((*Check_Abort_Status) ()) + { + exception = &_abort_signal; + msg = ""; + } + else + return; + + break; + + default: + /* Everything else is a Program_Error. */ + exception = &program_error; + msg = "unhandled signal"; + } + + mstate = (*Get_Machine_State_Addr)(); + if (mstate != 0) + memcpy ((void *) mstate, (const void *) sc, sizeof (sigcontext_t)); + + Raise_From_Signal_Handler (exception, msg); + +} + +void +__gnat_install_handler () +{ + stack_t ss; + struct sigaction act; + + /* Setup signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER + SA_RESTART; + (void) sigfillset (&act.sa_mask); + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGABRT, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + (void) sigaction (SIGADAABORT, &act, NULL); + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ +} + +/*************************************************/ +/* __gnat_initialize (Solaris and SunOS version) */ +/*************************************************/ + +#elif defined (sun) && defined (__SVR4) && !defined (__vxworks) + +#include <signal.h> +#include <siginfo.h> + +static void __gnat_error_handler PARAMS ((int, siginfo_t *)); + +static void +__gnat_error_handler (sig, sip) + int sig; + siginfo_t *sip; +{ + struct Exception_Data *exception; + static int recurse = 0; + char *msg; + + /* If this was an explicit signal from a "kill", just resignal it. */ + if (SI_FROMUSER (sip)) + { + signal (sig, SIG_DFL); + kill (getpid(), sig); + } + + /* Otherwise, treat it as something we handle. */ + switch (sig) + { + case SIGSEGV: + /* If the problem was permissions, this is a constraint error. + Likewise if the failing address isn't maximally aligned or if + we've recursed. + + ??? Using a static variable here isn't task-safe, but it's + much too hard to do anything else and we're just determining + which exception to raise. */ + if (sip->si_code == SEGV_ACCERR + || (((long) sip->si_addr) & 3) != 0 + || recurse) + { + exception = &constraint_error; + msg = "SIGSEGV"; + } + else + { + /* See if the page before the faulting page is accessable. Do that + by trying to access it. We'd like to simply try to access + 4096 + the faulting address, but it's not guaranteed to be + the actual address, just to be on the same page. */ + recurse++; + ((volatile char *) + ((long) sip->si_addr & - getpagesize ()))[getpagesize ()]; + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + } + break; + + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + recurse = 0; + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGABRT, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGFPE, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ +} + +/***********************************/ +/* __gnat_initialize (SNI version) */ +/***********************************/ + +#elif defined (__sni__) + +/* SNI needs special defines and includes */ + +#define _XOPEN_SOURCE +#define _POSIX_SOURCE +#include <signal.h> + +extern size_t __gnat_getpagesize PARAMS ((void)); +static void __gnat_error_handler PARAMS ((int)); + +/* The run time needs this function which is a #define in SNI */ + +size_t +__gnat_getpagesize () +{ + return getpagesize (); +} + +static void +__gnat_error_handler (sig) + int sig; +{ + struct Exception_Data *exception; + char *msg; + + switch (sig) + { + case SIGSEGV: + /* FIXME: we need to detect the case of a *real* SIGSEGV */ + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGABRT, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + __gnat_handler_installed = 1; +} + +void +__gnat_initialize () +{ +} + +/***********************************/ +/* __gnat_initialize (VMS version) */ +/***********************************/ + +#elif defined (VMS) + +/* The prehandler actually gets control first on a condition. It swaps the + stack pointer and calls the handler (__gnat_error_handler). */ +extern long __gnat_error_prehandler (); + +extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */ + +/* Conditions that don't have an Ada exception counterpart must raise + Non_Ada_Error. Since this is defined in s-auxdec, it should only be + referenced by user programs, not the compiler or tools. Hence the + #ifdef IN_RTS. */ + +#ifdef IN_RTS +#define Non_Ada_Error system__aux_dec__non_ada_error +extern struct Exception_Data Non_Ada_Error; + +#define Coded_Exception system__vms_exception_table__coded_exception +extern struct Exception_Data *Coded_Exception (int); +#endif + +/* Define macro symbols for the VMS conditions that become Ada exceptions. + Most of these are also defined in the header file ssdef.h which has not + yet been converted to be recoginized by Gnu C. Some, which couldn't be + located, are assigned names based on the DEC test suite tests which + raise them. */ + +#define SS$_ACCVIO 12 +#define SS$_DEBUG 1132 +#define SS$_INTDIV 1156 +#define SS$_HPARITH 1284 +#define SS$_STKOVF 1364 +#define SS$_RESIGNAL 2328 +#define MTH$_FLOOVEMAT 1475268 /* Some ACVC_21 CXA tests */ +#define SS$_CE24VRU 3253636 /* Write to unopened file */ +#define SS$_C980VTE 3246436 /* AST requests time slice */ +#define CMA$_EXIT_THREAD 4227492 +#define CMA$_EXCCOPLOS 4228108 +#define CMA$_ALERTED 4227460 + +struct descriptor_s {unsigned short len, mbz; char *adr; }; + +static long __gnat_error_handler PARAMS ((int *, void *)); + +static long +__gnat_error_handler (sigargs, mechargs) + int *sigargs; + void *mechargs; +{ + struct Exception_Data *exception = 0; + char *msg = ""; + char message [256]; + long prvhnd; + struct descriptor_s msgdesc; + int msg_flag = 0x000f; /* 1 bit for each of the four message parts */ + unsigned short outlen; + char curr_icb [544]; + long curr_invo_handle; + long *mstate; + + /* Resignaled condtions aren't effected by by pragma Import_Exception */ + + switch (sigargs[1]) + { + + case CMA$_EXIT_THREAD: + return SS$_RESIGNAL; + + case SS$_DEBUG: /* Gdb attach, resignal to merge activate gdbstub. */ + return SS$_RESIGNAL; + + case 1409786: /* Nickerson bug #33 ??? */ + return SS$_RESIGNAL; + + case 1381050: /* Nickerson bug #33 ??? */ + return SS$_RESIGNAL; + + case 11829410: /* Resignalled as Use_Error for CE10VRC */ + return SS$_RESIGNAL; + + } + +#ifdef IN_RTS + /* See if it's an imported exception. Mask off severity bits. */ + exception = Coded_Exception (sigargs [1] & 0xfffffff8); + if (exception) + { + msgdesc.len = 256; + msgdesc.mbz = 0; + msgdesc.adr = message; + SYS$GETMSG (sigargs[1], &outlen, &msgdesc, msg_flag, 0); + message [outlen] = 0; + msg = message; + + exception->Name_Length = 19; + /* The full name really should be get sys$getmsg returns. ??? */ + exception->Full_Name = "IMPORTED_EXCEPTION"; + exception->Import_Code = sigargs [1] & 0xfffffff8; + } +#endif + + if (exception == 0) + switch (sigargs[1]) + { + case SS$_ACCVIO: + if (sigargs[3] == 0) + { + exception = &constraint_error; + msg = "access zero"; + } + else + { + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; + } + break; + + case SS$_STKOVF: + exception = &storage_error; + msg = "stack overflow"; + break; + + case SS$_INTDIV: + exception = &constraint_error; + msg = "division by zero"; + break; + + case SS$_HPARITH: +#ifndef IN_RTS + return SS$_RESIGNAL; /* toplev.c handles for compiler */ +#else + { + exception = &constraint_error; + msg = "arithmetic error"; + } +#endif + break; + + case MTH$_FLOOVEMAT: + exception = &constraint_error; + msg = "floating overflow in math library"; + break; + + case SS$_CE24VRU: + exception = &constraint_error; + msg = ""; + break; + + case SS$_C980VTE: + exception = &program_error; + msg = ""; + break; + + default: +#ifndef IN_RTS + exception = &program_error; +#else + /* User programs expect Non_Ada_Error to be raised, reference + DEC Ada test CXCONDHAN. */ + exception = &Non_Ada_Error; +#endif + msgdesc.len = 256; + msgdesc.mbz = 0; + msgdesc.adr = message; + SYS$GETMSG (sigargs[1], &outlen, &msgdesc, msg_flag, 0); + message [outlen] = 0; + msg = message; + break; + } + + mstate = (long *) (*Get_Machine_State_Addr) (); + if (mstate != 0) + { + LIB$GET_CURR_INVO_CONTEXT (&curr_icb); + LIB$GET_PREV_INVO_CONTEXT (&curr_icb); + LIB$GET_PREV_INVO_CONTEXT (&curr_icb); + curr_invo_handle = LIB$GET_INVO_HANDLE (&curr_icb); + *mstate = curr_invo_handle; + } + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + long prvhnd; + char *c; + + c = (char *) malloc (1025); + + __gnat_error_prehandler_stack = &c[1024]; + + /* __gnat_error_prehandler is an assembly function. */ + SYS$SETEXV (1, __gnat_error_prehandler, 3, &prvhnd); + __gnat_handler_installed = 1; +} + +void +__gnat_initialize() +{ +} + +/***************************************/ +/* __gnat_initialize (VXWorks version) */ +/***************************************/ + +#elif defined(__vxworks) + +#include <signal.h> +#include <taskLib.h> +#include <intLib.h> +#include <iv.h> + +static void __gnat_init_handler PARAMS ((int)); +extern int __gnat_inum_to_ivec PARAMS ((int)); +static void __gnat_error_handler PARAMS ((int, int, struct sigcontext *)); + +static void +__gnat_int_handler (interr) + int interr; +{ + /* Note that we should use something like Raise_From_Int_Handler here, but + for now Raise_From_Signal_Handler will do the job. ??? */ + + Raise_From_Signal_Handler (&storage_error, "stack overflow"); +} + +/* Used for stack-checking on VxWorks. Must be task-local in + tasking programs */ + +void *__gnat_stack_limit = NULL; + +#ifndef __alpha_vxworks + +/* getpid is used by s-parint.adb, but is not defined by VxWorks, except + on Alpha VxWorks */ + +extern long getpid PARAMS ((void)); + +long +getpid () +{ + return taskIdSelf (); +} +#endif + +/* This is needed by the GNAT run time to handle Vxworks interrupts */ +int +__gnat_inum_to_ivec (num) + int num; +{ + return INUM_TO_IVEC (num); +} + +static void +__gnat_error_handler (sig, code, sc) + int sig; + int code; + struct sigcontext *sc; +{ + struct Exception_Data *exception; + sigset_t mask; + int result; + char *msg; + + /* VxWorks will always mask out the signal during the signal handler and + will reenable it on a longjmp. GNAT does not generate a longjmp to + return from a signal handler so the signal will still be masked unless + we unmask it. */ + (void) sigprocmask (SIG_SETMASK, NULL, &mask); + sigdelset (&mask, sig); + (void) sigprocmask (SIG_SETMASK, &mask, NULL); + + /* VxWorks will suspend the task when it gets a hardware exception. We + take the liberty of resuming the task for the application. */ + if (taskIsSuspended (taskIdSelf ()) != 0) + (void) taskResume (taskIdSelf ()); + + switch (sig) + { + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + case SIGILL: + exception = &constraint_error; + msg = "SIGILL"; + break; + case SIGSEGV: + exception = &program_error; + msg = "SIGSEGV"; + break; + case SIGBUS: + exception = &program_error; + msg = "SIGBUS"; + break; + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +void +__gnat_install_handler () +{ + struct sigaction act; + + /* Setup signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! */ + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_SIGINFO | SA_ONSTACK; + (void) sigemptyset (&act.sa_mask); + + (void) sigaction (SIGFPE, &act, NULL); + + if (__gl_unreserve_all_interrupts == 0) + { + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); + } + __gnat_handler_installed = 1; +} + +#define HAVE_GNAT_INIT_FLOAT + +void +__gnat_init_float () +{ +#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) + /* Disable overflow/underflow exceptions on the PPC processor, this is needed + to get correct Ada semantic */ + asm ("mtfsb0 25"); + asm ("mtfsb0 26"); +#endif +} + +void +__gnat_initialize () +{ + TASK_DESC pTaskDesc; + + if (taskInfoGet (taskIdSelf (), &pTaskDesc) != OK) + printErr ("Cannot get task info"); + + __gnat_stack_limit = (void *) pTaskDesc.td_pStackLimit; + + __gnat_init_float (); + +#ifdef __mips_vxworks +#if 0 + /* For now remove this handler, since it is causing interferences with gdb */ + + /* Connect the overflow trap directly to the __gnat_int_handler routine + as it is not converted to a signal by VxWorks. */ + + intConnect (INUM_TO_IVEC (IV_TRAP_VEC), &__gnat_int_handler, IV_TRAP_VEC); +#endif +#endif +} + + +/***************************************/ +/* __gnat_initialize (default version) */ +/***************************************/ + +/* Get the stack unwinding mechanism when available and when compiling + a-init.c for the run time. Except in the case of a restricted run-time, + such as RT-Linux modules (__RT__ is defined). */ + +#elif defined (IN_RTS) && !defined (__RT__) + +/* If we have a definition of INCOMING_RETURN_ADDR_RTX, assume that + the rest of the DWARF 2 frame unwind support is also provided. */ +#if !defined (DWARF2_UNWIND_INFO) && defined (INCOMING_RETURN_ADDR_RTX) +#define DWARF2_UNWIND_INFO 1 +#endif + +#ifdef DWARF2_UNWIND_INFO +#include "frame.h" + +struct machine_state +{ + frame_state f1, f2, f3; + frame_state *udata, *udata_start, *sub_udata; + void *pc, *pc_start, *new_pc; +}; + +typedef int word_type __attribute__ ((mode (__word__))); + +/* This type is used in get_reg and put_reg to deal with ABIs where a void* + is smaller than a word, such as the Irix 6 n32 ABI. We cast twice to + avoid a warning about casting between int and pointer of different + sizes. */ + +typedef int ptr_type __attribute__ ((mode (pointer))); + +static void get_reg PARAMS ((unsigned int, frame_state *, + frame_state *)); +static void put_reg PARAMS ((unsigned int, void *, + frame_state *)); +static void copy_reg PARAMS ((unsigned int, frame_state *, + frame_state *)); +static inline void put_return_addr PARAMS ((void *, frame_state *)); +static inline void *get_return_addr PARAMS ((frame_state *, + frame_state *)); +static frame_state *__frame_state_for_r PARAMS ((void *, frame_state *)); + +#ifdef INCOMING_REGNO +static int in_reg_window PARAMS ((unsigned int, frame_state *)); +#endif + +extern void __gnat_pop_frame PARAMS ((struct machine_state *)); +extern void __gnat_set_machine_state PARAMS ((struct machine_state *)); +extern void __gnat_enter_handler PARAMS ((struct machine_state *, + void *)); +extern __SIZE_TYPE__ __gnat_machine_state_length PARAMS ((void)); +extern void *__gnat_get_code_loc PARAMS ((struct machine_state *)); + +/* Get the value of register REG as saved in UDATA, where SUB_UDATA is a + frame called by UDATA or 0. */ + +static void * +get_reg (reg, udata, sub_udata) + unsigned int reg; + frame_state *udata, *sub_udata; +{ + if (udata->saved[reg] == REG_SAVED_OFFSET) + return + (void *) (ptr_type) *(word_type *) (udata->cfa + + udata->reg_or_offset[reg]); + else if (udata->saved[reg] == REG_SAVED_REG && sub_udata) + return get_reg (udata->reg_or_offset[reg], sub_udata, 0); + else + abort (); +} + +/* Overwrite the saved value for register REG in frame UDATA with VAL. */ + +static void +put_reg (reg, val, udata) + unsigned int reg; + void *val; + frame_state *udate; +{ + if (udata->saved[reg] == REG_SAVED_OFFSET) + *(word_type *) (udata->cfa + udata->reg_or_offset[reg]) + = (word_type) (ptr_type) val; + else + abort (); +} + +/* Copy the saved value for register REG from frame UDATA to frame + TARGET_UDATA. Unlike the previous two functions, this can handle + registers that are not one word large. */ + +static void +copy_reg (reg, udata, target_udata) + unsigned int reg; + frame_state *udate, *target_udata; +{ + if (udata->saved[reg] == REG_SAVED_OFFSET + && target_udata->saved[reg] == REG_SAVED_OFFSET) + memcpy (target_udata->cfa + target_udata->reg_or_offset[reg], + udata->cfa + udata->reg_or_offset[reg], + __builtin_dwarf_reg_size (reg)); + else + abort (); +} + +/* Overwrite the return address for frame UDATA with VAL. */ + +static inline void +put_return_addr (val, udata) + void *val; + frame_state *udata; +{ + val = __builtin_frob_return_addr (val); + put_reg (udata->retaddr_column, val, udata); +} + +#ifdef INCOMING_REGNO + +/* Is the saved value for register REG in frame UDATA stored in a register + window in the previous frame? */ + +static int +in_reg_window (reg, udata) + unsigned int reg; + frame_state *udata; +{ + if (udata->saved[reg] != REG_SAVED_OFFSET) + return 0; + +#ifdef STACK_GROWS_DOWNWARD + return udata->reg_or_offset[reg] > 0; +#else + return udata->reg_or_offset[reg] < 0; +#endif +} +#endif /* INCOMING_REGNO */ + +/* Retrieve the return address for frame UDATA, where SUB_UDATA is a + frame called by UDATA or 0. */ + +static inline void * +get_return_addr (udata, sub_udata) + frame_state *udate, *sub_udata; +{ + return __builtin_extract_return_addr (get_reg (udata->retaddr_column, + udata, sub_udata)); +} + +/* Thread-safe version of __frame_state_for */ + +static frame_state * +__frame_state_for_r (void *pc_target, frame_state *state_in) + void *pc_target; + frame_state *state_in; +{ + frame_state *f; + + (*Lock_Task) (); + f = __frame_state_for (pc_target, state_in); + (*Unlock_Task) (); + return f; +} + +/* Given the current frame UDATA and its return address PC, return the + information about the calling frame in CALLER_UDATA. */ + +void +__gnat_pop_frame (m) + struct machine_state *m; +{ + frame_state *p; + + int i; + + m->pc = m->new_pc; + p = m->udata; + if (! __frame_state_for_r (m->pc, m->sub_udata)) + { + m->new_pc = 0; + return; + } + + /* Now go back to our caller's stack frame. If our caller's CFA register + was saved in our stack frame, restore it; otherwise, assume the CFA + register is SP and restore it to our CFA value. */ + if (m->udata->saved[m->sub_udata->cfa_reg]) + m->sub_udata->cfa = get_reg (m->sub_udata->cfa_reg, m->udata, 0); + else + m->sub_udata->cfa = m->udata->cfa; + m->sub_udata->cfa += m->sub_udata->cfa_offset; + + m->udata = m->sub_udata; + m->sub_udata = p; + m->new_pc = get_return_addr (m->udata, m->sub_udata) - 1; + + return; + +/* ??? disable this code for now since it doesn't work properly */ +#if 0 + if (m->pc == m->pc_start) + return; + + /* Copy the frame's saved register values into our register save slots. */ + + for (i = 0; i < FIRST_PSEUDO_REGISTER; ++i) + if (i != m->udata->retaddr_column && m->udata->saved[i]) + { +#ifdef INCOMING_REGNO + /* If you modify the saved value of the return address + register on the SPARC, you modify the return address for + your caller's frame. Don't do that here, as it will + confuse get_return_addr. */ + if (in_reg_window (i, m->udata) + && m->udata->saved[m->udata->retaddr_column] == REG_SAVED_REG + && m->udata->reg_or_offset[m->udata->retaddr_column] == i) + continue; +#endif + copy_reg (i, m->udata, m->udata_start); + } +#endif +} + +void +__gnat_set_machine_state (machine_state) + struct machine_state *machine_state; +{ + frame_state sub_udata; + + /* Start at our stack frame. */ +label: + machine_state->udata = &machine_state->f1; + machine_state->sub_udata = &machine_state->f2; + machine_state->udata_start = &machine_state->f3; + + if (! __frame_state_for_r (&&label, machine_state->udata)) + return; + + /* We need to get the value from the CFA register. At this point in + compiling libgnat.a we don't know whether or not we will use the frame + pointer register for the CFA, so we check our unwind info. */ + if (machine_state->udata->cfa_reg == __builtin_dwarf_fp_regnum ()) + machine_state->udata->cfa = __builtin_fp (); + else + machine_state->udata->cfa = __builtin_sp (); + machine_state->udata->cfa += machine_state->udata->cfa_offset; + + memcpy (machine_state->udata_start, machine_state->udata, + sizeof (frame_state)); + machine_state->new_pc = + machine_state->pc_start = + machine_state->pc = &&label; + + /* Do any necessary initialization to access arbitrary stack frames. + On the SPARC, this means flushing the register windows. */ + __builtin_unwind_init (); + + /* go up one frame */ + __gnat_pop_frame (machine_state); +} + +void +__gnat_enter_handler (m, handler) + struct machine_state *m; + void *handler; +{ + void *retaddr; + +#ifdef INCOMING_REGNO + /* we need to update the saved return address register from + the last frame we unwind, or the handler frame will have the wrong + return address. */ + if (m->udata->saved[m->udata->retaddr_column] == REG_SAVED_REG) + { + int i = m->udata->reg_or_offset[m->udata->retaddr_column]; + if (in_reg_window (i, m->udata)) + copy_reg (i, m->udata, m->udata_start); + } +#endif + + /* Emit the stub to adjust sp and jump to the handler. */ + retaddr = __builtin_eh_stub (); + + /* And then set our return address to point to the stub. */ + if (m->udata_start->saved[m->udata_start->retaddr_column] == + REG_SAVED_OFFSET) + put_return_addr (retaddr, m->udata_start); + else + __builtin_set_return_addr_reg (retaddr); + + /* Set up the registers we use to communicate with the stub. + We check STACK_GROWS_DOWNWARD so the stub can use adjust_stack. */ + __builtin_set_eh_regs + (handler, +#ifdef STACK_GROWS_DOWNWARD + m->udata->cfa - m->udata_start->cfa +#else + m->udata_start->cfa - m->udata->cfa +#endif + + m->udata->args_size); + + /* Epilogue: restore the handler frame's register values and return + to the stub. */ +} + +__SIZE_TYPE__ +__gnat_machine_state_length () +{ + return sizeof (struct machine_state); +} + +void * +__gnat_get_code_loc (m) + struct machine_state *m; +{ + return m->pc; +} +#endif /* DWARF2_UNWIND_INFO */ + +#else + +/* For all other versions of GNAT, the initialize routine and handler + installation do nothing */ + +/***************************************/ +/* __gnat_initialize (default version) */ +/***************************************/ + +void +__gnat_initialize () +{ +} + +/********************************************/ +/* __gnat_install_handler (default version) */ +/********************************************/ + +void +__gnat_install_handler () +{ + __gnat_handler_installed = 1; +} + +#endif + + +/*********************/ +/* __gnat_init_float */ +/*********************/ + +/* This routine is called as each process thread is created, for possible + initialization of the FP processor. This version is used under INTERIX, + WIN32 and could be used under OS/2 */ + +#if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \ + || defined (__Lynx__) + +#define HAVE_GNAT_INIT_FLOAT + +void +__gnat_init_float () +{ +#if defined (__i386__) || defined (i386) + + /* This is used to properly initialize the FPU on an x86 for each + process thread. */ + + asm ("finit"); + +#endif /* Defined __i386__ */ +} +#endif + + +#ifndef HAVE_GNAT_INIT_FLOAT + +/* All targets without a specific __gnat_init_float will use an empty one */ +void +__gnat_init_float () +{ +} +#endif diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb new file mode 100644 index 00000000000..b21ca1f53dd --- /dev/null +++ b/gcc/ada/inline.adb @@ -0,0 +1,954 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N L I N E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.55 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch11; use Exp_Ch11; +with Exp_Tss; use Exp_Tss; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch12; use Sem_Ch12; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Uname; use Uname; + +package body Inline is + + -------------------- + -- Inlined Bodies -- + -------------------- + + -- Inlined functions are actually placed in line by the backend if the + -- corresponding bodies are available (i.e. compiled). Whenever we find + -- a call to an inlined subprogram, we add the name of the enclosing + -- compilation unit to a worklist. After all compilation, and after + -- expansion of generic bodies, we traverse the list of pending bodies + -- and compile them as well. + + package Inlined_Bodies is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Inlined_Bodies_Initial, + Table_Increment => Alloc.Inlined_Bodies_Increment, + Table_Name => "Inlined_Bodies"); + + ----------------------- + -- Inline Processing -- + ----------------------- + + -- For each call to an inlined subprogram, we make entries in a table + -- that stores caller and callee, and indicates a prerequisite from + -- one to the other. We also record the compilation unit that contains + -- the callee. After analyzing the bodies of all such compilation units, + -- we produce a list of subprograms in topological order, for use by the + -- back-end. If P2 is a prerequisite of P1, then P1 calls P2, and for + -- proper inlining the back-end must analyze the body of P2 before that of + -- P1. The code below guarantees that the transitive closure of inlined + -- subprograms called from the main compilation unit is made available to + -- the code generator. + + Last_Inlined : Entity_Id := Empty; + + -- For each entry in the table we keep a list of successors in topological + -- order, i.e. callers of the current subprogram. + + type Subp_Index is new Nat; + No_Subp : constant Subp_Index := 0; + + -- The subprogram entities are hashed into the Inlined table. + + Num_Hash_Headers : constant := 512; + + Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1) + of Subp_Index; + + type Succ_Index is new Nat; + No_Succ : constant Succ_Index := 0; + + type Succ_Info is record + Subp : Subp_Index; + Next : Succ_Index; + end record; + + -- The following table stores list elements for the successor lists. + -- These lists cannot be chained directly through entries in the Inlined + -- table, because a given subprogram can appear in several such lists. + + package Successors is new Table.Table ( + Table_Component_Type => Succ_Info, + Table_Index_Type => Succ_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Successors_Initial, + Table_Increment => Alloc.Successors_Increment, + Table_Name => "Successors"); + + type Subp_Info is record + Name : Entity_Id := Empty; + First_Succ : Succ_Index := No_Succ; + Count : Integer := 0; + Listed : Boolean := False; + Main_Call : Boolean := False; + Next : Subp_Index := No_Subp; + Next_Nopred : Subp_Index := No_Subp; + end record; + + package Inlined is new Table.Table ( + Table_Component_Type => Subp_Info, + Table_Index_Type => Subp_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Inlined_Initial, + Table_Increment => Alloc.Inlined_Increment, + Table_Name => "Inlined"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean; + -- Return True if Scop is in the main unit or its spec, or in a + -- parent of the main unit if it is a child unit. + + procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty); + -- Make two entries in Inlined table, for an inlined subprogram being + -- called, and for the inlined subprogram that contains the call. If + -- the call is in the main compilation unit, Caller is Empty. + + function Add_Subp (E : Entity_Id) return Subp_Index; + -- Make entry in Inlined table for subprogram E, or return table index + -- that already holds E. + + function Has_Initialized_Type (E : Entity_Id) return Boolean; + -- If a candidate for inlining contains type declarations for types with + -- non-trivial initialization procedures, they are not worth inlining. + + function Is_Nested (E : Entity_Id) return Boolean; + -- If the function is nested inside some other function, it will + -- always be compiled if that function is, so don't add it to the + -- inline list. We cannot compile a nested function outside the + -- scope of the containing function anyway. This is also the case if + -- the function is defined in a task body or within an entry (for + -- example, an initialization procedure). + + procedure Add_Inlined_Subprogram (Index : Subp_Index); + -- Add subprogram to Inlined List once all of its predecessors have been + -- placed on the list. Decrement the count of all its successors, and + -- add them to list (recursively) if count drops to zero. + + ------------------------------ + -- Deferred Cleanup Actions -- + ------------------------------ + + -- The cleanup actions for scopes that contain instantiations is delayed + -- until after expansion of those instantiations, because they may + -- contain finalizable objects or tasks that affect the cleanup code. + -- A scope that contains instantiations only needs to be finalized once, + -- even if it contains more than one instance. We keep a list of scopes + -- that must still be finalized, and call cleanup_actions after all the + -- instantiations have been completed. + + To_Clean : Elist_Id; + + procedure Add_Scope_To_Clean (Inst : Entity_Id); + -- Build set of scopes on which cleanup actions must be performed. + + procedure Cleanup_Scopes; + -- Complete cleanup actions on scopes that need it. + + -------------- + -- Add_Call -- + -------------- + + procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is + P1 : Subp_Index := Add_Subp (Called); + P2 : Subp_Index; + J : Succ_Index; + + begin + if Present (Caller) then + P2 := Add_Subp (Caller); + + -- Add P2 to the list of successors of P1, if not already there. + -- Note that P2 may contain more than one call to P1, and only + -- one needs to be recorded. + + J := Inlined.Table (P1).First_Succ; + + while J /= No_Succ loop + + if Successors.Table (J).Subp = P2 then + return; + end if; + + J := Successors.Table (J).Next; + end loop; + + -- On exit, make a successor entry for P2. + + Successors.Increment_Last; + Successors.Table (Successors.Last).Subp := P2; + Successors.Table (Successors.Last).Next := + Inlined.Table (P1).First_Succ; + Inlined.Table (P1).First_Succ := Successors.Last; + + Inlined.Table (P2).Count := Inlined.Table (P2).Count + 1; + + else + Inlined.Table (P1).Main_Call := True; + end if; + end Add_Call; + + ---------------------- + -- Add_Inlined_Body -- + ---------------------- + + procedure Add_Inlined_Body (E : Entity_Id) is + Pack : Entity_Id; + Comp_Unit : Node_Id; + + function Must_Inline return Boolean; + -- Inlining is only done if the call statement N is in the main unit, + -- or within the body of another inlined subprogram. + + function Must_Inline return Boolean is + Scop : Entity_Id := Current_Scope; + Comp : Node_Id; + + begin + -- Check if call is in main unit. + + while Scope (Scop) /= Standard_Standard + and then not Is_Child_Unit (Scop) + loop + Scop := Scope (Scop); + end loop; + + Comp := Parent (Scop); + + while Nkind (Comp) /= N_Compilation_Unit loop + Comp := Parent (Comp); + end loop; + + if (Comp = Cunit (Main_Unit) + or else Comp = Library_Unit (Cunit (Main_Unit))) + then + Add_Call (E); + return True; + end if; + + -- Call is not in main unit. See if it's in some inlined + -- subprogram. + + Scop := Current_Scope; + while Scope (Scop) /= Standard_Standard + and then not Is_Child_Unit (Scop) + loop + if Is_Overloadable (Scop) + and then Is_Inlined (Scop) + then + Add_Call (E, Scop); + return True; + end if; + + Scop := Scope (Scop); + end loop; + + return False; + + end Must_Inline; + + -- Start of processing for Add_Inlined_Body + + begin + -- Find unit containing E, and add to list of inlined bodies if needed. + -- If the body is already present, no need to load any other unit. This + -- is the case for an initialization procedure, which appears in the + -- package declaration that contains the type. It is also the case if + -- the body has already been analyzed. Finally, if the unit enclosing + -- E is an instance, the instance body will be analyzed in any case, + -- and there is no need to add the enclosing unit (whose body might not + -- be available). + + -- Library-level functions must be handled specially, because there is + -- no enclosing package to retrieve. In this case, it is the body of + -- the function that will have to be loaded. + + if not Is_Abstract (E) and then not Is_Nested (E) + and then Convention (E) /= Convention_Protected + then + Pack := Scope (E); + + if Must_Inline + and then Ekind (Pack) = E_Package + then + Set_Is_Called (E); + Comp_Unit := Parent (Pack); + + if Pack = Standard_Standard then + + -- Library-level inlined function. Add function iself to + -- list of needed units. + + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := E; + + elsif Is_Generic_Instance (Pack) then + null; + + elsif not Is_Inlined (Pack) + and then not Has_Completion (E) + and then not Scope_In_Main_Unit (Pack) + then + Set_Is_Inlined (Pack); + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; + end if; + end if; + end if; + end Add_Inlined_Body; + + ---------------------------- + -- Add_Inlined_Subprogram -- + ---------------------------- + + procedure Add_Inlined_Subprogram (Index : Subp_Index) is + E : constant Entity_Id := Inlined.Table (Index).Name; + Succ : Succ_Index; + Subp : Subp_Index; + + begin + -- Insert the current subprogram in the list of inlined subprograms + + if not Scope_In_Main_Unit (E) + and then Is_Inlined (E) + and then not Is_Nested (E) + and then not Has_Initialized_Type (E) + then + if No (Last_Inlined) then + Set_First_Inlined_Subprogram (Cunit (Main_Unit), E); + else + Set_Next_Inlined_Subprogram (Last_Inlined, E); + end if; + + Last_Inlined := E; + end if; + + Inlined.Table (Index).Listed := True; + Succ := Inlined.Table (Index).First_Succ; + + while Succ /= No_Succ loop + Subp := Successors.Table (Succ).Subp; + Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1; + + if Inlined.Table (Subp).Count = 0 then + Add_Inlined_Subprogram (Subp); + end if; + + Succ := Successors.Table (Succ).Next; + end loop; + end Add_Inlined_Subprogram; + + ------------------------ + -- Add_Scope_To_Clean -- + ------------------------ + + procedure Add_Scope_To_Clean (Inst : Entity_Id) is + Elmt : Elmt_Id; + Scop : Entity_Id := Enclosing_Dynamic_Scope (Inst); + + begin + -- If the instance appears in a library-level package declaration, + -- all finalization is global, and nothing needs doing here. + + if Scop = Standard_Standard then + return; + end if; + + Elmt := First_Elmt (To_Clean); + + while Present (Elmt) loop + + if Node (Elmt) = Scop then + return; + end if; + + Elmt := Next_Elmt (Elmt); + end loop; + + Append_Elmt (Scop, To_Clean); + end Add_Scope_To_Clean; + + -------------- + -- Add_Subp -- + -------------- + + function Add_Subp (E : Entity_Id) return Subp_Index is + Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers; + J : Subp_Index; + + procedure New_Entry; + -- Initialize entry in Inlined table. + + procedure New_Entry is + begin + Inlined.Increment_Last; + Inlined.Table (Inlined.Last).Name := E; + Inlined.Table (Inlined.Last).First_Succ := No_Succ; + Inlined.Table (Inlined.Last).Count := 0; + Inlined.Table (Inlined.Last).Listed := False; + Inlined.Table (Inlined.Last).Main_Call := False; + Inlined.Table (Inlined.Last).Next := No_Subp; + Inlined.Table (Inlined.Last).Next_Nopred := No_Subp; + end New_Entry; + + -- Start of processing for Add_Subp + + begin + if Hash_Headers (Index) = No_Subp then + New_Entry; + Hash_Headers (Index) := Inlined.Last; + return Inlined.Last; + + else + J := Hash_Headers (Index); + + while J /= No_Subp loop + + if Inlined.Table (J).Name = E then + return J; + else + Index := J; + J := Inlined.Table (J).Next; + end if; + end loop; + + -- On exit, subprogram was not found. Enter in table. Index is + -- the current last entry on the hash chain. + + New_Entry; + Inlined.Table (Index).Next := Inlined.Last; + return Inlined.Last; + end if; + end Add_Subp; + + ---------------------------- + -- Analyze_Inlined_Bodies -- + ---------------------------- + + procedure Analyze_Inlined_Bodies is + Comp_Unit : Node_Id; + J : Int; + Pack : Entity_Id; + S : Succ_Index; + + begin + Analyzing_Inlined_Bodies := False; + + if Errors_Detected = 0 then + New_Scope (Standard_Standard); + + J := 0; + while J <= Inlined_Bodies.Last + and then Errors_Detected = 0 + loop + Pack := Inlined_Bodies.Table (J); + + while Present (Pack) + and then Scope (Pack) /= Standard_Standard + and then not Is_Child_Unit (Pack) + loop + Pack := Scope (Pack); + end loop; + + Comp_Unit := Parent (Pack); + + while Present (Comp_Unit) + and then Nkind (Comp_Unit) /= N_Compilation_Unit + loop + Comp_Unit := Parent (Comp_Unit); + end loop; + + if Present (Comp_Unit) + and then Comp_Unit /= Cunit (Main_Unit) + and then Body_Required (Comp_Unit) + then + declare + Bname : constant Unit_Name_Type := + Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); + + OK : Boolean; + + begin + if not Is_Loaded (Bname) then + Load_Needed_Body (Comp_Unit, OK); + + if not OK then + Error_Msg_Unit_1 := Bname; + Error_Msg_N + ("one or more inlined subprograms accessed in $!", + Comp_Unit); + Error_Msg_Name_1 := + Get_File_Name (Bname, Subunit => False); + Error_Msg_N ("\but file{ was not found!", Comp_Unit); + raise Unrecoverable_Error; + end if; + end if; + end; + end if; + + J := J + 1; + end loop; + + -- The analysis of required bodies may have produced additional + -- generic instantiations. To obtain further inlining, we perform + -- another round of generic body instantiations. Establishing a + -- fully recursive loop between inlining and generic instantiations + -- is unlikely to yield more than this one additional pass. + + Instantiate_Bodies; + + -- The list of inlined subprograms is an overestimate, because + -- it includes inlined functions called from functions that are + -- compiled as part of an inlined package, but are not themselves + -- called. An accurate computation of just those subprograms that + -- are needed requires that we perform a transitive closure over + -- the call graph, starting from calls in the main program. Here + -- we do one step of the inverse transitive closure, and reset + -- the Is_Called flag on subprograms all of whose callers are not. + + for Index in Inlined.First .. Inlined.Last loop + S := Inlined.Table (Index).First_Succ; + + if S /= No_Succ + and then not Inlined.Table (Index).Main_Call + then + Set_Is_Called (Inlined.Table (Index).Name, False); + + while S /= No_Succ loop + + if Is_Called + (Inlined.Table (Successors.Table (S).Subp).Name) + or else Inlined.Table (Successors.Table (S).Subp).Main_Call + then + Set_Is_Called (Inlined.Table (Index).Name); + exit; + end if; + + S := Successors.Table (S).Next; + end loop; + end if; + end loop; + + -- Now that the units are compiled, chain the subprograms within + -- that are called and inlined. Produce list of inlined subprograms + -- sorted in topological order. Start with all subprograms that + -- have no prerequisites, i.e. inlined subprograms that do not call + -- other inlined subprograms. + + for Index in Inlined.First .. Inlined.Last loop + + if Is_Called (Inlined.Table (Index).Name) + and then Inlined.Table (Index).Count = 0 + and then not Inlined.Table (Index).Listed + then + Add_Inlined_Subprogram (Index); + end if; + end loop; + + -- Because Add_Inlined_Subprogram treats recursively nodes that have + -- no prerequisites left, at the end of the loop all subprograms + -- must have been listed. If there are any unlisted subprograms + -- left, there must be some recursive chains that cannot be inlined. + + for Index in Inlined.First .. Inlined.Last loop + if Is_Called (Inlined.Table (Index).Name) + and then Inlined.Table (Index).Count /= 0 + and then not Is_Predefined_File_Name + (Unit_File_Name + (Get_Source_Unit (Inlined.Table (Index).Name))) + then + Error_Msg_N + ("& cannot be inlined?", Inlined.Table (Index).Name); + -- A warning on the first one might be sufficient. + end if; + end loop; + + Pop_Scope; + end if; + end Analyze_Inlined_Bodies; + + -------------------------------- + -- Check_Body_For_Inlining -- + -------------------------------- + + procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is + Bname : Unit_Name_Type; + E : Entity_Id; + OK : Boolean; + + begin + if Is_Compilation_Unit (P) + and then not Is_Generic_Instance (P) + then + Bname := Get_Body_Name (Get_Unit_Name (Unit (N))); + E := First_Entity (P); + + while Present (E) loop + if Has_Pragma_Inline (E) then + if not Is_Loaded (Bname) then + Load_Needed_Body (N, OK); + + if not OK + and then Ineffective_Inline_Warnings + then + Error_Msg_Unit_1 := Bname; + Error_Msg_N + ("unable to inline subprograms defined in $?", P); + Error_Msg_N ("\body not found?", P); + return; + end if; + end if; + + return; + end if; + + Next_Entity (E); + end loop; + end if; + end Check_Body_For_Inlining; + + -------------------- + -- Cleanup_Scopes -- + -------------------- + + procedure Cleanup_Scopes is + Elmt : Elmt_Id; + Decl : Node_Id; + Scop : Entity_Id; + + begin + Elmt := First_Elmt (To_Clean); + + while Present (Elmt) loop + Scop := Node (Elmt); + + if Ekind (Scop) = E_Entry then + Scop := Protected_Body_Subprogram (Scop); + end if; + + if Ekind (Scop) = E_Block then + Decl := Block_Node (Scop); + + else + Decl := Unit_Declaration_Node (Scop); + + if Nkind (Decl) = N_Subprogram_Declaration + or else Nkind (Decl) = N_Task_Type_Declaration + or else Nkind (Decl) = N_Subprogram_Body_Stub + then + Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); + end if; + end if; + + New_Scope (Scop); + Expand_Cleanup_Actions (Decl); + End_Scope; + + Elmt := Next_Elmt (Elmt); + end loop; + end Cleanup_Scopes; + + -------------------------- + -- Has_Initialized_Type -- + -------------------------- + + function Has_Initialized_Type (E : Entity_Id) return Boolean is + E_Body : constant Node_Id := Get_Subprogram_Body (E); + Decl : Node_Id; + + begin + if No (E_Body) then -- imported subprogram + return False; + + else + Decl := First (Declarations (E_Body)); + + while Present (Decl) loop + + if Nkind (Decl) = N_Full_Type_Declaration + and then Present (Init_Proc (Defining_Identifier (Decl))) + then + return True; + end if; + + Next (Decl); + end loop; + end if; + + return False; + end Has_Initialized_Type; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Analyzing_Inlined_Bodies := False; + Pending_Descriptor.Init; + Pending_Instantiations.Init; + Inlined_Bodies.Init; + Successors.Init; + Inlined.Init; + + for J in Hash_Headers'Range loop + Hash_Headers (J) := No_Subp; + end loop; + end Initialize; + + ------------------------ + -- Instantiate_Bodies -- + ------------------------ + + -- Generic bodies contain all the non-local references, so an + -- instantiation does not need any more context than Standard + -- itself, even if the instantiation appears in an inner scope. + -- Generic associations have verified that the contract model is + -- satisfied, so that any error that may occur in the analysis of + -- the body is an internal error. + + procedure Instantiate_Bodies is + J : Int; + Info : Pending_Body_Info; + + begin + if Errors_Detected = 0 then + + Expander_Active := (Operating_Mode = Opt.Generate_Code); + New_Scope (Standard_Standard); + To_Clean := New_Elmt_List; + + if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then + Start_Generic; + end if; + + -- A body instantiation may generate additional instantiations, so + -- the following loop must scan to the end of a possibly expanding + -- set (that's why we can't simply use a FOR loop here). + + J := 0; + + while J <= Pending_Instantiations.Last + and then Errors_Detected = 0 + loop + + Info := Pending_Instantiations.Table (J); + + -- If the instantiation node is absent, it has been removed + -- as part of unreachable code. + + if No (Info.Inst_Node) then + null; + + elsif Nkind (Info. Act_Decl) = N_Package_Declaration then + Instantiate_Package_Body (Info); + Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl)); + + else + Instantiate_Subprogram_Body (Info); + end if; + + J := J + 1; + end loop; + + -- Reset the table of instantiations. Additional instantiations + -- may be added through inlining, when additional bodies are + -- analyzed. + + Pending_Instantiations.Init; + + -- We can now complete the cleanup actions of scopes that contain + -- pending instantiations (skipped for generic units, since we + -- never need any cleanups in generic units). + -- pending instantiations. + + if Expander_Active + and then not Is_Generic_Unit (Main_Unit_Entity) + then + Cleanup_Scopes; + + -- Also generate subprogram descriptors that were delayed + + for J in Pending_Descriptor.First .. Pending_Descriptor.Last loop + declare + Ent : constant Entity_Id := Pending_Descriptor.Table (J); + + begin + if Is_Subprogram (Ent) then + Generate_Subprogram_Descriptor_For_Subprogram + (Get_Subprogram_Body (Ent), Ent); + + elsif Ekind (Ent) = E_Package then + Generate_Subprogram_Descriptor_For_Package + (Parent (Declaration_Node (Ent)), Ent); + + elsif Ekind (Ent) = E_Package_Body then + Generate_Subprogram_Descriptor_For_Package + (Declaration_Node (Ent), Ent); + end if; + end; + end loop; + + elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then + End_Generic; + end if; + + Pop_Scope; + end if; + end Instantiate_Bodies; + + --------------- + -- Is_Nested -- + --------------- + + function Is_Nested (E : Entity_Id) return Boolean is + Scop : Entity_Id := Scope (E); + + begin + while Scop /= Standard_Standard loop + if Ekind (Scop) in Subprogram_Kind then + return True; + + elsif Ekind (Scop) = E_Task_Type + or else Ekind (Scop) = E_Entry + or else Ekind (Scop) = E_Entry_Family then + return True; + end if; + + Scop := Scope (Scop); + end loop; + + return False; + end Is_Nested; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Pending_Instantiations.Locked := True; + Inlined_Bodies.Locked := True; + Successors.Locked := True; + Inlined.Locked := True; + Pending_Instantiations.Release; + Inlined_Bodies.Release; + Successors.Release; + Inlined.Release; + end Lock; + + -------------------------- + -- Remove_Dead_Instance -- + -------------------------- + + procedure Remove_Dead_Instance (N : Node_Id) is + J : Int; + + begin + J := 0; + + while J <= Pending_Instantiations.Last loop + + if Pending_Instantiations.Table (J).Inst_Node = N then + Pending_Instantiations.Table (J).Inst_Node := Empty; + return; + end if; + + J := J + 1; + end loop; + end Remove_Dead_Instance; + + ------------------------ + -- Scope_In_Main_Unit -- + ------------------------ + + function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean is + Comp : Node_Id; + S : Entity_Id := Scop; + Ent : Entity_Id := Cunit_Entity (Main_Unit); + + begin + -- The scope may be within the main unit, or it may be an ancestor + -- of the main unit, if the main unit is a child unit. In both cases + -- it makes no sense to process the body before the main unit. In + -- the second case, this may lead to circularities if a parent body + -- depends on a child spec, and we are analyzing the child. + + while Scope (S) /= Standard_Standard + and then not Is_Child_Unit (S) + loop + S := Scope (S); + end loop; + + Comp := Parent (S); + + while Present (Comp) + and then Nkind (Comp) /= N_Compilation_Unit + loop + Comp := Parent (Comp); + end loop; + + if Is_Child_Unit (Ent) then + + while Present (Ent) + and then Is_Child_Unit (Ent) + loop + if Scope (Ent) = S then + return True; + end if; + + Ent := Scope (Ent); + end loop; + end if; + + return + Comp = Cunit (Main_Unit) + or else Comp = Library_Unit (Cunit (Main_Unit)); + end Scope_In_Main_Unit; + +end Inline; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads new file mode 100644 index 00000000000..788d33c9376 --- /dev/null +++ b/gcc/ada/inline.ads @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N L I N E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.17 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This module handles two kinds of inlining activity: + +-- a) Instantiation of generic bodies. This is done unconditionally, after +-- analysis and expansion of the main unit. + +-- b) Compilation of unit bodies that contain the bodies of inlined sub- +-- programs. This is done only if inlining is enabled (-gnatn). Full inlining +-- requires that a) an b) be mutually recursive, because each step may +-- generate another generic expansion and further inlined calls. For now each +-- of them uses a workpile algorithm, but they are called independently from +-- Frontend, and thus are not mutually recursive. + +with Alloc; +with Table; +with Types; use Types; + +package Inline is + + -------------------------------- + -- Generic Body Instantiation -- + -------------------------------- + + -- The bodies of generic instantiations are built after semantic analysis + -- of the main unit is complete. Generic instantiations are saved in a + -- global data structure, and the bodies constructed by means of a separate + -- analysis and expansion step. + + -- See full description in body of Sem_Ch12 for details + + type Pending_Body_Info is record + Inst_Node : Node_Id; + -- Node for instantiation that requires the body + + Act_Decl : Node_Id; + -- Declaration for package or subprogram spec for instantiation + + Expander_Status : Boolean; + -- If the body is instantiated only for semantic checking, expansion + -- must be inhibited. + + Current_Sem_Unit : Unit_Number_Type; + -- The semantic unit within which the instantiation is found. Must + -- be restored when compiling the body, to insure that internal enti- + -- ties use the same counter and are unique over spec and body. + end record; + + package Pending_Instantiations is new Table.Table ( + Table_Component_Type => Pending_Body_Info, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Pending_Instantiations_Initial, + Table_Increment => Alloc.Pending_Instantiations_Increment, + Table_Name => "Pending_Instantiations"); + + -- The following table records subprograms and packages for which + -- generation of subprogram descriptors must be delayed. + + package Pending_Descriptor is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Pending_Instantiations_Initial, + Table_Increment => Alloc.Pending_Instantiations_Increment, + Table_Name => "Pending_Descriptor"); + + Analyzing_Inlined_Bodies : Boolean; + -- This flag is set False by the call to Initialize, and then is set + -- True by the call to Analyze_Inlined_Bodies. It is used to suppress + -- generation of subprogram descriptors for inlined bodies. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Initialize internal tables + + procedure Lock; + -- Lock internal tables before calling backend + + procedure Instantiate_Bodies; + -- This procedure is called after semantic analysis is complete, to + -- instantiate the bodies of generic instantiations that appear in the + -- compilation unit. + + procedure Add_Inlined_Body (E : Entity_Id); + -- E is an inlined subprogram appearing in a call, either explicitly, or + -- a discriminant check for which gigi builds a call. Add E's enclosing + -- unit to Inlined_Bodies so that body of E can be subsequently retrieved + -- and analyzed. + + procedure Analyze_Inlined_Bodies; + -- At end of compilation, analyze the bodies of all units that contain + -- inlined subprograms that are actually called. + + procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id); + -- If front-end inlining is enabled and a package declaration contains + -- inlined subprograms, load and compile the package body to collect the + -- bodies of these subprograms, so they are available to inline calls. + -- N is the compilation unit for the package. + + procedure Remove_Dead_Instance (N : Node_Id); + -- If an instantiation appears in unreachable code, delete the pending + -- body instance. + +end Inline; diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads new file mode 100644 index 00000000000..40cedcf9a87 --- /dev/null +++ b/gcc/ada/interfac.ads @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Assumes integer sizes of 8, 16, 32 and 64 are available, and that the +-- floating-point formats are IEEE compatible. + +-- There is a specialized version of this package for OpenVMS. + +package Interfaces is +pragma Pure (Interfaces); + + type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1; + for Integer_8'Size use 8; + + type Integer_16 is range -2 ** 15 .. 2 ** 15 - 1; + for Integer_16'Size use 16; + + type Integer_32 is range -2 ** 31 .. 2 ** 31 - 1; + for Integer_32'Size use 32; + + type Integer_64 is range -2 ** 63 .. 2 ** 63 - 1; + for Integer_64'Size use 64; + + type Unsigned_8 is mod 2 ** 8; + for Unsigned_8'Size use 8; + + type Unsigned_16 is mod 2 ** 16; + for Unsigned_16'Size use 16; + + type Unsigned_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type Unsigned_64 is mod 2 ** 64; + for Unsigned_64'Size use 64; + + function Shift_Left + (Value : Unsigned_8; + Amount : Natural) + return Unsigned_8; + + function Shift_Right + (Value : Unsigned_8; + Amount : Natural) + return Unsigned_8; + + function Shift_Right_Arithmetic + (Value : Unsigned_8; + Amount : Natural) + return Unsigned_8; + + function Rotate_Left + (Value : Unsigned_8; + Amount : Natural) + return Unsigned_8; + + function Rotate_Right + (Value : Unsigned_8; + Amount : Natural) + return Unsigned_8; + + function Shift_Left + (Value : Unsigned_16; + Amount : Natural) + return Unsigned_16; + + function Shift_Right + (Value : Unsigned_16; + Amount : Natural) + return Unsigned_16; + + function Shift_Right_Arithmetic + (Value : Unsigned_16; + Amount : Natural) + return Unsigned_16; + + function Rotate_Left + (Value : Unsigned_16; + Amount : Natural) + return Unsigned_16; + + function Rotate_Right + (Value : Unsigned_16; + Amount : Natural) + return Unsigned_16; + + function Shift_Left + (Value : Unsigned_32; + Amount : Natural) + return Unsigned_32; + + function Shift_Right + (Value : Unsigned_32; + Amount : Natural) + return Unsigned_32; + + function Shift_Right_Arithmetic + (Value : Unsigned_32; + Amount : Natural) + return Unsigned_32; + + function Rotate_Left + (Value : Unsigned_32; + Amount : Natural) + return Unsigned_32; + + function Rotate_Right + (Value : Unsigned_32; + Amount : Natural) + return Unsigned_32; + + function Shift_Left + (Value : Unsigned_64; + Amount : Natural) + return Unsigned_64; + + function Shift_Right + (Value : Unsigned_64; + Amount : Natural) + return Unsigned_64; + + function Shift_Right_Arithmetic + (Value : Unsigned_64; + Amount : Natural) + return Unsigned_64; + + function Rotate_Left + (Value : Unsigned_64; + Amount : Natural) + return Unsigned_64; + + function Rotate_Right + (Value : Unsigned_64; + Amount : Natural) + return Unsigned_64; + + pragma Import (Intrinsic, Shift_Left); + pragma Import (Intrinsic, Shift_Right); + pragma Import (Intrinsic, Shift_Right_Arithmetic); + pragma Import (Intrinsic, Rotate_Left); + pragma Import (Intrinsic, Rotate_Right); + + -- Floating point types. We assume that we are on an IEEE machine, and + -- that the types Short_Float and Long_Float in Standard refer to the + -- 32-bit short and 64-bit long IEEE forms. Furthermore, if there is + -- an extended float, we assume that it is available as Long_Long_Float. + -- Note: it is harmless, and explicitly permitted, to include additional + -- types in interfaces, so it is not wrong to have IEEE_Extended_Float + -- defined even if the extended format is not available. + + type IEEE_Float_32 is new Short_Float; + type IEEE_Float_64 is new Long_Float; + type IEEE_Extended_Float is new Long_Long_Float; + +end Interfaces; diff --git a/gcc/ada/io-aux.c b/gcc/ada/io-aux.c new file mode 100644 index 00000000000..33fbd5f2f8e --- /dev/null +++ b/gcc/ada/io-aux.c @@ -0,0 +1,54 @@ +/**************************************************************************** + * * + * GNAT RUN-TIME COMPONENTS * + * * + * A - T R A N S * + * * + * C Implementation File * + * * + * $Revision: 1.5 $ + * * + * Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion 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. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +#include <stdio.h> + +/* Function wrappers are needed to access the values from Ada which are */ +/* defined as C macros. */ + +FILE *c_stdin (void) { return stdin; } +FILE *c_stdout (void) { return stdout;} +FILE *c_stderr (void) { return stderr;} + +#ifndef SEEK_SET /* Symbolic constants for the "fseek" function: */ +#define SEEK_SET 0 /* Set file pointer to offset */ +#define SEEK_CUR 1 /* Set file pointer to its current value plus offset */ +#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */ +#endif + +int seek_set_function (void) { return SEEK_SET; } +int seek_end_function (void) { return SEEK_END; } +void *null_function (void) { return NULL; } + +int c_fileno (FILE *s) { return fileno (s); } diff --git a/gcc/ada/ioexcept.ads b/gcc/ada/ioexcept.ads new file mode 100644 index 00000000000..ef8c1ae418d --- /dev/null +++ b/gcc/ada/ioexcept.ads @@ -0,0 +1,20 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- I O _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_95; +with Ada.IO_Exceptions; +package IO_Exceptions renames Ada.IO_Exceptions; diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb new file mode 100644 index 00000000000..27b634dabe1 --- /dev/null +++ b/gcc/ada/itypes.adb @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I T Y P E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.31 $ +-- -- +-- Copyright (C) 1992-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; + +package body Itypes is + + ------------------ + -- Create_Itype -- + ------------------ + + function Create_Itype + (Ekind : Entity_Kind; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Suffix_Index : Nat := 0; + Scope_Id : Entity_Id := Current_Scope) + return Entity_Id + is + Typ : Entity_Id; + + begin + if Related_Id = Empty then + Typ := New_Internal_Entity (Ekind, Scope_Id, Sloc (Related_Nod), 'T'); + Set_Public_Status (Typ); + + else + Typ := New_External_Entity + (Ekind, Scope_Id, Sloc (Related_Nod), Related_Id, Suffix, + Suffix_Index, 'T'); + end if; + + Init_Size_Align (Typ); + Set_Etype (Typ, Any_Type); + Set_Is_Itype (Typ); + Set_Associated_Node_For_Itype (Typ, Related_Nod); + return Typ; + end Create_Itype; + +end Itypes; diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads new file mode 100644 index 00000000000..b44a28ee7d8 --- /dev/null +++ b/gcc/ada/itypes.ads @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.22 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995,1996 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains declarations for handling of implicit types + +with Einfo; use Einfo; +with Sem_Util; use Sem_Util; +with Types; use Types; + +package Itypes is + + -------------------- + -- Implicit Types -- + -------------------- + + -- Implicit types are types and subtypes created by the semantic phase + -- or the expander to reflect the underlying semantics. These could be + -- generated by building trees for corresponding declarations and then + -- analyzing these trees, but there are three reasons for not doing this: + + -- 1. The declarations would require more tree nodes + + -- 2. In some cases, the elaboration of these types is associated + -- with internal nodes in the tree. + + -- 3. For some types, notably class wide types, there is no Ada + -- declaration that would correspond to the desired entity. + + -- So instead, implicit types are constructed by simply creating an + -- appropriate entity with the help of routines in this package. These + -- entities are fully decorated, as described in Einfo (just as though + -- they had been created by the normal analysis procedure). + + -- The type declaration declaring an Itype must be analyzed with checks + -- off because this declaration has not been inserted in the tree (if it + -- has been then it is not an itype), and hence checks that would be + -- generated during the analysis cannot be inserted in the tree. At any + -- rate, itype analysis should always be done with checks off, otherwise + -- duplicate checks will most likely be emitted. + + -- Unlike types declared explicitly, implicit types are defined on first + -- use, which means that Gigi detects the use of such types, and defines + -- them at the point of the first use automatically. + + -- Although Itypes are not explicitly declared, they are associated with + -- a specific node in the tree (roughly the node that caused them to be + -- created), via the Associated_Node_For_Itype field. This association is + -- used particularly by New_Copy_Tree, which uses it to determine whether + -- or not to copy a referenced Itype. If the associated node is part of + -- the tree to be copied by New_Copy_Tree, then (since the idea of the + -- call to New_Copy_Tree is to create a complete duplicate of a tree, + -- as though it had appeared separately int he source), the Itype in + -- question is duplicated as part of the New_Copy_Tree processing. + + ----------------- + -- Subprograms -- + ----------------- + + function Create_Itype + (Ekind : Entity_Kind; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' '; + Suffix_Index : Nat := 0; + Scope_Id : Entity_Id := Current_Scope) + return Entity_Id; + -- Used to create a new Itype. + -- + -- Related_Nod is the node for which this Itype was created. It is + -- set as the Associated_Node_For_Itype of the new itype. The Sloc of + -- the new Itype is that of this node. + -- + -- Related_Id is present only if the implicit type name may be referenced + -- as a public symbol, and thus needs a unique external name. The name + -- is created by a call to: + -- + -- New_External_Name (Chars (Related_Id), Suffix, Suffix_Index, 'T') + -- + -- If the implicit type does not need an external name, then the + -- Related_Id parameter is omitted (and hence Empty). In this case + -- Suffix and Suffix_Index are ignored and the implicit type name is + -- created by a call to New_Internal_Name ('T'). + -- + -- Note that in all cases, the name starts with "T". This is used + -- to identify implicit types in the error message handling circuits. + -- + -- The Scope_Id parameter specifies the scope of the created type, and + -- is normally the Current_Scope as shown, but can be set otherwise. + +end Itypes; diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb new file mode 100644 index 00000000000..3f160e6fd4d --- /dev/null +++ b/gcc/ada/krunch.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- K R U N C H -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1992-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +procedure Krunch + (Buffer : in out String; + Len : in out Natural; + Maxlen : Natural; + No_Predef : Boolean) + +is + B1 : Character renames Buffer (1); + Curlen : Natural; + Krlen : Natural; + Num_Seps : Natural; + Startloc : Natural; + +begin + -- Deal with special predefined children cases. Startloc is the first + -- location for the krunch, set to 1, except for the predefined children + -- case, where it is set to 3, to start after the standard prefix. + + if No_Predef then + Startloc := 1; + Curlen := Len; + Krlen := Maxlen; + + elsif Len >= 18 + and then Buffer (1 .. 17) = "ada-wide_text_io-" + then + Startloc := 3; + Buffer (2 .. 5) := "-wt-"; + Buffer (6 .. Len - 12) := Buffer (18 .. Len); + Curlen := Len - 12; + Krlen := 8; + + elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then + Startloc := 3; + Buffer (2 .. Len - 2) := Buffer (4 .. Len); + Curlen := Len - 2; + Krlen := 8; + + elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then + Startloc := 3; + Buffer (2 .. Len - 3) := Buffer (5 .. Len); + Curlen := Len - 3; + Krlen := 8; + + elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then + Startloc := 3; + Buffer (2 .. Len - 5) := Buffer (7 .. Len); + Curlen := Len - 5; + Krlen := 8; + + elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then + Startloc := 3; + Buffer (2 .. Len - 9) := Buffer (11 .. Len); + Curlen := Len - 9; + Krlen := 8; + + -- For the renamings in the obsolescent section, we also force krunching + -- to 8 characters, but no other special processing is required here. + -- Note that text_io and calendar are already short enough anyway. + + elsif (Len = 9 and then Buffer (1 .. 9) = "direct_io") + or else (Len = 10 and then Buffer (1 .. 10) = "interfaces") + or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions") + or else (Len = 12 and then Buffer (1 .. 12) = "machine_code") + or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io") + or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion") + or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation") + then + Startloc := 1; + Krlen := 8; + Curlen := Len; + + -- Special case of a child unit whose parent unit is a single letter that + -- is A, G, I, or S. In order to prevent confusion with krunched names + -- of predefined units use a tilde rather than a minus as the second + -- character of the file name. On VMS a tilde is an illegal character + -- in a file name, so a dollar_sign is used instead. + + elsif Len > 1 + and then Buffer (2) = '-' + and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's') + and then Len <= Maxlen + then + if Hostparm.OpenVMS then + Buffer (2) := '$'; + else + Buffer (2) := '~'; + end if; + + return; + + -- Normal case, not a predefined file + + else + Startloc := 1; + Curlen := Len; + Krlen := Maxlen; + end if; + + -- Immediate return if file name is short enough now + + if Curlen <= Krlen then + Len := Curlen; + return; + end if; + + -- For now, refuse to krunch a name that contains an ESC character (wide + -- character sequence) since it's too much trouble to do this right ??? + + for J in 1 .. Curlen loop + if Buffer (J) = ASCII.ESC then + return; + end if; + end loop; + + -- Count number of separators (minus signs and underscores) and for now + -- replace them by spaces. We keep them around till the end to control + -- the krunching process, and then we eliminate them as the last step + + Num_Seps := 0; + + for J in Startloc .. Curlen loop + if Buffer (J) = '-' or else Buffer (J) = '_' then + Buffer (J) := ' '; + Num_Seps := Num_Seps + 1; + end if; + end loop; + + -- Now we do the one character at a time krunch till we are short enough + + while Curlen - Num_Seps > Krlen loop + declare + Long_Length : Natural := 0; + Long_Last : Natural := 0; + Piece_Start : Natural; + Ptr : Natural; + + begin + Ptr := Startloc; + + -- Loop through pieces to find longest piece + + while Ptr <= Curlen loop + Piece_Start := Ptr; + + -- Loop through characters in one piece of name + + while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop + Ptr := Ptr + 1; + end loop; + + if Ptr - Piece_Start > Long_Length then + Long_Length := Ptr - Piece_Start; + Long_Last := Ptr - 1; + end if; + + Ptr := Ptr + 1; + end loop; + + -- Remove last character of longest piece + + if Long_Last < Curlen then + Buffer (Long_Last .. Curlen - 1) := + Buffer (Long_Last + 1 .. Curlen); + end if; + + Curlen := Curlen - 1; + end; + end loop; + + -- Final step, remove the spaces + + Len := 0; + + for J in 1 .. Curlen loop + if Buffer (J) /= ' ' then + Len := Len + 1; + Buffer (Len) := Buffer (J); + end if; + end loop; + + return; + +end Krunch; diff --git a/gcc/ada/krunch.ads b/gcc/ada/krunch.ads new file mode 100644 index 00000000000..54877bce5a7 --- /dev/null +++ b/gcc/ada/krunch.ads @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- K R U N C H -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.13 $ -- +-- -- +-- Copyright (C) 1992-1997 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure implements file name crunching + +-- First, the name is divided into segments separated by minus signs and +-- underscores, then all minus signs and underscores are eliminated. If +-- this leaves the name short enough, we are done. + +-- If not, then the longest segment is located (left-most if there are +-- two of equal length), and shortened by dropping its last character. +-- This is repeated until the name is short enough. + +-- As an example, consider the krunch of our-strings-wide_fixed.adb +-- to fit the name into 8 characters as required by DOS: + +-- our-strings-wide_fixed 22 +-- our strings wide fixed 19 +-- our string wide fixed 18 +-- our strin wide fixed 17 +-- our stri wide fixed 16 +-- our stri wide fixe 15 +-- our str wide fixe 14 +-- our str wid fixe 13 +-- our str wid fix 12 +-- ou str wid fix 11 +-- ou st wid fix 10 +-- ou st wi fix 9 +-- ou st wi fi 8 + +-- Final file name: OUSTWIFX.ADB + +-- A special rule applies for children of System, Ada, Gnat, and Interfaces. +-- In these cases, the following special prefix replacements occur: + +-- ada- replaced by a- +-- gnat- replaced by g- +-- interfaces- replaced by i- +-- system- replaced by s- + +-- The rest of the name is krunched in the usual manner described above. +-- In addition, these names, as well as the names of the renamed packages +-- from the obsolescent features annex, are always krunched to 8 characters +-- regardless of the setting of Maxlen. + +-- As an example of this special rule, consider ada-strings-wide_fixed.adb +-- which gets krunched as follows: + +-- ada-strings-wide_fixed 22 +-- a- strings wide fixed 18 +-- a- string wide fixed 17 +-- a- strin wide fixed 16 +-- a- stri wide fixed 15 +-- a- stri wide fixe 14 +-- a- str wide fixe 13 +-- a- str wid fixe 12 +-- a- str wid fix 11 +-- a- st wid fix 10 +-- a- st wi fix 9 +-- a- st wi fi 8 + +-- Final file name: A-STWIFX.ADB + +-- Since children of units named A, G, I or S might conflict with the names +-- of predefined units, the naming rule in that case is that the first hyphen +-- is replaced by a tilde sign. + +-- Note: as described below, this special treatment of predefined library +-- unit file names can be inhibited by setting the No_Predef flag. + +-- Of course there is no guarantee that this algorithm results in uniquely +-- crunched names (nor, obviously, is there any algorithm which would do so) +-- In fact we run into such a case in the standard library routines with +-- children of Wide_Text_IO, so a special rule is applied to deal with this +-- clash, namely the prefix ada-wide_text_io- is replaced by a-wt- and then +-- the normal crunching rules are applied, so that for example, the unit: + +-- Ada.Wide_Text_IO.Float_IO + +-- has the file name + +-- a-wtflio + +-- This is the only irregularity required (so far!) to keep the file names +-- unique in the standard predefined libraries. + +procedure Krunch + (Buffer : in out String; + Len : in out Natural; + Maxlen : Natural; + No_Predef : Boolean); +pragma Elaborate_Body (Krunch); +-- The full file name is stored in Buffer (1 .. Len) on entry. The file +-- name is crunched in place and on return Len is updated, so that the +-- resulting krunched name is in Buffer (1 .. Len) where Len <= Maxlen. +-- Note that Len may be less than or equal to Maxlen on entry, in which +-- case it may be possible that Krunch does not modify Buffer. The fourth +-- parameter, No_Predef, is a switch which, if set to True, disables the +-- normal special treatment of predefined library unit file names. +-- +-- Note: the string Buffer must have a lower bound of 1, and may not +-- contain any blanks (in particular, it must not have leading blanks). diff --git a/gcc/ada/lang-options.h b/gcc/ada/lang-options.h new file mode 100644 index 00000000000..bd42c9b6bbd --- /dev/null +++ b/gcc/ada/lang-options.h @@ -0,0 +1,39 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L A N G - O P T I O N S * + * * + * C Header File * + * * + * $Revision: 1.5 $ + * * + * Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +DEFINE_LANG_NAME ("Ada") + +/* This is the contribution to the `lang_options' array in gcc.c for + GNAT. */ + + {"-gnat", "Specify options to GNAT"}, + {"-gant", ""}, + {"-I", "Name of directory to search for sources"}, + {"-nostdinc", "Don't use system library for sources"}, + + diff --git a/gcc/ada/lang-specs.h b/gcc/ada/lang-specs.h new file mode 100644 index 00000000000..0019bb939d0 --- /dev/null +++ b/gcc/ada/lang-specs.h @@ -0,0 +1,43 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L A N G - S P E C S * + * * + * C Header File * + * * + * $Revision: 1.17 $ + * * + * Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This is the contribution to the `default_compilers' array in gcc.c for + GNAT. */ + + {".ads", "@ada"}, + {".adb", "@ada"}, + {"@ada", + "gnat1 %{^I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\ + -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\ + %{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\ + %{!S:%{o*:%w%*-gnatO}} \ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %i %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:%{!gnatc:%{!gnatz:%{!gnats:as %a %Y %{c:%W{o*}%{!o*:-o %w%b%O}}\ + %{!c:%e-c or -S required for Ada}\ + %{!pipe:%g.s} %A\n}}}} "}, diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb new file mode 100644 index 00000000000..2ac451768a6 --- /dev/null +++ b/gcc/ada/layout.adb @@ -0,0 +1,2573 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L A Y O U T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.33 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Repinfo; use Repinfo; +with Sem; use Sem; +with Sem_Ch13; use Sem_Ch13; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +package body Layout is + + ------------------------ + -- Local Declarations -- + ------------------------ + + SSU : constant Int := Ttypes.System_Storage_Unit; + -- Short hand for System_Storage_Unit + + Vname : constant Name_Id := Name_uV; + -- Formal parameter name used for functions generated for size offset + -- values that depend on the discriminant. All such functions have the + -- following form: + -- + -- function xxx (V : vtyp) return Unsigned is + -- begin + -- return ... expression involving V.discrim + -- end xxx; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Adjust_Esize_Alignment (E : Entity_Id); + -- E is the entity for a type or object. This procedure checks that the + -- size and alignment are compatible, and if not either gives an error + -- message if they cannot be adjusted or else adjusts them appropriately. + + function Assoc_Add + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + -- This is like Make_Op_Add except that it optimizes some cases knowing + -- that associative rearrangement is allowed for constant folding if one + -- of the operands is a compile time known value. + + function Assoc_Multiply + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + -- This is like Make_Op_Multiply except that it optimizes some cases + -- knowing that associative rearrangement is allowed for constant + -- folding if one of the operands is a compile time known value + + function Assoc_Subtract + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + -- This is like Make_Op_Subtract except that it optimizes some cases + -- knowing that associative rearrangement is allowed for constant + -- folding if one of the operands is a compile time known value + + function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id; + -- Given expressions for the low bound (Lo) and the high bound (Hi), + -- Build an expression for the value hi-lo+1, converted to type + -- Standard.Unsigned. Takes care of the case where the operands + -- are of an enumeration type (so that the subtraction cannot be + -- done directly) by applying the Pos operator to Hi/Lo first. + + function Expr_From_SO_Ref + (Loc : Source_Ptr; + D : SO_Ref) + return Node_Id; + -- Given a value D from a size or offset field, return an expression + -- representing the value stored. If the value is known at compile time, + -- then an N_Integer_Literal is returned with the appropriate value. If + -- the value references a constant entity, then an N_Identifier node + -- referencing this entity is returned. The Loc value is used for the + -- Sloc value of constructed notes. + + function SO_Ref_From_Expr + (Expr : Node_Id; + Ins_Type : Entity_Id; + Vtype : Entity_Id := Empty) + return Dynamic_SO_Ref; + -- This routine is used in the case where a size/offset value is dynamic + -- and is represented by the expression Expr. SO_Ref_From_Expr checks if + -- the Expr contains a reference to the identifier V, and if so builds + -- a function depending on discriminants of the formal parameter V which + -- is of type Vtype. If not, then a constant entity with the value Expr + -- is built. The result is a Dynamic_SO_Ref to the created entity. Note + -- that Vtype can be omitted if Expr does not contain any reference to V. + -- the created entity. The declaration created is inserted in the freeze + -- actions of Ins_Type, which also supplies the Sloc for created nodes. + -- This function also takes care of making sure that the expression is + -- properly analyzed and resolved (which may not be the case yet if we + -- build the expression in this unit). + + function Get_Max_Size (E : Entity_Id) return Node_Id; + -- E is an array type or subtype that has at least one index bound that + -- is the value of a record discriminant. For such an array, the function + -- computes an expression that yields the maximum possible size of the + -- array in storage units. The result is not defined for any other type, + -- or for arrays that do not depend on discriminants, and it is a fatal + -- error to call this unless Size_Depends_On_Discrminant (E) is True. + + procedure Layout_Array_Type (E : Entity_Id); + -- Front end layout of non-bit-packed array type or subtype + + procedure Layout_Record_Type (E : Entity_Id); + -- Front end layout of record type + -- Variant records not handled yet ??? + + procedure Rewrite_Integer (N : Node_Id; V : Uint); + -- Rewrite node N with an integer literal whose value is V. The Sloc + -- for the new node is taken from N, and the type of the literal is + -- set to a copy of the type of N on entry. + + procedure Set_And_Check_Static_Size + (E : Entity_Id; + Esiz : SO_Ref; + RM_Siz : SO_Ref); + -- This procedure is called to check explicit given sizes (possibly + -- stored in the Esize and RM_Size fields of E) against computed + -- Object_Size (Esiz) and Value_Size (RM_Siz) values. Appropriate + -- errors and warnings are posted if specified sizes are inconsistent + -- with specified sizes. On return, the Esize and RM_Size fields of + -- E are set (either from previously given values, or from the newly + -- computed values, as appropriate). + + ---------------------------- + -- Adjust_Esize_Alignment -- + ---------------------------- + + procedure Adjust_Esize_Alignment (E : Entity_Id) is + Abits : Int; + Esize_Set : Boolean; + + begin + -- Nothing to do if size unknown + + if Unknown_Esize (E) then + return; + end if; + + -- Determine if size is constrained by an attribute definition clause + -- which must be obeyed. If so, we cannot increase the size in this + -- routine. + + -- For a type, the issue is whether an object size clause has been + -- set. A normal size clause constrains only the value size (RM_Size) + + if Is_Type (E) then + Esize_Set := Has_Object_Size_Clause (E); + + -- For an object, the issue is whether a size clause is present + + else + Esize_Set := Has_Size_Clause (E); + end if; + + -- If size is known it must be a multiple of the byte size + + if Esize (E) mod SSU /= 0 then + + -- If not, and size specified, then give error + + if Esize_Set then + Error_Msg_NE + ("size for& not a multiple of byte size", Size_Clause (E), E); + return; + + -- Otherwise bump up size to a byte boundary + + else + Set_Esize (E, (Esize (E) + SSU - 1) / SSU * SSU); + end if; + end if; + + -- Now we have the size set, it must be a multiple of the alignment + -- nothing more we can do here if the alignment is unknown here. + + if Unknown_Alignment (E) then + return; + end if; + + -- At this point both the Esize and Alignment are known, so we need + -- to make sure they are consistent. + + Abits := UI_To_Int (Alignment (E)) * SSU; + + if Esize (E) mod Abits = 0 then + return; + end if; + + -- Here we have a situation where the Esize is not a multiple of + -- the alignment. We must either increase Esize or reduce the + -- alignment to correct this situation. + + -- The case in which we can decrease the alignment is where the + -- alignment was not set by an alignment clause, and the type in + -- question is a discrete type, where it is definitely safe to + -- reduce the alignment. For example: + + -- t : integer range 1 .. 2; + -- for t'size use 8; + + -- In this situation, the initial alignment of t is 4, copied from + -- the Integer base type, but it is safe to reduce it to 1 at this + -- stage, since we will only be loading a single byte. + + if Is_Discrete_Type (Etype (E)) + and then not Has_Alignment_Clause (E) + then + loop + Abits := Abits / 2; + exit when Esize (E) mod Abits = 0; + end loop; + + Init_Alignment (E, Abits / SSU); + return; + end if; + + -- Now the only possible approach left is to increase the Esize + -- but we can't do that if the size was set by a specific clause. + + if Esize_Set then + Error_Msg_NE + ("size for& is not a multiple of alignment", + Size_Clause (E), E); + + -- Otherwise we can indeed increase the size to a multiple of alignment + + else + Set_Esize (E, ((Esize (E) + (Abits - 1)) / Abits) * Abits); + end if; + end Adjust_Esize_Alignment; + + --------------- + -- Assoc_Add -- + --------------- + + function Assoc_Add + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + L : Node_Id; + R : Uint; + + begin + -- Case of right operand is a constant + + if Compile_Time_Known_Value (Right_Opnd) then + L := Left_Opnd; + R := Expr_Value (Right_Opnd); + + -- Case of left operand is a constant + + elsif Compile_Time_Known_Value (Left_Opnd) then + L := Right_Opnd; + R := Expr_Value (Left_Opnd); + + -- Neither operand is a constant, do the addition with no optimization + + else + return Make_Op_Add (Loc, Left_Opnd, Right_Opnd); + end if; + + -- Case of left operand is an addition + + if Nkind (L) = N_Op_Add then + + -- (C1 + E) + C2 = (C1 + C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) + R); + return L; + + -- (E + C1) + C2 = E + (C1 + C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) + R); + return L; + end if; + + -- Case of left operand is a subtraction + + elsif Nkind (L) = N_Op_Subtract then + + -- (C1 - E) + C2 = (C1 + C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) + R); + return L; + + -- (E - C1) + C2 = E - (C1 - C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) - R); + return L; + end if; + end if; + + -- Not optimizable, do the addition + + return Make_Op_Add (Loc, Left_Opnd, Right_Opnd); + end Assoc_Add; + + -------------------- + -- Assoc_Multiply -- + -------------------- + + function Assoc_Multiply + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + L : Node_Id; + R : Uint; + + begin + -- Case of right operand is a constant + + if Compile_Time_Known_Value (Right_Opnd) then + L := Left_Opnd; + R := Expr_Value (Right_Opnd); + + -- Case of left operand is a constant + + elsif Compile_Time_Known_Value (Left_Opnd) then + L := Right_Opnd; + R := Expr_Value (Left_Opnd); + + -- Neither operand is a constant, do the multiply with no optimization + + else + return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd); + end if; + + -- Case of left operand is an multiplication + + if Nkind (L) = N_Op_Multiply then + + -- (C1 * E) * C2 = (C1 * C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) * R); + return L; + + -- (E * C1) * C2 = E * (C1 * C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) * R); + return L; + end if; + end if; + + -- Not optimizable, do the multiplication + + return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd); + end Assoc_Multiply; + + -------------------- + -- Assoc_Subtract -- + -------------------- + + function Assoc_Subtract + (Loc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + L : Node_Id; + R : Uint; + + begin + -- Case of right operand is a constant + + if Compile_Time_Known_Value (Right_Opnd) then + L := Left_Opnd; + R := Expr_Value (Right_Opnd); + + -- Right operand is a constant, do the subtract with no optimization + + else + return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd); + end if; + + -- Case of left operand is an addition + + if Nkind (L) = N_Op_Add then + + -- (C1 + E) - C2 = (C1 - C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) - R); + return L; + + -- (E + C1) - C2 = E + (C1 - C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) - R); + return L; + end if; + + -- Case of left operand is a subtraction + + elsif Nkind (L) = N_Op_Subtract then + + -- (C1 - E) - C2 = (C1 - C2) + E + + if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then + Rewrite_Integer + (Sinfo.Left_Opnd (L), + Expr_Value (Sinfo.Left_Opnd (L)) + R); + return L; + + -- (E - C1) - C2 = E - (C1 + C2) + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + Rewrite_Integer + (Sinfo.Right_Opnd (L), + Expr_Value (Sinfo.Right_Opnd (L)) + R); + return L; + end if; + end if; + + -- Not optimizable, do the subtraction + + return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd); + end Assoc_Subtract; + + -------------------- + -- Compute_Length -- + -------------------- + + function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Lo); + Typ : constant Entity_Id := Etype (Lo); + Lo_Op : Node_Id; + Hi_Op : Node_Id; + + begin + Lo_Op := New_Copy_Tree (Lo); + Hi_Op := New_Copy_Tree (Hi); + + -- If type is enumeration type, then use Pos attribute to convert + -- to integer type for which subtraction is a permitted operation. + + if Is_Enumeration_Type (Typ) then + Lo_Op := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Lo_Op)); + + Hi_Op := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Hi_Op)); + end if; + + return + Convert_To (Standard_Unsigned, + Assoc_Add (Loc, + Left_Opnd => + Assoc_Subtract (Loc, + Left_Opnd => Hi_Op, + Right_Opnd => Lo_Op), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + end Compute_Length; + + ---------------------- + -- Expr_From_SO_Ref -- + ---------------------- + + function Expr_From_SO_Ref + (Loc : Source_Ptr; + D : SO_Ref) + return Node_Id + is + Ent : Entity_Id; + + begin + if Is_Dynamic_SO_Ref (D) then + Ent := Get_Dynamic_SO_Entity (D); + + if Is_Discrim_SO_Function (Ent) then + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Chars => Vname))); + + else + return New_Occurrence_Of (Ent, Loc); + end if; + + else + return Make_Integer_Literal (Loc, D); + end if; + end Expr_From_SO_Ref; + + ------------------ + -- Get_Max_Size -- + ------------------ + + function Get_Max_Size (E : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (E); + Indx : Node_Id; + Ityp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + S : Uint; + Len : Node_Id; + + type Val_Status_Type is (Const, Dynamic); + -- Shows the status of the value so far. Const means that the value + -- is constant, and Sval is the current constant value. Dynamic means + -- that the value is dynamic, and in this case Snod is the Node_Id of + -- the expression to compute the value. + + Val_Status : Val_Status_Type; + -- Indicate status of value so far + + Sval : Uint := Uint_0; + -- Calculated value so far if Val_Status = Const + -- (initialized to prevent junk warning) + + Snod : Node_Id; + -- Expression value so far if Val_Status = Dynamic + + SU_Convert_Required : Boolean := False; + -- This is set to True if the final result must be converted from + -- bits to storage units (rounding up to a storage unit boundary). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Max_Discrim (N : in out Node_Id); + -- If the node N represents a discriminant, replace it by the maximum + -- value of the discriminant. + + procedure Min_Discrim (N : in out Node_Id); + -- If the node N represents a discriminant, replace it by the minimum + -- value of the discriminant. + + ----------------- + -- Max_Discrim -- + ----------------- + + procedure Max_Discrim (N : in out Node_Id) is + begin + if Nkind (N) = N_Identifier + and then Ekind (Entity (N)) = E_Discriminant + then + N := Type_High_Bound (Etype (N)); + end if; + end Max_Discrim; + + ----------------- + -- Min_Discrim -- + ----------------- + + procedure Min_Discrim (N : in out Node_Id) is + begin + if Nkind (N) = N_Identifier + and then Ekind (Entity (N)) = E_Discriminant + then + N := Type_Low_Bound (Etype (N)); + end if; + end Min_Discrim; + + -- Start of processing for Layout_Array_Type + + begin + pragma Assert (Size_Depends_On_Discriminant (E)); + + -- Initialize status from component size + + if Known_Static_Component_Size (E) then + Val_Status := Const; + Sval := Component_Size (E); + + else + Val_Status := Dynamic; + Snod := Expr_From_SO_Ref (Loc, Component_Size (E)); + end if; + + -- Loop through indices + + Indx := First_Index (E); + while Present (Indx) loop + Ityp := Etype (Indx); + Lo := Type_Low_Bound (Ityp); + Hi := Type_High_Bound (Ityp); + + Min_Discrim (Lo); + Max_Discrim (Hi); + + -- Value of the current subscript range is statically known + + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + then + S := Expr_Value (Hi) - Expr_Value (Lo) + 1; + + -- If known flat bound, entire size of array is zero! + + if S <= 0 then + return Make_Integer_Literal (Loc, 0); + end if; + + -- Current value is constant, evolve value + + if Val_Status = Const then + Sval := Sval * S; + + -- Current value is dynamic + + else + -- An interesting little optimization, if we have a pending + -- conversion from bits to storage units, and the current + -- length is a multiple of the storage unit size, then we + -- can take the factor out here statically, avoiding some + -- extra dynamic computations at the end. + + if SU_Convert_Required and then S mod SSU = 0 then + S := S / SSU; + SU_Convert_Required := False; + end if; + + Snod := + Assoc_Multiply (Loc, + Left_Opnd => Snod, + Right_Opnd => + Make_Integer_Literal (Loc, Intval => S)); + end if; + + -- Value of the current subscript range is dynamic + + else + -- If the current size value is constant, then here is where we + -- make a transition to dynamic values, which are always stored + -- in storage units, However, we do not want to convert to SU's + -- too soon, consider the case of a packed array of single bits, + -- we want to do the SU conversion after computing the size in + -- this case. + + if Val_Status = Const then + Val_Status := Dynamic; + + -- If the current value is a multiple of the storage unit, + -- then most certainly we can do the conversion now, simply + -- by dividing the current value by the storage unit value. + -- If this works, we set SU_Convert_Required to False. + + if Sval mod SSU = 0 then + Snod := Make_Integer_Literal (Loc, Sval / SSU); + SU_Convert_Required := False; + + -- Otherwise, we go ahead and convert the value in bits, + -- and set SU_Convert_Required to True to ensure that the + -- final value is indeed properly converted. + + else + Snod := Make_Integer_Literal (Loc, Sval); + SU_Convert_Required := True; + end if; + end if; + + -- Length is hi-lo+1 + + Len := Compute_Length (Lo, Hi); + + -- Check possible range of Len + + declare + OK : Boolean; + LLo : Uint; + LHi : Uint; + + begin + Set_Parent (Len, E); + Determine_Range (Len, OK, LLo, LHi); + + -- If we cannot verify that range cannot be super-flat, + -- we need a max with zero, since length must be non-neg. + + if not OK or else LLo < 0 then + Len := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Unsigned, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + Len)); + end if; + end; + end if; + + Next_Index (Indx); + end loop; + + -- Here after processing all bounds to set sizes. If the value is + -- a constant, then it is bits, and we just return the value. + + if Val_Status = Const then + return Make_Integer_Literal (Loc, Sval); + + -- Case where the value is dynamic + + else + -- Do convert from bits to SU's if needed + + if SU_Convert_Required then + + -- The expression required is (Snod + SU - 1) / SU + + Snod := + Make_Op_Divide (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Snod, + Right_Opnd => Make_Integer_Literal (Loc, SSU - 1)), + Right_Opnd => Make_Integer_Literal (Loc, SSU)); + end if; + + return Snod; + end if; + end Get_Max_Size; + + ----------------------- + -- Layout_Array_Type -- + ----------------------- + + procedure Layout_Array_Type (E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + Ctyp : constant Entity_Id := Component_Type (E); + Indx : Node_Id; + Ityp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + S : Uint; + Len : Node_Id; + + Insert_Typ : Entity_Id; + -- This is the type with which any generated constants or functions + -- will be associated (i.e. inserted into the freeze actions). This + -- is normally the type being layed out. The exception occurs when + -- we are laying out Itype's which are local to a record type, and + -- whose scope is this record type. Such types do not have freeze + -- nodes (because we have no place to put them). + + ------------------------------------ + -- How An Array Type is Layed Out -- + ------------------------------------ + + -- Here is what goes on. We need to multiply the component size of + -- the array (which has already been set) by the length of each of + -- the indexes. If all these values are known at compile time, then + -- the resulting size of the array is the appropriate constant value. + + -- If the component size or at least one bound is dynamic (but no + -- discriminants are present), then the size will be computed as an + -- expression that calculates the proper size. + + -- If there is at least one discriminant bound, then the size is also + -- computed as an expression, but this expression contains discriminant + -- values which are obtained by selecting from a function parameter, and + -- the size is given by a function that is passed the variant record in + -- question, and whose body is the expression. + + type Val_Status_Type is (Const, Dynamic, Discrim); + -- Shows the status of the value so far. Const means that the value + -- is constant, and Sval is the current constant value. Dynamic means + -- that the value is dynamic, and in this case Snod is the Node_Id of + -- the expression to compute the value, and Discrim means that at least + -- one bound is a discriminant, in which case Snod is the expression so + -- far (which will be the body of the function). + + Val_Status : Val_Status_Type; + -- Indicate status of value so far + + Sval : Uint := Uint_0; + -- Calculated value so far if Val_Status = Const + -- Initialized to prevent junk warning + + Snod : Node_Id; + -- Expression value so far if Val_Status /= Const + + Vtyp : Entity_Id; + -- Variant record type for the formal parameter of the discriminant + -- function V if Val_Status = Discrim. + + SU_Convert_Required : Boolean := False; + -- This is set to True if the final result must be converted from + -- bits to storage units (rounding up to a storage unit boundary). + + procedure Discrimify (N : in out Node_Id); + -- If N represents a discriminant, then the Val_Status is set to + -- Discrim, and Vtyp is set. The parameter N is replaced with the + -- proper expression to extract the discriminant value from V. + + ---------------- + -- Discrimify -- + ---------------- + + procedure Discrimify (N : in out Node_Id) is + Decl : Node_Id; + Typ : Entity_Id; + + begin + if Nkind (N) = N_Identifier + and then Ekind (Entity (N)) = E_Discriminant + then + Set_Size_Depends_On_Discriminant (E); + + if Val_Status /= Discrim then + Val_Status := Discrim; + Decl := Parent (Parent (Entity (N))); + Vtyp := Defining_Identifier (Decl); + end if; + + Typ := Etype (N); + + N := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Chars => Vname), + Selector_Name => New_Occurrence_Of (Entity (N), Loc)); + + Analyze_And_Resolve (N, Typ); + end if; + end Discrimify; + + -- Start of processing for Layout_Array_Type + + begin + -- Default alignment is component alignment + + if Unknown_Alignment (E) then + Set_Alignment (E, Alignment (Ctyp)); + end if; + + -- Calculate proper type for insertions + + if Is_Record_Type (Scope (E)) then + Insert_Typ := Scope (E); + else + Insert_Typ := E; + end if; + + -- Cannot do anything if Esize of component type unknown + + if Unknown_Esize (Ctyp) then + return; + end if; + + -- Set component size if not set already + + if Unknown_Component_Size (E) then + Set_Component_Size (E, Esize (Ctyp)); + end if; + + -- (RM 13.3 (48)) says that the size of an unconstrained array + -- is implementation defined. We choose to leave it as Unknown + -- here, and the actual behavior is determined by the back end. + + if not Is_Constrained (E) then + return; + end if; + + -- Initialize status from component size + + if Known_Static_Component_Size (E) then + Val_Status := Const; + Sval := Component_Size (E); + + else + Val_Status := Dynamic; + Snod := Expr_From_SO_Ref (Loc, Component_Size (E)); + end if; + + -- Loop to process array indices + + Indx := First_Index (E); + while Present (Indx) loop + Ityp := Etype (Indx); + Lo := Type_Low_Bound (Ityp); + Hi := Type_High_Bound (Ityp); + + -- Value of the current subscript range is statically known + + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + then + S := Expr_Value (Hi) - Expr_Value (Lo) + 1; + + -- If known flat bound, entire size of array is zero! + + if S <= 0 then + Set_Esize (E, Uint_0); + Set_RM_Size (E, Uint_0); + return; + end if; + + -- If constant, evolve value + + if Val_Status = Const then + Sval := Sval * S; + + -- Current value is dynamic + + else + -- An interesting little optimization, if we have a pending + -- conversion from bits to storage units, and the current + -- length is a multiple of the storage unit size, then we + -- can take the factor out here statically, avoiding some + -- extra dynamic computations at the end. + + if SU_Convert_Required and then S mod SSU = 0 then + S := S / SSU; + SU_Convert_Required := False; + end if; + + -- Now go ahead and evolve the expression + + Snod := + Assoc_Multiply (Loc, + Left_Opnd => Snod, + Right_Opnd => + Make_Integer_Literal (Loc, Intval => S)); + end if; + + -- Value of the current subscript range is dynamic + + else + -- If the current size value is constant, then here is where we + -- make a transition to dynamic values, which are always stored + -- in storage units, However, we do not want to convert to SU's + -- too soon, consider the case of a packed array of single bits, + -- we want to do the SU conversion after computing the size in + -- this case. + + if Val_Status = Const then + Val_Status := Dynamic; + + -- If the current value is a multiple of the storage unit, + -- then most certainly we can do the conversion now, simply + -- by dividing the current value by the storage unit value. + -- If this works, we set SU_Convert_Required to False. + + if Sval mod SSU = 0 then + Snod := Make_Integer_Literal (Loc, Sval / SSU); + SU_Convert_Required := False; + + -- Otherwise, we go ahead and convert the value in bits, + -- and set SU_Convert_Required to True to ensure that the + -- final value is indeed properly converted. + + else + Snod := Make_Integer_Literal (Loc, Sval); + SU_Convert_Required := True; + end if; + end if; + + Discrimify (Lo); + Discrimify (Hi); + + -- Length is hi-lo+1 + + Len := Compute_Length (Lo, Hi); + + -- Check possible range of Len + + declare + OK : Boolean; + LLo : Uint; + LHi : Uint; + + begin + Set_Parent (Len, E); + Determine_Range (Len, OK, LLo, LHi); + + -- If range definitely flat or superflat, result size is zero + + if OK and then LHi <= 0 then + Set_Esize (E, Uint_0); + Set_RM_Size (E, Uint_0); + return; + end if; + + -- If we cannot verify that range cannot be super-flat, we + -- need a maximum with zero, since length cannot be negative. + + if not OK or else LLo < 0 then + Len := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Unsigned, Loc), + Attribute_Name => Name_Max, + Expressions => New_List ( + Make_Integer_Literal (Loc, 0), + Len)); + end if; + end; + + -- At this stage, Len has the expression for the length + + Snod := + Assoc_Multiply (Loc, + Left_Opnd => Snod, + Right_Opnd => Len); + end if; + + Next_Index (Indx); + end loop; + + -- Here after processing all bounds to set sizes. If the value is + -- a constant, then it is bits, and the only thing we need to do + -- is to check against explicit given size and do alignment adjust. + + if Val_Status = Const then + Set_And_Check_Static_Size (E, Sval, Sval); + Adjust_Esize_Alignment (E); + + -- Case where the value is dynamic + + else + -- Do convert from bits to SU's if needed + + if SU_Convert_Required then + + -- The expression required is (Snod + SU - 1) / SU + + Snod := + Make_Op_Divide (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => Snod, + Right_Opnd => Make_Integer_Literal (Loc, SSU - 1)), + Right_Opnd => Make_Integer_Literal (Loc, SSU)); + end if; + + -- Now set the dynamic size (the Value_Size is always the same + -- as the Object_Size for arrays whose length is dynamic). + + Set_Esize (E, SO_Ref_From_Expr (Snod, Insert_Typ, Vtyp)); + Set_RM_Size (E, Esize (E)); + end if; + end Layout_Array_Type; + + ------------------- + -- Layout_Object -- + ------------------- + + procedure Layout_Object (E : Entity_Id) is + T : constant Entity_Id := Etype (E); + + begin + -- Nothing to do if backend does layout + + if not Frontend_Layout_On_Target then + return; + end if; + + -- Set size if not set for object and known for type. Use the + -- RM_Size if that is known for the type and Esize is not. + + if Unknown_Esize (E) then + if Known_Esize (T) then + Set_Esize (E, Esize (T)); + + elsif Known_RM_Size (T) then + Set_Esize (E, RM_Size (T)); + end if; + end if; + + -- Set alignment from type if unknown and type alignment known + + if Unknown_Alignment (E) and then Known_Alignment (T) then + Set_Alignment (E, Alignment (T)); + end if; + + -- Make sure size and alignment are consistent + + Adjust_Esize_Alignment (E); + + -- Final adjustment, if we don't know the alignment, and the Esize + -- was not set by an explicit Object_Size attribute clause, then + -- we reset the Esize to unknown, since we really don't know it. + + if Unknown_Alignment (E) + and then not Has_Size_Clause (E) + then + Set_Esize (E, Uint_0); + end if; + end Layout_Object; + + ------------------------ + -- Layout_Record_Type -- + ------------------------ + + procedure Layout_Record_Type (E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + Decl : Node_Id; + + Comp : Entity_Id; + -- Current component being layed out + + Prev_Comp : Entity_Id; + -- Previous layed out component + + procedure Get_Next_Component_Location + (Prev_Comp : Entity_Id; + Align : Uint; + New_Npos : out SO_Ref; + New_Fbit : out SO_Ref; + New_NPMax : out SO_Ref; + Force_SU : Boolean); + -- Given the previous component in Prev_Comp, which is already laid + -- out, and the alignment of the following component, lays out the + -- following component, and returns its starting position in New_Npos + -- (Normalized_Position value), New_Fbit (Normalized_First_Bit value), + -- and New_NPMax (Normalized_Position_Max value). If Prev_Comp is empty + -- (no previous component is present), then New_Npos, New_Fbit and + -- New_NPMax are all set to zero on return. This procedure is also + -- used to compute the size of a record or variant by giving it the + -- last component, and the record alignment. Force_SU is used to force + -- the new component location to be aligned on a storage unit boundary, + -- even in a packed record, False means that the new position does not + -- need to be bumped to a storage unit boundary, True means a storage + -- unit boundary is always required. + + procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id); + -- Lays out component Comp, given Prev_Comp, the previously laid-out + -- component (Prev_Comp = Empty if no components laid out yet). The + -- alignment of the record itself is also updated if needed. Both + -- Comp and Prev_Comp can be either components or discriminants. A + -- special case is when Comp is Empty, this is used at the end + -- to determine the size of the entire record. For this special + -- call the resulting offset is placed in Final_Offset. + + procedure Layout_Components + (From : Entity_Id; + To : Entity_Id; + Esiz : out SO_Ref; + RM_Siz : out SO_Ref); + -- This procedure lays out the components of the given component list + -- which contains the components starting with From, and ending with To. + -- The Next_Entity chain is used to traverse the components. On entry + -- Prev_Comp is set to the component preceding the list, so that the + -- list is layed out after this component. Prev_Comp is set to Empty if + -- the component list is to be layed out starting at the start of the + -- record. On return, the components are all layed out, and Prev_Comp is + -- set to the last layed out component. On return, Esiz is set to the + -- resulting Object_Size value, which is the length of the record up + -- to and including the last layed out entity. For Esiz, the value is + -- adjusted to match the alignment of the record. RM_Siz is similarly + -- set to the resulting Value_Size value, which is the same length, but + -- not adjusted to meet the alignment. Note that in the case of variant + -- records, Esiz represents the maximum size. + + procedure Layout_Non_Variant_Record; + -- Procedure called to layout a non-variant record type or subtype + + procedure Layout_Variant_Record; + -- Procedure called to layout a variant record type. Decl is set to the + -- full type declaration for the variant record. + + --------------------------------- + -- Get_Next_Component_Location -- + --------------------------------- + + procedure Get_Next_Component_Location + (Prev_Comp : Entity_Id; + Align : Uint; + New_Npos : out SO_Ref; + New_Fbit : out SO_Ref; + New_NPMax : out SO_Ref; + Force_SU : Boolean) + is + begin + -- No previous component, return zero position + + if No (Prev_Comp) then + New_Npos := Uint_0; + New_Fbit := Uint_0; + New_NPMax := Uint_0; + return; + end if; + + -- Here we have a previous component + + declare + Loc : constant Source_Ptr := Sloc (Prev_Comp); + + Old_Npos : constant SO_Ref := Normalized_Position (Prev_Comp); + Old_Fbit : constant SO_Ref := Normalized_First_Bit (Prev_Comp); + Old_NPMax : constant SO_Ref := Normalized_Position_Max (Prev_Comp); + Old_Esiz : constant SO_Ref := Esize (Prev_Comp); + + Old_Maxsz : Node_Id; + -- Expression representing maximum size of previous component + + begin + -- Case where previous field had a dynamic size + + if Is_Dynamic_SO_Ref (Esize (Prev_Comp)) then + + -- If the previous field had a dynamic length, then it is + -- required to occupy an integral number of storage units, + -- and start on a storage unit boundary. This means that + -- the Normalized_First_Bit value is zero in the previous + -- component, and the new value is also set to zero. + + New_Fbit := Uint_0; + + -- In this case, the new position is given by an expression + -- that is the sum of old normalized position and old size. + + New_Npos := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => Expr_From_SO_Ref (Loc, Old_Npos), + Right_Opnd => Expr_From_SO_Ref (Loc, Old_Esiz)), + Ins_Type => E, + Vtype => E); + + -- Get maximum size of previous component + + if Size_Depends_On_Discriminant (Etype (Prev_Comp)) then + Old_Maxsz := Get_Max_Size (Etype (Prev_Comp)); + else + Old_Maxsz := Expr_From_SO_Ref (Loc, Old_Esiz); + end if; + + -- Now we can compute the new max position. If the max size + -- is static and the old position is static, then we can + -- compute the new position statically. + + if Nkind (Old_Maxsz) = N_Integer_Literal + and then Known_Static_Normalized_Position_Max (Prev_Comp) + then + New_NPMax := Old_NPMax + Intval (Old_Maxsz); + + -- Otherwise new max position is dynamic + + else + New_NPMax := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax), + Right_Opnd => Old_Maxsz), + Ins_Type => E, + Vtype => E); + end if; + + -- Previous field has known static Esize + + else + New_Fbit := Old_Fbit + Old_Esiz; + + -- Bump New_Fbit to storage unit boundary if required + + if New_Fbit /= 0 and then Force_SU then + New_Fbit := (New_Fbit + SSU - 1) / SSU * SSU; + end if; + + -- If old normalized position is static, we can go ahead + -- and compute the new normalized position directly. + + if Known_Static_Normalized_Position (Prev_Comp) then + New_Npos := Old_Npos; + + if New_Fbit >= SSU then + New_Npos := New_Npos + New_Fbit / SSU; + New_Fbit := New_Fbit mod SSU; + end if; + + -- Bump alignment if stricter than prev + + if Align > Alignment (Prev_Comp) then + New_Npos := (New_Npos + Align - 1) / Align * Align; + end if; + + -- The max position is always equal to the position if + -- the latter is static, since arrays depending on the + -- values of discriminants never have static sizes. + + New_NPMax := New_Npos; + return; + + -- Case of old normalized position is dynamic + + else + -- If new bit position is within the current storage unit, + -- we can just copy the old position as the result position + -- (we have already set the new first bit value). + + if New_Fbit < SSU then + New_Npos := Old_Npos; + New_NPMax := Old_NPMax; + + -- If new bit position is past the current storage unit, we + -- need to generate a new dynamic value for the position + -- ??? need to deal with alignment + + else + New_Npos := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => Expr_From_SO_Ref (Loc, Old_Npos), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => New_Fbit / SSU)), + Ins_Type => E, + Vtype => E); + + New_NPMax := + SO_Ref_From_Expr + (Assoc_Add (Loc, + Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => New_Fbit / SSU)), + Ins_Type => E, + Vtype => E); + New_Fbit := New_Fbit mod SSU; + end if; + end if; + end if; + end; + end Get_Next_Component_Location; + + ---------------------- + -- Layout_Component -- + ---------------------- + + procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id) is + Ctyp : constant Entity_Id := Etype (Comp); + Npos : SO_Ref; + Fbit : SO_Ref; + NPMax : SO_Ref; + Forc : Boolean; + + begin + -- Parent field is always at start of record, this will overlap + -- the actual fields that are part of the parent, and that's fine + + if Chars (Comp) = Name_uParent then + Set_Normalized_Position (Comp, Uint_0); + Set_Normalized_First_Bit (Comp, Uint_0); + Set_Normalized_Position_Max (Comp, Uint_0); + Set_Component_Bit_Offset (Comp, Uint_0); + Set_Esize (Comp, Esize (Ctyp)); + return; + end if; + + -- Check case of type of component has a scope of the record we + -- are laying out. When this happens, the type in question is an + -- Itype that has not yet been layed out (that's because such + -- types do not get frozen in the normal manner, because there + -- is no place for the freeze nodes). + + if Scope (Ctyp) = E then + Layout_Type (Ctyp); + end if; + + -- Increase alignment of record if necessary. Note that we do not + -- do this for packed records, which have an alignment of one by + -- default, or for records for which an explicit alignment was + -- specified with an alignment clause. + + if not Is_Packed (E) + and then not Has_Alignment_Clause (E) + and then Alignment (Ctyp) > Alignment (E) + then + Set_Alignment (E, Alignment (Ctyp)); + end if; + + -- If component already laid out, then we are done + + if Known_Normalized_Position (Comp) then + return; + end if; + + -- Set size of component from type. We use the Esize except in a + -- packed record, where we use the RM_Size (since that is exactly + -- what the RM_Size value, as distinct from the Object_Size is + -- useful for!) + + if Is_Packed (E) then + Set_Esize (Comp, RM_Size (Ctyp)); + else + Set_Esize (Comp, Esize (Ctyp)); + end if; + + -- Compute the component position from the previous one. See if + -- current component requires being on a storage unit boundary. + + -- If record is not packed, we always go to a storage unit boundary + + if not Is_Packed (E) then + Forc := True; + + -- Packed cases + + else + -- Elementary types do not need SU boundary in packed record + + if Is_Elementary_Type (Ctyp) then + Forc := False; + + -- Packed array types with a modular packed array type do not + -- force a storage unit boundary (since the code generation + -- treats these as equivalent to the underlying modular type), + + elsif Is_Array_Type (Ctyp) + and then Is_Bit_Packed_Array (Ctyp) + and then Is_Modular_Integer_Type (Packed_Array_Type (Ctyp)) + then + Forc := False; + + -- Record types with known length less than or equal to the length + -- of long long integer can also be unaligned, since they can be + -- treated as scalars. + + elsif Is_Record_Type (Ctyp) + and then not Is_Dynamic_SO_Ref (Esize (Ctyp)) + and then Esize (Ctyp) <= Esize (Standard_Long_Long_Integer) + then + Forc := False; + + -- All other cases force a storage unit boundary, even when packed + + else + Forc := True; + end if; + end if; + + -- Now get the next component location + + Get_Next_Component_Location + (Prev_Comp, Alignment (Ctyp), Npos, Fbit, NPMax, Forc); + Set_Normalized_Position (Comp, Npos); + Set_Normalized_First_Bit (Comp, Fbit); + Set_Normalized_Position_Max (Comp, NPMax); + + -- Set Component_Bit_Offset in the static case + + if Known_Static_Normalized_Position (Comp) + and then Known_Normalized_First_Bit (Comp) + then + Set_Component_Bit_Offset (Comp, SSU * Npos + Fbit); + end if; + end Layout_Component; + + ----------------------- + -- Layout_Components -- + ----------------------- + + procedure Layout_Components + (From : Entity_Id; + To : Entity_Id; + Esiz : out SO_Ref; + RM_Siz : out SO_Ref) + is + End_Npos : SO_Ref; + End_Fbit : SO_Ref; + End_NPMax : SO_Ref; + + begin + -- Only layout components if there are some to layout! + + if Present (From) then + + -- Layout components with no component clauses + + Comp := From; + loop + if (Ekind (Comp) = E_Component + or else Ekind (Comp) = E_Discriminant) + and then No (Component_Clause (Comp)) + then + Layout_Component (Comp, Prev_Comp); + Prev_Comp := Comp; + end if; + + exit when Comp = To; + Next_Entity (Comp); + end loop; + end if; + + -- Set size fields, both are zero if no components + + if No (Prev_Comp) then + Esiz := Uint_0; + RM_Siz := Uint_0; + + else + -- First the object size, for which we align past the last + -- field to the alignment of the record (the object size + -- is required to be a multiple of the alignment). + + Get_Next_Component_Location + (Prev_Comp, + Alignment (E), + End_Npos, + End_Fbit, + End_NPMax, + Force_SU => True); + + -- If the resulting normalized position is a dynamic reference, + -- then the size is dynamic, and is stored in storage units. + -- In this case, we set the RM_Size to the same value, it is + -- simply not worth distinguishing Esize and RM_Size values in + -- the dynamic case, since the RM has nothing to say about them. + + -- Note that a size cannot have been given in this case, since + -- size specifications cannot be given for variable length types. + + declare + Align : constant Uint := Alignment (E); + + begin + if Is_Dynamic_SO_Ref (End_Npos) then + RM_Siz := End_Npos; + + -- Set the Object_Size allowing for alignment. In the + -- dynamic case, we have to actually do the runtime + -- computation. We can skip this in the non-packed + -- record case if the last component has a smaller + -- alignment than the overall record alignment. + + if Is_Dynamic_SO_Ref (End_NPMax) then + Esiz := End_NPMax; + + if Is_Packed (E) + or else Alignment (Prev_Comp) < Align + then + -- The expression we build is + -- (expr + align - 1) / align * align + + Esiz := + SO_Ref_From_Expr + (Expr => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + Expr_From_SO_Ref (Loc, Esiz), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => Align - 1)), + Right_Opnd => + Make_Integer_Literal (Loc, Align)), + Right_Opnd => + Make_Integer_Literal (Loc, Align)), + Ins_Type => E, + Vtype => E); + end if; + + -- Here Esiz is static, so we can adjust the alignment + -- directly go give the required aligned value. + + else + Esiz := (End_NPMax + Align - 1) / Align * Align * SSU; + end if; + + -- Case where computed size is static + + else + -- The ending size was computed in Npos in storage units, + -- but the actual size is stored in bits, so adjust + -- accordingly. We also adjust the size to match the + -- alignment here. + + Esiz := (End_NPMax + Align - 1) / Align * Align * SSU; + + -- Compute the resulting Value_Size (RM_Size). For this + -- purpose we do not force alignment of the record or + -- storage size alignment of the result. + + Get_Next_Component_Location + (Prev_Comp, + Uint_0, + End_Npos, + End_Fbit, + End_NPMax, + Force_SU => False); + + RM_Siz := End_Npos * SSU + End_Fbit; + Set_And_Check_Static_Size (E, Esiz, RM_Siz); + end if; + end; + end if; + end Layout_Components; + + ------------------------------- + -- Layout_Non_Variant_Record -- + ------------------------------- + + procedure Layout_Non_Variant_Record is + Esiz : SO_Ref; + RM_Siz : SO_Ref; + + begin + Layout_Components (First_Entity (E), Last_Entity (E), Esiz, RM_Siz); + Set_Esize (E, Esiz); + Set_RM_Size (E, RM_Siz); + end Layout_Non_Variant_Record; + + --------------------------- + -- Layout_Variant_Record -- + --------------------------- + + procedure Layout_Variant_Record is + Tdef : constant Node_Id := Type_Definition (Decl); + Dlist : constant List_Id := Discriminant_Specifications (Decl); + Esiz : SO_Ref; + RM_Siz : SO_Ref; + + RM_Siz_Expr : Node_Id := Empty; + -- Expression for the evolving RM_Siz value. This is typically a + -- conditional expression which involves tests of discriminant + -- values that are formed as references to the entity V. At + -- the end of scanning all the components, a suitable function + -- is constructed in which V is the parameter. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Layout_Component_List + (Clist : Node_Id; + Esiz : out SO_Ref; + RM_Siz_Expr : out Node_Id); + -- Recursive procedure, called to layout one component list + -- Esiz and RM_Siz_Expr are set to the Object_Size and Value_Size + -- values respectively representing the record size up to and + -- including the last component in the component list (including + -- any variants in this component list). RM_Siz_Expr is returned + -- as an expression which may in the general case involve some + -- references to the discriminants of the current record value, + -- referenced by selecting from the entity V. + + --------------------------- + -- Layout_Component_List -- + --------------------------- + + procedure Layout_Component_List + (Clist : Node_Id; + Esiz : out SO_Ref; + RM_Siz_Expr : out Node_Id) + is + Citems : constant List_Id := Component_Items (Clist); + Vpart : constant Node_Id := Variant_Part (Clist); + Prv : Node_Id; + Var : Node_Id; + RM_Siz : Uint; + RMS_Ent : Entity_Id; + + begin + if Is_Non_Empty_List (Citems) then + Layout_Components + (From => Defining_Identifier (First (Citems)), + To => Defining_Identifier (Last (Citems)), + Esiz => Esiz, + RM_Siz => RM_Siz); + else + Layout_Components (Empty, Empty, Esiz, RM_Siz); + end if; + + -- Case where no variants are present in the component list + + if No (Vpart) then + + -- The Esiz value has been correctly set by the call to + -- Layout_Components, so there is nothing more to be done. + + -- For RM_Siz, we have an SO_Ref value, which we must convert + -- to an appropriate expression. + + if Is_Static_SO_Ref (RM_Siz) then + RM_Siz_Expr := + Make_Integer_Literal (Loc, + Intval => RM_Siz); + + else + RMS_Ent := Get_Dynamic_SO_Entity (RM_Siz); + + -- If the size is represented by a function, then we + -- create an appropriate function call using V as + -- the parameter to the call. + + if Is_Discrim_SO_Function (RMS_Ent) then + RM_Siz_Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RMS_Ent, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Chars => Vname))); + + -- If the size is represented by a constant, then the + -- expression we want is a reference to this constant + + else + RM_Siz_Expr := New_Occurrence_Of (RMS_Ent, Loc); + end if; + end if; + + -- Case where variants are present in this component list + + else + declare + EsizV : SO_Ref; + RM_SizV : Node_Id; + Dchoice : Node_Id; + Discrim : Node_Id; + Dtest : Node_Id; + + begin + RM_Siz_Expr := Empty; + Prv := Prev_Comp; + + Var := Last (Variants (Vpart)); + while Present (Var) loop + Prev_Comp := Prv; + Layout_Component_List + (Component_List (Var), EsizV, RM_SizV); + + -- Set the Object_Size. If this is the first variant, + -- we just set the size of this first variant. + + if Var = Last (Variants (Vpart)) then + Esiz := EsizV; + + -- Otherwise the Object_Size is formed as a maximum + -- of Esiz so far from previous variants, and the new + -- Esiz value from the variant we just processed. + + -- If both values are static, we can just compute the + -- maximum directly to save building junk nodes. + + elsif not Is_Dynamic_SO_Ref (Esiz) + and then not Is_Dynamic_SO_Ref (EsizV) + then + Esiz := UI_Max (Esiz, EsizV); + + -- If either value is dynamic, then we have to generate + -- an appropriate Standard_Unsigned'Max attribute call. + + else + Esiz := + SO_Ref_From_Expr + (Make_Attribute_Reference (Loc, + Attribute_Name => Name_Max, + Prefix => + New_Occurrence_Of (Standard_Unsigned, Loc), + Expressions => New_List ( + Expr_From_SO_Ref (Loc, Esiz), + Expr_From_SO_Ref (Loc, EsizV))), + Ins_Type => E, + Vtype => E); + end if; + + -- Now deal with Value_Size (RM_Siz). We are aiming at + -- an expression that looks like: + + -- if xxDx (V.disc) then rmsiz1 + -- else if xxDx (V.disc) then rmsiz2 + -- else ... + + -- Where rmsiz1, rmsiz2... are the RM_Siz values for the + -- individual variants, and xxDx are the discriminant + -- checking functions generated for the variant type. + + -- If this is the first variant, we simply set the + -- result as the expression. Note that this takes + -- care of the others case. + + if No (RM_Siz_Expr) then + RM_Siz_Expr := RM_SizV; + + -- Otherwise construct the appropriate test + + else + -- Discriminant to be tested + + Discrim := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars => Vname), + Selector_Name => + New_Occurrence_Of + (Entity (Name (Vpart)), Loc)); + + -- The test to be used in general is a call to the + -- discriminant checking function. However, it is + -- definitely worth special casing the very common + -- case where a single value is involved. + + Dchoice := First (Discrete_Choices (Var)); + + if No (Next (Dchoice)) + and then Nkind (Dchoice) /= N_Range + then + Dtest := + Make_Op_Eq (Loc, + Left_Opnd => Discrim, + Right_Opnd => New_Copy (Dchoice)); + + else + Dtest := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (Dcheck_Function (Var), Loc), + Parameter_Associations => New_List (Discrim)); + end if; + + RM_Siz_Expr := + Make_Conditional_Expression (Loc, + Expressions => + New_List (Dtest, RM_SizV, RM_Siz_Expr)); + end if; + + Prev (Var); + end loop; + end; + end if; + end Layout_Component_List; + + -- Start of processing for Layout_Variant_Record + + begin + -- We need the discriminant checking functions, since we generate + -- calls to these functions for the RM_Size expression, so make + -- sure that these functions have been constructed in time. + + Build_Discr_Checking_Funcs (Decl); + + -- Layout the discriminants + + Layout_Components + (From => Defining_Identifier (First (Dlist)), + To => Defining_Identifier (Last (Dlist)), + Esiz => Esiz, + RM_Siz => RM_Siz); + + -- Layout the main component list (this will make recursive calls + -- to layout all component lists nested within variants). + + Layout_Component_List (Component_List (Tdef), Esiz, RM_Siz_Expr); + Set_Esize (E, Esiz); + + -- If the RM_Size is a literal, set its value + + if Nkind (RM_Siz_Expr) = N_Integer_Literal then + Set_RM_Size (E, Intval (RM_Siz_Expr)); + + -- Otherwise we construct a dynamic SO_Ref + + else + Set_RM_Size (E, + SO_Ref_From_Expr + (RM_Siz_Expr, + Ins_Type => E, + Vtype => E)); + end if; + end Layout_Variant_Record; + + -- Start of processing for Layout_Record_Type + + begin + -- If this is a cloned subtype, just copy the size fields from the + -- original, nothing else needs to be done in this case, since the + -- components themselves are all shared. + + if (Ekind (E) = E_Record_Subtype + or else Ekind (E) = E_Class_Wide_Subtype) + and then Present (Cloned_Subtype (E)) + then + Set_Esize (E, Esize (Cloned_Subtype (E))); + Set_RM_Size (E, RM_Size (Cloned_Subtype (E))); + Set_Alignment (E, Alignment (Cloned_Subtype (E))); + + -- Another special case, class-wide types. The RM says that the size + -- of such types is implementation defined (RM 13.3(48)). What we do + -- here is to leave the fields set as unknown values, and the backend + -- determines the actual behavior. + + elsif Ekind (E) = E_Class_Wide_Type then + null; + + -- All other cases + + else + -- Initialize aligment conservatively to 1. This value will + -- be increased as necessary during processing of the record. + + if Unknown_Alignment (E) then + Set_Alignment (E, Uint_1); + end if; + + -- Initialize previous component. This is Empty unless there + -- are components which have already been laid out by component + -- clauses. If there are such components, we start our layout of + -- the remaining components following the last such component + + Prev_Comp := Empty; + + Comp := First_Entity (E); + while Present (Comp) loop + if (Ekind (Comp) = E_Component + or else Ekind (Comp) = E_Discriminant) + and then Present (Component_Clause (Comp)) + then + if No (Prev_Comp) + or else + Component_Bit_Offset (Comp) > + Component_Bit_Offset (Prev_Comp) + then + Prev_Comp := Comp; + end if; + end if; + + Next_Entity (Comp); + end loop; + + -- We have two separate circuits, one for non-variant records and + -- one for variant records. For non-variant records, we simply go + -- through the list of components. This handles all the non-variant + -- cases including those cases of subtypes where there is no full + -- type declaration, so the tree cannot be used to drive the layout. + -- For variant records, we have to drive the layout from the tree + -- since we need to understand the variant structure in this case. + + if Present (Full_View (E)) then + Decl := Declaration_Node (Full_View (E)); + else + Decl := Declaration_Node (E); + end if; + + -- Scan all the components + + if Nkind (Decl) = N_Full_Type_Declaration + and then Has_Discriminants (E) + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + and then + Present (Variant_Part (Component_List (Type_Definition (Decl)))) + then + Layout_Variant_Record; + else + Layout_Non_Variant_Record; + end if; + end if; + end Layout_Record_Type; + + ----------------- + -- Layout_Type -- + ----------------- + + procedure Layout_Type (E : Entity_Id) is + begin + -- For string literal types, for now, kill the size always, this + -- is because gigi does not like or need the size to be set ??? + + if Ekind (E) = E_String_Literal_Subtype then + Set_Esize (E, Uint_0); + Set_RM_Size (E, Uint_0); + return; + end if; + + -- For access types, set size/alignment. This is system address + -- size, except for fat pointers (unconstrained array access types), + -- where the size is two times the address size, to accomodate the + -- two pointers that are required for a fat pointer (data and + -- template). Note that E_Access_Protected_Subprogram_Type is not + -- an access type for this purpose since it is not a pointer but is + -- equivalent to a record. For access subtypes, copy the size from + -- the base type since Gigi represents them the same way. + + if Is_Access_Type (E) then + + -- If Esize already set (e.g. by a size clause), then nothing + -- further to be done here. + + if Known_Esize (E) then + null; + + -- Access to subprogram is a strange beast, and we let the + -- backend figure out what is needed (it may be some kind + -- of fat pointer, including the static link for example. + + elsif Ekind (E) = E_Access_Protected_Subprogram_Type then + null; + + -- For access subtypes, copy the size information from base type + + elsif Ekind (E) = E_Access_Subtype then + Set_Size_Info (E, Base_Type (E)); + Set_RM_Size (E, RM_Size (Base_Type (E))); + + -- For other access types, we use either address size, or, if + -- a fat pointer is used (pointer-to-unconstrained array case), + -- twice the address size to accomodate a fat pointer. + + else + declare + Desig : Entity_Id := Designated_Type (E); + + begin + if Is_Private_Type (Desig) + and then Present (Full_View (Desig)) + then + Desig := Full_View (Desig); + end if; + + if (Is_Array_Type (Desig) + and then not Is_Constrained (Desig) + and then not Has_Completion_In_Body (Desig) + and then not Debug_Flag_6) + then + Init_Size (E, 2 * System_Address_Size); + + -- Check for bad convention set + + if Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP + then + Error_Msg_N + ("?this access type does not " & + "correspond to C pointer", E); + end if; + + else + Init_Size (E, System_Address_Size); + end if; + end; + end if; + + Set_Prim_Alignment (E); + + -- Scalar types: set size and alignment + + elsif Is_Scalar_Type (E) then + + -- For discrete types, the RM_Size and Esize must be set + -- already, since this is part of the earlier processing + -- and the front end is always required to layout the + -- sizes of such types (since they are available as static + -- attributes). All we do is to check that this rule is + -- indeed obeyed! + + if Is_Discrete_Type (E) then + + -- If the RM_Size is not set, then here is where we set it. + + -- Note: an RM_Size of zero looks like not set here, but this + -- is a rare case, and we can simply reset it without any harm. + + if not Known_RM_Size (E) then + Set_Discrete_RM_Size (E); + end if; + + -- If Esize for a discrete type is not set then set it + + if not Known_Esize (E) then + declare + S : Int := 8; + + begin + loop + -- If size is big enough, set it and exit + + if S >= RM_Size (E) then + Init_Esize (E, S); + exit; + + -- If the RM_Size is greater than 64 (happens only + -- when strange values are specified by the user, + -- then Esize is simply a copy of RM_Size, it will + -- be further refined later on) + + elsif S = 64 then + Set_Esize (E, RM_Size (E)); + exit; + + -- Otherwise double possible size and keep trying + + else + S := S * 2; + end if; + end loop; + end; + end if; + + -- For non-discrete sclar types, if the RM_Size is not set, + -- then set it now to a copy of the Esize if the Esize is set. + + else + if Known_Esize (E) and then Unknown_RM_Size (E) then + Set_RM_Size (E, Esize (E)); + end if; + end if; + + Set_Prim_Alignment (E); + + -- Non-primitive types + + else + -- If RM_Size is known, set Esize if not known + + if Known_RM_Size (E) and then Unknown_Esize (E) then + + -- If the alignment is known, we bump the Esize up to the + -- next alignment boundary if it is not already on one. + + if Known_Alignment (E) then + declare + A : constant Uint := Alignment_In_Bits (E); + S : constant SO_Ref := RM_Size (E); + + begin + Set_Esize (E, (S * A + A - 1) / A); + end; + end if; + + -- If Esize is set, and RM_Size is not, RM_Size is copied from + -- Esize at least for now this seems reasonable, and is in any + -- case needed for compatibility with old versions of gigi. + -- look to be unknown. + + elsif Known_Esize (E) and then Unknown_RM_Size (E) then + Set_RM_Size (E, Esize (E)); + end if; + + -- For array base types, set component size if object size of + -- the component type is known and is a small power of 2 (8, + -- 16, 32, 64), since this is what will always be used. + + if Ekind (E) = E_Array_Type + and then Unknown_Component_Size (E) + then + declare + CT : constant Entity_Id := Component_Type (E); + + begin + -- For some reasons, access types can cause trouble, + -- So let's just do this for discrete types ??? + + if Present (CT) + and then Is_Discrete_Type (CT) + and then Known_Static_Esize (CT) + then + declare + S : constant Uint := Esize (CT); + + begin + if S = 8 or else + S = 16 or else + S = 32 or else + S = 64 + then + Set_Component_Size (E, Esize (CT)); + end if; + end; + end if; + end; + end if; + end if; + + -- Layout array and record types if front end layout set + + if Frontend_Layout_On_Target then + if Is_Array_Type (E) and then not Is_Bit_Packed_Array (E) then + Layout_Array_Type (E); + elsif Is_Record_Type (E) then + Layout_Record_Type (E); + end if; + end if; + end Layout_Type; + + --------------------- + -- Rewrite_Integer -- + --------------------- + + procedure Rewrite_Integer (N : Node_Id; V : Uint) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + Rewrite (N, Make_Integer_Literal (Loc, Intval => V)); + Set_Etype (N, Typ); + end Rewrite_Integer; + + ------------------------------- + -- Set_And_Check_Static_Size -- + ------------------------------- + + procedure Set_And_Check_Static_Size + (E : Entity_Id; + Esiz : SO_Ref; + RM_Siz : SO_Ref) + is + SC : Node_Id; + + procedure Check_Size_Too_Small (Spec : Uint; Min : Uint); + -- Spec is the number of bit specified in the size clause, and + -- Min is the minimum computed size. An error is given that the + -- specified size is too small if Spec < Min, and in this case + -- both Esize and RM_Size are set to unknown in E. The error + -- message is posted on node SC. + + procedure Check_Unused_Bits (Spec : Uint; Max : Uint); + -- Spec is the number of bits specified in the size clause, and + -- Max is the maximum computed size. A warning is given about + -- unused bits if Spec > Max. This warning is posted on node SC. + + -------------------------- + -- Check_Size_Too_Small -- + -------------------------- + + procedure Check_Size_Too_Small (Spec : Uint; Min : Uint) is + begin + if Spec < Min then + Error_Msg_Uint_1 := Min; + Error_Msg_NE + ("size for & too small, minimum allowed is ^", SC, E); + Init_Esize (E); + Init_RM_Size (E); + end if; + end Check_Size_Too_Small; + + ----------------------- + -- Check_Unused_Bits -- + ----------------------- + + procedure Check_Unused_Bits (Spec : Uint; Max : Uint) is + begin + if Spec > Max then + Error_Msg_Uint_1 := Spec - Max; + Error_Msg_NE ("?^ bits of & unused", SC, E); + end if; + end Check_Unused_Bits; + + -- Start of processing for Set_And_Check_Static_Size + + begin + -- Case where Object_Size (Esize) is already set by a size clause + + if Known_Static_Esize (E) then + SC := Size_Clause (E); + + if No (SC) then + SC := Get_Attribute_Definition_Clause (E, Attribute_Object_Size); + end if; + + -- Perform checks on specified size against computed sizes + + if Present (SC) then + Check_Unused_Bits (Esize (E), Esiz); + Check_Size_Too_Small (Esize (E), RM_Siz); + end if; + end if; + + -- Case where Value_Size (RM_Size) is set by specific Value_Size + -- clause (we do not need to worry about Value_Size being set by + -- a Size clause, since that will have set Esize as well, and we + -- already took care of that case). + + if Known_Static_RM_Size (E) then + SC := Get_Attribute_Definition_Clause (E, Attribute_Value_Size); + + -- Perform checks on specified size against computed sizes + + if Present (SC) then + Check_Unused_Bits (RM_Size (E), Esiz); + Check_Size_Too_Small (RM_Size (E), RM_Siz); + end if; + end if; + + -- Set sizes if unknown + + if Unknown_Esize (E) then + Set_Esize (E, Esiz); + end if; + + if Unknown_RM_Size (E) then + Set_RM_Size (E, RM_Siz); + end if; + end Set_And_Check_Static_Size; + + -------------------------- + -- Set_Discrete_RM_Size -- + -------------------------- + + procedure Set_Discrete_RM_Size (Def_Id : Entity_Id) is + FST : constant Entity_Id := First_Subtype (Def_Id); + + begin + -- All discrete types except for the base types in standard + -- are constrained, so indicate this by setting Is_Constrained. + + Set_Is_Constrained (Def_Id); + + -- We set generic types to have an unknown size, since the + -- representation of a generic type is irrelevant, in view + -- of the fact that they have nothing to do with code. + + if Is_Generic_Type (Root_Type (FST)) then + Set_RM_Size (Def_Id, Uint_0); + + -- If the subtype statically matches the first subtype, then + -- it is required to have exactly the same layout. This is + -- required by aliasing considerations. + + elsif Def_Id /= FST and then + Subtypes_Statically_Match (Def_Id, FST) + then + Set_RM_Size (Def_Id, RM_Size (FST)); + Set_Size_Info (Def_Id, FST); + + -- In all other cases the RM_Size is set to the minimum size. + -- Note that this routine is never called for subtypes for which + -- the RM_Size is set explicitly by an attribute clause. + + else + Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id))); + end if; + end Set_Discrete_RM_Size; + + ------------------------ + -- Set_Prim_Alignment -- + ------------------------ + + procedure Set_Prim_Alignment (E : Entity_Id) is + begin + -- Do not set alignment for packed array types, unless we are doing + -- front end layout, because otherwise this is always handled in the + -- backend. + + if Is_Packed_Array_Type (E) and then not Frontend_Layout_On_Target then + return; + + -- If there is an alignment clause, then we respect it + + elsif Has_Alignment_Clause (E) then + return; + + -- If the size is not set, then don't attempt to set the alignment. This + -- happens in the backend layout case for access to subprogram types. + + elsif not Known_Static_Esize (E) then + return; + + -- For access types, do not set the alignment if the size is less than + -- the allowed minimum size. This avoids cascaded error messages. + + elsif Is_Access_Type (E) + and then Esize (E) < System_Address_Size + then + return; + end if; + + -- Here we calculate the alignment as the largest power of two + -- multiple of System.Storage_Unit that does not exceed either + -- the actual size of the type, or the maximum allowed alignment. + + declare + S : constant Int := + UI_To_Int (Esize (E)) / SSU; + A : Nat; + + begin + A := 1; + while 2 * A <= Ttypes.Maximum_Alignment + and then 2 * A <= S + loop + A := 2 * A; + end loop; + + -- Now we think we should set the alignment to A, but we + -- skip this if an alignment is already set to a value + -- greater than A (happens for derived types). + + -- However, if the alignment is known and too small it + -- must be increased, this happens in a case like: + + -- type R is new Character; + -- for R'Size use 16; + + -- Here the alignment inherited from Character is 1, but + -- it must be increased to 2 to reflect the increased size. + + if Unknown_Alignment (E) or else Alignment (E) < A then + Init_Alignment (E, A); + end if; + end; + end Set_Prim_Alignment; + + ---------------------- + -- SO_Ref_From_Expr -- + ---------------------- + + function SO_Ref_From_Expr + (Expr : Node_Id; + Ins_Type : Entity_Id; + Vtype : Entity_Id := Empty) + return Dynamic_SO_Ref + is + Loc : constant Source_Ptr := Sloc (Ins_Type); + + K : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('K')); + + Decl : Node_Id; + + function Check_Node_V_Ref (N : Node_Id) return Traverse_Result; + -- Function used to check one node for reference to V + + function Has_V_Ref is new Traverse_Func (Check_Node_V_Ref); + -- Function used to traverse tree to check for reference to V + + ---------------------- + -- Check_Node_V_Ref -- + ---------------------- + + function Check_Node_V_Ref (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier then + if Chars (N) = Vname then + return Abandon; + else + return Skip; + end if; + + else + return OK; + end if; + end Check_Node_V_Ref; + + -- Start of processing for SO_Ref_From_Expr + + begin + -- Case of expression is an integer literal, in this case we just + -- return the value (which must always be non-negative, since size + -- and offset values can never be negative). + + if Nkind (Expr) = N_Integer_Literal then + pragma Assert (Intval (Expr) >= 0); + return Intval (Expr); + end if; + + -- Case where there is a reference to V, create function + + if Has_V_Ref (Expr) = Abandon then + + pragma Assert (Present (Vtype)); + Set_Is_Discrim_SO_Function (K); + + Decl := + Make_Subprogram_Body (Loc, + + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => K, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars => Vname), + Parameter_Type => + New_Occurrence_Of (Vtype, Loc))), + Subtype_Mark => + New_Occurrence_Of (Standard_Unsigned, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => Expr)))); + + -- No reference to V, create constant + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => K, + Object_Definition => + New_Occurrence_Of (Standard_Unsigned, Loc), + Constant_Present => True, + Expression => Expr); + end if; + + Append_Freeze_Action (Ins_Type, Decl); + Analyze (Decl); + return Create_Dynamic_SO_Ref (K); + end SO_Ref_From_Expr; + +end Layout; diff --git a/gcc/ada/layout.ads b/gcc/ada/layout.ads new file mode 100644 index 00000000000..277ef5c0994 --- /dev/null +++ b/gcc/ada/layout.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L A Y O U T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package does front-end layout of types and objects. The result is +-- to annotate the tree with information on size and alignment of types +-- and objects. How much layout is performed depends on the setting of the +-- target dependent parameter Backend_Layout. + +with Types; use Types; + +package Layout is + + -- The following procedures are called from Freeze, so all entities + -- for types and objects that get frozen (which should be all such + -- entities which are seen by the back end) will get layed out by one + -- of these two procedures. + + procedure Layout_Type (E : Entity_Id); + -- This procedure may set or adjust the fields Esize, RM_Size and + -- Alignment in the non-generic type or subtype entity E. If the + -- Backend_Layout switch is False, then it is guaranteed that all + -- three fields will be properly set on return. Regardless of the + -- Backend_Layout value, it is guaranteed that all discrete types + -- will have both Esize and RM_Size fields set on return (since + -- these are static values). Note that Layout_Type is not called + -- for generic types, since these play no part in code generation, + -- and hence representation aspects are irrelevant. + + procedure Layout_Object (E : Entity_Id); + -- E is either a variable (E_Variable), a constant (E_Constant), + -- a loop parameter (E_Loop_Parameter), or a formal parameter of + -- a non-generic subprogram (E_In_Parameter, E_In_Out_Parameter, + -- or E_Out_Parameter). This procedure may set or adjust the + -- Esize and Alignment fields of E. If Backend_Layout is False, + -- then it is guaranteed that both fields will be properly set + -- on return. If the Esize is still unknown in the latter case, + -- it means that the object must be allocated dynamically, since + -- its length is not known at compile time. + + procedure Set_Discrete_RM_Size (Def_Id : Entity_Id); + -- Set proper RM_Size for discrete size, this is normally the minimum + -- number of bits to accomodate the range given, except in the case + -- where the subtype statically matches the first subtype, in which + -- case the size must be copied from the first subtype. For generic + -- types, the RM_Size is simply set to zero. This routine also sets + -- the Is_Constrained flag in Def_Id. + + procedure Set_Prim_Alignment (E : Entity_Id); + -- The front end always sets alignments for primitive types by calling this + -- procedure. Note that we have to do this for discrete types (since the + -- Alignment attribute is static), so we might as well do it for all + -- scalar types, since the processing is the same. + +end Layout; diff --git a/gcc/ada/lib-list.adb b/gcc/ada/lib-list.adb new file mode 100644 index 00000000000..0c900c6a691 --- /dev/null +++ b/gcc/ada/lib-list.adb @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . L I S T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.32 $ +-- -- +-- Copyright (C) 1992-1999 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Output; use Output; + +separate (Lib) +procedure List (File_Names_Only : Boolean := False) is + + Num_Units : constant Nat := Int (Units.Last) - Int (Units.First) + 1; + -- Number of units in file table + + Sorted_Units : Unit_Ref_Table (1 .. Num_Units); + -- Table of unit numbers that we will sort + + Unit_Node : Node_Id; + -- Compilation unit node for current unit + + Unit_Hed : constant String := "Unit name "; + Unit_Und : constant String := "--------- "; + Unit_Bln : constant String := " "; + File_Hed : constant String := "File name "; + File_Und : constant String := "--------- "; + File_Bln : constant String := " "; + Time_Hed : constant String := "Time stamp"; + Time_Und : constant String := "----------"; + + Unit_Length : constant Natural := Unit_Hed'Length; + File_Length : constant Natural := File_Hed'Length; + +begin + -- First step is to make a sorted table of units + + for J in 1 .. Num_Units loop + Sorted_Units (J) := Unit_Number_Type (Int (Units.First) + J - 1); + end loop; + + Sort (Sorted_Units); + + -- Now we can generate the unit table listing + + Write_Eol; + + if not File_Names_Only then + Write_Str (Unit_Hed); + Write_Str (File_Hed); + Write_Str (Time_Hed); + Write_Eol; + + Write_Str (Unit_Und); + Write_Str (File_Und); + Write_Str (Time_Und); + Write_Eol; + Write_Eol; + end if; + + for R in Sorted_Units'Range loop + Unit_Node := Cunit (Sorted_Units (R)); + + if File_Names_Only then + if not Is_Internal_File_Name + (File_Name (Source_Index (Sorted_Units (R)))) + then + Write_Name (Full_File_Name (Source_Index (Sorted_Units (R)))); + Write_Eol; + end if; + + else + Write_Unit_Name (Unit_Name (Sorted_Units (R))); + + if Name_Len > (Unit_Length - 1) then + Write_Eol; + Write_Str (Unit_Bln); + else + for J in Name_Len + 1 .. Unit_Length loop + Write_Char (' '); + end loop; + end if; + + Write_Name (Full_File_Name (Source_Index (Sorted_Units (R)))); + + if Name_Len > (File_Length - 1) then + Write_Eol; + Write_Str (Unit_Bln); + Write_Str (File_Bln); + else + for J in Name_Len + 1 .. File_Length loop + Write_Char (' '); + end loop; + end if; + + Write_Str (String (Time_Stamp (Source_Index (Sorted_Units (R))))); + Write_Eol; + end if; + end loop; + + Write_Eol; +end List; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb new file mode 100644 index 00000000000..b1f18d5f41e --- /dev/null +++ b/gcc/ada/lib-load.adb @@ -0,0 +1,717 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . L O A D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.86 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Errout; use Errout; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Par; +with Scn; use Scn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Tbuild; use Tbuild; +with Uname; use Uname; + +package body Lib.Load is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Spec_Is_Irrelevant + (Spec_Unit : Unit_Number_Type; + Body_Unit : Unit_Number_Type) + return Boolean; + -- The Spec_Unit and Body_Unit parameters are the unit numbers of the + -- spec file that corresponds to the main unit which is a body. This + -- function determines if the spec file is irrelevant and will be + -- overridden by the body as described in RM 10.1.4(4). See description + -- in "Special Handling of Subprogram Bodies" for further details. + + procedure Write_Dependency_Chain; + -- This procedure is used to generate error message info lines that + -- trace the current dependency chain when a load error occurs. + + ------------------------------- + -- Create_Dummy_Package_Unit -- + ------------------------------- + + function Create_Dummy_Package_Unit + (With_Node : Node_Id; + Spec_Name : Unit_Name_Type) + return Unit_Number_Type + is + Unum : Unit_Number_Type; + Cunit_Entity : Entity_Id; + Cunit : Node_Id; + Du_Name : Node_Or_Entity_Id; + End_Lab : Node_Id; + Save_CS : constant Boolean := Get_Comes_From_Source_Default; + + begin + -- The created dummy package unit does not come from source + + Set_Comes_From_Source_Default (False); + + -- Normal package + + if Nkind (Name (With_Node)) = N_Identifier then + Cunit_Entity := + Make_Defining_Identifier (No_Location, + Chars => Chars (Name (With_Node))); + Du_Name := Cunit_Entity; + End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location); + + -- Child package + + else -- Nkind (Name (With_Node)) = N_Expanded_Name + Cunit_Entity := + Make_Defining_Identifier (No_Location, + Chars => Chars (Selector_Name (Name (With_Node)))); + Du_Name := + Make_Defining_Program_Unit_Name (No_Location, + Name => New_Copy_Tree (Prefix (Name (With_Node))), + Defining_Identifier => Cunit_Entity); + End_Lab := + Make_Designator (No_Location, + Name => New_Copy_Tree (Prefix (Name (With_Node))), + Identifier => New_Occurrence_Of (Cunit_Entity, No_Location)); + end if; + + Cunit := + Make_Compilation_Unit (No_Location, + Context_Items => Empty_List, + Unit => + Make_Package_Declaration (No_Location, + Specification => + Make_Package_Specification (No_Location, + Defining_Unit_Name => Du_Name, + Visible_Declarations => Empty_List, + End_Label => End_Lab)), + Aux_Decls_Node => + Make_Compilation_Unit_Aux (No_Location)); + + Units.Increment_Last; + Unum := Units.Last; + + Units.Table (Unum) := ( + Cunit => Cunit, + Cunit_Entity => Cunit_Entity, + Dependency_Num => 0, + Dependent_Unit => False, + Dynamic_Elab => False, + Error_Location => Sloc (With_Node), + Expected_Unit => Spec_Name, + Fatal_Error => True, + Generate_Code => False, + Has_RACW => False, + Ident_String => Empty, + Loading => False, + Main_Priority => Default_Main_Priority, + Serial_Number => 0, + Source_Index => No_Source_File, + Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), + Unit_Name => Spec_Name, + Version => 0); + + Set_Comes_From_Source_Default (Save_CS); + Set_Error_Posted (Cunit_Entity); + Set_Error_Posted (Cunit); + return Unum; + end Create_Dummy_Package_Unit; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Fname : File_Name_Type; + + begin + Units.Init; + Load_Stack.Init; + Load_Stack.Increment_Last; + Load_Stack.Table (Load_Stack.Last) := Main_Unit; + + -- Initialize unit table entry for Main_Unit. Note that we don't know + -- the unit name yet, that gets filled in when the parser parses the + -- main unit, at which time a check is made that it matches the main + -- file name, and then the Unit_Name field is set. The Cunit and + -- Cunit_Entity fields also get filled in later by the parser. + + Units.Increment_Last; + Fname := Next_Main_Source; + + Units.Table (Main_Unit).Unit_File_Name := Fname; + + if Fname /= No_File then + + Main_Source_File := Load_Source_File (Fname); + Current_Error_Source_File := Main_Source_File; + + Units.Table (Main_Unit) := ( + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dependent_Unit => True, + Dynamic_Elab => False, + Error_Location => No_Location, + Expected_Unit => No_Name, + Fatal_Error => False, + Generate_Code => False, + Has_RACW => False, + Loading => True, + Ident_String => Empty, + Main_Priority => Default_Main_Priority, + Serial_Number => 0, + Source_Index => Main_Source_File, + Unit_File_Name => Fname, + Unit_Name => No_Name, + Version => Source_Checksum (Main_Source_File)); + end if; + end Initialize; + + ------------------------ + -- Initialize_Version -- + ------------------------ + + procedure Initialize_Version (U : Unit_Number_Type) is + begin + Units.Table (U).Version := Source_Checksum (Source_Index (U)); + end Initialize_Version; + + --------------- + -- Load_Unit -- + --------------- + + function Load_Unit + (Load_Name : Unit_Name_Type; + Required : Boolean; + Error_Node : Node_Id; + Subunit : Boolean; + Corr_Body : Unit_Number_Type := No_Unit; + Renamings : Boolean := False) + return Unit_Number_Type + is + Calling_Unit : Unit_Number_Type; + Uname_Actual : Unit_Name_Type; + Unum : Unit_Number_Type; + Unump : Unit_Number_Type; + Fname : File_Name_Type; + Src_Ind : Source_File_Index; + Discard : List_Id; + + procedure Set_Load_Unit_Dependency (U : Unit_Number_Type); + -- Sets the Dependent_Unit flag unless we have a predefined unit + -- being loaded in No_Run_Time mode. In this case we do not want + -- to create a dependency, since we have loaded the unit only + -- to inline stuff from it. If this is not the case, an error + -- message will be issued in Rtsfind in any case. + + procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is + begin + if No_Run_Time + and then Is_Internal_File_Name (Unit_File_Name (U)) + then + null; + else + Units.Table (U).Dependent_Unit := True; + end if; + end Set_Load_Unit_Dependency; + + -- Start of processing for Load_Unit + + begin + -- If renamings are allowed and we have a child unit name, then we + -- must first load the parent to deal with finding the real name. + + if Renamings and then Is_Child_Name (Load_Name) then + Unump := + Load_Unit + (Load_Name => Get_Parent_Spec_Name (Load_Name), + Required => Required, + Subunit => False, + Renamings => True, + Error_Node => Error_Node); + + if Unump = No_Unit then + return No_Unit; + end if; + + -- If parent is a renaming, then we use the renamed package as + -- the actual parent for the subsequent load operation. + + if Nkind (Parent (Cunit_Entity (Unump))) = + N_Package_Renaming_Declaration + then + Uname_Actual := + New_Child + (Load_Name, + Get_Unit_Name (Name (Parent (Cunit_Entity (Unump))))); + + -- Save the renaming entity, to establish its visibility when + -- installing the context. The implicit with is on this entity, + -- not on the package it renames. + + if Nkind (Error_Node) = N_With_Clause + and then Nkind (Name (Error_Node)) = N_Selected_Component + then + declare + Par : Node_Id := Name (Error_Node); + + begin + while Nkind (Par) = N_Selected_Component + and then Chars (Selector_Name (Par)) /= + Chars (Cunit_Entity (Unump)) + loop + Par := Prefix (Par); + end loop; + + if Nkind (Par) = N_Selected_Component then + -- some intermediate parent is a renaming. + + Set_Entity (Selector_Name (Par), Cunit_Entity (Unump)); + + else + -- the ultimate parent is a renaming. + + Set_Entity (Par, Cunit_Entity (Unump)); + end if; + end; + end if; + + -- If the parent is not a renaming, then get its name (this may + -- be different from the parent spec name obtained above because + -- of renamings higher up in the hierarchy). + + else + Uname_Actual := New_Child (Load_Name, Unit_Name (Unump)); + end if; + + -- Here if unit to be loaded is not a child unit + + else + Uname_Actual := Load_Name; + end if; + + Fname := Get_File_Name (Uname_Actual, Subunit); + + if Debug_Flag_L then + Write_Eol; + Write_Str ("*** Load request for unit: "); + Write_Unit_Name (Load_Name); + + if Required then + Write_Str (" (Required = True)"); + else + Write_Str (" (Required = False)"); + end if; + + Write_Eol; + + if Uname_Actual /= Load_Name then + Write_Str ("*** Actual unit loaded: "); + Write_Unit_Name (Uname_Actual); + end if; + end if; + + -- Capture error location if it is for the main unit. The idea is to + -- post errors on the main unit location, not the most recent unit. + + if Present (Error_Node) then + + -- It seems like In_Extended_Main_Source_Unit (Error_Node) would + -- do the trick here, but that's wrong, it is much too early to + -- call this routine. We are still in the parser, and the required + -- semantic information is not established yet. So we base the + -- judgment on unit names. + + Get_External_Unit_Name_String (Unit_Name (Main_Unit)); + + declare + Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len); + + begin + Get_External_Unit_Name_String + (Unit_Name (Get_Source_Unit (Error_Node))); + + -- If the two names are identical, then for sure we are part + -- of the extended main unit + + if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then + Load_Msg_Sloc := Sloc (Error_Node); + + -- If the load is called from a with_type clause, the error + -- node is correct. + + elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then + Load_Msg_Sloc := Sloc (Error_Node); + + -- Otherwise, check for the subunit case, and if so, consider + -- we have a match if one name is a prefix of the other name. + + else + if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit + or else + Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) = + N_Subunit + then + Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length); + + if Name_Buffer (1 .. Name_Len) + = + Main_Unit_Name (1 .. Name_Len) + then + Load_Msg_Sloc := Sloc (Error_Node); + end if; + end if; + end if; + end; + end if; + + -- If we are generating error messages, then capture calling unit + + if Present (Error_Node) then + Calling_Unit := Get_Source_Unit (Error_Node); + else + Calling_Unit := No_Unit; + end if; + + -- See if we already have an entry for this unit + + Unum := Main_Unit; + + while Unum <= Units.Last loop + exit when Uname_Actual = Units.Table (Unum).Unit_Name; + Unum := Unum + 1; + end loop; + + -- Whether or not the entry was found, Unum is now the right value, + -- since it is one more than Units.Last (i.e. the index of the new + -- entry we will create) in the not found case. + + -- A special check is necessary in the unit not found case. If the unit + -- is not found, but the file in which it lives has already been loaded, + -- then we have the problem that the file does not contain the unit that + -- is needed. We simply treat this as a file not found condition. + + if Unum > Units.Last then + for J in Units.First .. Units.Last loop + if Fname = Units.Table (J).Unit_File_Name then + if Debug_Flag_L then + Write_Str (" file does not contain unit, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + Write_Eol; + end if; + + if Present (Error_Node) then + + if Is_Predefined_File_Name (Fname) then + Error_Msg_Name_1 := Uname_Actual; + Error_Msg + ("% is not a language defined unit", Load_Msg_Sloc); + else + Error_Msg_Name_1 := Fname; + Error_Msg_Unit_1 := Uname_Actual; + Error_Msg + ("File{ does not contain unit$", Load_Msg_Sloc); + end if; + + Write_Dependency_Chain; + return No_Unit; + + else + return No_Unit; + end if; + end if; + end loop; + end if; + + -- If we are proceeding with load, then make load stack entry + + Load_Stack.Increment_Last; + Load_Stack.Table (Load_Stack.Last) := Unum; + + -- Case of entry already in table + + if Unum <= Units.Last then + + -- Here is where we check for a circular dependency, which is + -- an attempt to load a unit which is currently in the process + -- of being loaded. We do *not* care about a circular chain that + -- leads back to a body, because this kind of circular dependence + -- legitimately occurs (e.g. two package bodies that contain + -- inlined subprogram referenced by the other). + + if Loading (Unum) + and then (Is_Spec_Name (Units.Table (Unum).Unit_Name) + or else Acts_As_Spec (Units.Table (Unum).Cunit)) + then + if Debug_Flag_L then + Write_Str (" circular dependency encountered"); + Write_Eol; + end if; + + if Present (Error_Node) then + Error_Msg ("circular unit dependency", Load_Msg_Sloc); + Write_Dependency_Chain; + else + Load_Stack.Decrement_Last; + end if; + + return No_Unit; + end if; + + if Debug_Flag_L then + Write_Str (" unit already in file table, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + end if; + + Load_Stack.Decrement_Last; + Set_Load_Unit_Dependency (Unum); + return Unum; + + -- File is not already in table, so try to open it + + else + if Debug_Flag_L then + Write_Str (" attempt unit load, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + end if; + + Src_Ind := Load_Source_File (Fname); + + -- Make a partial entry in the file table, used even in the file not + -- found case to print the dependency chain including the last entry + + Units.Increment_Last; + Units.Table (Unum).Unit_Name := Uname_Actual; + + -- File was found + + if Src_Ind /= No_Source_File then + Units.Table (Unum) := ( + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dependent_Unit => False, + Dynamic_Elab => False, + Error_Location => Sloc (Error_Node), + Expected_Unit => Uname_Actual, + Fatal_Error => False, + Generate_Code => False, + Has_RACW => False, + Ident_String => Empty, + Loading => True, + Main_Priority => Default_Main_Priority, + Serial_Number => 0, + Source_Index => Src_Ind, + Unit_File_Name => Fname, + Unit_Name => Uname_Actual, + Version => Source_Checksum (Src_Ind)); + + -- Parse the new unit + + Initialize_Scanner (Unum, Source_Index (Unum)); + Discard := Par (Configuration_Pragmas => False); + Set_Loading (Unum, False); + + -- If spec is irrelevant, then post errors and quit + + if Corr_Body /= No_Unit + and then Spec_Is_Irrelevant (Unum, Corr_Body) + then + Error_Msg_Name_1 := Unit_File_Name (Corr_Body); + Error_Msg + ("cannot compile subprogram in file {!", + Load_Msg_Sloc); + Error_Msg_Name_1 := Unit_File_Name (Unum); + Error_Msg + ("incorrect spec in file { must be removed first!", + Load_Msg_Sloc); + return No_Unit; + end if; + + -- If loaded unit had a fatal error, then caller inherits it! + + if Units.Table (Unum).Fatal_Error + and then Present (Error_Node) + then + Units.Table (Calling_Unit).Fatal_Error := True; + end if; + + -- Remove load stack entry and return the entry in the file table + + Load_Stack.Decrement_Last; + Set_Load_Unit_Dependency (Unum); + return Unum; + + -- Case of file not found + + else + if Debug_Flag_L then + Write_Str (" file was not found, load failed"); + Write_Eol; + end if; + + -- Generate message if unit required + + if Required and then Present (Error_Node) then + + if Is_Predefined_File_Name (Fname) then + Error_Msg_Name_1 := Uname_Actual; + Error_Msg + ("% is not a predefined library unit", Load_Msg_Sloc); + + else + Error_Msg_Name_1 := Fname; + Error_Msg ("file{ not found", Load_Msg_Sloc); + end if; + + Write_Dependency_Chain; + + -- Remove unit from stack, to avoid cascaded errors on + -- subsequent missing files. + + Load_Stack.Decrement_Last; + Units.Decrement_Last; + + -- If unit not required, remove load stack entry and the junk + -- file table entry, and return No_Unit to indicate not found, + + else + Load_Stack.Decrement_Last; + Units.Decrement_Last; + end if; + + return No_Unit; + end if; + end if; + end Load_Unit; + + ------------------------ + -- Make_Instance_Unit -- + ------------------------ + + -- If the unit is an instance, it appears as a package declaration, but + -- contains both declaration and body of the instance. The body becomes + -- the main unit of the compilation, and the declaration is inserted + -- at the end of the unit table. The main unit now has the name of a + -- body, which is constructed from the name of the original spec, + -- and is attached to the compilation node of the original unit. The + -- declaration has been attached to a new compilation unit node, and + -- code will have to be generated for it. + + procedure Make_Instance_Unit (N : Node_Id) is + Sind : constant Source_File_Index := Source_Index (Main_Unit); + + begin + Units.Increment_Last; + + Units.Table (Units.Last) := Units.Table (Main_Unit); + Units.Table (Units.Last).Cunit := Library_Unit (N); + Units.Table (Units.Last).Generate_Code := True; + + Units.Table (Main_Unit).Cunit := N; + Units.Table (Main_Unit).Unit_Name := + Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))); + Units.Table (Main_Unit).Version := Source_Checksum (Sind); + end Make_Instance_Unit; + + ------------------------ + -- Spec_Is_Irrelevant -- + ------------------------ + + function Spec_Is_Irrelevant + (Spec_Unit : Unit_Number_Type; + Body_Unit : Unit_Number_Type) + return Boolean + is + Sunit : constant Node_Id := Cunit (Spec_Unit); + Bunit : constant Node_Id := Cunit (Body_Unit); + + begin + -- The spec is irrelevant if the body is a subprogram body, and the + -- spec is other than a subprogram spec or generic subprogram spec. + -- Note that the names must be the same, we don't need to check that, + -- because we already know that from the fact that the file names are + -- the same. + + return + Nkind (Unit (Bunit)) = N_Subprogram_Body + and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration + and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration; + + end Spec_Is_Irrelevant; + + -------------------- + -- Version_Update -- + -------------------- + + procedure Version_Update (U : Node_Id; From : Node_Id) is + Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U); + Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From); + + begin + Units.Table (Unum).Version := + Units.Table (Unum).Version + xor + Source_Checksum (Source_Index (Fnum)); + end Version_Update; + + ---------------------------- + -- Write_Dependency_Chain -- + ---------------------------- + + procedure Write_Dependency_Chain is + begin + -- The dependency chain is only written if it is at least two entries + -- deep, otherwise it is trivial (the main unit depending on a unit + -- that it obviously directly depends on). + + if Load_Stack.Last - 1 > Load_Stack.First then + for U in Load_Stack.First .. Load_Stack.Last - 1 loop + Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U)); + Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1)); + Error_Msg ("$ depends on $!", Load_Msg_Sloc); + end loop; + end if; + end Write_Dependency_Chain; + +end Lib.Load; diff --git a/gcc/ada/lib-load.ads b/gcc/ada/lib-load.ads new file mode 100644 index 00000000000..1434e843238 --- /dev/null +++ b/gcc/ada/lib-load.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . L O A D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This child package contains the function used to load a separately +-- compiled unit, as well as the routine used to initialize the unit +-- table and load the main source file. + +package Lib.Load is + + ------------------------------- + -- Handling of Renamed Units -- + ------------------------------- + + -- A compilation unit can be a renaming of another compilation unit. + -- Such renamed units are not allowed as parent units, that is you + -- cannot declare a unit: + + -- with x; + -- package x.y is end; + + -- where x is a renaming of some other package. However you can refer + -- to a renamed unit in a with clause: + + -- package p is end; + + -- package p.q is end; + + -- with p; + -- package pr renames p; + + -- with pr.q .... + + -- This means that in the context of a with clause, the normal fixed + -- correspondence between unit and file names is broken. In the above + -- example, there is no file named pr-q.ads, since the actual child + -- unit is p.q, and it will be found in file p-q.ads. + + -- In order to deal with this case, we have to first load pr.ads, and + -- then discover that it is a renaming of p, so that we know that pr.q + -- really refers to p.q. Furthermore this can happen at any level: + + -- with p.q; + -- package p.r renames p.q; + + -- with p.q; + -- package p.q.s is end; + + -- with p.r.s ... + + -- Now we have a case where the parent p.r is a child unit and is + -- a renaming. This shows that renaming can occur at any level. + + -- Finally, consider: + + -- with pr.q.s ... + + -- Here the parent pr.q is not itself a renaming, but it really refers + -- to the unit p.q, and again we cannot know this without loading the + -- parent. The bottom line here is that while the file name of a unit + -- always corresponds to the unit name, the unit name as given to the + -- Load_Unit function may not be the real unit. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Called at the start of compiling a new main source unit to initialize + -- the library processing for the new main source. Establishes and + -- initializes the units table entry for the new main unit (leaving + -- the Unit_File_Name entry of Main_Unit set to No_File if there are no + -- more files. Otherwise the main source file has been opened and read + -- and then closed on return. + + procedure Initialize_Version (U : Unit_Number_Type); + -- This is called once the source file corresponding to unit U has been + -- fully scanned. At that point the checksum is computed, and can be used + -- to initialize the version number. + + function Load_Unit + (Load_Name : Unit_Name_Type; + Required : Boolean; + Error_Node : Node_Id; + Subunit : Boolean; + Corr_Body : Unit_Number_Type := No_Unit; + Renamings : Boolean := False) + return Unit_Number_Type; + -- This function loads and parses the unit specified by Load_Name (or + -- returns the unit number for the previously constructed units table + -- entry if this is not the first call for this unit). Required indicates + -- the behavior on a file not found condition, as further described below, + -- and Error_Node is the node in the calling program to which error + -- messages are to be attached. + -- + -- If the corresponding file is found, the value returned by Load is the + -- unit number that indexes the corresponding entry in the units table. If + -- a serious enough parser error occurs to prevent subsequent semantic + -- analysis, then the Fatal_Error flag of the returned entry is set and + -- in addition, the fatal error flag of the calling unit is also set. + -- + -- If the corresponding file is not found, then the behavior depends on + -- the setting of Required. If Required is False, then No_Unit is returned + -- and no error messages are issued. If Required is True, then an error + -- message is posted, and No_Unit is returned. + -- + -- A special case arises in the call from Rtsfind, where Error_Node is set + -- to Empty. In this case Required is False, and the caller in any case + -- treats any error as fatal. + -- + -- The Subunit parameter is True to load a subunit, and False to load + -- any other kind of unit (including all specs, package bodies, and + -- subprogram bodies). + -- + -- The Corr_Body argument is normally defaulted. It is set only in the + -- case of loading the corresponding spec when the main unit is a body. + -- In this case, Corr_Body is the unit number of this corresponding + -- body. This is used to set the Serial_Ref_Unit field of the unit + -- table entry. It is also used to deal with the special processing + -- required by RM 10.1.4(4). See description in lib.ads. + -- + -- Renamings activates the handling of renamed units as separately + -- described in the documentation of this unit. If this parameter is + -- set to True, then Load_Name may not be the real unit name and it + -- is necessary to load parents to find the real name. + + function Create_Dummy_Package_Unit + (With_Node : Node_Id; + Spec_Name : Unit_Name_Type) + return Unit_Number_Type; + -- With_Node is the Node_Id of a with statement for which the file could + -- not be found, and Spec_Name is the corresponding unit name. This call + -- creates a dummy package unit so that compilation can continue without + -- blowing up when the missing unit is referenced. + + procedure Make_Instance_Unit (N : Node_Id); + -- When a compilation unit is an instantiation, it contains both the + -- declaration and the body of the instance, each of which can have its + -- own elaboration routine. The file itself corresponds to the declaration. + -- We create an additional entry for the body, so that the binder can + -- generate the proper elaboration calls to both. The argument N is the + -- compilation unit node created for the body. + + procedure Version_Update (U : Node_Id; From : Node_Id); + -- This routine is called when unit U is found to be semantically + -- dependent on unit From. It updates the version of U to register + -- dependence on the version of From. The arguments are compilation + -- unit nodes for the relevant library nodes. + +end Lib.Load; diff --git a/gcc/ada/lib-sort.adb b/gcc/ada/lib-sort.adb new file mode 100644 index 00000000000..3fdfb72fe92 --- /dev/null +++ b/gcc/ada/lib-sort.adb @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . S O R T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995,1996 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; + +separate (Lib) +procedure Sort (Tbl : in out Unit_Ref_Table) is + + T : array (0 .. Integer (Tbl'Last - Tbl'First + 1)) of Unit_Number_Type; + -- Actual sort is done on this copy of the array with 0's origin + -- subscripts. Location 0 is used as a temporary by the sorting algorithm. + -- Also the addressing of the table is more efficient with 0's origin, + -- even though we have to copy Tbl back and forth. + + function Lt_Uname (C1, C2 : Natural) return Boolean; + -- Comparison routine for comparing Unames. Needed by the sorting routine. + + procedure Move_Uname (From : Natural; To : Natural); + -- Move routine needed by the sorting routine below. + + -------------- + -- Lt_Uname -- + -------------- + + function Lt_Uname (C1, C2 : Natural) return Boolean is + begin + return + Uname_Lt + (Units.Table (T (C1)).Unit_Name, Units.Table (T (C2)).Unit_Name); + end Lt_Uname; + + ---------------- + -- Move_Uname -- + ---------------- + + procedure Move_Uname (From : Natural; To : Natural) is + begin + T (To) := T (From); + end Move_Uname; + +-- Start of processing for Sort + +begin + if T'Last > 0 then + for I in 1 .. T'Last loop + T (I) := Tbl (Int (I) - 1 + Tbl'First); + end loop; + + Sort (T'Last, + Move_Uname'Unrestricted_Access, Lt_Uname'Unrestricted_Access); + + -- Sort is complete, copy result back into place + + for I in 1 .. T'Last loop + Tbl (Int (I) - 1 + Tbl'First) := T (I); + end loop; + end if; +end Sort; diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb new file mode 100644 index 00000000000..4e3770c5bab --- /dev/null +++ b/gcc/ada/lib-util.adb @@ -0,0 +1,219 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . U T I L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Namet; use Namet; +with Osint; use Osint; + +package body Lib.Util is + + Max_Line : constant Natural := 2 * Hostparm.Max_Name_Length + 64; + Max_Buffer : constant Natural := 1000 * Max_Line; + + Info_Buffer : String (1 .. Max_Buffer); + -- Info_Buffer used to prepare lines of library output + + Info_Buffer_Len : Natural := 0; + -- Number of characters stored in Info_Buffer + + Info_Buffer_Col : Natural := 1; + -- Column number of next character to be written. + -- Can be different from Info_Buffer_Len + 1 + -- because of tab characters written by Write_Info_Tab. + + --------------------- + -- Write_Info_Char -- + --------------------- + + procedure Write_Info_Char (C : Character) is + begin + Info_Buffer_Len := Info_Buffer_Len + 1; + Info_Buffer (Info_Buffer_Len) := C; + Info_Buffer_Col := Info_Buffer_Col + 1; + end Write_Info_Char; + + -------------------------- + -- Write_Info_Char_Code -- + -------------------------- + + procedure Write_Info_Char_Code (Code : Char_Code) is + + procedure Write_Info_Hex_Byte (J : Natural); + -- Write single hex digit + + procedure Write_Info_Hex_Byte (J : Natural) is + Hexd : String := "0123456789abcdef"; + + begin + Write_Info_Char (Hexd (J / 16 + 1)); + Write_Info_Char (Hexd (J mod 16 + 1)); + end Write_Info_Hex_Byte; + + -- Start of processing for Write_Info_Char_Code + + begin + if Code in 16#00# .. 16#7F# then + Write_Info_Char (Character'Val (Code)); + + elsif Code in 16#80# .. 16#FF# then + Write_Info_Char ('U'); + Write_Info_Hex_Byte (Natural (Code)); + + else + Write_Info_Char ('W'); + Write_Info_Hex_Byte (Natural (Code / 256)); + Write_Info_Hex_Byte (Natural (Code mod 256)); + end if; + end Write_Info_Char_Code; + + -------------------- + -- Write_Info_Col -- + -------------------- + + function Write_Info_Col return Positive is + begin + return Info_Buffer_Col; + end Write_Info_Col; + + -------------------- + -- Write_Info_EOL -- + -------------------- + + procedure Write_Info_EOL is + begin + if Hostparm.OpenVMS + or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer + then + Write_Info_Terminate; + else + -- Delete any trailing blanks + + while Info_Buffer_Len > 0 + and then Info_Buffer (Info_Buffer_Len) = ' ' + loop + Info_Buffer_Len := Info_Buffer_Len - 1; + end loop; + + Info_Buffer_Len := Info_Buffer_Len + 1; + Info_Buffer (Info_Buffer_Len) := ASCII.LF; + Info_Buffer_Col := 1; + end if; + end Write_Info_EOL; + + ------------------------- + -- Write_Info_Initiate -- + ------------------------- + + procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char; + + --------------------- + -- Write_Info_Name -- + --------------------- + + procedure Write_Info_Name (Name : Name_Id) is + begin + Get_Name_String (Name); + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := + Name_Buffer (1 .. Name_Len); + Info_Buffer_Len := Info_Buffer_Len + Name_Len; + Info_Buffer_Col := Info_Buffer_Col + Name_Len; + end Write_Info_Name; + + -------------------- + -- Write_Info_Nat -- + -------------------- + + procedure Write_Info_Nat (N : Nat) is + begin + if N > 9 then + Write_Info_Nat (N / 10); + end if; + + Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0'))); + end Write_Info_Nat; + + -------------------- + -- Write_Info_Str -- + -------------------- + + procedure Write_Info_Str (Val : String) is + begin + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length) + := Val; + Info_Buffer_Len := Info_Buffer_Len + Val'Length; + Info_Buffer_Col := Info_Buffer_Col + Val'Length; + end Write_Info_Str; + + -------------------- + -- Write_Info_Tab -- + -------------------- + + procedure Write_Info_Tab (Col : Positive) is + Next_Tab : Positive; + + begin + if Col <= Info_Buffer_Col then + Write_Info_Str (" "); + else + loop + Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1; + exit when Col < Next_Tab; + Write_Info_Char (ASCII.HT); + Info_Buffer_Col := Next_Tab; + end loop; + + while Info_Buffer_Col < Col loop + Write_Info_Char (' '); + end loop; + end if; + end Write_Info_Tab; + + -------------------------- + -- Write_Info_Terminate -- + -------------------------- + + procedure Write_Info_Terminate is + begin + -- Delete any trailing blanks + + while Info_Buffer_Len > 0 + and then Info_Buffer (Info_Buffer_Len) = ' ' + loop + Info_Buffer_Len := Info_Buffer_Len - 1; + end loop; + + -- Write_Library_Info adds the EOL + + Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len)); + + Info_Buffer_Len := 0; + Info_Buffer_Col := 1; + + end Write_Info_Terminate; + +end Lib.Util; diff --git a/gcc/ada/lib-util.ads b/gcc/ada/lib-util.ads new file mode 100644 index 00000000000..48644764d65 --- /dev/null +++ b/gcc/ada/lib-util.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . U T I L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1992-1999 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package Lib.Util is + + -- This package implements a buffered write of library information + + procedure Write_Info_Char (C : Character); + pragma Inline (Write_Info_Char); + -- Adds one character to the info + + procedure Write_Info_Char_Code (Code : Char_Code); + -- Write a single character code. Upper half values in the range + -- 16#80..16#FF are written as Uhh (hh = 2 hex digits), and values + -- greater than 16#FF are written as Whhhh (hhhh = 4 hex digits). + + function Write_Info_Col return Positive; + -- Returns the column in which the next character will be written + + procedure Write_Info_EOL; + -- Terminate current info line. This only flushes the buffer + -- if there is not enough room for another complete line or + -- if the host system needs a write for each line. + + procedure Write_Info_Initiate (Key : Character); + -- Initiates write of new line to info file, the parameter is the + -- keyword character for the line. The caller is responsible for + -- writing the required blank after the key character. + + procedure Write_Info_Nat (N : Nat); + -- Adds image of N to Info_Buffer with no leading or trailing blanks + + procedure Write_Info_Name (Name : Name_Id); + -- Adds characters of Name to Info_Buffer + + procedure Write_Info_Str (Val : String); + -- Adds characters of Val to Info_Buffer surrounded by quotes + + procedure Write_Info_Tab (Col : Positive); + -- Tab out with blanks and HT's to column Col. If already at or past + -- Col, writes a single blank, so that we do get a required field + -- separation. + + procedure Write_Info_Terminate; + -- Terminate current info line and output lines built in Info_Buffer + +end Lib.Util; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb new file mode 100644 index 00000000000..a7039f8390f --- /dev/null +++ b/gcc/ada/lib-writ.adb @@ -0,0 +1,936 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . W R I T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.160 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with ALI; use ALI; +with Atree; use Atree; +with Casing; use Casing; +with Einfo; use Einfo; +with Errout; use Errout; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib.Util; use Lib.Util; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Gnatvsn; use Gnatvsn; +with Opt; use Opt; +with Osint; use Osint; +with Par; +with Restrict; use Restrict; +with Scn; use Scn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Uname; use Uname; + +with System.WCh_Con; use System.WCh_Con; + +package body Lib.Writ is + + ------------------------------ + -- Ensure_System_Dependency -- + ------------------------------ + + procedure Ensure_System_Dependency is + Discard : List_Id; + + System_Uname : Unit_Name_Type; + -- Unit name for system spec if needed for dummy entry + + System_Fname : File_Name_Type; + -- File name for system spec if needed for dummy entry + + begin + -- Nothing to do if we already compiled System + + for Unum in Units.First .. Last_Unit loop + if Units.Table (Unum).Source_Index = System_Source_File_Index then + return; + end if; + end loop; + + -- If no entry for system.ads in the units table, then add a entry + -- to the units table for system.ads, which will be referenced when + -- the ali file is generated. We need this because every unit depends + -- on system as a result of Targparm scanning the system.ads file to + -- determine the target dependent parameters for the compilation. + + Name_Len := 6; + Name_Buffer (1 .. 6) := "system"; + System_Uname := Name_To_Unit_Name (Name_Enter); + System_Fname := File_Name (System_Source_File_Index); + + Units.Increment_Last; + Units.Table (Units.Last) := ( + Unit_File_Name => System_Fname, + Unit_Name => System_Uname, + Expected_Unit => System_Uname, + Source_Index => System_Source_File_Index, + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dependent_Unit => True, + Dynamic_Elab => False, + Fatal_Error => False, + Generate_Code => False, + Has_RACW => False, + Ident_String => Empty, + Loading => False, + Main_Priority => -1, + Serial_Number => 0, + Version => 0, + Error_Location => No_Location); + + -- Parse system.ads so that the checksum is set right + + Initialize_Scanner (Units.Last, System_Source_File_Index); + Discard := Par (Configuration_Pragmas => False); + end Ensure_System_Dependency; + + --------------- + -- Write_ALI -- + --------------- + + procedure Write_ALI (Object : Boolean) is + + ---------------- + -- Local Data -- + ---------------- + + Last_Unit : constant Unit_Number_Type := Units.Last; + -- Record unit number of last unit. We capture this in case we + -- have to add a dummy entry to the unit table for package System. + + With_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units are with'ed + + Elab_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have pragma Elaborate set + + Elab_All_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have pragma Elaborate All set + + Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have Elaborate_All_Desirable set + + Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2)); + -- Sorted table of source dependencies. One extra entry in case we + -- have to add a dummy entry for System. + + Num_Sdep : Nat := 0; + -- Number of active entries in Sdep_Table + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Collect_Withs (Cunit : Node_Id); + -- Collect with lines for entries in the context clause of the + -- given compilation unit, Cunit. + + procedure Update_Tables_From_ALI_File; + -- Given an up to date ALI file (see Up_To_Date_ALI_file_Exists + -- function), update tables from the ALI information, including + -- specifically the Compilation_Switches table. + + function Up_To_Date_ALI_File_Exists return Boolean; + -- If there exists an ALI file that is up to date, then this function + -- initializes the tables in the ALI spec to contain information on + -- this file (using Scan_ALI) and returns True. If no file exists, + -- or the file is not up to date, then False is returned. + + procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); + -- Write out the library information for one unit for which code is + -- generated (includes unit line and with lines). + + procedure Write_With_Lines; + -- Write out with lines collected by calls to Collect_Withs + + ------------------- + -- Collect_Withs -- + ------------------- + + procedure Collect_Withs (Cunit : Node_Id) is + Item : Node_Id; + Unum : Unit_Number_Type; + + begin + Item := First (Context_Items (Cunit)); + while Present (Item) loop + + if Nkind (Item) = N_With_Clause then + Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); + With_Flags (Unum) := True; + + if Elaborate_Present (Item) then + Elab_Flags (Unum) := True; + end if; + + if Elaborate_All_Present (Item) then + Elab_All_Flags (Unum) := True; + end if; + + if Elaborate_All_Desirable (Cunit_Entity (Unum)) then + Elab_Des_Flags (Unum) := True; + end if; + end if; + + Next (Item); + end loop; + end Collect_Withs; + + -------------------------------- + -- Up_To_Date_ALI_File_Exists -- + -------------------------------- + + function Up_To_Date_ALI_File_Exists return Boolean is + Name : File_Name_Type; + Text : Text_Buffer_Ptr; + Id : Sdep_Id; + Sind : Source_File_Index; + + begin + Opt.Check_Object_Consistency := True; + Read_Library_Info (Name, Text); + + -- Return if we could not find an ALI file + + if Text = null then + return False; + end if; + + -- Return if ALI file has bad format + + Initialize_ALI; + + if Scan_ALI (Name, Text, False, Err => True) = No_ALI_Id then + return False; + end if; + + -- If we have an OK ALI file, check if it is up to date + -- Note that we assume that the ALI read has all the entries + -- we have in our table, plus some additional ones (that can + -- come from expansion). + + Id := First_Sdep_Entry; + for J in 1 .. Num_Sdep loop + Sind := Units.Table (Sdep_Table (J)).Source_Index; + + while Sdep.Table (Id).Sfile /= File_Name (Sind) loop + if Id = Sdep.Last then + return False; + else + Id := Id + 1; + end if; + end loop; + + if Sdep.Table (Id).Stamp /= Time_Stamp (Sind) then + return False; + end if; + end loop; + + return True; + end Up_To_Date_ALI_File_Exists; + + --------------------------------- + -- Update_Tables_From_ALI_File -- + --------------------------------- + + procedure Update_Tables_From_ALI_File is + begin + -- Build Compilation_Switches table + + Compilation_Switches.Init; + + for J in First_Arg_Entry .. Args.Last loop + Compilation_Switches.Increment_Last; + Compilation_Switches.Table (Compilation_Switches.Last) := + Args.Table (J); + end loop; + end Update_Tables_From_ALI_File; + + ---------------------------- + -- Write_Unit_Information -- + ---------------------------- + + procedure Write_Unit_Information (Unit_Num : Unit_Number_Type) is + Unode : constant Node_Id := Cunit (Unit_Num); + Ukind : constant Node_Kind := Nkind (Unit (Unode)); + Uent : constant Entity_Id := Cunit_Entity (Unit_Num); + Pnode : Node_Id; + + begin + Write_Info_Initiate ('U'); + Write_Info_Char (' '); + Write_Info_Name (Unit_Name (Unit_Num)); + Write_Info_Tab (25); + Write_Info_Name (Unit_File_Name (Unit_Num)); + + Write_Info_Tab (49); + Write_Info_Str (Version_Get (Unit_Num)); + + if Dynamic_Elab (Unit_Num) then + Write_Info_Str (" DE"); + end if; + + -- We set the Elaborate_Body indication if either an explicit pragma + -- was present, or if this is an instantiation. RM 12.3(20) requires + -- that the body be immediately elaborated after the spec. We would + -- normally do that anyway, but the EB we generate here ensures that + -- this gets done even when we use the -p gnatbind switch. + + if Has_Pragma_Elaborate_Body (Uent) + or else (Ukind = N_Package_Declaration + and then Is_Generic_Instance (Uent) + and then Present (Corresponding_Body (Unit (Unode)))) + then + Write_Info_Str (" EB"); + end if; + + -- Now see if we should tell the binder that an elaboration entity + -- is present, which must be reset to true during elaboration. We + -- generate the indication if the following condition is met: + + -- If this is a spec ... + + if (Is_Subprogram (Uent) + or else + Ekind (Uent) = E_Package + or else + Is_Generic_Unit (Uent)) + + -- and an elaboration entity was declared ... + + and then Present (Elaboration_Entity (Uent)) + + -- and either the elaboration flag is required ... + + and then + (Elaboration_Entity_Required (Uent) + + -- or this unit has elaboration code ... + + or else not Has_No_Elaboration_Code (Unode) + + -- or this unit has a separate body and this + -- body has elaboration code. + + or else + (Ekind (Uent) = E_Package + and then Present (Body_Entity (Uent)) + and then + not Has_No_Elaboration_Code + (Parent + (Declaration_Node + (Body_Entity (Uent)))))) + then + Write_Info_Str (" EE"); + end if; + + if Has_No_Elaboration_Code (Unode) then + Write_Info_Str (" NE"); + end if; + + if Is_Preelaborated (Uent) then + Write_Info_Str (" PR"); + end if; + + if Is_Pure (Uent) then + Write_Info_Str (" PU"); + end if; + + if Has_RACW (Unit_Num) then + Write_Info_Str (" RA"); + end if; + + if Is_Remote_Call_Interface (Uent) then + Write_Info_Str (" RC"); + end if; + + if Is_Remote_Types (Uent) then + Write_Info_Str (" RT"); + end if; + + if Is_Shared_Passive (Uent) then + Write_Info_Str (" SP"); + end if; + + if Ukind = N_Subprogram_Declaration + or else Ukind = N_Subprogram_Body + then + Write_Info_Str (" SU"); + + elsif Ukind = N_Package_Declaration + or else + Ukind = N_Package_Body + then + -- If this is a wrapper package for a subprogram instantiation, + -- the user view is the subprogram. Note that in this case the + -- ali file contains both the spec and body of the instance. + + if Is_Wrapper_Package (Uent) then + Write_Info_Str (" SU"); + else + Write_Info_Str (" PK"); + end if; + + elsif Ukind = N_Generic_Package_Declaration then + Write_Info_Str (" PK"); + + end if; + + if Ukind in N_Generic_Declaration + or else + (Present (Library_Unit (Unode)) + and then + Nkind (Unit (Library_Unit (Unode))) in N_Generic_Declaration) + then + Write_Info_Str (" GE"); + end if; + + if not Is_Internal_File_Name (Unit_File_Name (Unit_Num), True) then + case Identifier_Casing (Source_Index (Unit_Num)) is + when All_Lower_Case => Write_Info_Str (" IL"); + when All_Upper_Case => Write_Info_Str (" IU"); + when others => null; + end case; + + case Keyword_Casing (Source_Index (Unit_Num)) is + when Mixed_Case => Write_Info_Str (" KM"); + when All_Upper_Case => Write_Info_Str (" KU"); + when others => null; + end case; + end if; + + if Initialize_Scalars then + Write_Info_Str (" IS"); + end if; + + Write_Info_EOL; + + -- Generate with lines, first those that are directly with'ed + + for J in With_Flags'Range loop + With_Flags (J) := False; + Elab_Flags (J) := False; + Elab_All_Flags (J) := False; + Elab_Des_Flags (J) := False; + end loop; + + Collect_Withs (Unode); + + -- For a body, we must also check for any subunits which belong to + -- it and which have context clauses of their own, since these + -- with'ed units are part of its own elaboration dependencies. + + if Nkind (Unit (Unode)) in N_Unit_Body then + for S in Units.First .. Last_Unit loop + + -- We are only interested in subunits + + if Nkind (Unit (Cunit (S))) = N_Subunit then + Pnode := Library_Unit (Cunit (S)); + + -- In gnatc mode, the errors in the subunits will not + -- have been recorded, but the analysis of the subunit + -- may have failed. There is no information to add to + -- ALI file in this case. + + if No (Pnode) then + exit; + end if; + + -- Find ultimate parent of the subunit + + while Nkind (Unit (Pnode)) = N_Subunit loop + Pnode := Library_Unit (Pnode); + end loop; + + -- See if it belongs to current unit, and if so, include + -- its with_clauses. + + if Pnode = Unode then + Collect_Withs (Cunit (S)); + end if; + end if; + end loop; + end if; + + Write_With_Lines; + end Write_Unit_Information; + + ---------------------- + -- Write_With_Lines -- + ---------------------- + + procedure Write_With_Lines is + With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1)); + Num_Withs : Int := 0; + Unum : Unit_Number_Type; + Cunit : Node_Id; + Cunite : Entity_Id; + Uname : Unit_Name_Type; + Fname : File_Name_Type; + Pname : constant Unit_Name_Type := + Get_Parent_Spec_Name (Unit_Name (Main_Unit)); + Body_Fname : File_Name_Type; + + begin + -- Loop to build the with table. A with on the main unit itself + -- is ignored (AARM 10.2(14a)). Such a with-clause can occur if + -- the main unit is a subprogram with no spec, and a subunit of + -- it unecessarily withs the parent. + + for J in Units.First + 1 .. Last_Unit loop + + -- Add element to with table if it is with'ed or if it is the + -- parent spec of the main unit (case of main unit is a child + -- unit). The latter with is not needed for semantic purposes, + -- but is required by the binder for elaboration purposes. + + if (With_Flags (J) or else Unit_Name (J) = Pname) + and then Units.Table (J).Dependent_Unit + then + Num_Withs := Num_Withs + 1; + With_Table (Num_Withs) := J; + end if; + end loop; + + -- Sort and output the table + + Sort (With_Table (1 .. Num_Withs)); + + for J in 1 .. Num_Withs loop + Unum := With_Table (J); + Cunit := Units.Table (Unum).Cunit; + Cunite := Units.Table (Unum).Cunit_Entity; + Uname := Units.Table (Unum).Unit_Name; + Fname := Units.Table (Unum).Unit_File_Name; + + Write_Info_Initiate ('W'); + Write_Info_Char (' '); + Write_Info_Name (Uname); + + -- Now we need to figure out the names of the files that contain + -- the with'ed unit. These will usually be the files for the body, + -- except in the case of a package that has no body. + + if (Nkind (Unit (Cunit)) not in N_Generic_Declaration + and then + Nkind (Unit (Cunit)) not in N_Generic_Renaming_Declaration) + or else Generic_Separately_Compiled (Cunite) + then + Write_Info_Tab (25); + + if Is_Spec_Name (Uname) then + Body_Fname := + Get_File_Name (Get_Body_Name (Uname), Subunit => False); + else + Body_Fname := Get_File_Name (Uname, Subunit => False); + end if; + + -- A package is considered to have a body if it requires + -- a body or if a body is present in Ada 83 mode. + + if Body_Required (Cunit) + or else (Ada_83 + and then Full_Source_Name (Body_Fname) /= No_File) + then + Write_Info_Name (Body_Fname); + Write_Info_Tab (49); + Write_Info_Name (Lib_File_Name (Body_Fname)); + else + Write_Info_Name (Fname); + Write_Info_Tab (49); + Write_Info_Name (Lib_File_Name (Fname)); + end if; + + if Elab_Flags (Unum) then + Write_Info_Str (" E"); + end if; + + if Elab_All_Flags (Unum) then + Write_Info_Str (" EA"); + end if; + + if Elab_Des_Flags (Unum) then + Write_Info_Str (" ED"); + end if; + end if; + + Write_Info_EOL; + end loop; + end Write_With_Lines; + + -- Start of processing for Writ_ALI + + begin + -- Build sorted source dependency table. We do this right away, + -- because it is referenced by Up_To_Date_ALI_File_Exists. + + for Unum in Units.First .. Last_Unit loop + Num_Sdep := Num_Sdep + 1; + Sdep_Table (Num_Sdep) := Unum; + end loop; + + -- Sort the table so that the D lines are in order + + Lib.Sort (Sdep_Table (1 .. Num_Sdep)); + + -- If we are not generating code, and there is an up to date + -- ali file accessible, read it, and acquire the compilation + -- arguments from this file. + + if Operating_Mode /= Generate_Code then + if Up_To_Date_ALI_File_Exists then + Update_Tables_From_ALI_File; + return; + end if; + end if; + + -- Otherwise acquire compilation arguments and prepare to write + -- out a new ali file. + + Create_Output_Library_Info; + + -- Output version line + + Write_Info_Initiate ('V'); + Write_Info_Str (" """); + Write_Info_Str (Library_Version); + Write_Info_Char ('"'); + + Write_Info_EOL; + + -- Output main program line if this is acceptable main program + + declare + U : Node_Id := Unit (Units.Table (Main_Unit).Cunit); + S : Node_Id; + + procedure M_Parameters; + -- Output parameters for main program line + + procedure M_Parameters is + begin + if Main_Priority (Main_Unit) /= Default_Main_Priority then + Write_Info_Char (' '); + Write_Info_Nat (Main_Priority (Main_Unit)); + end if; + + if Opt.Time_Slice_Set then + Write_Info_Str (" T="); + Write_Info_Nat (Opt.Time_Slice_Value); + end if; + + Write_Info_Str (" W="); + Write_Info_Char + (WC_Encoding_Letters (Wide_Character_Encoding_Method)); + + Write_Info_EOL; + end M_Parameters; + + begin + if Nkind (U) = N_Subprogram_Body + or else (Nkind (U) = N_Package_Body + and then + (Nkind (Original_Node (U)) = N_Function_Instantiation + or else + Nkind (Original_Node (U)) = + N_Procedure_Instantiation)) + then + -- If the unit is a subprogram instance, the entity for the + -- subprogram is the alias of the visible entity, which is the + -- related instance of the wrapper package. We retrieve the + -- subprogram declaration of the desired entity. + + if Nkind (U) = N_Package_Body then + U := Parent (Parent ( + Alias (Related_Instance (Defining_Unit_Name + (Specification (Unit (Library_Unit (Parent (U))))))))); + end if; + + S := Specification (U); + + if not Present (Parameter_Specifications (S)) then + if Nkind (S) = N_Procedure_Specification then + Write_Info_Initiate ('M'); + Write_Info_Str (" P"); + M_Parameters; + + else + declare + Nam : Node_Id := Defining_Unit_Name (S); + + begin + -- If it is a child unit, get its simple name. + + if Nkind (Nam) = N_Defining_Program_Unit_Name then + Nam := Defining_Identifier (Nam); + end if; + + if Is_Integer_Type (Etype (Nam)) then + Write_Info_Initiate ('M'); + Write_Info_Str (" F"); + M_Parameters; + end if; + end; + end if; + end if; + end if; + end; + + -- Write command argmument ('A') lines + + for A in 1 .. Compilation_Switches.Last loop + Write_Info_Initiate ('A'); + Write_Info_Char (' '); + Write_Info_Str (Compilation_Switches.Table (A).all); + Write_Info_Terminate; + end loop; + + -- Output parameters ('P') line + + Write_Info_Initiate ('P'); + + if Compilation_Errors then + Write_Info_Str (" CE"); + end if; + + if Opt.Float_Format /= ' ' then + Write_Info_Str (" F"); + + if Opt.Float_Format = 'I' then + Write_Info_Char ('I'); + + elsif Opt.Float_Format_Long = 'D' then + Write_Info_Char ('D'); + + else + Write_Info_Char ('G'); + end if; + end if; + + if Tasking_Used + and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit)) + then + if Locking_Policy /= ' ' then + Write_Info_Str (" L"); + Write_Info_Char (Locking_Policy); + end if; + + if Queuing_Policy /= ' ' then + Write_Info_Str (" Q"); + Write_Info_Char (Queuing_Policy); + end if; + + if Task_Dispatching_Policy /= ' ' then + Write_Info_Str (" T"); + Write_Info_Char (Task_Dispatching_Policy); + Write_Info_Char (' '); + end if; + end if; + + if not Object then + Write_Info_Str (" NO"); + end if; + + if No_Run_Time then + Write_Info_Str (" NR"); + end if; + + if Normalize_Scalars then + Write_Info_Str (" NS"); + end if; + + if Unreserve_All_Interrupts then + Write_Info_Str (" UA"); + end if; + + if ZCX_By_Default_On_Target then + if Unit_Exception_Table_Present then + Write_Info_Str (" UX"); + end if; + + Write_Info_Str (" ZX"); + end if; + + Write_Info_EOL; + + -- Output restrictions line + + Write_Info_Initiate ('R'); + Write_Info_Char (' '); + + for J in Partition_Restrictions loop + if Main_Restrictions (J) then + Write_Info_Char ('r'); + elsif Violations (J) then + Write_Info_Char ('v'); + else + Write_Info_Char ('n'); + end if; + end loop; + + Write_Info_EOL; + + -- Loop through file table to output information for all units for which + -- we have generated code, as marked by the Generate_Code flag. + + for Unit in Units.First .. Last_Unit loop + if Units.Table (Unit).Generate_Code + or else Unit = Main_Unit + then + Write_Info_EOL; -- blank line + Write_Unit_Information (Unit); + end if; + end loop; + + Write_Info_EOL; -- blank line + + -- Output linker option lines + + for J in 1 .. Linker_Option_Lines.Last loop + declare + S : constant String_Id := Linker_Option_Lines.Table (J); + C : Character; + + begin + Write_Info_Initiate ('L'); + Write_Info_Str (" """); + + for J in 1 .. String_Length (S) loop + C := Get_Character (Get_String_Char (S, J)); + + if C in Character'Val (16#20#) .. Character'Val (16#7E#) + and then C /= '{' + then + Write_Info_Char (C); + + if C = '"' then + Write_Info_Char (C); + end if; + + else + declare + Hex : array (0 .. 15) of Character := "0123456789ABCDEF"; + + begin + Write_Info_Char ('{'); + Write_Info_Char (Hex (Character'Pos (C) / 16)); + Write_Info_Char (Hex (Character'Pos (C) mod 16)); + Write_Info_Char ('}'); + end; + end if; + end loop; + + Write_Info_Char ('"'); + Write_Info_EOL; + end; + end loop; + + -- Output external version reference lines + + for J in 1 .. Version_Ref.Last loop + Write_Info_Initiate ('E'); + Write_Info_Char (' '); + + for K in 1 .. String_Length (Version_Ref.Table (J)) loop + Write_Info_Char_Code (Get_String_Char (Version_Ref.Table (J), K)); + end loop; + + Write_Info_EOL; + end loop; + + -- Prepare to output the source dependency lines + + declare + Unum : Unit_Number_Type; + -- Number of unit being output + + Sind : Source_File_Index; + -- Index of corresponding source file + + begin + for J in 1 .. Num_Sdep loop + Unum := Sdep_Table (J); + Sind := Units.Table (Unum).Source_Index; + + -- Error defence, ignore entries with no source index + + if Sind /= No_Source_File then + Units.Table (Unum).Dependency_Num := J; + + if Units.Table (Unum).Dependent_Unit then + Write_Info_Initiate ('D'); + Write_Info_Char (' '); + Write_Info_Name (File_Name (Sind)); + Write_Info_Tab (25); + Write_Info_Str (String (Time_Stamp (Sind))); + Write_Info_Char (' '); + Write_Info_Str (Get_Hex_String (Source_Checksum (Sind))); + + -- If subunit, add unit name, omitting the %b at the end + + if Present (Cunit (Unum)) + and then Nkind (Unit (Cunit (Unum))) = N_Subunit + then + Get_Decoded_Name_String (Unit_Name (Unum)); + Write_Info_Char (' '); + Write_Info_Str (Name_Buffer (1 .. Name_Len - 2)); + end if; + + -- If Source_Reference pragma used output information + + if Num_SRef_Pragmas (Sind) > 0 then + Write_Info_Char (' '); + + if Num_SRef_Pragmas (Sind) = 1 then + Write_Info_Nat (Int (First_Mapped_Line (Sind))); + else + Write_Info_Nat (0); + end if; + + Write_Info_Char (':'); + Write_Info_Name (Reference_Name (Sind)); + end if; + + Write_Info_EOL; + end if; + end if; + end loop; + end; + + Output_References; + Write_Info_Terminate; + Close_Output_Library_Info; + + end Write_ALI; + +end Lib.Writ; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads new file mode 100644 index 00000000000..f4ca41ac011 --- /dev/null +++ b/gcc/ada/lib-writ.ads @@ -0,0 +1,467 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . W R I T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for writing the library information + +package Lib.Writ is + + ----------------------------------- + -- Format of Library Information -- + ----------------------------------- + + -- Note: the contents of the ali file are summarized in the GNAT + -- user's guide, so if any non-trivial changes are made to this + -- section, they should be reflected in the user's guide. + + -- This section describes the format of the library information that is + -- associated with object files. The exact method of this association is + -- potentially implementation dependent and is described and implemented + -- in package From the point of view of the description here, all we + -- need to know is that the information is represented as a string of + -- characters that is somehow associated with an object file, and can be + -- retrieved. If no library information exists for a given object file, + -- then we take this as equivalent to the non-existence of the object + -- file, as if source file has not been previously compiled. + + -- The library information is written as a series of lines of the form: + + -- Key_Character parameter parameter ... + + ------------------ + -- Header Lines -- + ------------------ + + -- The initial header lines in the file give information about the + -- compilation environment, and identify other special information + -- such as main program parameters. + + -- ---------------- + -- -- V Version -- + -- ---------------- + + -- V "xxxxxxxxxxxxxxxx" + -- + -- This line indicates the library output version, as defined in + -- Gnatvsn. It ensures that separate object modules of a program are + -- consistent. It has to be changed if anything changes which would + -- affect successful binding of separately compiled modules. + -- Examples of such changes are modifications in the format of the + -- library info described in this package, or modifications to + -- calling sequences, or to the way that data is represented. + + -- --------------------- + -- -- M Main Program -- + -- --------------------- + + -- M type [priority] [T=time-slice] W=? + + -- This line appears only if the main unit for this file is + -- suitable for use as a main program. The parameters are: + + -- type + + -- P for a parameterless procedure + -- F for a function returning a value of integral type + -- (used for writing a main program returning an exit status) + + -- priority + + -- Present only if there was a valid pragma Priority in the + -- corresponding unit to set the main task priority. It is + -- an unsigned decimal integer. + + -- T=time-slice + + -- Present only if there was a valid pragma Time_Slice in the + -- corresponding unit. It is an unsigned decimal integer in + -- the range 0 .. 10**9 giving the time slice value in units + -- of milliseconds. The actual significance of this parameter + -- is target dependent. + + -- W=? + + -- This parameter indicates the wide character encoding + -- method used when compiling the main program file. The ? + -- character is the single character used in the -gnatW? + -- switch. This is used to provide the default wide-character + -- encoding for Wide_Text_IO files. + + -- ----------------- + -- -- A Argument -- + -- ----------------- + + -- A argument + + -- One of these lines appears for each of the arguments present + -- in the call to the gnat1 program. This can be used if it is + -- necessary to reconstruct this call (e.g. for fix and continue) + + -- ------------------- + -- -- P Parameters -- + -- ------------------- + + -- P <<parameters>> + + -- Indicates various information that applies to the compilation + -- of the corresponding source unit. Parameters is a sequence of + -- zero or more two letter codes that indicate configuration + -- pragmas and other parameters that apply: + -- + -- Present if the unit uses tasking directly or indirectly and + -- has one or more valid xxx_Policy pragmas that apply to the unit. + -- The arguments are as follows: + -- + -- CE Compilation errors. If this is present it means that the + -- ali file resulted from a compilation with the -gnatQ + -- switch set, and illegalities were detected. The ali + -- file contents may not be completely reliable, but the + -- format will be correct and complete. Note that NO is + -- always present if CE is present. + -- + -- FD Configuration pragmas apply to all the units in this + -- file specifying a possibly non-standard floating point + -- format (VAX float with Long_Float using D_Float) + -- + -- FG Configuration pragmas apply to all the units in this + -- file specifying a possibly non-standard floating point + -- format (VAX float with Long_Float using G_Float) + -- + -- FI Configuration pragmas apply to all the units in this + -- file specifying a possibly non-standard floating point + -- format (IEEE Float) + -- + -- Lx A valid Locking_Policy pragma applies to all the units + -- in this file, where x is the first character (upper case) + -- of the policy name (e.g. 'C' for Ceiling_Locking) + -- + -- NO No object. This flag indicates that the units in this + -- file were not compiled to produce an object. This can + -- occur as a result of the use of -gnatc, or if no object + -- can be produced (e.g. when a package spec is compiled + -- instead of the body, or a subunit on its own). + -- + -- NR No_Run_Time pragma in effect for all units in this file + -- + -- NS Normalize_Scalars pragma in effect for all units in + -- this file + -- + -- Qx A valid Queueing_Policy pragma applies to all the units + -- in this file, where x is the first character (upper case) + -- of the policy name (e.g. 'P' for Priority_Queueing). + -- + -- Tx A valid Task_Dispatching_Policy pragma applies to all + -- the units in this file, where x is the first character + -- (upper case) of the corresponding policy name (e.g. 'F' + -- for FIFO_Within_Priorities). + -- + -- UA Unreserve_All_Interrupts pragma was processed in one or + -- more units in this file + -- + -- UX Generated code contains unit exception table pointer + -- (i.e. it uses zero-cost exceptions, and there is at + -- least one subprogram present). + -- + -- ZX Units in this file use zero-cost exceptions and have + -- generated exception tables. If ZX is not present, the + -- longjmp/setjmp exception scheme is in use. + -- + -- Note that language defined units never output policy (Lx,Tx,Qx) + -- parameters. Language defined units must correctly handle all + -- possible cases. These values are checked for consistency by the + -- binder and then copied to the generated binder output file. + + -- --------------------- + -- -- R Restrictions -- + -- --------------------- + + -- R <<restriction-characters>> + + -- This line records information regarding restrictions. The + -- parameter is a string of characters, one for each entry in + -- Restrict.Partition_Restrictions, in order. There are three + -- settings possible settings for each restriction: + + -- r Restricted. Unit was compiled under control of a pragma + -- Restrictions for the corresponding restriction. In + -- this case the unit certainly does not violate the + -- Restriction, since this would have been detected by + -- the compiler. + + -- n Not used. The unit was not compiled under control of a + -- pragma Restrictions for the corresponding restriction, + -- and does not make any use of the referenced feature. + + -- v Violated. The unit was not compiled uner control of a + -- pragma Restrictions for the corresponding restriction, + -- and it does indeed use the referenced feature. + + -- This information is used in the binder to check consistency, + -- i.e. to detect cases where one unit has "r" and another unit + -- has "v", which is not permitted, since these restrictions + -- are partition-wide. + + ---------------------------- + -- Compilation Unit Lines -- + ---------------------------- + + -- Following these header lines, a set of information lines appears for + -- each compilation unit that appears in the corresponding object file. + -- In particular, when a package body or subprogram body is compiled, + -- there will be two sets of information, one for the spec and one for + -- the body. with the entry for the body appearing first. This is the + -- only case in which a single ALI file contains more than one unit (in + -- particular note that subunits do *not* count as compilation units for + -- this purpose, and generate no library information, since they are + -- inlined). + + -- -------------------- + -- -- U Unit Header -- + -- -------------------- + + -- The lines for each compilation unit have the following form. + + -- U unit-name source-name version <<attributes>> + -- + -- This line identifies the unit to which this section of the + -- library information file applies. The first three parameters are + -- the unit name in internal format, as described in package Uname, + -- and the name of the source file containing the unit. + -- + -- Version is the version given as eight hexadecimal characters + -- with upper case letters. This value is the exclusive or of the + -- source checksums of the unit and all its semantically dependent + -- units. + -- + -- The <<attributes>> are a series of two letter codes indicating + -- information about the unit: + -- + -- DE Dynamic Elaboration. This unit was compiled with the + -- dynamic elaboration model, as set by either the -gnatE + -- switch or pragma Elaboration_Checks (Dynamic). + -- + -- EB Unit has pragma Elaborate_Body + -- + -- EE Elaboration entity is present which must be set true when + -- the unit is elaborated. The name of the elaboration entity + -- is formed from the unit name in the usual way. If EE is + -- present, then this boolean must be set True as part of the + -- elaboration processing routine generated by the binder. + -- Note that EE can be set even if NE is set. This happens + -- when the boolean is needed solely for checking for the + -- case of access before elaboration. + -- + -- GE Unit is a generic declaration, or corresponding body + -- + -- IL Unit source uses a style with identifiers in all lower + -- IU case (IL) or all upper case (IU). If the standard mixed- + -- case usage is detected, or the compiler cannot determine + -- the style, then no I parameter will appear. + -- + -- IS Initialize_Scalars pragma applies to this unit + -- + -- KM Unit source uses a style with keywords in mixed case + -- KU (KM) or all upper case (KU). If the standard lower-case + -- usage is detected, or the compiler cannot determine the + -- style, then no K parameter will appear. + -- + -- NE Unit has no elaboration routine. All subprogram bodies + -- and specs are in this category. Package bodies and specs + -- may or may not have NE set, depending on whether or not + -- elaboration code is required. Set if N_Compilation_Unit + -- node has flag Has_No_Elaboration_Code set. + -- + -- PK Unit is package, rather than a subprogram + -- + -- PU Unit has pragma Pure + -- + -- PR Unit has pragma Preelaborate + -- + -- RA Unit declares a Remote Access to Class-Wide (RACW) type + -- + -- RC Unit has pragma Remote_Call_Interface + -- + -- RT Unit has pragma Remote_Types + -- + -- SP Unit has pragma Shared_Passive. + -- + -- SU Unit is a subprogram, rather than a package + -- + -- The attributes may appear in any order, separated by spaces. + + -- --------------------- + -- -- W Withed Units -- + -- --------------------- + + -- Following each U line, is a series of lines of the form + + -- W unit-name [source-name lib-name] [E] [EA] [ED] + -- + -- One of these lines is present for each unit that is mentioned in + -- an explicit with clause by the current unit. The first parameter + -- is the unit name in internal format. The second parameter is the + -- file name of the file that must be compiled to compile this unit + -- (which is usually the file for the body, except for packages + -- which have no body). The third parameter is the file name of the + -- library information file that contains the results of compiling + -- this unit. The optional modifiers are used as follows: + -- + -- E pragma Elaborate applies to this unit + -- + -- EA pragma Elaborate_All applies to this unit + -- + -- ED Elaborate_All_Desirable set for this unit, which means + -- that there is no Elaborate_All, but the analysis suggests + -- that Program_Error may be raised if the Elaborate_All + -- conditions cannot be satisfied. The binder will attempt + -- to treat ED as EA if it can. + -- + -- The parameter source-name and lib-name are omitted for the case + -- of a generic unit compiled with earlier versions of GNAT which + -- did not generate object or ali files for generics. + + --------------------- + -- Reference Lines -- + --------------------- + + -- The reference lines contain information about references from + -- any of the units in the compilation (including, body version + -- and version attributes, linker options pragmas and source + -- dependencies. + + -- ----------------------- + -- -- L Linker_Options -- + -- ----------------------- + + -- Following the unit information is an optional series of lines that + -- indicates the usage of pragma Linker_Options. For each appearence + -- of pragma Linker_Actions in any of the units for which unit lines + -- are present, a line of the form: + + -- L "string" + + -- where string is the string from the unit line enclosed in quotes. + -- Within the quotes the following can occur: + + -- c graphic characters in range 20-7E other than " or { + -- "" indicating a single " character + -- {hh} indicating a character whose code is hex hh (0-9,A-F) + -- {00} [ASCII.NUL] is used as a separator character + -- to separate multiple arguments of a single + -- Linker_Options pragma. + + -- For further details, see Stringt.Write_String_Table_Entry. Note + -- that wide characters in the form {hhhh} cannot be produced, since + -- pragma Linker_Option accepts only String, not Wide_String. + + -- ------------------------------------ + -- -- E External Version References -- + -- ------------------------------------ + + -- One of these lines is present for each use of 'Body_Version or + -- 'Version in any of the units of the compilation. These are used + -- by the linker to determine which version symbols must be output. + -- The format is simply: + + -- E name + + -- where name is the external name, i.e. the unit name with either + -- a S or a B for spec or body version referenced (Body_Version + -- always references the body, Version references the Spec, except + -- in the case of a reference to a subprogram with no separate spec). + -- Upper half and wide character codes are encoded using the same + -- method as in Namet (Uhh for upper half, Whhhh for wide character, + -- where hh are hex digits). + + -- --------------------- + -- -- D Dependencies -- + -- --------------------- + + -- The dependency lines indicate the source files on which the compiled + -- units depend. This is used by the binder for consistency checking. + + -- D source-name time-stamp checksum [subunit-name] line:file-name + + -- The time-stamp field contains the time stamp of the + -- corresponding source file. See types.ads for details on + -- time stamp representation. + + -- The checksum is an 8-hex digit representation of the source + -- file checksum, with letters given in upper case. + + -- The subunit name is present only if the dependency line is for + -- a subunit. It contains the fully qualified name of the subunit + -- in all lower case letters. + + -- The line:file-name entry is present only if a Source_Reference + -- pragma appeared in the source file identified by source-name. + -- In this case, it gives the information from this pragma. Note + -- that this allows cross-reference information to be related back + -- to the original file. Note: the reason the line number comes + -- first is that a leading digit immediately identifies this as + -- a Source_Reference entry, rather than a subunit-name. + + -- A line number of zero for line: in this entry indicates that + -- there is more than one source reference pragma. In this case, + -- the line numbers in the cross-reference are correct, and refer + -- to the original line number, but there is no information that + -- allows a reader of the ALI file to determine the exact mapping + -- of physical line numbers back to the original source. + + -- Note: blank lines are ignored when the library information is + -- read, and separate sections of the file are separated by blank + -- lines to ease readability. Blanks between fields are also + -- ignored. + + -------------------------- + -- Cross-Reference Data -- + -------------------------- + + -- The cross-reference data follows the dependency lines. See + -- the spec of Lib.Xref for details on the format of this data. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Ensure_System_Dependency; + -- This procedure ensures that a dependency is created on system.ads. + -- Even if there is no semantic dependency, Targparm has read the + -- file to acquire target parameters, so we need a source dependency. + + procedure Write_ALI (Object : Boolean); + -- This procedure writes the library information for the current main unit + -- The Object parameter is true if an object file is created, and false + -- otherwise. + -- + -- Note: in the case where we are not generating code (-gnatc mode), this + -- routine only writes an ALI file if it cannot find an existing up to + -- date ALI file. If it *can* find an existing up to date ALI file, then + -- it reads this file and sets the Lib.Compilation_Arguments table from + -- the A lines in this file. + +end Lib.Writ; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb new file mode 100644 index 00000000000..f7e12ef65f1 --- /dev/null +++ b/gcc/ada/lib-xref.adb @@ -0,0 +1,784 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . X R E F -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.56 $ +-- -- +-- Copyright (C) 1998-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Csets; use Csets; +with Lib.Util; use Lib.Util; +with Namet; use Namet; +with Opt; use Opt; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Table; use Table; +with Widechar; use Widechar; + +with GNAT.Heap_Sort_A; + +package body Lib.Xref is + + ------------------ + -- Declarations -- + ------------------ + + -- The Xref table is used to record references. The Loc field is set + -- to No_Location for a definition entry. + + subtype Xref_Entry_Number is Int; + + type Xref_Entry is record + Ent : Entity_Id; + -- Entity referenced (E parameter to Generate_Reference) + + Def : Source_Ptr; + -- Original source location for entity being referenced. Note that + -- these values are used only during the output process, they are + -- not set when the entries are originally built. This is because + -- private entities can be swapped when the initial call is made. + + Loc : Source_Ptr; + -- Location of reference (Original_Location (Sloc field of N parameter + -- to Generate_Reference). Set to No_Location for the case of a + -- defining occurrence. + + Typ : Character; + -- Reference type (Typ param to Generate_Reference) + + Eun : Unit_Number_Type; + -- Unit number corresponding to Ent + + Lun : Unit_Number_Type; + -- Unit number corresponding to Loc. Value is undefined and not + -- referenced if Loc is set to No_Location. + + end record; + + package Xrefs is new Table.Table ( + Table_Component_Type => Xref_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => Alloc.Xrefs_Initial, + Table_Increment => Alloc.Xrefs_Increment, + Table_Name => "Xrefs"); + + function Get_Xref_Index (E : Entity_Id) return Xref_Entry_Number; + -- Returns the Xref entry table index for entity E. + -- So : Xrefs.Table (Get_Xref_Index (E)).Ent = E + + ------------------------- + -- Generate_Definition -- + ------------------------- + + procedure Generate_Definition (E : Entity_Id) is + Loc : Source_Ptr; + Indx : Nat; + + begin + pragma Assert (Nkind (E) in N_Entity); + + -- Note that we do not test Xref_Entity_Letters here. It is too + -- early to do so, since we are often called before the entity + -- is fully constructed, so that the Ekind is still E_Void. + + if Opt.Xref_Active + + -- Definition must come from source + + and then Comes_From_Source (E) + + -- And must have a reasonable source location that is not + -- within an instance (all entities in instances are ignored) + + and then Sloc (E) > No_Location + and then Instantiation_Location (Sloc (E)) = No_Location + + -- And must be a non-internal name from the main source unit + + and then In_Extended_Main_Source_Unit (E) + and then not Is_Internal_Name (Chars (E)) + then + Xrefs.Increment_Last; + Indx := Xrefs.Last; + Loc := Original_Location (Sloc (E)); + + Xrefs.Table (Indx).Ent := E; + Xrefs.Table (Indx).Loc := No_Location; + Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc); + Xrefs.Table (Indx).Lun := No_Unit; + end if; + end Generate_Definition; + + --------------------------------- + -- Generate_Operator_Reference -- + --------------------------------- + + procedure Generate_Operator_Reference (N : Node_Id) is + begin + if not In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If the operator is not a Standard operator, then we generate + -- a real reference to the user defined operator. + + if Sloc (Entity (N)) /= Standard_Location then + Generate_Reference (Entity (N), N); + + -- A reference to an implicit inequality operator is a also a + -- reference to the user-defined equality. + + if Nkind (N) = N_Op_Ne + and then not Comes_From_Source (Entity (N)) + and then Present (Corresponding_Equality (Entity (N))) + then + Generate_Reference (Corresponding_Equality (Entity (N)), N); + end if; + + -- For the case of Standard operators, we mark the result type + -- as referenced. This ensures that in the case where we are + -- using a derived operator, we mark an entity of the unit that + -- implicitly defines this operator as used. Otherwise we may + -- think that no entity of the unit is used. The actual entity + -- marked as referenced is the first subtype, which is the user + -- defined entity that is relevant. + + else + if Nkind (N) = N_Op_Eq + or else Nkind (N) = N_Op_Ne + or else Nkind (N) = N_Op_Le + or else Nkind (N) = N_Op_Lt + or else Nkind (N) = N_Op_Ge + or else Nkind (N) = N_Op_Gt + then + Set_Referenced (First_Subtype (Etype (Right_Opnd (N)))); + else + Set_Referenced (First_Subtype (Etype (N))); + end if; + end if; + end Generate_Operator_Reference; + + ------------------------ + -- Generate_Reference -- + ------------------------ + + procedure Generate_Reference + (E : Entity_Id; + N : Node_Id; + Typ : Character := 'r'; + Set_Ref : Boolean := True; + Force : Boolean := False) + is + Indx : Nat; + Nod : Node_Id; + Ref : Source_Ptr; + Def : Source_Ptr; + Ent : Entity_Id; + + begin + pragma Assert (Nkind (E) in N_Entity); + + -- Never collect references if not in main source unit. However, + -- we omit this test if Typ is 'e', since these entries are + -- really structural, and it is useful to have them in units + -- that reference packages as well as units that define packages. + + if not In_Extended_Main_Source_Unit (N) + and then Typ /= 'e' + then + return; + end if; + + -- Unless the reference is forced, we ignore references where + -- the reference itself does not come from Source. + + if not Force and then not Comes_From_Source (N) then + return; + end if; + + -- Deal with setting entity as referenced, unless suppressed. + -- Note that we still do Set_Referenced on entities that do not + -- come from source. This situation arises when we have a source + -- reference to a derived operation, where the derived operation + -- itself does not come from source, but we still want to mark it + -- as referenced, since we really are referencing an entity in the + -- corresponding package (this avoids incorrect complaints that the + -- package contains no referenced entities). + + if Set_Ref then + Set_Referenced (E); + + -- If this is a subprogram instance, mark as well the internal + -- subprogram in the wrapper package, which may be a visible + -- compilation unit. + + if Is_Overloadable (E) + and then Is_Generic_Instance (E) + and then Present (Alias (E)) + then + Set_Referenced (Alias (E)); + end if; + end if; + + -- Generate reference if all conditions are met: + + if + -- Cross referencing must be active + + Opt.Xref_Active + + -- The entity must be one for which we collect references + + and then Xref_Entity_Letters (Ekind (E)) /= ' ' + + -- Both Sloc values must be set to something sensible + + and then Sloc (E) > No_Location + and then Sloc (N) > No_Location + + -- We ignore references from within an instance + + and then Instantiation_Location (Sloc (N)) = No_Location + + -- Ignore dummy references + + and then Typ /= ' ' + then + if Nkind (N) = N_Identifier + or else + Nkind (N) = N_Defining_Identifier + or else + Nkind (N) in N_Op + or else + Nkind (N) = N_Defining_Operator_Symbol + or else + (Nkind (N) = N_Character_Literal + and then Sloc (Entity (N)) /= Standard_Location) + or else + Nkind (N) = N_Defining_Character_Literal + then + Nod := N; + + elsif Nkind (N) = N_Expanded_Name + or else + Nkind (N) = N_Selected_Component + then + Nod := Selector_Name (N); + + else + return; + end if; + + -- Normal case of source entity comes from source + + if Comes_From_Source (E) then + Ent := E; + + -- Entity does not come from source, but is a derived subprogram + -- and the derived subprogram comes from source, in which case + -- the reference is to this parent subprogram. + + elsif Is_Overloadable (E) + and then Present (Alias (E)) + and then Comes_From_Source (Alias (E)) + then + Ent := Alias (E); + + -- Ignore reference to any other source that is not from source + + else + return; + end if; + + -- Record reference to entity + + Ref := Original_Location (Sloc (Nod)); + Def := Original_Location (Sloc (Ent)); + + Xrefs.Increment_Last; + Indx := Xrefs.Last; + + Xrefs.Table (Indx).Loc := Ref; + Xrefs.Table (Indx).Typ := Typ; + Xrefs.Table (Indx).Eun := Get_Source_Unit (Def); + Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref); + Xrefs.Table (Indx).Ent := Ent; + end if; + end Generate_Reference; + + -------------------- + -- Get_Xref_Index -- + -------------------- + + function Get_Xref_Index (E : Entity_Id) return Xref_Entry_Number is + begin + for K in 1 .. Xrefs.Last loop + if Xrefs.Table (K).Ent = E then + return K; + end if; + end loop; + + -- not found, this happend if the entity is not in the compiled unit. + + return 0; + end Get_Xref_Index; + + ----------------------- + -- Output_References -- + ----------------------- + + procedure Output_References is + Nrefs : constant Nat := Xrefs.Last; + + Rnums : array (0 .. Nrefs) of Nat; + -- This array contains numbers of references in the Xrefs table. This + -- list is sorted in output order. The extra 0'th entry is convenient + -- for the call to sort. When we sort the table, we move these entries + -- around, but we do not move the original table entries. + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Comparison function for Sort call + + procedure Move (From : Natural; To : Natural); + -- Move procedure for Sort call + + function Lt (Op1, Op2 : Natural) return Boolean is + T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1))); + T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2))); + + begin + -- First test. If entity is in different unit, sort by unit + + if T1.Eun /= T2.Eun then + return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun); + + -- Second test, within same unit, sort by entity Sloc + + elsif T1.Def /= T2.Def then + return T1.Def < T2.Def; + + -- Third test, sort definitions ahead of references + + elsif T1.Loc = No_Location then + return True; + + elsif T2.Loc = No_Location then + return False; + + -- Fourth test, for same entity, sort by reference location unit + + elsif T1.Lun /= T2.Lun then + return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun); + + -- Fifth test order of location within referencing unit + + elsif T1.Loc /= T2.Loc then + return T1.Loc < T2.Loc; + + -- Finally, for two locations at the same address, we prefer + -- the one that does NOT have the type 'r' so that a modification + -- or extension takes preference, when there are more than one + -- reference at the same location. + + else + return T2.Typ = 'r'; + end if; + end Lt; + + procedure Move (From : Natural; To : Natural) is + begin + Rnums (Nat (To)) := Rnums (Nat (From)); + end Move; + + -- Start of processing for Output_References + + begin + if not Opt.Xref_Active then + return; + end if; + + -- Capture the definition Sloc values. We delay doing this till now, + -- since at the time the reference or definition is made, private + -- types may be swapped, and the Sloc value may be incorrect. We + -- also set up the pointer vector for the sort. + + for J in 1 .. Nrefs loop + Rnums (J) := J; + Xrefs.Table (J).Def := + Original_Location (Sloc (Xrefs.Table (J).Ent)); + end loop; + + -- Sort the references + + GNAT.Heap_Sort_A.Sort + (Integer (Nrefs), + Move'Unrestricted_Access, + Lt'Unrestricted_Access); + + -- Now output the references + + Output_Refs : declare + + Curxu : Unit_Number_Type; + -- Current xref unit + + Curru : Unit_Number_Type; + -- Current reference unit for one entity + + Cursrc : Source_Buffer_Ptr; + -- Current xref unit source text + + Curent : Entity_Id; + -- Current entity + + Curnam : String (1 .. Name_Buffer'Length); + Curlen : Natural; + -- Simple name and length of current entity + + Curdef : Source_Ptr; + -- Original source location for current entity + + Crloc : Source_Ptr; + -- Current reference location + + Ctyp : Character; + -- Entity type character + + Parent_Entry : Int; + -- entry for parent of derived type. + + function Name_Change (X : Entity_Id) return Boolean; + -- Determines if entity X has a different simple name from Curent + + function Get_Parent_Entry (X : Entity_Id) return Int; + -- For a derived type, locate entry of parent type, if defined in + -- in the current unit. + + function Get_Parent_Entry (X : Entity_Id) return Int is + Parent_Type : Entity_Id; + + begin + if not Is_Type (X) + or else not Is_Derived_Type (X) + then + return 0; + else + Parent_Type := First_Subtype (Etype (Base_Type (X))); + + if Comes_From_Source (Parent_Type) then + return Get_Xref_Index (Parent_Type); + + else + return 0; + end if; + end if; + end Get_Parent_Entry; + + function Name_Change (X : Entity_Id) return Boolean is + begin + Get_Unqualified_Name_String (Chars (X)); + + if Name_Len /= Curlen then + return True; + + else + return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen); + end if; + end Name_Change; + + -- Start of processing for Output_Refs + + begin + Curxu := No_Unit; + Curent := Empty; + Curdef := No_Location; + Curru := No_Unit; + Crloc := No_Location; + + for Refno in 1 .. Nrefs loop + declare + XE : Xref_Entry renames Xrefs.Table (Rnums (Refno)); + -- The current entry to be accessed + + P : Source_Ptr; + -- Used to index into source buffer to get entity name + + P2 : Source_Ptr; + WC : Char_Code; + Err : Boolean; + Ent : Entity_Id; + + begin + Ent := XE.Ent; + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + + -- Skip reference if it is the only reference to an entity, + -- and it is an end-line reference, and the entity is not in + -- the current extended source. This prevents junk entries + -- consisting only of packages with end lines, where no + -- entity from the package is actually referenced. + + if XE.Typ = 'e' + and then Ent /= Curent + and then (Refno = Nrefs or else + Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent) + and then + not In_Extended_Main_Source_Unit (Ent) + then + goto Continue; + end if; + + -- For private type, get full view type + + if Ctyp = '+' + and then Present (Full_View (XE.Ent)) + then + Ent := Underlying_Type (Ent); + + if Present (Ent) then + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + end if; + end if; + + -- Special exception for Boolean + + if Ctyp = 'E' and then Is_Boolean_Type (Ent) then + Ctyp := 'B'; + end if; + + -- For variable reference, get corresponding type + + if Ctyp = '*' then + Ent := Etype (XE.Ent); + Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent))); + + -- If variable is private type, get full view type + + if Ctyp = '+' + and then Present (Full_View (Etype (XE.Ent))) + then + Ent := Underlying_Type (Etype (XE.Ent)); + + if Present (Ent) then + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + end if; + end if; + + -- Special handling for access parameter + + if Ekind (Etype (XE.Ent)) = E_Anonymous_Access_Type + and then Is_Formal (XE.Ent) + then + Ctyp := 'p'; + + -- Special handling for Boolean + + elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then + Ctyp := 'b'; + end if; + end if; + + -- Only output reference if interesting type of entity, + -- and suppress self references. Also suppress definitions + -- of body formals (we only treat these as references, and + -- the references were separately recorded). + + if Ctyp /= ' ' + and then XE.Loc /= XE.Def + and then (not Is_Formal (XE.Ent) + or else No (Spec_Entity (XE.Ent))) + then + -- Start new Xref section if new xref unit + + if XE.Eun /= Curxu then + + if Write_Info_Col > 1 then + Write_Info_EOL; + end if; + + Curxu := XE.Eun; + Cursrc := Source_Text (Source_Index (Curxu)); + + Write_Info_Initiate ('X'); + Write_Info_Char (' '); + Write_Info_Nat (Dependency_Num (XE.Eun)); + Write_Info_Char (' '); + Write_Info_Name (Reference_Name (Source_Index (XE.Eun))); + end if; + + -- Start new Entity line if new entity. Note that we + -- consider two entities the same if they have the same + -- name and source location. This causes entities in + -- instantiations to be treated as though they referred + -- to the template. + + if No (Curent) + or else + (XE.Ent /= Curent + and then + (Name_Change (XE.Ent) or else XE.Def /= Curdef)) + then + Curent := XE.Ent; + Curdef := XE.Def; + + Get_Unqualified_Name_String (Chars (XE.Ent)); + Curlen := Name_Len; + Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen); + + if Write_Info_Col > 1 then + Write_Info_EOL; + end if; + + -- Write column number information + + Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def))); + Write_Info_Char (Ctyp); + Write_Info_Nat (Int (Get_Column_Number (XE.Def))); + + -- Write level information + + if Is_Public (Curent) and then not Is_Hidden (Curent) then + Write_Info_Char ('*'); + else + Write_Info_Char (' '); + end if; + + -- Output entity name. We use the occurrence from the + -- actual source program at the definition point + + P := Original_Location (Sloc (XE.Ent)); + + -- Entity is character literal + + if Cursrc (P) = ''' then + Write_Info_Char (Cursrc (P)); + Write_Info_Char (Cursrc (P + 1)); + Write_Info_Char (Cursrc (P + 2)); + + -- Entity is operator symbol + + elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then + Write_Info_Char (Cursrc (P)); + + P2 := P; + loop + P2 := P2 + 1; + Write_Info_Char (Cursrc (P2)); + exit when Cursrc (P2) = Cursrc (P); + end loop; + + -- Entity is identifier + + else + loop + if Is_Start_Of_Wide_Char (Cursrc, P) then + Scan_Wide (Cursrc, P, WC, Err); + elsif not Identifier_Char (Cursrc (P)) then + exit; + else + P := P + 1; + end if; + end loop; + + for J in + Original_Location (Sloc (XE.Ent)) .. P - 1 + loop + Write_Info_Char (Cursrc (J)); + end loop; + end if; + + -- Output derived entity name if it is available + + Parent_Entry := Get_Parent_Entry (XE.Ent); + + if Parent_Entry /= 0 then + declare + XD : Xref_Entry renames Xrefs.Table (Parent_Entry); + + begin + Write_Info_Char ('<'); + + -- Write unit number only if different from the + -- current one. + + if XE.Eun /= XD.Eun then + Write_Info_Nat (Dependency_Num (XD.Eun)); + Write_Info_Char ('|'); + end if; + + Write_Info_Nat + (Int (Get_Logical_Line_Number (XD.Def))); + Write_Info_Char + (Xref_Entity_Letters (Ekind (XD.Ent))); + Write_Info_Nat (Int (Get_Column_Number (XD.Def))); + + Write_Info_Char ('>'); + end; + end if; + + Curru := Curxu; + Crloc := No_Location; + end if; + + -- Output the reference + + if XE.Loc /= No_Location + and then XE.Loc /= Crloc + then + Crloc := XE.Loc; + + -- Start continuation if line full, else blank + + if Write_Info_Col > 72 then + Write_Info_EOL; + Write_Info_Initiate ('.'); + end if; + + Write_Info_Char (' '); + + -- Output file number if changed + + if XE.Lun /= Curru then + Curru := XE.Lun; + Write_Info_Nat (Dependency_Num (Curru)); + Write_Info_Char ('|'); + end if; + + Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc))); + Write_Info_Char (XE.Typ); + Write_Info_Nat (Int (Get_Column_Number (XE.Loc))); + end if; + end if; + end; + + <<Continue>> + null; + end loop; + + Write_Info_EOL; + end Output_Refs; + end Output_References; + +end Lib.Xref; diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads new file mode 100644 index 00000000000..d0d2c8ab36c --- /dev/null +++ b/gcc/ada/lib-xref.ads @@ -0,0 +1,444 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . X R E F -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.31 $ +-- -- +-- Copyright (C) 1998-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains for collecting and outputting cross-reference +-- information. + +with Einfo; use Einfo; +with Types; use Types; + +package Lib.Xref is + + ------------------------------------------------------- + -- Format of Cross-Reference Information in ALI File -- + ------------------------------------------------------- + + -- Cross-reference sections follow the dependency section (D lines) in + -- an ALI file, so that they need not be read by gnatbind, gnatmake etc. + -- + -- A cross reference section has a header of the form + -- + -- X dependency-number filename + -- + -- This header precedes xref information (entities/references from + -- the unit, identified by dependency number and file name. The + -- dependency number is the index into the generated D lines and + -- is ones origin (i.e. 2 = reference to second generated D line). + -- + -- Note that the filename here will reflect the original name if + -- a Source_Reference pragma was encountered (since all line number + -- references will be with respect to the original file). + -- + -- The lines following the header look like + -- + -- line type col level entity ptype ref ref ref + -- + -- line is the line number of the referenced entity. It starts + -- in column one. + -- + -- type is a single letter identifying the type of the entity. + -- See next section (Cross-Reference Entity Identifiers) for a + -- full list of the characters used). + -- + -- col is the column number of the referenced entity + -- + -- level is a single character that separates the col and + -- entity fields. It is an asterisk for a top level library + -- entity that is publicly visible, and space otherwise. + -- + -- entity is the name of the referenced entity, with casing in + -- the canical casing for the source file where it is defined. + -- + -- ptype is the parent's entity reference. This part is optional (it + -- is only set for derived types) and has the following format: + -- + -- < file | line type col > + -- + -- file is the dependency number of the file containing the + -- declaration of the parent type. This number and the following + -- vertical bar are omitted if the parent type is defined in the + -- same file as the derived type. The line, type, col are defined + -- as previously described, and give the location of the parent + -- type declaration in the referenced file. + -- + -- There may be zero or more ref entries on each line + -- + -- file | line type col + -- + -- file is the dependency number of the file with the reference. + -- It and the following vertical bar are omitted if the file is + -- the same as the previous ref, and the refs for the current + -- file are first (and do not need a bar). + -- + -- type is one of + -- r = reference + -- m = modification + -- b = body entity + -- c = completion of private or incomplete type + -- x = type extension + -- i = implicit reference + -- e = end of spec + -- t = end of body + -- + -- b is used for spec entities that are repeated in a body, + -- including the unit (subprogram, package, task, protected + -- body, protected entry) name itself, and in the case of a + -- subprogram, the formals. This letter is also used for the + -- occurrence of entry names in accept statements. Such entities + -- are not considered to be definitions for cross-referencing + -- purposes, but rather are considered to be references to the + -- corresponding spec entities, marked with this special type. + -- + -- c is similarly used to mark the completion of a private or + -- incomplete type. Again, the completion is not regarded as + -- a separate definition, but rather a reference to the initial + -- declaration, marked with this special type. + -- + -- x is used to identify the reference as the entity from which + -- a tagged type is extended. This allows immediate access to + -- the parent of a tagged type. + -- + -- i is used to identify a reference to the entity in a generic + -- actual or in a default in a call. The node that denotes the + -- entity does not come from source, but it has the Sloc of the + -- source node that generates the implicit reference, and it is + -- useful to record this one. + -- + -- e is used to identify the end of a construct in the following + -- cases: + -- + -- Block Statement end [block_IDENTIFIER]; + -- Loop Statement end loop [loop_IDENTIFIER]; + -- Package Specification end [[PARENT_UNIT_NAME .] IDENTIFIER]; + -- Task Definition end [task_IDENTIFIER]; + -- Protected Definition end [protected_IDENTIFIER]; + -- Record Definition end record; + -- + -- Note that 'e' entries are special in that you get they appear + -- even in referencing units (normally xref entries appear only + -- for references in the extended main source unit (see Lib) to + -- which the ali applies. But 'e' entries are really structural + -- and simply indicate where packages end. This information can + -- be used to reconstruct scope information for any entities + -- referenced from within the package. + -- + -- t is similarly used to identify the end of a corresponding + -- body (such a reference always links up with a b reference) + -- + -- Subprogram Body end [DESIGNATOR]; + -- Package Body end [[PARENT_UNIT_NAME .] IDENTIFIER]; + -- Task Body end [task_IDENTIFIER]; + -- Entry Body end [entry_IDENTIFIER]; + -- Protected Body end [protected_IDENTIFIER] + -- Accept Statement end [entry_IDENTIFIER]]; + -- + -- Note that in the case of accept statements, there can + -- be multiple b and T/t entries for the same entity. + -- + -- Examples: + -- + -- 44B5*Flag_Type 5r23 6m45 3|9r35 11r56 + -- + -- This line gives references for the publicly visible Boolean + -- type Flag_Type declared on line 44, column 5. There are four + -- references + -- + -- a reference on line 5, column 23 of the current file + -- + -- a modification on line 6, column 45 of the current file + -- + -- a reference on line 9, column 35 of unit number 3 + -- + -- a reference on line 11, column 56 of unit number 3 + -- + -- 2U13 p3 5b13 8r4 12r13 12t15 + -- + -- This line gives references for the non-publicly visible + -- procedure p3 declared on line 2, column 13. There are + -- four references: + -- + -- the corresponding body entity at line 5, column 13, + -- of the current file. + -- + -- a reference (e.g. a call) at line 8 column 4 of the + -- of the current file. + -- + -- the END line of the body has an explict reference to + -- the name of the procedure at line 12, column 13. + -- + -- the body ends at line 12, column 15, just past this label. + -- + -- 16I9*My_Type<2|4I9> 18r8 + -- + -- This line gives references for the publicly visible Integer + -- derived type My_Type declared on line 16, column 9. It also + -- gives references to the parent type declared in the unit + -- number 2 on line 4, column 9. There is one reference: + -- + -- a reference (e.g. a variable declaration) at line 18 column + -- 4 of the current file. + -- + -- Continuation lines are used if the reference list gets too long, + -- a continuation line starts with a period, and then has references + -- continuing from the previous line. The references are sorted first + -- by unit, then by position in the source. + + -- Note on handling of generic entities. The cross-reference is oriented + -- towards source references, so the entities in a generic instantiation + -- are not considered distinct from the entities in the template. All + -- definitions and references from generic instantiations are suppressed, + -- since they will be generated from the template. Any references to + -- entities in a generic instantiation from outside the instantiation + -- are considered to be references to the original template entity. + + ---------------------------------------- + -- Cross-Reference Entity Identifiers -- + ---------------------------------------- + + -- In the cross-reference section of the ali file, entity types are + -- identified by a single letter, indicating the entity type. The + -- following table indicates the letter. A space for an entry is + -- used for entities that do not appear in the cross-reference table. + + -- For objects, the character * appears in this table. In the xref + -- listing, this character is replaced by the lower case letter that + -- corresponds to the type of the object. For example, if a variable + -- is of a Float type, then, since the type is represented by an + -- upper case F, the object would be represented by a lower case f. + + -- A special exception is the case of booleans, whose entities are + -- normal E_Enumeration_Type or E_Enumeration_Subtype entities, but + -- which appear as B/b in the xref lines, rather than E/e. + + -- For private types, the character + appears in the table. In this + -- case the kind of the underlying type is used, if available, to + -- determine the character to use in the xref listing. The listing + -- will still include a '+' for a generic private type, for example. + + Xref_Entity_Letters : array (Entity_Kind) of Character := ( + E_Void => ' ', + E_Variable => '*', + E_Component => '*', + E_Constant => '*', + E_Discriminant => '*', + + E_Loop_Parameter => '*', + E_In_Parameter => '*', + E_Out_Parameter => '*', + E_In_Out_Parameter => '*', + E_Generic_In_Out_Parameter => '*', + + E_Generic_In_Parameter => '*', + E_Named_Integer => 'N', + E_Named_Real => 'N', + E_Enumeration_Type => 'E', -- B for boolean + E_Enumeration_Subtype => 'E', -- B for boolean + + E_Signed_Integer_Type => 'I', + E_Signed_Integer_Subtype => 'I', + E_Modular_Integer_Type => 'M', + E_Modular_Integer_Subtype => 'M', + E_Ordinary_Fixed_Point_Type => 'O', + + E_Ordinary_Fixed_Point_Subtype => 'O', + E_Decimal_Fixed_Point_Type => 'D', + E_Decimal_Fixed_Point_Subtype => 'D', + E_Floating_Point_Type => 'F', + E_Floating_Point_Subtype => 'F', + + E_Access_Type => 'P', + E_Access_Subtype => 'P', + E_Access_Attribute_Type => 'P', + E_Allocator_Type => ' ', + E_General_Access_Type => 'P', + + E_Access_Subprogram_Type => 'P', + E_Access_Protected_Subprogram_Type => 'P', + E_Anonymous_Access_Type => ' ', + E_Array_Type => 'A', + E_Array_Subtype => 'A', + + E_String_Type => 'S', + E_String_Subtype => 'S', + E_String_Literal_Subtype => ' ', + E_Class_Wide_Type => 'C', + + E_Class_Wide_Subtype => 'C', + E_Record_Type => 'R', + E_Record_Subtype => 'R', + E_Record_Type_With_Private => 'R', + E_Record_Subtype_With_Private => 'R', + + E_Private_Type => '+', + E_Private_Subtype => '+', + E_Limited_Private_Type => '+', + E_Limited_Private_Subtype => '+', + E_Incomplete_Type => '+', + + E_Task_Type => 'T', + E_Task_Subtype => 'T', + E_Protected_Type => 'W', + E_Protected_Subtype => 'W', + E_Exception_Type => ' ', + + E_Subprogram_Type => ' ', + E_Enumeration_Literal => 'n', + E_Function => 'V', + E_Operator => 'V', + E_Procedure => 'U', + + E_Entry => 'Y', + E_Entry_Family => 'Y', + E_Block => 'q', + E_Entry_Index_Parameter => '*', + E_Exception => 'X', + + E_Generic_Function => 'v', + E_Generic_Package => 'k', + E_Generic_Procedure => 'u', + E_Label => 'L', + E_Loop => 'l', + + E_Package => 'K', + + -- The following entities are not ones to which we gather + -- cross-references, since it does not make sense to do so + -- (e.g. references to a package are to the spec, not the body) + -- Indeed the occurrence of the body entity is considered to + -- be a reference to the spec entity. + + E_Package_Body => ' ', + E_Protected_Object => ' ', + E_Protected_Body => ' ', + E_Task_Body => ' ', + E_Subprogram_Body => ' '); + + -- The following table is for information purposes. It shows the + -- use of each character appearing as an entity type. + + -- letter lower case usage UPPER CASE USAGE + + -- a array object (except string) array type (except string) + -- b Boolean object Boolean type + -- c class-wide object class-wide type + -- d decimal fixed-point object decimal fixed-point type + -- e non-Boolean enumeration object non_Boolean enumeration type + -- f floating-point object floating-point type + -- g (unused) (unused) + -- h (unused) (unused) + -- i signed integer object signed integer type + -- j (unused) (unused) + -- k generic package package + -- l label on loop label on statement + -- m modular integer object modular integer type + -- n enumeration literal named number + -- o ordinary fixed-point object ordinary fixed-point type + -- p access object access type + -- q label on block (unused) + -- r record object record type + -- s string object string type + -- t task object task type + -- u generic procedure procedure + -- v generic function or operator function or operator + -- w protected object protected type + -- x (unused) exception + -- y (unused) entry or entry family + -- z (unused) (unused) + + ----------------- + -- Subprograms -- + ----------------- + + procedure Generate_Definition (E : Entity_Id); + -- Records the definition of an entity + + procedure Generate_Operator_Reference (N : Node_Id); + -- Node N is an operator node, whose entity has been set. If this entity + -- is a user defined operator (i.e. an operator not defined in package + -- Standard), then a reference to the operator is recorded at node N. + + procedure Generate_Reference + (E : Entity_Id; + N : Node_Id; + Typ : Character := 'r'; + Set_Ref : Boolean := True; + Force : Boolean := False); + -- This procedure is called to record a reference. N is the location + -- of the reference and E is the referenced entity. Typ is one of: + -- + -- 'b' body entity (see below) + -- 'c' completion of incomplete or private type (see below) + -- 'E' end of spec (label present) + -- 'e' end of spec (no label present) + -- 'i' implicit reference + -- 'm' modification + -- 'r' standard reference + -- 'T' end of body (label present) + -- 't' end of body (no label present) + -- 'x' type extension + -- ' ' dummy reference (see below) + -- + -- Note: all references to incomplete or private types are to the + -- original (incomplete or private type) declaration. The full + -- declaration is treated as a reference with type 'c'. + -- + -- Note: all references to packages or subprograms are to the entity + -- for the spec. The entity in the body is treated as a reference + -- with type 'b'. Similar handling for references to subprogram formals. + -- + -- The call has no effect if N is not in the extended main source unit. + -- If N is in the extended main source unit, then the Is_Referenced + -- flag of E is set. In addition, if appropriate, a cross-reference + -- entry is made. The entry is made if: + -- + -- cross-reference collection is enabled + -- both entity and reference come from source (or Force is True) + -- the entity is one for which xrefs are appropriate + -- the type letter is non-blank + -- the node N is an identifier, defining identifier, or expanded name + -- + -- If all these conditions are met, then a cross-reference entry is + -- made for later output when Output_References is called. + -- + -- Note: the dummy entry is for the convenience of some callers, who + -- find it easier to pass a space to suppress the entry than to do a + -- specific test. The call has no effect if the type is a space. + -- + -- The parameter Set_Ref is normally True, and indicates that in + -- addition to generating a cross-reference, the Referenced flag + -- of the specified entity should be set. If this parameter is + -- False, then setting of the Referenced flag is inhibited. + -- + -- The parameter Force is set to True to force a reference to be + -- generated even if Comes_From_Source is false. This is used for + -- certain implicit references, and also for end label references. + + procedure Output_References; + -- Output references to the current ali file + +end Lib.Xref; diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb new file mode 100644 index 00000000000..53e74f5459b --- /dev/null +++ b/gcc/ada/lib.adb @@ -0,0 +1,866 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.97 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Subprogram ordering not enforced in this unit +-- (because of some logical groupings). + +with Atree; use Atree; +with Einfo; use Einfo; +with Fname; use Fname; +with Namet; use Namet; +with Namet; use Namet; +with Output; use Output; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Stand; use Stand; +with Stringt; use Stringt; +with Tree_IO; use Tree_IO; +with Uname; use Uname; + +package body Lib is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + type SEU_Result is ( + Yes_Before, -- S1 is in same extended unit as S2 and appears before it + Yes_Same, -- S1 is in same extended unit as S2, Slocs are the same + Yes_After, -- S1 is in same extended unit as S2, and appears after it + No); -- S2 is not in same extended unit as S2 + + function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result; + -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns + -- value as described above. + + -------------------------------------------- + -- Access Functions for Unit Table Fields -- + -------------------------------------------- + + function Cunit (U : Unit_Number_Type) return Node_Id is + begin + return Units.Table (U).Cunit; + end Cunit; + + function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is + begin + return Units.Table (U).Cunit_Entity; + end Cunit_Entity; + + function Dependency_Num (U : Unit_Number_Type) return Nat is + begin + return Units.Table (U).Dependency_Num; + end Dependency_Num; + + function Dependent_Unit (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Dependent_Unit; + end Dependent_Unit; + + function Dynamic_Elab (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Dynamic_Elab; + end Dynamic_Elab; + + function Error_Location (U : Unit_Number_Type) return Source_Ptr is + begin + return Units.Table (U).Error_Location; + end Error_Location; + + function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is + begin + return Units.Table (U).Expected_Unit; + end Expected_Unit; + + function Fatal_Error (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Fatal_Error; + end Fatal_Error; + + function Generate_Code (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Generate_Code; + end Generate_Code; + + function Has_RACW (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Has_RACW; + end Has_RACW; + + function Ident_String (U : Unit_Number_Type) return Node_Id is + begin + return Units.Table (U).Ident_String; + end Ident_String; + + function Loading (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Loading; + end Loading; + + function Main_Priority (U : Unit_Number_Type) return Int is + begin + return Units.Table (U).Main_Priority; + end Main_Priority; + + function Source_Index (U : Unit_Number_Type) return Source_File_Index is + begin + return Units.Table (U).Source_Index; + end Source_Index; + + function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is + begin + return Units.Table (U).Unit_File_Name; + end Unit_File_Name; + + function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is + begin + return Units.Table (U).Unit_Name; + end Unit_Name; + + ------------------------------------------ + -- Subprograms to Set Unit Table Fields -- + ------------------------------------------ + + procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is + begin + Units.Table (U).Cunit := N; + end Set_Cunit; + + procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is + begin + Units.Table (U).Cunit_Entity := E; + Set_Is_Compilation_Unit (E); + end Set_Cunit_Entity; + + procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Dynamic_Elab := B; + end Set_Dynamic_Elab; + + procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is + begin + Units.Table (U).Error_Location := W; + end Set_Error_Location; + + procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Fatal_Error := True; + end Set_Fatal_Error; + + procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Generate_Code := B; + end Set_Generate_Code; + + procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Has_RACW := B; + end Set_Has_RACW; + + procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is + begin + Units.Table (U).Ident_String := N; + end Set_Ident_String; + + procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Loading := B; + end Set_Loading; + + procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is + begin + Units.Table (U).Main_Priority := P; + end Set_Main_Priority; + + procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is + begin + Units.Table (U).Unit_Name := N; + end Set_Unit_Name; + + ------------------------------ + -- Check_Same_Extended_Unit -- + ------------------------------ + + function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is + Sloc1 : Source_Ptr; + Sloc2 : Source_Ptr; + Sind1 : Source_File_Index; + Sind2 : Source_File_Index; + Inst1 : Source_Ptr; + Inst2 : Source_Ptr; + Unum1 : Unit_Number_Type; + Unum2 : Unit_Number_Type; + Unit1 : Node_Id; + Unit2 : Node_Id; + Depth1 : Nat; + Depth2 : Nat; + + begin + if S1 = No_Location or else S2 = No_Location then + return No; + + elsif S1 = Standard_Location then + if S2 = Standard_Location then + return Yes_Same; + else + return No; + end if; + + elsif S2 = Standard_Location then + return No; + end if; + + Sloc1 := S1; + Sloc2 := S2; + Unum1 := Get_Code_Unit (Sloc1); + Unum2 := Get_Code_Unit (Sloc2); + + loop + Sind1 := Get_Source_File_Index (Sloc1); + Sind2 := Get_Source_File_Index (Sloc2); + + if Sind1 = Sind2 then + if Sloc1 < Sloc2 then + return Yes_Before; + elsif Sloc1 > Sloc2 then + return Yes_After; + else + return Yes_Same; + end if; + end if; + + -- OK, the two nodes are in separate source elements, but this is not + -- decisive, because of the issue of subunits and instantiations. + + -- First we deal with subunits, since if the subunit is in an + -- instantiation, we know that the parent is in the corresponding + -- instantiation, since that is the only way we can have a subunit + -- that is part of an instantiation. + + Unit1 := Unit (Cunit (Unum1)); + Unit2 := Unit (Cunit (Unum2)); + + if Nkind (Unit1) = N_Subunit + and then Present (Corresponding_Stub (Unit1)) + then + -- Both in subunits. They could have a common ancestor. If they + -- do, then the deeper one must have a longer unit name. Replace + -- the deeper one with its corresponding stub, in order to find + -- nearest common ancestor, if any. + + if Nkind (Unit2) = N_Subunit + and then Present (Corresponding_Stub (Unit2)) + then + if Length_Of_Name (Unit_Name (Unum1)) < + Length_Of_Name (Unit_Name (Unum2)) + then + Sloc2 := Sloc (Corresponding_Stub (Unit2)); + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + + else + Sloc1 := Sloc (Corresponding_Stub (Unit1)); + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Nod1 in subunit, Nod2 not + + else + Sloc1 := Sloc (Corresponding_Stub (Unit1)); + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Nod2 in subunit, Nod1 not + + elsif Nkind (Unit2) = N_Subunit + and then Present (Corresponding_Stub (Unit2)) + then + Sloc2 := Sloc (Corresponding_Stub (Unit2)); + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- At this stage we know that neither is a subunit, so we deal + -- with instantiations, since we culd have a common ancestor + + Inst1 := Instantiation (Sind1); + Inst2 := Instantiation (Sind2); + + if Inst1 /= No_Location then + + -- Both are instantiations + + if Inst2 /= No_Location then + + Depth1 := Instantiation_Depth (Sloc1); + Depth2 := Instantiation_Depth (Sloc2); + + if Depth1 < Depth2 then + Sloc2 := Inst2; + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + + elsif Depth1 > Depth2 then + Sloc1 := Inst1; + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + + else + Sloc1 := Inst1; + Sloc2 := Inst2; + Unum1 := Get_Source_Unit (Sloc1); + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- Only first node is in instantiation + + else + Sloc1 := Inst1; + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Only second node is instantiation + + elsif Inst2 /= No_Location then + Sloc2 := Inst2; + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- No instantiations involved, so we are not in the same unit + -- However, there is one case still to check, namely the case + -- where one location is in the spec, and the other in the + -- corresponding body (the spec location is earlier). + + if Nkind (Unit1) = N_Subprogram_Body + or else + Nkind (Unit1) = N_Package_Body + then + if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then + return Yes_After; + end if; + + elsif Nkind (Unit2) = N_Subprogram_Body + or else + Nkind (Unit2) = N_Package_Body + then + if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then + return Yes_Before; + end if; + end if; + + -- If that special case does not occur, then we are certain that + -- the two locations are really in separate units. + + return No; + + <<Continue>> + null; + end loop; + + end Check_Same_Extended_Unit; + + ------------------------------ + -- Earlier_In_Extended_Unit -- + ------------------------------ + + function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is + begin + return Check_Same_Extended_Unit (S1, S2) = Yes_Before; + end Earlier_In_Extended_Unit; + + ---------------------------- + -- Entity_Is_In_Main_Unit -- + ---------------------------- + + function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is + S : Entity_Id; + + begin + S := Scope (E); + + while S /= Standard_Standard loop + if S = Main_Unit_Entity then + return True; + elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then + return False; + else + S := Scope (S); + end if; + end loop; + + return False; + end Entity_Is_In_Main_Unit; + + --------------------------------- + -- Generic_Separately_Compiled -- + --------------------------------- + + function Generic_Separately_Compiled (E : Entity_Id) return Boolean is + begin + -- We do not generate object files for internal generics, because + -- the only thing they would contain is the elaboration boolean, and + -- we are careful to elaborate all predefined units first anyway, so + -- this boolean is not needed. + + if Is_Internal_File_Name + (Fname => Unit_File_Name (Get_Source_Unit (E)), + Renamings_Included => True) + then + return False; + + -- All other generic units do generate object files + + else + return True; + end if; + end Generic_Separately_Compiled; + + ------------------- + -- Get_Code_Unit -- + ------------------- + + function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is + Source_File : Source_File_Index := + Get_Source_File_Index (Top_Level_Location (S)); + + begin + for U in Units.First .. Units.Last loop + if Source_Index (U) = Source_File then + return U; + end if; + end loop; + + -- If not in the table, must be the main source unit, and we just + -- have not got it put into the table yet. + + return Main_Unit; + end Get_Code_Unit; + + function Get_Code_Unit (N : Node_Id) return Unit_Number_Type is + begin + return Get_Code_Unit (Sloc (N)); + end Get_Code_Unit; + + ---------------------------- + -- Get_Compilation_Switch -- + ---------------------------- + + function Get_Compilation_Switch (N : Pos) return String_Ptr is + begin + if N >= Compilation_Switches.Last then + return Compilation_Switches.Table (N); + + else + return null; + end if; + end Get_Compilation_Switch; + + ---------------------------------- + -- Get_Cunit_Entity_Unit_Number -- + ---------------------------------- + + function Get_Cunit_Entity_Unit_Number + (E : Entity_Id) + return Unit_Number_Type + is + begin + for U in Units.First .. Units.Last loop + if Cunit_Entity (U) = E then + return U; + end if; + end loop; + + -- If not in the table, must be the main source unit, and we just + -- have not got it put into the table yet. + + return Main_Unit; + end Get_Cunit_Entity_Unit_Number; + + --------------------------- + -- Get_Cunit_Unit_Number -- + --------------------------- + + function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is + begin + for U in Units.First .. Units.Last loop + if Cunit (U) = N then + return U; + end if; + end loop; + + -- If not in the table, must be the main source unit, and we just + -- have not got it put into the table yet. + + return Main_Unit; + end Get_Cunit_Unit_Number; + + --------------------- + -- Get_Source_Unit -- + --------------------- + + function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is + Source_File : Source_File_Index := + Get_Source_File_Index (Top_Level_Location (S)); + + begin + Source_File := Get_Source_File_Index (S); + while Template (Source_File) /= No_Source_File loop + Source_File := Template (Source_File); + end loop; + + for U in Units.First .. Units.Last loop + if Source_Index (U) = Source_File then + return U; + end if; + end loop; + + -- If not in the table, must be the main source unit, and we just + -- have not got it put into the table yet. + + return Main_Unit; + end Get_Source_Unit; + + function Get_Source_Unit (N : Node_Id) return Unit_Number_Type is + begin + return Get_Source_Unit (Sloc (N)); + end Get_Source_Unit; + + -------------------------------- + -- In_Extended_Main_Code_Unit -- + -------------------------------- + + function In_Extended_Main_Code_Unit (N : Node_Id) return Boolean is + begin + if Sloc (N) = Standard_Location then + return True; + + elsif Sloc (N) = No_Location then + return False; + + -- Special case Itypes to test the Sloc of the associated node. The + -- reason we do this is for possible calls from gigi after -gnatD + -- processing is complete in sprint. This processing updates the + -- sloc fields of all nodes in the tree, but itypes are not in the + -- tree so their slocs do not get updated. + + elsif Nkind (N) = N_Defining_Identifier + and then Is_Itype (N) + then + return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N)); + + elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then + return True; + + else -- node may be in spec of main unit + return + In_Same_Extended_Unit (Sloc (N), Sloc (Cunit (Main_Unit))); + end if; + end In_Extended_Main_Code_Unit; + + ---------------------------------- + -- In_Extended_Main_Source_Unit -- + ---------------------------------- + + function In_Extended_Main_Source_Unit (N : Node_Id) return Boolean is + begin + if Sloc (N) = Standard_Location then + return True; + + elsif Sloc (N) = No_Location then + return False; + + -- Special case Itypes to test the Sloc of the associated node. The + -- reason we do this is for possible calls from gigi after -gnatD + -- processing is complete in sprint. This processing updates the + -- sloc fields of all nodes in the tree, but itypes are not in the + -- tree so their slocs do not get updated. + + elsif Nkind (N) = N_Defining_Identifier + and then Is_Itype (N) + then + return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N)); + + else + return + In_Same_Extended_Unit + (Original_Location (Sloc (N)), + Original_Location (Sloc (Cunit (Main_Unit)))); + end if; + end In_Extended_Main_Source_Unit; + + ----------------------- + -- In_Same_Code_Unit -- + ----------------------- + + function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is + S1 : constant Source_Ptr := Sloc (N1); + S2 : constant Source_Ptr := Sloc (N2); + + begin + if S1 = No_Location or else S2 = No_Location then + return False; + + elsif S1 = Standard_Location then + return S2 = Standard_Location; + + elsif S2 = Standard_Location then + return False; + end if; + + return Get_Code_Unit (N1) = Get_Code_Unit (N2); + end In_Same_Code_Unit; + + --------------------------- + -- In_Same_Extended_Unit -- + --------------------------- + + function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is + begin + return Check_Same_Extended_Unit (S1, S2) /= No; + end In_Same_Extended_Unit; + + ------------------------- + -- In_Same_Source_Unit -- + ------------------------- + + function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is + S1 : constant Source_Ptr := Sloc (N1); + S2 : constant Source_Ptr := Sloc (N2); + + begin + if S1 = No_Location or else S2 = No_Location then + return False; + + elsif S1 = Standard_Location then + return S2 = Standard_Location; + + elsif S2 = Standard_Location then + return False; + end if; + + return Get_Source_Unit (N1) = Get_Source_Unit (N2); + end In_Same_Source_Unit; + + ----------------------------- + -- Increment_Serial_Number -- + ----------------------------- + + function Increment_Serial_Number return Nat is + TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; + + begin + TSN := TSN + 1; + return TSN; + end Increment_Serial_Number; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Linker_Option_Lines.Init; + Load_Stack.Init; + Units.Init; + Unit_Exception_Table_Present := False; + Compilation_Switches.Init; + end Initialize; + + --------------- + -- Is_Loaded -- + --------------- + + function Is_Loaded (Uname : Unit_Name_Type) return Boolean is + begin + for Unum in Units.First .. Units.Last loop + if Uname = Unit_Name (Unum) then + return True; + end if; + end loop; + + return False; + end Is_Loaded; + + --------------- + -- Last_Unit -- + --------------- + + function Last_Unit return Unit_Number_Type is + begin + return Units.Last; + end Last_Unit; + + ---------- + -- List -- + ---------- + + procedure List (File_Names_Only : Boolean := False) is separate; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Linker_Option_Lines.Locked := True; + Load_Stack.Locked := True; + Units.Locked := True; + Linker_Option_Lines.Release; + Load_Stack.Release; + Units.Release; + end Lock; + + --------------- + -- Num_Units -- + --------------- + + function Num_Units return Nat is + begin + return Int (Units.Last) - Int (Main_Unit) + 1; + end Num_Units; + + ---------------------------------- + -- Replace_Linker_Option_String -- + ---------------------------------- + + procedure Replace_Linker_Option_String + (S : String_Id; Match_String : String) + is + begin + if Match_String'Length > 0 then + for J in 1 .. Linker_Option_Lines.Last loop + String_To_Name_Buffer (Linker_Option_Lines.Table (J)); + + if Match_String = Name_Buffer (1 .. Match_String'Length) then + Linker_Option_Lines.Table (J) := S; + return; + end if; + end loop; + end if; + + Store_Linker_Option_String (S); + end Replace_Linker_Option_String; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Tbl : in out Unit_Ref_Table) is separate; + + ------------------------------ + -- Store_Compilation_Switch -- + ------------------------------ + + procedure Store_Compilation_Switch (Switch : String) is + begin + Compilation_Switches.Increment_Last; + Compilation_Switches.Table (Compilation_Switches.Last) + := new String'(Switch); + end Store_Compilation_Switch; + + -------------------------------- + -- Store_Linker_Option_String -- + -------------------------------- + + procedure Store_Linker_Option_String (S : String_Id) is + begin + Linker_Option_Lines.Increment_Last; + Linker_Option_Lines.Table (Linker_Option_Lines.Last) := S; + end Store_Linker_Option_String; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + N : Nat; + S : String_Ptr; + + begin + Units.Tree_Read; + + -- Read Compilation_Switches table + + Tree_Read_Int (N); + Compilation_Switches.Set_Last (N); + + for J in 1 .. N loop + Tree_Read_Str (S); + Compilation_Switches.Table (J) := S; + end loop; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Units.Tree_Write; + + -- Write Compilation_Switches table + + Tree_Write_Int (Compilation_Switches.Last); + + for J in 1 .. Compilation_Switches.Last loop + Tree_Write_Str (Compilation_Switches.Table (J)); + end loop; + end Tree_Write; + + ----------------- + -- Version_Get -- + ----------------- + + function Version_Get (U : Unit_Number_Type) return Word_Hex_String is + begin + return Get_Hex_String (Units.Table (U).Version); + end Version_Get; + + ------------------------ + -- Version_Referenced -- + ------------------------ + + procedure Version_Referenced (S : String_Id) is + begin + Version_Ref.Append (S); + end Version_Referenced; + +end Lib; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads new file mode 100644 index 00000000000..d14fa2d0cc2 --- /dev/null +++ b/gcc/ada/lib.ads @@ -0,0 +1,696 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.100 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for accessing and outputting the library +-- information. It contains the routine to load subsidiary units. + +with Alloc; +with Table; +with Types; use Types; + +package Lib is + + -------------------------------------------- + -- General Approach to Library Management -- + -------------------------------------------- + + -- As described in GNote #1, when a unit is compiled, all its subsidiary + -- units are recompiled, including the following: + + -- (a) Corresponding spec for a body + -- (b) Parent spec of a child library spec + -- (d) With'ed specs + -- (d) Parent body of a subunit + -- (e) Subunits corresponding to any specified stubs + -- (f) Bodies of inlined subprograms that are called + -- (g) Bodies of generic subprograms or packages that are instantiated + -- (h) Bodies of packages containing either of the above two items + -- (i) Specs and bodies of runtime units + -- (j) Parent specs for with'ed child library units + + -- If a unit is being compiled only for syntax checking, then no subsidiary + -- units are loaded, the syntax check applies only to the main unit, + -- i.e. the one contained in the source submitted to the library. + + -- If a unit is being compiled for syntax and semantic checking, then only + -- cases (a)-(d) loads are performed, since the full semantic checking can + -- be carried out without needing (e)-(i) loads. In this case no object + -- file, or library information file, is generated, so the missing units + -- do not affect the results. + + -- Specifications of library subprograms, subunits, and generic specs + -- and bodies, can only be compiled in syntax/semantic checking mode, + -- since no code is ever generated directly for these units. In the case + -- of subunits, only the compilation of the ultimate parent unit generates + -- actual code. If a subunit is submitted to the compiler in syntax/ + -- semantic checking mode, the parent (or parents in the nested case) are + -- semantically checked only up to the point of the corresponding stub. + + -- If code is being generated, then all the above units are required, + -- although the need for bodies of inlined procedures can be suppressed + -- by the use of a switch that sets the mode to ignore pragma Inline + -- statements. + + -- The two main sections of the front end, Par and Sem, are recursive. + -- Compilation proceeds unit by unit making recursive calls as necessary. + -- The process is controlled from the GNAT main program, which makes calls + -- to Par and Sem sequence for the main unit. + + -- Par parses the given unit, and then, after the parse is complete, uses + -- the Par.Load subprogram to load all its subsidiary units in categories + -- (a)-(d) above, installing pointers to the loaded units in the parse + -- tree, as described in a later section of this spec. If any of these + -- required units is missing, a fatal error is signalled, so that no + -- attempt is made to run Sem in such cases, since it is assumed that + -- too many cascaded errors would result, and the confusion would not + -- be helpful. + + -- Following the call to Par on the main unit, the entire tree of required + -- units is thus loaded, and Sem is called on the main unit. The parameter + -- passed to Sem is the unit to be analyzed. The visibility table, which + -- is a single global structure, starts out containing only the entries + -- for the visible entities in Standard. Every call to Sem establishes a + -- new scope stack table, pushing an entry for Standard on entry to provide + -- the proper initial scope environment. + + -- Sem first proceeds to perform semantic analysis on the currently loaded + -- units as follows: + + -- In the case of a body (case (a) above), Sem analyzes the corresponding + -- spec, using a recursive call to Sem. As is always expected to be the + -- case with calls to Sem, any entities installed in the visibility table + -- are removed on exit from Sem, so that these entities have to be + -- reinstalled on return to continue the analysis of the body which of + -- course needs visibility of these entities. + -- + -- In the case of the parent of a child spec (case (b) above), a similar + -- call is made to Sem to analyze the parent. Again, on return, the + -- entities from the analyzed parent spec have to be installed in the + -- visibility table of the caller (the child unit), which must have + -- visibility to the entities in its parent spec. + + -- For with'ed specs (case (c) above), a recursive call to Sem is made + -- to analyze each spec in turn. After all the spec's have been analyzed, + -- but not till that point, the entities from all the with'ed units are + -- reinstalled in the visibility table so that the caller can proceed + -- with the analysis of the unit doing the with's with the necessary + -- entities made either potentially use visible or visible by selection + -- as needed. + + -- Case (d) arises when Sem is passed a subunit to analyze. This means + -- that the main unit is a subunit, and the unit passed to Sem is either + -- the main unit, or one of its ancestors that is still a subunit. Since + -- analysis must start at the top of the tree, Sem essentially cancels + -- the current call by immediately making a call to analyze the parent + -- (when this call is finished it immediately returns, so logically this + -- call is like a goto). The subunit will then be analyzed at the proper + -- time as described for the stub case. Note that we also turn off the + -- indication that code should be generated in this case, since the only + -- time we generate code for subunits is when compiling the main parent. + + -- Case (e), subunits corresponding to stubs, are handled as the stubs + -- are encountered. There are three sub-cases: + + -- If the subunit has already been loaded, then this means that the + -- main unit was a subunit, and we are back on our way down to it + -- after following the initial processing described for case (d). + -- In this case we analyze this particular subunit, as described + -- for the case where we are generating code, but when we get back + -- we are all done, since the rest of the parent is irrelevant. To + -- get out of the parent, we raise the exception Subunit_Found, which + -- is handled at the outer level of Sem. + + -- The cases where the subunit has not already been loaded correspond + -- to cases where the main unit was a parent. In this case the action + -- depends on whether or not we are generating code. If we are not + -- generating code, then this is the case where we can simply ignore + -- the subunit, since in checking mode we don't even want to insist + -- that the subunit exist, much less waste time checking it. + + -- If we are generating code, then we need to load and analyze + -- all subunits. This is achieved with a call to Lib.Load to load + -- and parse the unit, followed by processing that installs the + -- context clause of the subunit, analyzes the subunit, and then + -- removes the context clause (from the visibility chains of the + -- parent). Note that we do *not* do a recursive call to Sem in + -- this case, precisely because we need to do the analysis of the + -- subunit with the current visibility table and scope stack. + + -- Case (f) applies only to subprograms for which a pragma Inline is + -- given, providing that the compiler is operating in the mode where + -- pragma Inline's are activated. When the expander encounters a call + -- to such a subprogram, it loads the body of the subprogram if it has + -- not already been loaded, and calls Sem to process it. + + -- Case (g) is similar to case (f), except that the body of a generic + -- is unconditionally required, regardless of compiler mode settings. + -- As in the subprogram case, when the expander encounters a generic + -- instantiation, it loads the generic body of the subprogram if it + -- has not already been loaded, and calls Sem to process it. + + -- Case (h) arises when a package contains either an inlined subprogram + -- which is called, or a generic which is instantiated. In this case the + -- body of the package must be loaded and analyzed with a call to Sem. + + -- Case (i) is handled by adding implicit with clauses to the context + -- clauses of all units that potentially reference the relevant runtime + -- entities. Note that since we have the full set of units available, + -- the parser can always determine the set of runtime units that is + -- needed. These with clauses do not have associated use clauses, so + -- all references to the entities must be by selection. Once the with + -- clauses have been added, subsequent processing is as for normal + -- with clauses. + + -- Case (j) is also handled by adding appropriate implicit with clauses + -- to any unit that withs a child unit. Again there is no use clause, + -- and subsequent processing proceeds as for an explicit with clause. + + -- Sem thus completes the loading of all required units, except those + -- required for inline subprogram bodies or inlined generics. If any + -- of these load attempts fails, then the expander will not be called, + -- even if code was to be generated. If the load attempts all succeed + -- then the expander is called, though the attempt to generate code may + -- still fail if an error occurs during a load attempt for an inlined + -- body or a generic body. + + ------------------------------------------- + -- Special Handling of Subprogram Bodies -- + ------------------------------------------- + + -- A subprogram body (in an adb file) may stand for both a spec and a + -- body. A simple model (and one that was adopted through version 2.07), + -- is simply to assume that such an adb file acts as its own spec if no + -- ads file is present. + + -- However, this is not correct. RM 10.1.4(4) requires that such a body + -- act as a spec unless a subprogram declaration of the same name is + -- already present. The correct interpretation of this in GNAT library + -- terms is to ignore an existing ads file of the same name unless this + -- ads file contains a subprogram declaration with the same name. + + -- If there is an ads file with a unit other than a subprogram declaration + -- with the same name, then a fatal message is output, noting that this + -- irrelevant file must be deleted before the body can be compiled. See + -- ACVC test CA1020D to see how this processing is required. + + ----------------- + -- Global Data -- + ----------------- + + Current_Sem_Unit : Unit_Number_Type := Main_Unit; + -- Unit number of unit currently being analyzed/expanded. This is set when + -- ever a new unit is entered, saving and restoring the old value, so that + -- it always reflects the unit currently being analyzed. The initial value + -- of Main_Unit ensures that a proper value is set initially, and in + -- particular for analysis of configuration pragmas in gnat.adc. + + Main_Unit_Entity : Entity_Id; + -- Entity of main unit, same as Cunit_Entity (Main_Unit) except where + -- Main_Unit is a body with a separate spec, in which case it is the + -- entity for the spec. + + Unit_Exception_Table_Present : Boolean; + -- Set true if a unit exception table is present for the unit (i.e. + -- zero cost exception handling is active and there is at least one + -- subprogram in the extended unit). + + ----------------- + -- Units Table -- + ----------------- + + -- The units table has an entry for each unit (source file) read in by the + -- current compilation. The table is indexed by the unit number value, + -- The first entry in the table, subscript Main_Unit, is for the main file. + -- Each entry in this units table contains the following data. + + -- Unit_File_Name + -- The name of the source file containing the unit. Set when the entry + -- is created by a call to Lib.Load, and then cannot be changed. + + -- Source_Index + -- The index in the source file table of the corresponding source file. + -- Set when the entry is created by a call to Lib.Load and then cannot + -- be changed. + + -- Error_Location + -- This is copied from the Sloc field of the Enode argument passed + -- to Load_Unit. It refers to the enclosing construct which caused + -- this unit to be loaded, e.g. most typically the with clause that + -- referenced the unit, and is used for error handling in Par.Load. + + -- Expected_Unit + -- This is the expected unit name for a file other than the main unit, + -- since these are cases where we load the unit using Lib.Load and we + -- know the unit that is expected. It must be the same as Unit_Name + -- if it is set (see test in Par.Load). Expected_Unit is set to + -- No_Name for the main unit. + + -- Unit_Name + -- The name of the unit. Initialized to No_Name by Lib.Load, and then + -- set by the parser when the unit is parsed to the unit name actually + -- found in the file (which should, in the absence of errors) be the + -- same name as Expected_Unit. + + -- Cunit + -- Pointer to the N_Compilation_Unit node. Initially set to Empty by + -- Lib.Load, and then reset to the required node by the parser when + -- the unit is parsed. + + -- Cunit_Entity + -- Pointer to the entity node for the compilation unit. Initially set + -- to Empty by Lib.Load, and then reset to the required entity by the + -- parser when the unit is parsed. + + -- Dependency_Num + -- This is the number of the unit within the generated dependency + -- lines (D lines in the ALI file) which are sorted into alphabetical + -- order. The number is ones origin, so a value of 2 refers to the + -- second generated D line. The Dependency_Number values are set + -- as the D lines are generated, and are used to generate proper + -- unit references in the generated xref information. + + -- Dynamic_Elab + -- A flag indicating if this unit was compiled with dynamic elaboration + -- checks specified (as the result of using the -gnatE compilation + -- option or a pragma Elaboration_Checks (Dynamic). + + -- Fatal_Error + -- A flag that is initialized to False, and gets set to True if a fatal + -- error occurs during the processing of a unit. A fatal error is one + -- defined as serious enough to stop the next phase of the compiler + -- from running (i.e. fatal error during parsing stops semantics, + -- fatal error during semantics stops code generation). Note that + -- currently, errors of any kind cause Fatal_Error to be set, but + -- eventually perhaps only errors labeled as Fatal_Errors should be + -- this severe if we decide to try Sem on sources with minor errors. + + -- Generate_Code + -- This flag is set True for all units in the current file for which + -- code is to be generated. This includes the unit explicitly compiled, + -- together with its specification, and any subunits. + + -- Has_RACW + -- A Boolean flag, initially set to False when a unit entry is created, + -- and set to True if the unit defines a remote access to class wide + -- (RACW) object. This is used for controlling generation of the RA + -- attribute in the ali file. + + -- Ident_String + -- N_String_Literal node from a valid pragma Ident that applies to + -- this unit. If no Ident pragma applies to the unit, then Empty. + + -- Loading + -- A flag that is used to catch circular WITH dependencies. It is set + -- True when an entry is initially created in the file table, and set + -- False when the load is completed, or ends with an error. + + -- Main_Priority + -- This field is used to indicate the priority of a possible main + -- program, as set by a pragma Priority. A value of -1 indicates + -- that the default priority is to be used (and is also used for + -- entries that do not correspond to possible main programs). + + -- Serial_Number + -- This field holds a serial number used by New_Internal_Name to + -- generate unique temporary numbers on a unit by unit basis. The + -- only access to this field is via the Increment_Serial_Number + -- routine which increments the current value and returns it. This + -- serial number is separate for each unit. + + -- Version + -- This field holds the version of the unit, which is computed as + -- the exclusive or of the checksums of this unit, and all its + -- semantically dependent units. Access to the version number field + -- is not direct, but is done through the routines described below. + -- When a unit table entry is created, this field is initialized to + -- the checksum of the corresponding source file. Version_Update is + -- then called to reflect the contributions of any unit on which this + -- unit is semantically dependent. + + -- Dependent_Unit + -- This is a Boolean flag, which is set True to indicate that this + -- entry is for a semantically dependent unit. This flag is nearly + -- always set True, the only exception is for a unit that is loaded + -- by an Rtsfind request in No_Run_Time mode, where the entity that + -- is obtained by Rtsfind.RTE is for an inlined subprogram or other + -- entity for which a dependency need not be created. + + -- The units table is reset to empty at the start of the compilation of + -- each main unit by Lib.Initialize. Entries are then added by calls to + -- the Lib.Load procedure. The following subprograms are used to access + -- and modify entries in the Units table. Individual entries are accessed + -- using a unit number value which ranges from Main_Unit (the first entry, + -- which is always for the current main unit) to Last_Unit. + + Default_Main_Priority : constant Int := -1; + -- Value used in Main_Priority field to indicate default main priority + + function Cunit (U : Unit_Number_Type) return Node_Id; + function Cunit_Entity (U : Unit_Number_Type) return Entity_Id; + function Dependent_Unit (U : Unit_Number_Type) return Boolean; + function Dependency_Num (U : Unit_Number_Type) return Nat; + function Dynamic_Elab (U : Unit_Number_Type) return Boolean; + function Error_Location (U : Unit_Number_Type) return Source_Ptr; + function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type; + function Fatal_Error (U : Unit_Number_Type) return Boolean; + function Generate_Code (U : Unit_Number_Type) return Boolean; + function Ident_String (U : Unit_Number_Type) return Node_Id; + function Has_RACW (U : Unit_Number_Type) return Boolean; + function Loading (U : Unit_Number_Type) return Boolean; + function Main_Priority (U : Unit_Number_Type) return Int; + function Source_Index (U : Unit_Number_Type) return Source_File_Index; + function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type; + function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; + -- Get value of named field from given units table entry + + procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id); + procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id); + procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr); + procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); + procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True); + procedure Set_Main_Priority (U : Unit_Number_Type; P : Int); + procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type); + -- Set value of named field for given units table entry. Note that we + -- do not have an entry for each possible field, since some of the fields + -- can only be set by specialized interfaces (defined below). + + function Version_Get (U : Unit_Number_Type) return Word_Hex_String; + -- Returns the version as a string with 8 hex digits (upper case letters) + + function Last_Unit return Unit_Number_Type; + -- Unit number of last allocated unit + + function Num_Units return Nat; + -- Number of units currently in unit table + + function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean; + -- Returns True if the entity E is declared in the main unit, or, in + -- its corresponding spec, or one of its subunits. Entities declared + -- within generic instantiations return True if the instantiation is + -- itself "in the main unit" by this definition. Otherwise False. + + function Get_Source_Unit (N : Node_Id) return Unit_Number_Type; + pragma Inline (Get_Source_Unit); + function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type; + -- Return unit number of file identified by given source pointer value. + -- This call must always succeed, since any valid source pointer value + -- belongs to some previously loaded module. If the given source pointer + -- value is within an instantiation, this function returns the unit + -- number of the templace, i.e. the unit containing the source code + -- corresponding to the given Source_Ptr value. The version taking + -- a Node_Id argument, N, simply applies the function to Sloc (N). + + function Get_Code_Unit (N : Node_Id) return Unit_Number_Type; + pragma Inline (Get_Code_Unit); + function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type; + -- This is like Get_Source_Unit, except that in the instantiation case, + -- it uses the location of the top level instantiation, rather than the + -- template, so it returns the unit number containing the code that + -- corresponds to the node N, or the source location S. + + function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean; + pragma Inline (In_Same_Source_Unit); + -- Determines if the two nodes or entities N1 and N2 are in the same + -- source unit, the criterion being that Get_Source_Unit yields the + -- same value for each argument. + + function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean; + pragma Inline (In_Same_Source_Unit); + -- Determines if the two nodes or entities N1 and N2 are in the same + -- code unit, the criterion being that Get_Code_Unit yields the same + -- value for each argument. + + function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean; + -- Determines if the two source locations S1 and S2 are in the same + -- extended unit, where an extended unit is defined as a unit and all + -- its subunits (considered recursively, i.e. subunits or subunits are + -- included). Returns true if S1 and S2 are in the same extended unit + -- and False otherwise. + + function In_Extended_Main_Code_Unit (N : Node_Id) return Boolean; + -- Return True if the node is in the generated code of the extended main + -- unit, defined as the main unit, its specification (if any), and all + -- its subunits (considered recursively). Units for which this enquiry + -- returns True are those for which code will be generated. Nodes from + -- instantiations are included in the extended main unit for this call. + -- If the main unit is itself a subunit, then the extended main unit + -- includes its parent unit, and the parent unit spec if it is separate. + + function In_Extended_Main_Source_Unit (N : Node_Id) return Boolean; + -- Return True if the node is in the source text of the extended main + -- unit, defined as the main unit, its specification (if any), and all + -- its subunits (considered recursively). Units for which this enquiry + -- returns True are those for which code will be generated. This differs + -- from In_Extended_Main_Code_Unit only in that instantiations are not + -- included for the purposes of this call. If the main unit is itself + -- a subunit, then the extended main unit includes its parent unit, + -- and the parent unit spec if it is separate. + + function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean; + -- Given two Sloc values for which In_Same_Extended_Unit is true, + -- determine if S1 appears before S2. Returns True if S1 appears before + -- S2, and False otherwise. The result is undefined if S1 and S2 are + -- not in the same extended unit. + + function Get_Compilation_Switch (N : Pos) return String_Ptr; + -- Return the Nth stored compilation switch, or null if less than N + -- switches have been stored. Used by ASIS. + + function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type; + -- Return unit number of the unit whose N_Compilation_Unit node is the + -- one passed as an argument. This must always succeed since the node + -- could not have been built without making a unit table entry. + + function Get_Cunit_Entity_Unit_Number + (E : Entity_Id) + return Unit_Number_Type; + -- Return unit number of the unit whose compilation unit spec entity is + -- the one passed as an argument. This must always succeed since the + -- entity could not have been built without making a unit table entry. + + function Increment_Serial_Number return Nat; + -- Increment Serial_Number field for current unit, and return the + -- incremented value. + + procedure Replace_Linker_Option_String + (S : String_Id; Match_String : String); + -- Replace an existing Linker_Option if the prefix Match_String + -- matches, otherwise call Store_Linker_Option_String. + + procedure Store_Compilation_Switch (Switch : String); + -- Called to register a compilation switch, either front-end or + -- back-end, which may influence the generated output file(s). + + procedure Store_Linker_Option_String (S : String_Id); + -- This procedure is called to register the string from a pragma + -- Linker_Option. The argument is the Id of the string to register. + + procedure Initialize; + -- Initialize internal tables + + procedure Lock; + -- Lock internal tables before calling back end + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write + + procedure Tree_Read; + -- Initializes internal tables from current tree file using Tree_Read + + function Is_Loaded (Uname : Unit_Name_Type) return Boolean; + -- Determines if unit with given name is already loaded, i.e. there is + -- already an entry in the file table with this unit name for which the + -- corresponding file was found and parsed. Note that the Fatal_Error flag + -- of this entry must be checked before proceeding with further processing. + + procedure Version_Referenced (S : String_Id); + -- This routine is called from Exp_Attr to register the use of a Version + -- or Body_Version attribute. The argument is the external name used to + -- access the version string. + + procedure List (File_Names_Only : Boolean := False); + -- Lists units in active library (i.e. generates output consisting of a + -- sorted listing of the units represented in File table, with the + -- exception of the main unit). If File_Names_Only is set to True, then + -- the list includes only file names, and no other information. Otherwise + -- the unit name and time stamp are also output. File_Names_Only also + -- restricts the list to exclude any predefined files. + + function Generic_Separately_Compiled (E : Entity_Id) return Boolean; + -- Most generic units must be separately compiled. Since we always use + -- macro substitution for generics, the resulting object file is a dummy + -- one with no code, but the ali file has the normal form, and we need + -- this ali file so that the binder can work out a correct order of + -- elaboration. However, we do not need to separate compile generics + -- if the generic files are language defined, since in this case there + -- are no order of elaborration problems, and we can simply incorporate + -- the context clause of the generic unit into the client. There are two + -- reasons for making this exception for predefined units. First, clearly + -- it is more efficient not to introduce extra unnecessary files. Second, + -- the old version of GNAT did not compile any generic units. That was + -- clearly incorrect in some cases of complex order of elaboration and + -- was fixed in version 3.10 of GNAT. However, the transition would have + -- caused bootstrap path problems in the case of generics used in the + -- compiler itself. The only such generics are predefined ones. This + -- function returns True if the given generic unit entity E is for a + -- generic unit that should be separately compiled, and false otherwise. + +private + pragma Inline (Cunit); + pragma Inline (Cunit_Entity); + pragma Inline (Dependency_Num); + pragma Inline (Dependent_Unit); + pragma Inline (Fatal_Error); + pragma Inline (Generate_Code); + pragma Inline (Has_RACW); + pragma Inline (Increment_Serial_Number); + pragma Inline (Loading); + pragma Inline (Main_Priority); + pragma Inline (Set_Cunit); + pragma Inline (Set_Cunit_Entity); + pragma Inline (Set_Fatal_Error); + pragma Inline (Set_Generate_Code); + pragma Inline (Set_Has_RACW); + pragma Inline (Set_Loading); + pragma Inline (Set_Main_Priority); + pragma Inline (Set_Unit_Name); + pragma Inline (Source_Index); + pragma Inline (Unit_File_Name); + pragma Inline (Unit_Name); + + type Unit_Record is record + Unit_File_Name : File_Name_Type; + Unit_Name : Unit_Name_Type; + Expected_Unit : Unit_Name_Type; + Source_Index : Source_File_Index; + Cunit : Node_Id; + Cunit_Entity : Node_Id; + Dependency_Num : Int; + Dependent_Unit : Boolean; + Fatal_Error : Boolean; + Generate_Code : Boolean; + Has_RACW : Boolean; + Ident_String : Node_Id; + Loading : Boolean; + Main_Priority : Int; + Serial_Number : Nat; + Version : Word; + Dynamic_Elab : Boolean; + Error_Location : Source_Ptr; + end record; + + package Units is new Table.Table ( + Table_Component_Type => Unit_Record, + Table_Index_Type => Unit_Number_Type, + Table_Low_Bound => Main_Unit, + Table_Initial => Alloc.Units_Initial, + Table_Increment => Alloc.Units_Increment, + Table_Name => "Units"); + + -- The following table stores strings from pragma Linker_Option lines + + package Linker_Option_Lines is new Table.Table ( + Table_Component_Type => String_Id, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => Alloc.Linker_Option_Lines_Initial, + Table_Increment => Alloc.Linker_Option_Lines_Increment, + Table_Name => "Linker_Option_Lines"); + + -- The following table records the compilation switches used to compile + -- the main unit. The table includes only switches and excludes -quiet, + -- -dumpbase, and -o switches, since the latter are typically artifacts + -- of the gcc/gnat1 interface. + + -- This table is set as part of the compiler argument scanning in + -- Back_End. It can also be reset in -gnatc mode from the data in an + -- existing ali file, and is read and written by the Tree_Read and + -- Tree_Write routines for ASIS. + + package Compilation_Switches is new Table.Table ( + Table_Component_Type => String_Ptr, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 30, + Table_Increment => 100, + Table_Name => "Compilation_Switches"); + + Load_Msg_Sloc : Source_Ptr; + -- Location for placing error messages (a token in the main source text) + -- This is set from Sloc (Enode) by Load only in the case where this Sloc + -- is in the main source file. This ensures that not found messages and + -- circular dependency messages reference the original with in this source. + + type Unit_Ref_Table is array (Pos range <>) of Unit_Number_Type; + -- Type to hold list of indirect references to unit number table + + -- The Load_Stack table contains a list of unit numbers (indexes into the + -- unit table) of units being loaded on a single dependency chain. The + -- First entry is the main unit. The second entry, if present is a unit + -- on which the first unit depends, etc. This stack is used to generate + -- error messages showing the dependency chain if a file is not found. + -- The Load function makes an entry in this table when it is called, and + -- removes the entry just before it returns. + + package Load_Stack is new Table.Table ( + Table_Component_Type => Unit_Number_Type, + Table_Index_Type => Nat, + Table_Low_Bound => 0, + Table_Initial => Alloc.Load_Stack_Initial, + Table_Increment => Alloc.Load_Stack_Increment, + Table_Name => "Load_Stack"); + + procedure Sort (Tbl : in out Unit_Ref_Table); + -- This procedure sorts the given unit reference table in order of + -- ascending unit names, where the ordering relation is as described + -- by the comparison routines provided by package Uname. + + -- The Version_Ref table records Body_Version and Version attribute + -- references. The entries are simply the strings for the external + -- names that correspond to the referenced values. + + package Version_Ref is new Table.Table ( + Table_Component_Type => String_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Version_Ref"); + +end Lib; diff --git a/gcc/ada/link.c b/gcc/ada/link.c new file mode 100644 index 00000000000..a33735be8d0 --- /dev/null +++ b/gcc/ada/link.c @@ -0,0 +1,188 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L I N K * + * * + * $Revision: 1.1 $ + * * + * C Implementation File * + * * + * Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion 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. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This file contains parameterizations used by gnatlink.adb in handling */ +/* very long linker lines in systems where there are limitations on the */ +/* argument length when the command line is used to pass items to the */ +/* linker */ + +#include <string.h> + +/* objlist_file_supported is set to 1 when the system linker allows */ +/* response file, that is a file that contains the list of object files. */ +/* This is useful on systems where the command line length is limited, */ +/* meaning that putting all the object files on the command line can */ +/* result in an unacceptable limit on the number of files. */ + +/* object_file_option denotes the system dependent linker option which */ +/* allows object file names to be placed in a file and then passed to */ +/* the linker. object_file_option must be set if objlist_file_supported */ +/* is set to 1. */ + +/* link_max is a conservative system specific threshold (in bytes) of the */ +/* argument length passed to the linker which will trigger a file being */ +/* used instead of the command line directly. If the argument length is */ +/* greater than this threshhold, then an objlist_file will be generated */ +/* and object_file_option and objlist_file_supported must be set. If */ +/* objlist_file_supported is set to 0 (unsupported), then link_max is */ +/* set to 2**31-1 so that the limit will never be exceeded. */ + +/* run_path_option is the system dependent linker option which specifies */ +/* the run time path to use when loading dynamic libraries. This should */ +/* be set to the null string if the system does not support dynmamic */ +/* loading of libraries. */ + +/* shared_libgnat_default gives the system dependent link method that */ +/* be used by default for linking libgnat (shared or static) */ + +/* using_gnu_linker is set to 1 when the GNU linker is used under this */ +/* target. */ + +/* RESPONSE FILE & GNU LINKER */ +/* -------------------------- */ +/* objlist_file_supported and using_gnu_link used together tell gnatlink */ +/* to generate a GNU style response file. Note that object_file_option */ +/* must be set to "" in this case, since no option is required for a */ +/* response file to be passed to GNU ld. With a GNU linker we use the */ +/* linker script to implement the response file feature. Any file passed */ +/* in the GNU ld command line with an unknown extension is supposed to be */ +/* a linker script. Each linker script augment the current configuration. */ +/* The format of such response file is as follow : */ +/* INPUT (obj1.p obj2.o ...) */ + +#define SHARED 'H' +#define STATIC 'T' + +#if defined (__osf__) +const char *object_file_option = "-Wl,-input,"; +const char *run_path_option = "-Wl,-rpath,"; +int link_max = 10000; +unsigned char objlist_file_supported = 1; +char shared_libgnat_default = STATIC; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; + +#elif defined (sgi) +const char *object_file_option = "-Wl,-objectlist,"; +const char *run_path_option = "-Wl,-rpath,"; +int link_max = 5000; +unsigned char objlist_file_supported = 1; +char shared_libgnat_default = SHARED; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; + +#elif defined (__WIN32) +const char *object_file_option = ""; +const char *run_path_option = ""; +int link_max = 30000; +unsigned char objlist_file_supported = 1; +char shared_libgnat_default = STATIC; +unsigned char using_gnu_linker = 1; +const char *object_library_extension = ".a"; + +#elif defined (__INTERIX) +const char *object_file_option = ""; +const char *run_path_option = ""; +int link_max = 5000; +unsigned char objlist_file_supported = 1; +char shared_libgnat_default = STATIC; +unsigned char using_gnu_linker = 1; +const char *object_library_extension = ".a"; + +#elif defined (hpux) +const char *object_file_option = "-Wl,-c,"; +const char *run_path_option = "-Wl,+b,"; +int link_max = 5000; +unsigned char objlist_file_supported = 1; +char shared_libgnat_default = STATIC; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; + +#elif defined (_AIX) +const char *object_file_option = "-Wl,-f,"; +const char *run_path_option = ""; +int link_max = 15000; +cnonst unsigned char objlist_file_supported = 1; +char shared_libgnat_default = STATIC; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; + +#elif defined (VMS) +const char *object_file_option = ""; +const char *run_path_option = ""; +char shared_libgnat_default = SHARED; +int link_max = 2147483647; +unsigned char objlist_file_supported = 0; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".olb"; + +#elif defined (sun) +const char *object_file_option = ""; +const char *run_path_option = "-R"; +char shared_libgnat_default = STATIC; +int link_max = 2147483647; +unsigned char objlist_file_supported = 0; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; + +#elif defined (linux) +const char *object_file_option = ""; +const char *run_path_option = "-Wl,-rpath,"; +char shared_libgnat_default = STATIC; +int link_max = 2147483647; +unsigned char objlist_file_supported = 0; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; + +#elif defined (__svr4__) && defined (i386) +const char *object_file_option = ""; +const char *run_path_option = ""; +char shared_libgnat_default = STATIC; +int link_max = 2147483647; +unsigned char objlist_file_supported = 0; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; + +#else + +/* These are the default settings for all other systems. No response file + is supported, the shared library default is STATIC. */ +const char *run_path_option = ""; +const char *object_file_option = ""; +char shared_libgnat_default = STATIC; +int link_max = 2147483647; +unsigned char objlist_file_supported = 0; +unsigned char using_gnu_linker = 0; +const char *object_library_extension = ".a"; +#endif diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb new file mode 100644 index 00000000000..16627c2b5cd --- /dev/null +++ b/gcc/ada/live.adb @@ -0,0 +1,346 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I V E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Lib; use Lib; +with Nlists; use Nlists; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Types; use Types; + +package body Live is + + -- Name_Set + + -- The Name_Set type is used to store the temporary mark bits + -- used by the garbage collection of entities. Using a separate + -- array prevents using up any valuable per-node space and possibly + -- results in better locality and cache usage. + + type Name_Set is array (Node_Id range <>) of Boolean; + pragma Pack (Name_Set); + + function Marked (Marks : Name_Set; Name : Node_Id) return Boolean; + pragma Inline (Marked); + + procedure Set_Marked + (Marks : in out Name_Set; + Name : Node_Id; + Mark : Boolean := True); + pragma Inline (Set_Marked); + + -- Algorithm + + -- The problem of finding live entities is solved in two steps: + + procedure Mark (Root : Node_Id; Marks : out Name_Set); + -- Mark all live entities in Root as Marked. + + procedure Sweep (Root : Node_Id; Marks : Name_Set); + -- For all unmarked entities in Root set Is_Eliminated to true + + -- The Mark phase is split into two phases: + + procedure Init_Marked (Root : Node_Id; Marks : out Name_Set); + -- For all subprograms, reset Is_Public flag if a pragma Eliminate + -- applies to the entity, and set the Marked flag to Is_Public + + procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set); + -- Traverse the tree skipping any unmarked subprogram bodies. + -- All visited entities are marked, as well as entities denoted + -- by a visited identifier or operator. When an entity is first + -- marked it is traced as well. + + -- Local functions + + function Body_Of (E : Entity_Id) return Node_Id; + -- Returns subprogram body corresponding to entity E + + function Spec_Of (N : Node_Id) return Entity_Id; + -- Given a subprogram body N, return defining identifier of its declaration + + -- ??? the body of this package contains no comments at all, this + -- should be fixed! + + ------------- + -- Body_Of -- + ------------- + + function Body_Of (E : Entity_Id) return Node_Id is + Decl : Node_Id := Unit_Declaration_Node (E); + Result : Node_Id; + Kind : Node_Kind := Nkind (Decl); + + begin + if Kind = N_Subprogram_Body then + Result := Decl; + + elsif Kind /= N_Subprogram_Declaration + and Kind /= N_Subprogram_Body_Stub + then + Result := Empty; + + else + Result := Corresponding_Body (Decl); + + if Result /= Empty then + Result := Unit_Declaration_Node (Result); + end if; + end if; + + return Result; + end Body_Of; + + ------------------------------ + -- Collect_Garbage_Entities -- + ------------------------------ + + procedure Collect_Garbage_Entities is + Root : constant Node_Id := Cunit (Main_Unit); + Marks : Name_Set (0 .. Last_Node_Id); + + begin + Mark (Root, Marks); + Sweep (Root, Marks); + end Collect_Garbage_Entities; + + ----------------- + -- Init_Marked -- + ----------------- + + procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is + + function Process (N : Node_Id) return Traverse_Result; + procedure Traverse is new Traverse_Proc (Process); + + function Process (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Entity'Range => + if Is_Eliminated (N) then + Set_Is_Public (N, False); + end if; + + Set_Marked (Marks, N, Is_Public (N)); + + when N_Subprogram_Body => + Traverse (Spec_Of (N)); + + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + Traverse (Proper_Body (Unit (Library_Unit (N)))); + end if; + + when N_Package_Body => + declare + Elmt : Node_Id := First (Declarations (N)); + begin + while Present (Elmt) loop + Traverse (Elmt); + Next (Elmt); + end loop; + end; + + when others => + null; + end case; + + return OK; + end Process; + + -- Start of processing for Init_Marked + + begin + Marks := (others => False); + Traverse (Root); + end Init_Marked; + + ---------- + -- Mark -- + ---------- + + procedure Mark (Root : Node_Id; Marks : out Name_Set) is + begin + Init_Marked (Root, Marks); + Trace_Marked (Root, Marks); + end Mark; + + ------------ + -- Marked -- + ------------ + + function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is + begin + return Marks (Name); + end Marked; + + ---------------- + -- Set_Marked -- + ---------------- + + procedure Set_Marked + (Marks : in out Name_Set; + Name : Node_Id; + Mark : Boolean := True) + is + begin + Marks (Name) := Mark; + end Set_Marked; + + ------------- + -- Spec_Of -- + ------------- + + function Spec_Of (N : Node_Id) return Entity_Id is + begin + if Acts_As_Spec (N) then + return Defining_Entity (N); + else + return Corresponding_Spec (N); + end if; + end Spec_Of; + + ----------- + -- Sweep -- + ----------- + + procedure Sweep (Root : Node_Id; Marks : Name_Set) is + + function Process (N : Node_Id) return Traverse_Result; + procedure Traverse is new Traverse_Proc (Process); + + function Process (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Entity'Range => + Set_Is_Eliminated (N, not Marked (Marks, N)); + + when N_Subprogram_Body => + Traverse (Spec_Of (N)); + + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + Traverse (Proper_Body (Unit (Library_Unit (N)))); + end if; + + when N_Package_Body => + declare + Elmt : Node_Id := First (Declarations (N)); + begin + while Present (Elmt) loop + Traverse (Elmt); + Next (Elmt); + end loop; + end; + + when others => + null; + end case; + return OK; + end Process; + + begin + Traverse (Root); + end Sweep; + + ------------------ + -- Trace_Marked -- + ------------------ + + procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is + + function Process (N : Node_Id) return Traverse_Result; + procedure Process (N : Node_Id); + procedure Traverse is new Traverse_Proc (Process); + + procedure Process (N : Node_Id) is + Result : Traverse_Result; + begin + Result := Process (N); + end Process; + + function Process (N : Node_Id) return Traverse_Result is + Result : Traverse_Result := OK; + B : Node_Id; + E : Entity_Id; + + begin + case Nkind (N) is + when N_Pragma | N_Generic_Declaration'Range | + N_Subprogram_Declaration | N_Subprogram_Body_Stub => + Result := Skip; + + when N_Subprogram_Body => + if not Marked (Marks, Spec_Of (N)) then + Result := Skip; + end if; + + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + Traverse (Proper_Body (Unit (Library_Unit (N)))); + end if; + + when N_Identifier | N_Operator_Symbol | N_Expanded_Name => + E := Entity (N); + + if E /= Empty and then not Marked (Marks, E) then + Process (E); + + if Is_Subprogram (E) then + B := Body_Of (E); + + if B /= Empty then + Traverse (B); + end if; + end if; + end if; + + when N_Entity'Range => + if (Ekind (N) = E_Component) and then not Marked (Marks, N) then + if Present (Discriminant_Checking_Func (N)) then + Process (Discriminant_Checking_Func (N)); + end if; + end if; + + Set_Marked (Marks, N); + + when others => + null; + end case; + + return Result; + end Process; + + -- Start of processing for Trace_Marked + + begin + Traverse (Root); + end Trace_Marked; + +end Live; diff --git a/gcc/ada/live.ads b/gcc/ada/live.ads new file mode 100644 index 00000000000..dcff98fcc30 --- /dev/null +++ b/gcc/ada/live.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I V E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements a compiler phase that determines the set +-- of live entities. For now entities are considered live when they +-- have at least one execution time reference. + +package Live is + + procedure Collect_Garbage_Entities; + -- Eliminate unreachable entities using a mark-and-sweep from + -- the set of root entities, ie. those having Is_Public set. + +end Live; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb new file mode 100644 index 00000000000..4fe8c1a74e5 --- /dev/null +++ b/gcc/ada/namet.adb @@ -0,0 +1,1216 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N A M E T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.86 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file a-namet.h +-- which is created manually from namet.ads and namet.adb. + +with Debug; use Debug; +with Output; use Output; +with Tree_IO; use Tree_IO; +with Widechar; use Widechar; + +package body Namet is + + Name_Chars_Reserve : constant := 5000; + Name_Entries_Reserve : constant := 100; + -- The names table is locked during gigi processing, since gigi assumes + -- that the table does not move. After returning from gigi, the names + -- table is unlocked again, since writing library file information needs + -- to generate some extra names. To avoid the inefficiency of always + -- reallocating during this second unlocked phase, we reserve a bit of + -- extra space before doing the release call. + + Hash_Num : constant Int := 2**12; + -- Number of headers in the hash table. Current hash algorithm is closely + -- tailored to this choice, so it can only be changed if a corresponding + -- change is made to the hash alogorithm. + + Hash_Max : constant Int := Hash_Num - 1; + -- Indexes in the hash header table run from 0 to Hash_Num - 1 + + subtype Hash_Index_Type is Int range 0 .. Hash_Max; + -- Range of hash index values + + Hash_Table : array (Hash_Index_Type) of Name_Id; + -- The hash table is used to locate existing entries in the names table. + -- The entries point to the first names table entry whose hash value + -- matches the hash code. Then subsequent names table entries with the + -- same hash code value are linked through the Hash_Link fields. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Hash return Hash_Index_Type; + pragma Inline (Hash); + -- Compute hash code for name stored in Name_Buffer (length in Name_Len) + + procedure Strip_Qualification_And_Package_Body_Suffix; + -- Given an encoded entity name in Name_Buffer, remove package body + -- suffix as described for Strip_Package_Body_Suffix, and also remove + -- all qualification, i.e. names followed by two underscores. The + -- contents of Name_Buffer is modified by this call, and on return + -- Name_Buffer and Name_Len reflect the stripped name. + + ----------------------------- + -- Add_Char_To_Name_Buffer -- + ----------------------------- + + procedure Add_Char_To_Name_Buffer (C : Character) is + begin + if Name_Len < Name_Buffer'Last then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := C; + end if; + end Add_Char_To_Name_Buffer; + + ---------------------------- + -- Add_Nat_To_Name_Buffer -- + ---------------------------- + + procedure Add_Nat_To_Name_Buffer (V : Nat) is + begin + if V >= 10 then + Add_Nat_To_Name_Buffer (V / 10); + end if; + + Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10)); + end Add_Nat_To_Name_Buffer; + + ---------------------------- + -- Add_Str_To_Name_Buffer -- + ---------------------------- + + procedure Add_Str_To_Name_Buffer (S : String) is + begin + for J in S'Range loop + Add_Char_To_Name_Buffer (S (J)); + end loop; + end Add_Str_To_Name_Buffer; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + Max_Chain_Length : constant := 50; + -- Max length of chains for which specific information is output + + F : array (Int range 0 .. Max_Chain_Length) of Int; + -- N'th entry is number of chains of length N + + Probes : Int := 0; + -- Used to compute average number of probes + + Nsyms : Int := 0; + -- Number of symbols in table + + begin + if Debug_Flag_H then + + for J in F'Range loop + F (J) := 0; + end loop; + + for I in Hash_Index_Type loop + if Hash_Table (I) = No_Name then + F (0) := F (0) + 1; + + else + Write_Str ("Hash_Table ("); + Write_Int (Int (I)); + Write_Str (") has "); + + declare + C : Int := 1; + N : Name_Id; + S : Int; + + begin + C := 0; + N := Hash_Table (I); + + while N /= No_Name loop + N := Name_Entries.Table (N).Hash_Link; + C := C + 1; + end loop; + + Write_Int (C); + Write_Str (" entries"); + Write_Eol; + + if C < Max_Chain_Length then + F (C) := F (C) + 1; + else + F (Max_Chain_Length) := F (Max_Chain_Length) + 1; + end if; + + N := Hash_Table (I); + + while N /= No_Name loop + S := Name_Entries.Table (N).Name_Chars_Index; + Write_Str (" "); + + for J in 1 .. Name_Entries.Table (N).Name_Len loop + Write_Char (Name_Chars.Table (S + Int (J))); + end loop; + + Write_Eol; + N := Name_Entries.Table (N).Hash_Link; + end loop; + end; + end if; + end loop; + + Write_Eol; + + for I in Int range 0 .. Max_Chain_Length loop + if F (I) /= 0 then + Write_Str ("Number of hash chains of length "); + + if I < 10 then + Write_Char (' '); + end if; + + Write_Int (I); + + if I = Max_Chain_Length then + Write_Str (" or greater"); + end if; + + Write_Str (" = "); + Write_Int (F (I)); + Write_Eol; + + if I /= 0 then + Nsyms := Nsyms + F (I); + Probes := Probes + F (I) * (1 + I) * 100; + end if; + end if; + end loop; + + Write_Eol; + Write_Str ("Average number of probes for lookup = "); + Probes := Probes / Nsyms; + Write_Int (Probes / 200); + Write_Char ('.'); + Probes := (Probes mod 200) / 2; + Write_Char (Character'Val (48 + Probes / 10)); + Write_Char (Character'Val (48 + Probes mod 10)); + Write_Eol; + Write_Eol; + end if; + end Finalize; + + ----------------------------- + -- Get_Decoded_Name_String -- + ----------------------------- + + procedure Get_Decoded_Name_String (Id : Name_Id) is + C : Character; + P : Natural; + + begin + Get_Name_String (Id); + + -- Quick loop to see if there is anything special to do + + P := 1; + loop + if P = Name_Len then + return; + + else + C := Name_Buffer (P); + + exit when + C = 'U' or else + C = 'W' or else + C = 'Q' or else + C = 'O'; + + P := P + 1; + end if; + end loop; + + -- Here we have at least some encoding that we must decode + + -- Here we have to decode one or more Uhh or Whhhh sequences + + declare + New_Len : Natural; + Old : Positive; + New_Buf : String (1 .. Name_Buffer'Last); + + procedure Insert_Character (C : Character); + -- Insert a new character into output decoded name + + procedure Copy_One_Character; + -- Copy a character from Name_Buffer to New_Buf. Includes case + -- of copying a Uhh or Whhhh sequence and decoding it. + + function Hex (N : Natural) return Natural; + -- Scans past N digits using Old pointer and returns hex value + + procedure Copy_One_Character is + C : Character; + + begin + C := Name_Buffer (Old); + + if C = 'U' then + Old := Old + 1; + Insert_Character (Character'Val (Hex (2))); + + elsif C = 'W' then + Old := Old + 1; + Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len); + + else + Insert_Character (Name_Buffer (Old)); + Old := Old + 1; + end if; + end Copy_One_Character; + + function Hex (N : Natural) return Natural is + T : Natural := 0; + C : Character; + + begin + for J in 1 .. N loop + C := Name_Buffer (Old); + Old := Old + 1; + + pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f'); + + if C <= '9' then + T := 16 * T + Character'Pos (C) - Character'Pos ('0'); + else -- C in 'a' .. 'f' + T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10); + end if; + end loop; + + return T; + end Hex; + + procedure Insert_Character (C : Character) is + begin + New_Len := New_Len + 1; + New_Buf (New_Len) := C; + end Insert_Character; + + -- Actual decoding processing + + begin + New_Len := 0; + Old := 1; + + -- Loop through characters of name + + while Old <= Name_Len loop + + -- Case of character literal, put apostrophes around character + + if Name_Buffer (Old) = 'Q' then + Old := Old + 1; + Insert_Character ('''); + Copy_One_Character; + Insert_Character ('''); + + -- Case of operator name + + elsif Name_Buffer (Old) = 'O' then + Old := Old + 1; + + declare + -- This table maps the 2nd and 3rd characters of the name + -- into the required output. Two blanks means leave the + -- name alone + + Map : constant String := + "ab " & -- Oabs => "abs" + "ad+ " & -- Oadd => "+" + "an " & -- Oand => "and" + "co& " & -- Oconcat => "&" + "di/ " & -- Odivide => "/" + "eq= " & -- Oeq => "=" + "ex**" & -- Oexpon => "**" + "gt> " & -- Ogt => ">" + "ge>=" & -- Oge => ">=" + "le<=" & -- Ole => "<=" + "lt< " & -- Olt => "<" + "mo " & -- Omod => "mod" + "mu* " & -- Omutliply => "*" + "ne/=" & -- One => "/=" + "no " & -- Onot => "not" + "or " & -- Oor => "or" + "re " & -- Orem => "rem" + "su- " & -- Osubtract => "-" + "xo "; -- Oxor => "xor" + + J : Integer; + + begin + Insert_Character ('"'); + + -- Search the map. Note that this loop must terminate, if + -- not we have some kind of internal error, and a constraint + -- constraint error may be raised. + + J := Map'First; + loop + exit when Name_Buffer (Old) = Map (J) + and then Name_Buffer (Old + 1) = Map (J + 1); + J := J + 4; + end loop; + + -- Special operator name + + if Map (J + 2) /= ' ' then + Insert_Character (Map (J + 2)); + + if Map (J + 3) /= ' ' then + Insert_Character (Map (J + 3)); + end if; + + Insert_Character ('"'); + + -- Skip past original operator name in input + + while Old <= Name_Len + and then Name_Buffer (Old) in 'a' .. 'z' + loop + Old := Old + 1; + end loop; + + -- For other operator names, leave them in lower case, + -- surrounded by apostrophes + + else + -- Copy original operator name from input to output + + while Old <= Name_Len + and then Name_Buffer (Old) in 'a' .. 'z' + loop + Copy_One_Character; + end loop; + + Insert_Character ('"'); + end if; + end; + + -- Else copy one character and keep going + + else + Copy_One_Character; + end if; + end loop; + + -- Copy new buffer as result + + Name_Len := New_Len; + Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len); + end; + + end Get_Decoded_Name_String; + + ------------------------------------------- + -- Get_Decoded_Name_String_With_Brackets -- + ------------------------------------------- + + procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is + P : Natural; + + begin + -- Case of operator name, normal decoding is fine + + if Name_Buffer (1) = 'O' then + Get_Decoded_Name_String (Id); + + -- For character literals, normal decoding is fine + + elsif Name_Buffer (1) = 'Q' then + Get_Decoded_Name_String (Id); + + -- Only remaining issue is U/W sequences + + else + Get_Name_String (Id); + + P := 1; + while P < Name_Len loop + if Name_Buffer (P) = 'U' then + for J in reverse P + 3 .. P + Name_Len loop + Name_Buffer (J + 3) := Name_Buffer (J); + end loop; + + Name_Len := Name_Len + 3; + Name_Buffer (P + 3) := Name_Buffer (P + 2); + Name_Buffer (P + 2) := Name_Buffer (P + 1); + Name_Buffer (P) := '['; + Name_Buffer (P + 1) := '"'; + Name_Buffer (P + 4) := '"'; + Name_Buffer (P + 5) := ']'; + P := P + 6; + + elsif Name_Buffer (P) = 'W' then + Name_Buffer (P + 8 .. P + Name_Len + 5) := + Name_Buffer (P + 5 .. Name_Len); + Name_Buffer (P + 5) := Name_Buffer (P + 4); + Name_Buffer (P + 4) := Name_Buffer (P + 3); + Name_Buffer (P + 3) := Name_Buffer (P + 2); + Name_Buffer (P + 2) := Name_Buffer (P + 1); + Name_Buffer (P) := '['; + Name_Buffer (P + 1) := '"'; + Name_Buffer (P + 6) := '"'; + Name_Buffer (P + 7) := ']'; + Name_Len := Name_Len + 5; + P := P + 8; + + else + P := P + 1; + end if; + end loop; + end if; + end Get_Decoded_Name_String_With_Brackets; + + --------------------- + -- Get_Name_String -- + --------------------- + + procedure Get_Name_String (Id : Name_Id) is + S : Int; + + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + + S := Name_Entries.Table (Id).Name_Chars_Index; + Name_Len := Natural (Name_Entries.Table (Id).Name_Len); + + for J in 1 .. Name_Len loop + Name_Buffer (J) := Name_Chars.Table (S + Int (J)); + end loop; + end Get_Name_String; + + function Get_Name_String (Id : Name_Id) return String is + S : Int; + + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + S := Name_Entries.Table (Id).Name_Chars_Index; + + declare + R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len)); + + begin + for J in R'Range loop + R (J) := Name_Chars.Table (S + Int (J)); + end loop; + + return R; + end; + end Get_Name_String; + + -------------------------------- + -- Get_Name_String_And_Append -- + -------------------------------- + + procedure Get_Name_String_And_Append (Id : Name_Id) is + S : Int; + + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + + S := Name_Entries.Table (Id).Name_Chars_Index; + + for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J)); + end loop; + end Get_Name_String_And_Append; + + ------------------------- + -- Get_Name_Table_Byte -- + ------------------------- + + function Get_Name_Table_Byte (Id : Name_Id) return Byte is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + return Name_Entries.Table (Id).Byte_Info; + end Get_Name_Table_Byte; + + ------------------------- + -- Get_Name_Table_Info -- + ------------------------- + + function Get_Name_Table_Info (Id : Name_Id) return Int is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + return Name_Entries.Table (Id).Int_Info; + end Get_Name_Table_Info; + + ----------------------------------------- + -- Get_Unqualified_Decoded_Name_String -- + ----------------------------------------- + + procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is + begin + Get_Decoded_Name_String (Id); + Strip_Qualification_And_Package_Body_Suffix; + end Get_Unqualified_Decoded_Name_String; + + --------------------------------- + -- Get_Unqualified_Name_String -- + --------------------------------- + + procedure Get_Unqualified_Name_String (Id : Name_Id) is + begin + Get_Name_String (Id); + Strip_Qualification_And_Package_Body_Suffix; + end Get_Unqualified_Name_String; + + ---------- + -- Hash -- + ---------- + + function Hash return Hash_Index_Type is + subtype Int_1_12 is Int range 1 .. 12; + -- Used to avoid when others on case jump below + + Even_Name_Len : Integer; + -- Last even numbered position (used for >12 case) + + begin + + -- Special test for 12 (rather than counting on a when others for the + -- case statement below) avoids some Ada compilers converting the case + -- statement into successive jumps. + + -- The case of a name longer than 12 characters is handled by taking + -- the first 6 odd numbered characters and the last 6 even numbered + -- characters + + if Name_Len > 12 then + Even_Name_Len := (Name_Len) / 2 * 2; + + return (((((((((((( + Character'Pos (Name_Buffer (01))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + + Character'Pos (Name_Buffer (03))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + + Character'Pos (Name_Buffer (05))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + + Character'Pos (Name_Buffer (07))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + + Character'Pos (Name_Buffer (09))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + + Character'Pos (Name_Buffer (11))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; + end if; + + -- For the cases of 1-12 characters, all characters participate in the + -- hash. The positioning is randomized, with the bias that characters + -- later on participate fully (i.e. are added towards the right side). + + case Int_1_12 (Name_Len) is + + when 1 => + return + Character'Pos (Name_Buffer (1)); + + when 2 => + return (( + Character'Pos (Name_Buffer (1))) * 64 + + Character'Pos (Name_Buffer (2))) mod Hash_Num; + + when 3 => + return ((( + Character'Pos (Name_Buffer (1))) * 16 + + Character'Pos (Name_Buffer (3))) * 16 + + Character'Pos (Name_Buffer (2))) mod Hash_Num; + + when 4 => + return (((( + Character'Pos (Name_Buffer (1))) * 8 + + Character'Pos (Name_Buffer (2))) * 8 + + Character'Pos (Name_Buffer (3))) * 8 + + Character'Pos (Name_Buffer (4))) mod Hash_Num; + + when 5 => + return ((((( + Character'Pos (Name_Buffer (4))) * 8 + + Character'Pos (Name_Buffer (1))) * 4 + + Character'Pos (Name_Buffer (3))) * 4 + + Character'Pos (Name_Buffer (5))) * 8 + + Character'Pos (Name_Buffer (2))) mod Hash_Num; + + when 6 => + return (((((( + Character'Pos (Name_Buffer (5))) * 4 + + Character'Pos (Name_Buffer (1))) * 4 + + Character'Pos (Name_Buffer (4))) * 4 + + Character'Pos (Name_Buffer (2))) * 4 + + Character'Pos (Name_Buffer (6))) * 4 + + Character'Pos (Name_Buffer (3))) mod Hash_Num; + + when 7 => + return ((((((( + Character'Pos (Name_Buffer (4))) * 4 + + Character'Pos (Name_Buffer (3))) * 4 + + Character'Pos (Name_Buffer (1))) * 4 + + Character'Pos (Name_Buffer (2))) * 2 + + Character'Pos (Name_Buffer (5))) * 2 + + Character'Pos (Name_Buffer (7))) * 2 + + Character'Pos (Name_Buffer (6))) mod Hash_Num; + + when 8 => + return (((((((( + Character'Pos (Name_Buffer (2))) * 4 + + Character'Pos (Name_Buffer (1))) * 4 + + Character'Pos (Name_Buffer (3))) * 2 + + Character'Pos (Name_Buffer (5))) * 2 + + Character'Pos (Name_Buffer (7))) * 2 + + Character'Pos (Name_Buffer (6))) * 2 + + Character'Pos (Name_Buffer (4))) * 2 + + Character'Pos (Name_Buffer (8))) mod Hash_Num; + + when 9 => + return ((((((((( + Character'Pos (Name_Buffer (2))) * 4 + + Character'Pos (Name_Buffer (1))) * 4 + + Character'Pos (Name_Buffer (3))) * 4 + + Character'Pos (Name_Buffer (4))) * 2 + + Character'Pos (Name_Buffer (8))) * 2 + + Character'Pos (Name_Buffer (7))) * 2 + + Character'Pos (Name_Buffer (5))) * 2 + + Character'Pos (Name_Buffer (6))) * 2 + + Character'Pos (Name_Buffer (9))) mod Hash_Num; + + when 10 => + return (((((((((( + Character'Pos (Name_Buffer (01))) * 2 + + Character'Pos (Name_Buffer (02))) * 2 + + Character'Pos (Name_Buffer (08))) * 2 + + Character'Pos (Name_Buffer (03))) * 2 + + Character'Pos (Name_Buffer (04))) * 2 + + Character'Pos (Name_Buffer (09))) * 2 + + Character'Pos (Name_Buffer (06))) * 2 + + Character'Pos (Name_Buffer (05))) * 2 + + Character'Pos (Name_Buffer (07))) * 2 + + Character'Pos (Name_Buffer (10))) mod Hash_Num; + + when 11 => + return ((((((((((( + Character'Pos (Name_Buffer (05))) * 2 + + Character'Pos (Name_Buffer (01))) * 2 + + Character'Pos (Name_Buffer (06))) * 2 + + Character'Pos (Name_Buffer (09))) * 2 + + Character'Pos (Name_Buffer (07))) * 2 + + Character'Pos (Name_Buffer (03))) * 2 + + Character'Pos (Name_Buffer (08))) * 2 + + Character'Pos (Name_Buffer (02))) * 2 + + Character'Pos (Name_Buffer (10))) * 2 + + Character'Pos (Name_Buffer (04))) * 2 + + Character'Pos (Name_Buffer (11))) mod Hash_Num; + + when 12 => + return (((((((((((( + Character'Pos (Name_Buffer (03))) * 2 + + Character'Pos (Name_Buffer (02))) * 2 + + Character'Pos (Name_Buffer (05))) * 2 + + Character'Pos (Name_Buffer (01))) * 2 + + Character'Pos (Name_Buffer (06))) * 2 + + Character'Pos (Name_Buffer (04))) * 2 + + Character'Pos (Name_Buffer (08))) * 2 + + Character'Pos (Name_Buffer (11))) * 2 + + Character'Pos (Name_Buffer (07))) * 2 + + Character'Pos (Name_Buffer (09))) * 2 + + Character'Pos (Name_Buffer (10))) * 2 + + Character'Pos (Name_Buffer (12))) mod Hash_Num; + + end case; + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + + begin + Name_Chars.Init; + Name_Entries.Init; + + -- Initialize entries for one character names + + for C in Character loop + Name_Entries.Increment_Last; + Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := + Name_Chars.Last; + Name_Entries.Table (Name_Entries.Last).Name_Len := 1; + Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; + Name_Entries.Table (Name_Entries.Last).Int_Info := 0; + Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; + Name_Chars.Increment_Last; + Name_Chars.Table (Name_Chars.Last) := C; + Name_Chars.Increment_Last; + Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; + end loop; + + -- Clear hash table + + for J in Hash_Index_Type loop + Hash_Table (J) := No_Name; + end loop; + end Initialize; + + ---------------------- + -- Is_Internal_Name -- + ---------------------- + + function Is_Internal_Name (Id : Name_Id) return Boolean is + begin + Get_Name_String (Id); + return Is_Internal_Name; + end Is_Internal_Name; + + function Is_Internal_Name return Boolean is + begin + if Name_Buffer (1) = '_' + or else Name_Buffer (Name_Len) = '_' + then + return True; + + else + -- Test backwards, because we only want to test the last entity + -- name if the name we have is qualified with other entities. + + for J in reverse 1 .. Name_Len loop + if Is_OK_Internal_Letter (Name_Buffer (J)) then + return True; + + -- Quit if we come to terminating double underscore (note that + -- if the current character is an underscore, we know that + -- there is a previous character present, since we already + -- filtered out the case of Name_Buffer (1) = '_' above. + + elsif Name_Buffer (J) = '_' + and then Name_Buffer (J - 1) = '_' + and then Name_Buffer (J - 2) /= '_' + then + return False; + end if; + end loop; + end if; + + return False; + end Is_Internal_Name; + + --------------------------- + -- Is_OK_Internal_Letter -- + --------------------------- + + function Is_OK_Internal_Letter (C : Character) return Boolean is + begin + return C in 'A' .. 'Z' + and then C /= 'O' + and then C /= 'Q' + and then C /= 'U' + and then C /= 'W' + and then C /= 'X'; + end Is_OK_Internal_Letter; + + -------------------- + -- Length_Of_Name -- + -------------------- + + function Length_Of_Name (Id : Name_Id) return Nat is + begin + return Int (Name_Entries.Table (Id).Name_Len); + end Length_Of_Name; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve); + Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve); + Name_Chars.Locked := True; + Name_Entries.Locked := True; + Name_Chars.Release; + Name_Entries.Release; + end Lock; + + ------------------------ + -- Name_Chars_Address -- + ------------------------ + + function Name_Chars_Address return System.Address is + begin + return Name_Chars.Table (0)'Address; + end Name_Chars_Address; + + ---------------- + -- Name_Enter -- + ---------------- + + function Name_Enter return Name_Id is + begin + + Name_Entries.Increment_Last; + Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := + Name_Chars.Last; + Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); + Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; + Name_Entries.Table (Name_Entries.Last).Int_Info := 0; + Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; + + -- Set corresponding string entry in the Name_Chars table + + for J in 1 .. Name_Len loop + Name_Chars.Increment_Last; + Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J); + end loop; + + Name_Chars.Increment_Last; + Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; + + return Name_Entries.Last; + end Name_Enter; + + -------------------------- + -- Name_Entries_Address -- + -------------------------- + + function Name_Entries_Address return System.Address is + begin + return Name_Entries.Table (First_Name_Id)'Address; + end Name_Entries_Address; + + ------------------------ + -- Name_Entries_Count -- + ------------------------ + + function Name_Entries_Count return Nat is + begin + return Int (Name_Entries.Last - Name_Entries.First + 1); + end Name_Entries_Count; + + --------------- + -- Name_Find -- + --------------- + + function Name_Find return Name_Id is + New_Id : Name_Id; + -- Id of entry in hash search, and value to be returned + + S : Int; + -- Pointer into string table + + Hash_Index : Hash_Index_Type; + -- Computed hash index + + begin + -- Quick handling for one character names + + if Name_Len = 1 then + return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1))); + + -- Otherwise search hash table for existing matching entry + + else + Hash_Index := Namet.Hash; + New_Id := Hash_Table (Hash_Index); + + if New_Id = No_Name then + Hash_Table (Hash_Index) := Name_Entries.Last + 1; + + else + Search : loop + if Name_Len /= + Integer (Name_Entries.Table (New_Id).Name_Len) + then + goto No_Match; + end if; + + S := Name_Entries.Table (New_Id).Name_Chars_Index; + + for I in 1 .. Name_Len loop + if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) then + goto No_Match; + end if; + end loop; + + return New_Id; + + -- Current entry in hash chain does not match + + <<No_Match>> + if Name_Entries.Table (New_Id).Hash_Link /= No_Name then + New_Id := Name_Entries.Table (New_Id).Hash_Link; + else + Name_Entries.Table (New_Id).Hash_Link := + Name_Entries.Last + 1; + exit Search; + end if; + + end loop Search; + end if; + + -- We fall through here only if a matching entry was not found in the + -- hash table. We now create a new entry in the names table. The hash + -- link pointing to the new entry (Name_Entries.Last+1) has been set. + + Name_Entries.Increment_Last; + Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := + Name_Chars.Last; + Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); + Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; + Name_Entries.Table (Name_Entries.Last).Int_Info := 0; + Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; + + -- Set corresponding string entry in the Name_Chars table + + for I in 1 .. Name_Len loop + Name_Chars.Increment_Last; + Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I); + end loop; + + Name_Chars.Increment_Last; + Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; + + return Name_Entries.Last; + end if; + end Name_Find; + + ---------------------- + -- Reset_Name_Table -- + ---------------------- + + procedure Reset_Name_Table is + begin + for J in First_Name_Id .. Name_Entries.Last loop + Name_Entries.Table (J).Int_Info := 0; + Name_Entries.Table (J).Byte_Info := 0; + end loop; + end Reset_Name_Table; + + -------------------------------- + -- Set_Character_Literal_Name -- + -------------------------------- + + procedure Set_Character_Literal_Name (C : Char_Code) is + begin + Name_Buffer (1) := 'Q'; + Name_Len := 1; + Store_Encoded_Character (C); + end Set_Character_Literal_Name; + + ------------------------- + -- Set_Name_Table_Byte -- + ------------------------- + + procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + Name_Entries.Table (Id).Byte_Info := Val; + end Set_Name_Table_Byte; + + ------------------------- + -- Set_Name_Table_Info -- + ------------------------- + + procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + Name_Entries.Table (Id).Int_Info := Val; + end Set_Name_Table_Info; + + ----------------------------- + -- Store_Encoded_Character -- + ----------------------------- + + procedure Store_Encoded_Character (C : Char_Code) is + + procedure Set_Hex_Chars (N : Natural); + -- Stores given value, which is in the range 0 .. 255, as two hex + -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len + + procedure Set_Hex_Chars (N : Natural) is + Hexd : constant String := "0123456789abcdef"; + + begin + Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1); + Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1); + Name_Len := Name_Len + 2; + end Set_Hex_Chars; + + begin + Name_Len := Name_Len + 1; + + if In_Character_Range (C) then + declare + CC : constant Character := Get_Character (C); + + begin + if CC in 'a' .. 'z' or else CC in '0' .. '9' then + Name_Buffer (Name_Len) := CC; + + else + Name_Buffer (Name_Len) := 'U'; + Set_Hex_Chars (Natural (C)); + end if; + end; + + else + Name_Buffer (Name_Len) := 'W'; + Set_Hex_Chars (Natural (C) / 256); + Set_Hex_Chars (Natural (C) mod 256); + end if; + + end Store_Encoded_Character; + + ------------------------------------------------- + -- Strip_Qualification_And_Package_Body_Suffix -- + ------------------------------------------------- + + procedure Strip_Qualification_And_Package_Body_Suffix is + begin + -- Strip package body qualification string off end + + for J in reverse 2 .. Name_Len loop + if Name_Buffer (J) = 'X' then + Name_Len := J - 1; + exit; + end if; + + exit when Name_Buffer (J) /= 'b' + and then Name_Buffer (J) /= 'n' + and then Name_Buffer (J) /= 'p'; + end loop; + + -- Find rightmost __ separator if one exists and strip it + -- and everything that precedes it from the name. + + for J in reverse 2 .. Name_Len - 2 loop + if Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then + Name_Buffer (1 .. Name_Len - J - 1) := + Name_Buffer (J + 2 .. Name_Len); + Name_Len := Name_Len - J - 1; + exit; + end if; + end loop; + end Strip_Qualification_And_Package_Body_Suffix; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Name_Chars.Tree_Read; + Name_Entries.Tree_Read; + + Tree_Read_Data + (Hash_Table'Address, + Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Name_Chars.Tree_Write; + Name_Entries.Tree_Write; + + Tree_Write_Data + (Hash_Table'Address, + Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); + end Tree_Write; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve); + Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve); + Name_Chars.Locked := False; + Name_Entries.Locked := False; + Name_Chars.Release; + Name_Entries.Release; + end Unlock; + + -------- + -- wn -- + -------- + + procedure wn (Id : Name_Id) is + begin + Write_Name (Id); + Write_Eol; + end wn; + + ---------------- + -- Write_Name -- + ---------------- + + procedure Write_Name (Id : Name_Id) is + begin + if Id >= First_Name_Id then + Get_Name_String (Id); + Write_Str (Name_Buffer (1 .. Name_Len)); + end if; + end Write_Name; + + ------------------------ + -- Write_Name_Decoded -- + ------------------------ + + procedure Write_Name_Decoded (Id : Name_Id) is + begin + if Id >= First_Name_Id then + Get_Decoded_Name_String (Id); + Write_Str (Name_Buffer (1 .. Name_Len)); + end if; + end Write_Name_Decoded; + +end Namet; diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads new file mode 100644 index 00000000000..2517c5579a3 --- /dev/null +++ b/gcc/ada/namet.ads @@ -0,0 +1,400 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N A M E T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.78 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Table; +with System; use System; +with Types; use Types; + +package Namet is + +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file namet.h +-- which is created manually from namet.ads and namet.adb. + +-- This package contains routines for handling the names table. The table +-- is used to store character strings for identifiers and operator symbols, +-- as well as other string values such as unit names and file names. + +-- The forms of the entries are as follows: + +-- Identifiers Stored with upper case letters folded to lower case. +-- Upper half (16#80# bit set) and wide characters are +-- stored in an encoded form (Uhh for upper half and +-- Whhhh for wide characters, as provided by the routine +-- Store_Encoded_Character, where hh are hex digits for +-- the character code using lower case a-f). Other +-- internally generated names use upper case letters +-- (other than O,Q,U,W) to ensure that they do not clash +-- with identifier names in the source program. + +-- Operator symbols Stored with an initial letter O, and the remainder +-- of the name is the lower case characters XXX where +-- the name is Name_Op_XXX, see Snames spec for a full +-- list of the operator names. + +-- Character literals Character literals have names that are used only for +-- debugging and error message purposes. The form is a +-- upper case Q followed by a single letter, or by a Uxx +-- or Wxxxx encoding as described for identifiers. The +-- Set_Character_Literal_Name procedure should be used +-- to construct these encodings. + +-- Unit names Stored with upper case letters folded to lower case, +-- using Uhh/Whhhh encoding as described for identifiers, +-- and a %s or %b suffix for specs/bodies. See package +-- Uname for further details. + +-- File names Are stored in the form provided by Osint. Typically +-- they may include wide character escape sequences and +-- upper case characters (in non-encoded form). Casing +-- is also derived from the external environment. Note +-- that file names provided by Osint must generally be +-- consistent with the names from Fname.Get_File_Name. + +-- Other strings The names table is also used as a convenient storage +-- location for other variable length strings such as +-- error messages etc. There are no restrictions on what +-- characters may appear for such entries. + +-- Note: the encodings Uhh (upper half characters), Whhhh (wide characters), +-- and Qx (character literal names) are described in the spec, since they +-- are visible throughout the system (e.g. in debugging output). However, +-- no code should depend on these particular encodings, so it should be +-- possible to change the encodings by making changes only to the Namet +-- specification (to change these comments) and the body (which actually +-- implements the encodings). + +-- The names are hashed so that a given name appears only once in the table, +-- except that names entered with Name_Enter as opposed to Name_Find are +-- omitted from the hash table. + +-- The first 26 entries in the names table (with Name_Id values in the range +-- First_Name_Id .. First_Name_Id + 25) represent names which are the one +-- character lower case letters in the range a-z, and these names are created +-- and initialized by the Initialize procedure. + +-- Two values, one of type Int and one of type Byte, are stored with each +-- names table entry and subprograms are provided for setting and retrieving +-- these associated values. The usage of these values is up to the client. +-- In the compiler, the Int field is used to point to a chain of potentially +-- visible entities (see Sem.Ch8 for details), and the Byte field is used +-- to hold the Token_Type value for reserved words (see Sem for details). +-- In the binder, the Byte field is unused, and the Int field is used in +-- various ways depending on the name involved (see binder documentation). + + Name_Buffer : String (1 .. 16*1024); + -- This buffer is used to set the name to be stored in the table for the + -- Name_Find call, and to retrieve the name for the Get_Name_String call. + -- The plus 1 in the length allows for cases of adding ASCII.NUL. The + -- 16K here is intended to be an infinite value that ensures that we + -- never overflow the buffer (names this long are too absurd to worry!) + + Name_Len : Natural; + -- Length of name stored in Name_Buffer. Used as an input parameter for + -- Name_Find, and as an output value by Get_Name_String, or Write_Name. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Finalize; + -- Called at the end of a use of the Namet package (before a subsequent + -- call to Initialize). Currently this routine is only used to generate + -- debugging output. + + procedure Get_Name_String (Id : Name_Id); + -- Get_Name_String is used to retrieve the string associated with an entry + -- in the names table. The resulting string is stored in Name_Buffer + -- and Name_Len is set. It is an error to call Get_Name_String with one + -- of the special name Id values (No_Name or Error_Name). + + function Get_Name_String (Id : Name_Id) return String; + -- This functional form returns the result as a string without affecting + -- the contents of either Name_Buffer or Name_Len. + + procedure Get_Unqualified_Name_String (Id : Name_Id); + -- Similar to the above except that qualification (as defined in unit + -- Exp_Dbug) is removed (including both preceding __ delimited names, + -- and also the suffix used to indicate package body entities). Note + -- that names are not qualified until just before the call to gigi, so + -- this routine is only needed by processing that occurs after gigi has + -- been called. This includes all ASIS processing, since ASIS works on + -- the tree written after gigi has been called. + + procedure Get_Name_String_And_Append (Id : Name_Id); + -- Like Get_Name_String but the resulting characters are appended to + -- the current contents of the entry stored in Name_Buffer, and Name_Len + -- is incremented to include the added characters. + + procedure Get_Decoded_Name_String (Id : Name_Id); + -- Same calling sequence an interface as Get_Name_String, except that the + -- result is decoded, so that upper half characters and wide characters + -- appear as originally found in the source program text, operators have + -- their source forms (special characters and enclosed in quotes), and + -- character literals appear surrounded by apostrophes. + + procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id); + -- Similar to the above except that qualification (as defined in unit + -- Exp_Dbug) is removed (including both preceding __ delimited names, + -- and also the suffix used to indicate package body entities). Note + -- that names are not qualified until just before the call to gigi, so + -- this routine is only needed by processing that occurs after gigi has + -- been called. This includes all ASIS processing, since ASIS works on + -- the tree written after gigi has been called. + + procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id); + -- This routine is similar to Decoded_Name, except that the brackets + -- notation (Uhh replaced by ["hh"], Whhhh replaced by ["hhhh"]) is + -- used for all non-lower half characters, regardless of the setting + -- of Opt.Wide_Character_Encoding_Method, and also in that characters + -- in the range 16#80# .. 16#FF# are converted to brackets notation + -- in all cases. This routine can be used when there is a requirement + -- for a canonical representation not affected by the character set + -- options (e.g. in the binder generation of symbols). + + function Get_Name_Table_Byte (Id : Name_Id) return Byte; + pragma Inline (Get_Name_Table_Byte); + -- Fetches the Byte value associated with the given name + + function Get_Name_Table_Info (Id : Name_Id) return Int; + pragma Inline (Get_Name_Table_Info); + -- Fetches the Int value associated with the given name + + procedure Initialize; + -- Initializes the names table, including initializing the first 26 + -- entries in the table (for the 1-character lower case names a-z) + -- Note that Initialize must not be called if Tree_Read is used. + + procedure Lock; + -- Lock name table before calling back end. Space for up to 10 extra + -- names and 1000 extra characters is reserved before the table is locked. + + procedure Unlock; + -- Unlocks the name table to allow use of the 10 extra names and 1000 + -- extra characters reserved by the Lock call. See gnat1drv for details + -- of the need for this. + + function Length_Of_Name (Id : Name_Id) return Nat; + pragma Inline (Length_Of_Name); + -- Returns length of given name in characters. This is the length of the + -- encoded name, as stored in the names table, the result is equivalent to + -- calling Get_Name_String and reading Name_Len, except that a call to + -- Length_Of_Name does not affect the contents of Name_Len and Name_Buffer. + + function Name_Chars_Address return System.Address; + -- Return starting address of name characters table (used in Back_End + -- call to Gigi). + + function Name_Find return Name_Id; + -- Name_Find is called with a string stored in Name_Buffer whose length + -- is in Name_Len (i.e. the characters of the name are in subscript + -- positions 1 to Name_Len in Name_Buffer). It searches the names + -- table to see if the string has already been stored. If so the Id of + -- the existing entry is returned. Otherwise a new entry is created with + -- its Name_Table_Info field set to zero. The contents of Name_Buffer + -- and Name_Len are not modified by this call. + + function Name_Enter return Name_Id; + -- Name_Enter has the same calling interface as Name_Find. The difference + -- is that it does not search the table for an existing match, and also + -- subsequent Name_Find calls using the same name will not locate the + -- entry created by this call. Thus multiple calls to Name_Enter with the + -- same name will create multiple entries in the name table with different + -- Name_Id values. This is useful in the case of created names, which are + -- never expected to be looked up. Note: Name_Enter should never be used + -- for one character names, since these are efficiently located without + -- hashing by Name_Find in any case. + + function Name_Entries_Address return System.Address; + -- Return starting address of Names table. Used in Back_End call to Gigi. + + function Name_Entries_Count return Nat; + -- Return current number of entries in the names table + + function Is_OK_Internal_Letter (C : Character) return Boolean; + pragma Inline (Is_OK_Internal_Letter); + -- Returns true if C is a suitable character for using as a prefix or a + -- suffix of an internally generated name, i.e. it is an upper case letter + -- other than one of the ones used for encoding source names (currently + -- the set of reserved letters is O, Q, U, W) and also returns False for + -- the letter X, which is reserved for debug output (see Exp_Dbug). + + function Is_Internal_Name (Id : Name_Id) return Boolean; + -- Returns True if the name is an internal name (i.e. contains a character + -- for which Is_OK_Internal_Letter is true, or if the name starts or ends + -- with an underscore. This call destroys the value of Name_Len and + -- Name_Buffer (it loads these as for Get_Name_String). + -- + -- Note: if the name is qualified (has a double underscore), then + -- only the final entity name is considered, not the qualifying + -- names. Consider for example that the name: + -- + -- pkg__B_1__xyz + -- + -- is not an internal name, because the B comes from the internal + -- name of a qualifying block, but the xyz means that this was + -- indeed a declared identifier called "xyz" within this block + -- and there is nothing internal about that name. + + function Is_Internal_Name return Boolean; + -- Like the form with an Id argument, except that the name to be tested is + -- passed in Name_Buffer and Name_Len (which are not affected by the call). + -- Name_Buffer (it loads these as for Get_Name_String). + + procedure Reset_Name_Table; + -- This procedure is used when there are multiple source files to reset + -- the name table info entries associated with current entries in the + -- names table. There is no harm in keeping the names entries themselves + -- from one compilation to another, but we can't keep the entity info, + -- since this refers to tree nodes, which are destroyed between each + -- main source file. + + procedure Add_Char_To_Name_Buffer (C : Character); + pragma Inline (Add_Char_To_Name_Buffer); + -- Add given character to the end of the string currently stored in the + -- Name_Buffer, incrementing Name_Len. + + procedure Add_Nat_To_Name_Buffer (V : Nat); + -- Add decimal representation of given value to the end of the string + -- currently stored in Name_Buffer, incrementing Name_Len as required. + + procedure Add_Str_To_Name_Buffer (S : String); + -- Add characters of string S to the end of the string currently stored + -- in the Name_Buffer, incrementing Name_Len by the length of the string. + + procedure Set_Character_Literal_Name (C : Char_Code); + -- This procedure sets the proper encoded name for the character literal + -- for the given character code. On return Name_Buffer and Name_Len are + -- set to reflect the stored name. + + procedure Set_Name_Table_Info (Id : Name_Id; Val : Int); + pragma Inline (Set_Name_Table_Info); + -- Sets the Int value associated with the given name + + procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); + pragma Inline (Set_Name_Table_Byte); + -- Sets the Byte value associated with the given name + + procedure Store_Encoded_Character (C : Char_Code); + -- Stores given character code at the end of Name_Buffer, updating the + -- value in Name_Len appropriately. Lower case letters and digits are + -- stored unchanged. Other 8-bit characters are stored using the Uhh + -- encoding (hh = hex code), and other 16-bit wide-character values + -- are stored using the Whhhh (hhhh = hex code) encoding. Note that + -- this procedure does not fold upper case letters (they are stored + -- using the Uhh encoding). If folding is required, it must be done + -- by the caller prior to the call. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using Tree_Read. + -- Note that Initialize should not be called if Tree_Read is used. + -- Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write + + procedure Write_Name (Id : Name_Id); + -- Write_Name writes the characters of the specified name using the + -- standard output procedures in package Output. No end of line is + -- written, just the characters of the name. On return Name_Buffer and + -- Name_Len are set as for a call to Get_Name_String. The name is written + -- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in + -- the name table). If Id is Error_Name, or No_Name, no text is output. + + procedure wn (Id : Name_Id); + -- Like Write_Name, but includes new line at end. Intended for use + -- from the debugger only. + + procedure Write_Name_Decoded (Id : Name_Id); + -- Like Write_Name, except that the name written is the decoded name, as + -- described for Get_Name_Decoded, and the resulting value stored in + -- Name_Len and Name_Buffer is the decoded name. + + --------------------------- + -- Table Data Structures -- + --------------------------- + + -- The following declarations define the data structures used to store + -- names. The definitions are in the private part of the package spec, + -- rather than the body, since they are referenced directly by gigi. + +private + + -- This table stores the actual string names. Although logically there + -- is no need for a terminating character (since the length is stored + -- in the name entry table), we still store a NUL character at the end + -- of every name (for convenience in interfacing to the C world). + + package Name_Chars is new Table.Table ( + Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Name_Chars_Initial, + Table_Increment => Alloc.Name_Chars_Increment, + Table_Name => "Name_Chars"); + + type Name_Entry is record + Name_Chars_Index : Int; + -- Starting location of characters in the Name_Chars table minus + -- one (i.e. pointer to character just before first character). The + -- reason for the bias of one is that indexes in Name_Buffer are + -- one's origin, so this avoids unnecessary adds and subtracts of 1. + + Name_Len : Short; + -- Length of this name in characters + + Byte_Info : Byte; + -- Byte value associated with this name + + Hash_Link : Name_Id; + -- Link to next entry in names table for same hash code + + Int_Info : Int; + -- Int Value associated with this name + end record; + + -- This is the table that is referenced by Name_Id entries. + -- It contains one entry for each unique name in the table. + + package Name_Entries is new Table.Table ( + Table_Component_Type => Name_Entry, + Table_Index_Type => Name_Id, + Table_Low_Bound => First_Name_Id, + Table_Initial => Alloc.Names_Initial, + Table_Increment => Alloc.Names_Increment, + Table_Name => "Name_Entries"); + +end Namet; diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h new file mode 100644 index 00000000000..feb69b713f2 --- /dev/null +++ b/gcc/ada/namet.h @@ -0,0 +1,141 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * N A M E T * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This is the C file that corresponds to the Ada package specification + Namet. It was created manually from files namet.ads and namet.adb. */ + +/* Structure defining a names table entry. */ + +struct Name_Entry +{ + Int Name_Chars_Index; /* Starting location of char in Name_Chars table. */ + Short Name_Len; /* Length of this name in characters. */ + Byte Byte_Info; /* Byte value associated with this name */ + Byte Spare; /* Unused */ + Name_Id Hash_Link; /* Link to next entry in names table for same hash + code. Not accessed by C routines. */ + Int Int_Info; /* Int value associated with this name */ +}; + +/* Pointer to names table vector. */ +#define Names_Ptr namet__name_entries__table +extern struct Name_Entry *Names_Ptr; + +/* Pointer to name characters table. */ +#define Name_Chars_Ptr namet__name_chars__table +extern char *Name_Chars_Ptr; + +#define Name_Buffer namet__name_buffer +extern char Name_Buffer[]; + +extern Int namet__name_len; +#define Name_Len namet__name_len + +/* Get_Name_String returns a null terminated C string for the specified name. + We could use the official Ada routine for this purpose, but since the + strings we want are sitting in the name strings table in exactly the form + we need them (null terminated), we just point to the name directly. */ + +static char *Get_Name_String PARAMS ((Name_Id)); + +INLINE char * +Get_Name_String (Id) + Name_Id Id; +{ + return Name_Chars_Ptr + Names_Ptr [Id - First_Name_Id].Name_Chars_Index + 1; +} + +/* Get_Decoded_Name_String returns a null terminated C string in the same + manner as Get_Name_String, except that it is decoded (i.e. upper half or + wide characters are put back in their external form, and character literals + are also returned in their external form (with surrounding apostrophes) */ + +extern void namet__get_decoded_name_string PARAMS ((Name_Id)); + +static char *Get_Decoded_Name_String PARAMS ((Name_Id)); + +INLINE char * +Get_Decoded_Name_String (Id) + Name_Id Id; +{ + namet__get_decoded_name_string (Id); + Name_Buffer [Name_Len] = 0; + return Name_Buffer; +} + +/* Like Get_Decoded_Name_String, but the result has all qualification and + package body entity suffixes stripped, and also all letters are upper + cased. This is used fo rbuilding the enumeration literal table. */ + +extern void casing__set_all_upper_case PARAMS ((void)); +extern void namet__get_unqualified_decoded_name_string PARAMS ((Name_Id)); + +static char *Get_Upper_Decoded_Name_String PARAMS ((Name_Id)); + +INLINE char * +Get_Upper_Decoded_Name_String (Id) + Name_Id Id; +{ + namet__get_unqualified_decoded_name_string (Id); + if (Name_Buffer [0] != '\'') + casing__set_all_upper_case (); + Name_Buffer [Name_Len] = 0; + return Name_Buffer; +} + +/* The following routines and variables are not part of Namet, but we + include the header here since it seems the best place for it. */ + +#define Get_Encoded_Type_Name exp_dbug__get_encoded_type_name +extern Boolean Get_Encoded_Type_Name PARAMS ((Entity_Id)); +#define Get_Variant_Encoding exp_dbug__get_variant_encoding +extern void Get_Variant_Encoding PARAMS ((Entity_Id)); + +#define Spec_Context_List exp_dbug__spec_context_list +#define Body_Context_List exp_dbug__body_context_list +extern char *Spec_Context_List, *Body_Context_List; +#define Spec_Filename exp_dbug__spec_filename +#define Body_Filename exp_dbug__body_filename +extern char *Spec_Filename, *Body_Filename; + +#define Is_Non_Ada_Error exp_ch11__is_non_ada_error +extern Boolean Is_Non_Ada_Error PARAMS ((Entity_Id)); + +/* Here are some functions in sinput.adb we call from a-trans.c. */ +typedef Nat Source_File_Index; +typedef Int Logical_Line_Number; + +#define Debug_Source_Name sinput__debug_source_name +#define Reference_Name sinput__reference_name +#define Get_Source_File_Index sinput__get_source_file_index +#define Get_Logical_Line_Number sinput__get_logical_line_number + +extern File_Name_Type Debug_Source_Name PARAMS ((Source_File_Index)); +extern File_Name_Type Reference_Name PARAMS ((Source_File_Index)); +extern Source_File_Index Get_Source_File_Index PARAMS ((Source_Ptr)); +extern Logical_Line_Number Get_Logical_Line_Number PARAMS ((Source_Ptr)); diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb new file mode 100644 index 00000000000..5e8fe695b9d --- /dev/null +++ b/gcc/ada/nlists.adb @@ -0,0 +1,1379 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N L I S T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.35 $ -- +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- WARNING: There is a C version of this package. Any changes to this source +-- file must be properly reflected in the corresponding C header a-nlists.h + +with Alloc; +with Atree; use Atree; +with Debug; use Debug; +with Output; use Output; +with Sinfo; use Sinfo; +with Table; + +package body Nlists is + + use Atree_Private_Part; + -- Get access to Nodes table + + ---------------------------------- + -- Implementation of Node Lists -- + ---------------------------------- + + -- A node list is represented by a list header which contains + -- three fields: + + type List_Header is record + First : Node_Id; + -- Pointer to first node in list. Empty if list is empty + + Last : Node_Id; + -- Pointer to last node in list. Empty if list is empty + + Parent : Node_Id; + -- Pointer to parent of list. Empty if list has no parent + end record; + + -- The node lists are stored in a table indexed by List_Id values + + package Lists is new Table.Table ( + Table_Component_Type => List_Header, + Table_Index_Type => List_Id, + Table_Low_Bound => First_List_Id, + Table_Initial => Alloc.Lists_Initial, + Table_Increment => Alloc.Lists_Increment, + Table_Name => "Lists"); + + -- The nodes in the list all have the In_List flag set, and their Link + -- fields (which otherwise point to the parent) contain the List_Id of + -- the list header giving immediate access to the list containing the + -- node, and its parent and first and last elements. + + -- Two auxiliary tables, indexed by Node_Id values and built in parallel + -- with the main nodes table and always having the same size contain the + -- list link values that allow locating the previous and next node in a + -- list. The entries in these tables are valid only if the In_List flag + -- is set in the corresponding node. Next_Node is Empty at the end of a + -- list and Prev_Node is Empty at the start of a list. + + package Next_Node is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Node_Id, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Orig_Nodes_Initial, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "Next_Node"); + + package Prev_Node is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Node_Id, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Orig_Nodes_Initial, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "Prev_Node"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Prepend_Debug (Node : Node_Id; To : List_Id); + pragma Inline (Prepend_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Remove_Next_Debug (Node : Node_Id); + pragma Inline (Remove_Next_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Set_First (List : List_Id; To : Node_Id); + pragma Inline (Set_First); + -- Sets First field of list header List to reference To + + procedure Set_Last (List : List_Id; To : Node_Id); + pragma Inline (Set_Last); + -- Sets Last field of list header List to reference To + + procedure Set_List_Link (Node : Node_Id; To : List_Id); + pragma Inline (Set_List_Link); + -- Sets list link of Node to list header To + + procedure Set_Next (Node : Node_Id; To : Node_Id); + pragma Inline (Set_Next); + -- Sets the Next_Node pointer for Node to reference To + + procedure Set_Prev (Node : Node_Id; To : Node_Id); + pragma Inline (Set_Prev); + -- Sets the Prev_Node pointer for Node to reference To + + -------------------------- + -- Allocate_List_Tables -- + -------------------------- + + procedure Allocate_List_Tables (N : Node_Id) is + begin + Next_Node.Set_Last (N); + Prev_Node.Set_Last (N); + end Allocate_List_Tables; + + ------------ + -- Append -- + ------------ + + procedure Append (Node : Node_Id; To : List_Id) is + L : constant Node_Id := Last (To); + + procedure Append_Debug; + pragma Inline (Append_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Append_Debug is + begin + if Debug_Flag_N then + Write_Str ("Append node "); + Write_Int (Int (Node)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Append_Debug; + + -- Start of processing for Append + + begin + pragma Assert (not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Append_Debug); + + if No (L) then + Set_First (To, Node); + else + Set_Next (L, Node); + end if; + + Set_Last (To, Node); + + Nodes.Table (Node).In_List := True; + + Set_Next (Node, Empty); + Set_Prev (Node, L); + Set_List_Link (Node, To); + end Append; + + ----------------- + -- Append_List -- + ----------------- + + procedure Append_List (List : List_Id; To : List_Id) is + + procedure Append_List_Debug; + pragma Inline (Append_List_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Append_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Append list "); + Write_Int (Int (List)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Append_List_Debug; + + -- Start of processing for Append_List + + begin + if Is_Empty_List (List) then + return; + + else + declare + L : constant Node_Id := Last (To); + F : constant Node_Id := First (List); + N : Node_Id; + + begin + pragma Debug (Append_List_Debug); + + N := F; + loop + Set_List_Link (N, To); + N := Next (N); + exit when No (N); + end loop; + + if No (L) then + Set_First (To, F); + else + Set_Next (L, F); + end if; + + Set_Prev (F, L); + Set_Last (To, Last (List)); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Append_List; + + -------------------- + -- Append_List_To -- + -------------------- + + procedure Append_List_To (To : List_Id; List : List_Id) is + begin + Append_List (List, To); + end Append_List_To; + + --------------- + -- Append_To -- + --------------- + + procedure Append_To (To : List_Id; Node : Node_Id) is + begin + Append (Node, To); + end Append_To; + + ----------------- + -- Delete_List -- + ----------------- + + procedure Delete_List (L : List_Id) is + N : Node_Id; + + begin + while Is_Non_Empty_List (L) loop + N := Remove_Head (L); + Delete_Tree (N); + end loop; + + -- Should recycle list header??? + end Delete_List; + + ----------- + -- First -- + ----------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + function First (List : List_Id) return Node_Id is + begin + if List = No_List then + return Empty; + else + pragma Assert (List in First_List_Id .. Lists.Last); + return Lists.Table (List).First; + end if; + end First; + + ---------------------- + -- First_Non_Pragma -- + ---------------------- + + function First_Non_Pragma (List : List_Id) return Node_Id is + N : constant Node_Id := First (List); + + begin + if Nkind (N) /= N_Pragma + and then + Nkind (N) /= N_Null_Statement + then + return N; + else + return Next_Non_Pragma (N); + end if; + end First_Non_Pragma; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + E : constant List_Id := Error_List; + + begin + Lists.Init; + Next_Node.Init; + Prev_Node.Init; + + -- Allocate Error_List list header + + Lists.Increment_Last; + Set_Parent (E, Empty); + Set_First (E, Empty); + Set_Last (E, Empty); + end Initialize; + + ------------------ + -- Insert_After -- + ------------------ + + procedure Insert_After (After : Node_Id; Node : Node_Id) is + + procedure Insert_After_Debug; + pragma Inline (Insert_After_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Insert_After_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert node"); + Write_Int (Int (Node)); + Write_Str (" after node "); + Write_Int (Int (After)); + Write_Eol; + end if; + end Insert_After_Debug; + + -- Start of processing for Insert_After + + begin + pragma Assert + (Is_List_Member (After) and then not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Insert_After_Debug); + + declare + Before : constant Node_Id := Next (After); + LC : constant List_Id := List_Containing (After); + + begin + if Present (Before) then + Set_Prev (Before, Node); + else + Set_Last (LC, Node); + end if; + + Set_Next (After, Node); + + Nodes.Table (Node).In_List := True; + + Set_Prev (Node, After); + Set_Next (Node, Before); + Set_List_Link (Node, LC); + end; + end Insert_After; + + ------------------- + -- Insert_Before -- + ------------------- + + procedure Insert_Before (Before : Node_Id; Node : Node_Id) is + + procedure Insert_Before_Debug; + pragma Inline (Insert_Before_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Insert_Before_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert node"); + Write_Int (Int (Node)); + Write_Str (" before node "); + Write_Int (Int (Before)); + Write_Eol; + end if; + end Insert_Before_Debug; + + -- Start of processing for Insert_Before + + begin + pragma Assert + (Is_List_Member (Before) and then not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Insert_Before_Debug); + + declare + After : constant Node_Id := Prev (Before); + LC : constant List_Id := List_Containing (Before); + + begin + if Present (After) then + Set_Next (After, Node); + else + Set_First (LC, Node); + end if; + + Set_Prev (Before, Node); + + Nodes.Table (Node).In_List := True; + + Set_Prev (Node, After); + Set_Next (Node, Before); + Set_List_Link (Node, LC); + end; + end Insert_Before; + + ----------------------- + -- Insert_List_After -- + ----------------------- + + procedure Insert_List_After (After : Node_Id; List : List_Id) is + + procedure Insert_List_After_Debug; + pragma Inline (Insert_List_After_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Insert_List_After_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert list "); + Write_Int (Int (List)); + Write_Str (" after node "); + Write_Int (Int (After)); + Write_Eol; + end if; + end Insert_List_After_Debug; + + -- Start of processing for Insert_List_After + + begin + pragma Assert (Is_List_Member (After)); + + if Is_Empty_List (List) then + return; + + else + declare + Before : constant Node_Id := Next (After); + LC : constant List_Id := List_Containing (After); + F : constant Node_Id := First (List); + L : constant Node_Id := Last (List); + N : Node_Id; + + begin + pragma Debug (Insert_List_After_Debug); + + N := F; + loop + Set_List_Link (N, LC); + exit when N = L; + N := Next (N); + end loop; + + if Present (Before) then + Set_Prev (Before, L); + else + Set_Last (LC, L); + end if; + + Set_Next (After, F); + Set_Prev (F, After); + Set_Next (L, Before); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Insert_List_After; + + ------------------------ + -- Insert_List_Before -- + ------------------------ + + procedure Insert_List_Before (Before : Node_Id; List : List_Id) is + + procedure Insert_List_Before_Debug; + pragma Inline (Insert_List_Before_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Insert_List_Before_Debug is + begin + if Debug_Flag_N then + Write_Str ("Insert list "); + Write_Int (Int (List)); + Write_Str (" before node "); + Write_Int (Int (Before)); + Write_Eol; + end if; + end Insert_List_Before_Debug; + + -- Start of prodcessing for Insert_List_Before + + begin + pragma Assert (Is_List_Member (Before)); + + if Is_Empty_List (List) then + return; + + else + declare + After : constant Node_Id := Prev (Before); + LC : constant List_Id := List_Containing (Before); + F : constant Node_Id := First (List); + L : constant Node_Id := Last (List); + N : Node_Id; + + begin + pragma Debug (Insert_List_Before_Debug); + + N := F; + loop + Set_List_Link (N, LC); + exit when N = L; + N := Next (N); + end loop; + + if Present (After) then + Set_Next (After, F); + else + Set_First (LC, F); + end if; + + Set_Prev (Before, L); + Set_Prev (F, After); + Set_Next (L, Before); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Insert_List_Before; + + ------------------- + -- Is_Empty_List -- + ------------------- + + function Is_Empty_List (List : List_Id) return Boolean is + begin + return First (List) = Empty; + end Is_Empty_List; + + -------------------- + -- Is_List_Member -- + -------------------- + + function Is_List_Member (Node : Node_Id) return Boolean is + begin + return Nodes.Table (Node).In_List; + end Is_List_Member; + + ----------------------- + -- Is_Non_Empty_List -- + ----------------------- + + function Is_Non_Empty_List (List : List_Id) return Boolean is + begin + return List /= No_List and then First (List) /= Empty; + end Is_Non_Empty_List; + + ---------- + -- Last -- + ---------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + function Last (List : List_Id) return Node_Id is + begin + pragma Assert (List in First_List_Id .. Lists.Last); + return Lists.Table (List).Last; + end Last; + + ------------------ + -- Last_List_Id -- + ------------------ + + function Last_List_Id return List_Id is + begin + return Lists.Last; + end Last_List_Id; + + --------------------- + -- Last_Non_Pragma -- + --------------------- + + function Last_Non_Pragma (List : List_Id) return Node_Id is + N : constant Node_Id := Last (List); + + begin + if Nkind (N) /= N_Pragma then + return N; + else + return Prev_Non_Pragma (N); + end if; + end Last_Non_Pragma; + + --------------------- + -- List_Containing -- + --------------------- + + function List_Containing (Node : Node_Id) return List_Id is + begin + pragma Assert (Is_List_Member (Node)); + return List_Id (Nodes.Table (Node).Link); + end List_Containing; + + ----------------- + -- List_Length -- + ----------------- + + function List_Length (List : List_Id) return Nat is + Result : Nat; + Node : Node_Id; + + begin + Result := 0; + Node := First (List); + while Present (Node) loop + Result := Result + 1; + Node := Next (Node); + end loop; + + return Result; + end List_Length; + + ------------------- + -- Lists_Address -- + ------------------- + + function Lists_Address return System.Address is + begin + return Lists.Table (First_List_Id)'Address; + end Lists_Address; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Lists.Locked := True; + Lists.Release; + + Prev_Node.Locked := True; + Next_Node.Locked := True; + + Prev_Node.Release; + Next_Node.Release; + end Lock; + + ------------------- + -- New_Copy_List -- + ------------------- + + function New_Copy_List (List : List_Id) return List_Id is + NL : List_Id; + E : Node_Id; + + begin + if List = No_List then + return No_List; + + else + NL := New_List; + E := First (List); + + while Present (E) loop + Append (New_Copy (E), NL); + E := Next (E); + end loop; + + return NL; + end if; + end New_Copy_List; + + ---------------------------- + -- New_Copy_List_Original -- + ---------------------------- + + function New_Copy_List_Original (List : List_Id) return List_Id is + NL : List_Id; + E : Node_Id; + + begin + if List = No_List then + return No_List; + + else + NL := New_List; + E := First (List); + + while Present (E) loop + if Comes_From_Source (E) then + Append (New_Copy (E), NL); + end if; + + E := Next (E); + end loop; + + return NL; + end if; + end New_Copy_List_Original; + + ------------------------ + -- New_Copy_List_Tree -- + ------------------------ + + function New_Copy_List_Tree (List : List_Id) return List_Id is + NL : List_Id; + E : Node_Id; + + begin + if List = No_List then + return No_List; + + else + NL := New_List; + E := First (List); + + while Present (E) loop + Append (New_Copy_Tree (E), NL); + E := Next (E); + end loop; + + return NL; + end if; + end New_Copy_List_Tree; + + -------------- + -- New_List -- + -------------- + + function New_List return List_Id is + + procedure New_List_Debug; + pragma Inline (New_List_Debug); + -- Output debugging information if Debug_Flag_N is set + + procedure New_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Allocate new list, returned ID = "); + Write_Int (Int (Lists.Last)); + Write_Eol; + end if; + end New_List_Debug; + + -- Start of processing for New_List + + begin + Lists.Increment_Last; + + declare + List : constant List_Id := Lists.Last; + + begin + Set_Parent (List, Empty); + Set_First (List, Empty); + Set_Last (List, Empty); + + pragma Debug (New_List_Debug); + return (List); + end; + end New_List; + + -- Since the one argument case is common, we optimize to build the right + -- list directly, rather than first building an empty list and then doing + -- the insertion, which results in some unnecessary work. + + function New_List (Node : Node_Id) return List_Id is + + procedure New_List_Debug; + pragma Inline (New_List_Debug); + -- Output debugging information if Debug_Flag_N is set + + procedure New_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Allocate new list, returned ID = "); + Write_Int (Int (Lists.Last)); + Write_Eol; + end if; + end New_List_Debug; + + -- Start of processing for New_List + + begin + if Node = Error then + return New_List; + + else + pragma Assert (not Is_List_Member (Node)); + + Lists.Increment_Last; + + declare + List : constant List_Id := Lists.Last; + + begin + Set_Parent (List, Empty); + Set_First (List, Node); + Set_Last (List, Node); + + Nodes.Table (Node).In_List := True; + Set_List_Link (Node, List); + Set_Prev (Node, Empty); + Set_Next (Node, Empty); + pragma Debug (New_List_Debug); + return List; + end; + end if; + end New_List; + + function New_List (Node1, Node2 : Node_Id) return List_Id is + L : constant List_Id := New_List (Node1); + + begin + Append (Node2, L); + return L; + end New_List; + + function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is + L : constant List_Id := New_List (Node1); + + begin + Append (Node2, L); + Append (Node3, L); + return L; + end New_List; + + function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is + L : constant List_Id := New_List (Node1); + + begin + Append (Node2, L); + Append (Node3, L); + Append (Node4, L); + return L; + end New_List; + + function New_List + (Node1 : Node_Id; + Node2 : Node_Id; + Node3 : Node_Id; + Node4 : Node_Id; + Node5 : Node_Id) + return List_Id + is + L : constant List_Id := New_List (Node1); + + begin + Append (Node2, L); + Append (Node3, L); + Append (Node4, L); + Append (Node5, L); + return L; + end New_List; + + function New_List + (Node1 : Node_Id; + Node2 : Node_Id; + Node3 : Node_Id; + Node4 : Node_Id; + Node5 : Node_Id; + Node6 : Node_Id) + return List_Id + is + L : constant List_Id := New_List (Node1); + + begin + Append (Node2, L); + Append (Node3, L); + Append (Node4, L); + Append (Node5, L); + Append (Node6, L); + return L; + end New_List; + + ---------- + -- Next -- + ---------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + function Next (Node : Node_Id) return Node_Id is + begin + pragma Assert (Is_List_Member (Node)); + return Next_Node.Table (Node); + end Next; + + procedure Next (Node : in out Node_Id) is + begin + Node := Next (Node); + end Next; + + ----------------------- + -- Next_Node_Address -- + ----------------------- + + function Next_Node_Address return System.Address is + begin + return Next_Node.Table (First_Node_Id)'Address; + end Next_Node_Address; + + --------------------- + -- Next_Non_Pragma -- + --------------------- + + function Next_Non_Pragma (Node : Node_Id) return Node_Id is + N : Node_Id; + + begin + N := Node; + loop + N := Next (N); + exit when Nkind (N) /= N_Pragma + and then + Nkind (N) /= N_Null_Statement; + end loop; + + return N; + end Next_Non_Pragma; + + procedure Next_Non_Pragma (Node : in out Node_Id) is + begin + Node := Next_Non_Pragma (Node); + end Next_Non_Pragma; + + -------- + -- No -- + -------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + function No (List : List_Id) return Boolean is + begin + return List = No_List; + end No; + + --------------- + -- Num_Lists -- + --------------- + + function Num_Lists return Nat is + begin + return Int (Lists.Last) - Int (Lists.First) + 1; + end Num_Lists; + + ------- + -- p -- + ------- + + function p (U : Union_Id) return Node_Id is + begin + if U in Node_Range then + return Parent (Node_Id (U)); + + elsif U in List_Range then + return Parent (List_Id (U)); + + else + return 99_999_999; + end if; + end p; + + ------------ + -- Parent -- + ------------ + + function Parent (List : List_Id) return Node_Id is + begin + pragma Assert (List in First_List_Id .. Lists.Last); + return Lists.Table (List).Parent; + end Parent; + + ---------- + -- Pick -- + ---------- + + function Pick (List : List_Id; Index : Pos) return Node_Id is + Elmt : Node_Id; + + begin + Elmt := First (List); + for J in 1 .. Index - 1 loop + Elmt := Next (Elmt); + end loop; + + return Elmt; + end Pick; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Node : Node_Id; To : List_Id) is + F : constant Node_Id := First (To); + + begin + pragma Assert (not Is_List_Member (Node)); + + if Node = Error then + return; + end if; + + pragma Debug (Prepend_Debug (Node, To)); + + if No (F) then + Set_Last (To, Node); + else + Set_Prev (F, Node); + end if; + + Set_First (To, Node); + + Nodes.Table (Node).In_List := True; + + Set_Next (Node, F); + Set_Prev (Node, Empty); + Set_List_Link (Node, To); + end Prepend; + + ------------------- + -- Prepend_Debug -- + ------------------- + + procedure Prepend_Debug (Node : Node_Id; To : List_Id) is + begin + if Debug_Flag_N then + Write_Str ("Prepend node "); + Write_Int (Int (Node)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Prepend_Debug; + + ---------------- + -- Prepend_To -- + ---------------- + + procedure Prepend_To (To : List_Id; Node : Node_Id) is + begin + Prepend (Node, To); + end Prepend_To; + + ------------- + -- Present -- + ------------- + + function Present (List : List_Id) return Boolean is + begin + return List /= No_List; + end Present; + + ---------- + -- Prev -- + ---------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + function Prev (Node : Node_Id) return Node_Id is + begin + pragma Assert (Is_List_Member (Node)); + return Prev_Node.Table (Node); + end Prev; + + procedure Prev (Node : in out Node_Id) is + begin + Node := Prev (Node); + end Prev; + + ----------------------- + -- Prev_Node_Address -- + ----------------------- + + function Prev_Node_Address return System.Address is + begin + return Prev_Node.Table (First_Node_Id)'Address; + end Prev_Node_Address; + + --------------------- + -- Prev_Non_Pragma -- + --------------------- + + function Prev_Non_Pragma (Node : Node_Id) return Node_Id is + N : Node_Id; + + begin + N := Node; + loop + N := Prev (N); + exit when Nkind (N) /= N_Pragma; + end loop; + + return N; + end Prev_Non_Pragma; + + procedure Prev_Non_Pragma (Node : in out Node_Id) is + begin + Node := Prev_Non_Pragma (Node); + end Prev_Non_Pragma; + + ------------ + -- Remove -- + ------------ + + procedure Remove (Node : Node_Id) is + Lst : constant List_Id := List_Containing (Node); + Prv : constant Node_Id := Prev (Node); + Nxt : constant Node_Id := Next (Node); + + procedure Remove_Debug; + pragma Inline (Remove_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Remove_Debug is + begin + if Debug_Flag_N then + Write_Str ("Remove node "); + Write_Int (Int (Node)); + Write_Eol; + end if; + end Remove_Debug; + + -- Start of processing for Remove + + begin + pragma Debug (Remove_Debug); + + if No (Prv) then + Set_First (Lst, Nxt); + else + Set_Next (Prv, Nxt); + end if; + + if No (Nxt) then + Set_Last (Lst, Prv); + else + Set_Prev (Nxt, Prv); + end if; + + Nodes.Table (Node).In_List := False; + Set_Parent (Node, Empty); + end Remove; + + ----------------- + -- Remove_Head -- + ----------------- + + function Remove_Head (List : List_Id) return Node_Id is + Frst : constant Node_Id := First (List); + + procedure Remove_Head_Debug; + pragma Inline (Remove_Head_Debug); + -- Output debug information if Debug_Flag_N set + + procedure Remove_Head_Debug is + begin + if Debug_Flag_N then + Write_Str ("Remove head of list "); + Write_Int (Int (List)); + Write_Eol; + end if; + end Remove_Head_Debug; + + -- Start of processing for Remove_Head + + begin + pragma Debug (Remove_Head_Debug); + + if Frst = Empty then + return Empty; + + else + declare + Nxt : constant Node_Id := Next (Frst); + + begin + Set_First (List, Nxt); + + if No (Nxt) then + Set_Last (List, Empty); + else + Set_Prev (Nxt, Empty); + end if; + + Nodes.Table (Frst).In_List := False; + Set_Parent (Frst, Empty); + return Frst; + end; + end if; + end Remove_Head; + + ----------------- + -- Remove_Next -- + ----------------- + + function Remove_Next (Node : Node_Id) return Node_Id is + Nxt : constant Node_Id := Next (Node); + + begin + if Present (Nxt) then + declare + Nxt2 : constant Node_Id := Next (Nxt); + LC : constant List_Id := List_Containing (Node); + + begin + pragma Debug (Remove_Next_Debug (Node)); + Set_Next (Node, Nxt2); + + if No (Nxt2) then + Set_Last (LC, Node); + else + Set_Prev (Nxt2, Node); + end if; + + Nodes.Table (Nxt).In_List := False; + Set_Parent (Nxt, Empty); + end; + end if; + + return Nxt; + end Remove_Next; + + ----------------------- + -- Remove_Next_Debug -- + ----------------------- + + procedure Remove_Next_Debug (Node : Node_Id) is + begin + if Debug_Flag_N then + Write_Str ("Remove next node after "); + Write_Int (Int (Node)); + Write_Eol; + end if; + end Remove_Next_Debug; + + --------------- + -- Set_First -- + --------------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + procedure Set_First (List : List_Id; To : Node_Id) is + begin + Lists.Table (List).First := To; + end Set_First; + + -------------- + -- Set_Last -- + -------------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + procedure Set_Last (List : List_Id; To : Node_Id) is + begin + Lists.Table (List).Last := To; + end Set_Last; + + ------------------- + -- Set_List_Link -- + ------------------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + procedure Set_List_Link (Node : Node_Id; To : List_Id) is + begin + Nodes.Table (Node).Link := Union_Id (To); + end Set_List_Link; + + -------------- + -- Set_Next -- + -------------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + procedure Set_Next (Node : Node_Id; To : Node_Id) is + begin + Next_Node.Table (Node) := To; + end Set_Next; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (List : List_Id; Node : Node_Id) is + begin + pragma Assert (List in First_List_Id .. Lists.Last); + Lists.Table (List).Parent := Node; + end Set_Parent; + + -------------- + -- Set_Prev -- + -------------- + + -- This subprogram is deliberately placed early on, out of alphabetical + -- order, so that it can be properly inlined from within this unit. + + procedure Set_Prev (Node : Node_Id; To : Node_Id) is + begin + Prev_Node.Table (Node) := To; + end Set_Prev; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Lists.Tree_Read; + Next_Node.Tree_Read; + Prev_Node.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Lists.Tree_Write; + Next_Node.Tree_Write; + Prev_Node.Tree_Write; + end Tree_Write; + +end Nlists; diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads new file mode 100644 index 00000000000..910e02546c5 --- /dev/null +++ b/gcc/ada/nlists.ads @@ -0,0 +1,349 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N L I S T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.31 $ -- +-- -- +-- Copyright (C) 1992-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for manipulating lists of nodes (see +-- package Atree for format and implementation of tree nodes). The Link field +-- of the nodes is used as the forward pointer for these lists. See also +-- package Elists which provides another form of lists that are not threaded +-- through the nodes (and therefore allow nodes to be on multiple lists). + +with System; +with Types; use Types; + +package Nlists is + + -- A node list is a list of nodes in a special format that means that + -- nodes can be on at most one such list. For each node list, a list + -- header is allocated in the lists table, and a List_Id value references + -- this header, which may be used to access the nodes in the list using + -- the set of routines that define this interface. + + -- Note: node lists can contain either nodes or entities (extended nodes) + -- or a mixture of nodes and extended nodes. + + function Last_List_Id return List_Id; + pragma Inline (Last_List_Id); + -- Returns Id of last allocated list header + + function Lists_Address return System.Address; + pragma Inline (Lists_Address); + -- Return address of Lists table (used in Back_End for Gigi call) + + function Num_Lists return Nat; + pragma Inline (Num_Lists); + -- Number of currently allocated lists + + function New_List return List_Id; + -- Creates a new empty node list. Typically this is used to initialize + -- a field in some other node which points to a node list where the list + -- is then subsequently filled in using Append calls. + + function Empty_List return List_Id renames New_List; + -- Used in contexts where an empty list (as opposed to an initially empty + -- list to be filled in) is required. + + function New_List (Node : Node_Id) return List_Id; + -- Build a new list initially containing the given node + + function New_List (Node1, Node2 : Node_Id) return List_Id; + -- Build a new list initially containing the two given nodes + + function New_List (Node1, Node2, Node3 : Node_Id) return List_Id; + -- Build a new list initially containing the three given nodes + + function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id; + -- Build a new list initially containing the four given nodes + + function New_List + (Node1 : Node_Id; + Node2 : Node_Id; + Node3 : Node_Id; + Node4 : Node_Id; + Node5 : Node_Id) + return List_Id; + -- Build a new list initially containing the five given nodes + + function New_List + (Node1 : Node_Id; + Node2 : Node_Id; + Node3 : Node_Id; + Node4 : Node_Id; + Node5 : Node_Id; + Node6 : Node_Id) + return List_Id; + -- Build a new list initially containing the five given nodes + + function New_Copy_List (List : List_Id) return List_Id; + -- Creates a new list containing copies (made with Atree.New_Copy) of every + -- node in the original list. If the argument is No_List, then the returned + -- result is No_List. If the argument is an empty list, then the returned + -- result is a new empty list. + + function New_Copy_List_Original (List : List_Id) return List_Id; + -- Same as New_Copy_List but copies only nodes coming from source + + function New_Copy_List_Tree (List : List_Id) return List_Id; + -- Similar to New_Copy_List, except that the copies are done using the + -- Atree.New_Copy_Tree function, which means that a full recursive copy + -- of the subtrees in the list is performed, setting proper parents. As + -- for New_Copy_Tree, it is illegal to attempt to copy extended nodes + -- (entities) either directly or indirectly using this function. + + function First (List : List_Id) return Node_Id; + pragma Inline (First); + -- Obtains the first element of the given node list or, if the node list + -- has no items or is equal to No_List, then Empty is returned. + + function First_Non_Pragma (List : List_Id) return Node_Id; + -- Used when dealing with a list that can contain pragmas to skip past + -- any initial pragmas and return the first element that is not a pragma. + -- If the list is empty, or if it contains only pragmas, then Empty is + -- returned. It is an error to call First_Non_Pragma with a Node_Id value + -- or No_List (No_List is not considered to be the same as an empty list). + -- This function also skips N_Null nodes which can result from rewriting + -- unrecognized or incorrrect pragmas. + + function Last (List : List_Id) return Node_Id; + pragma Inline (Last); + -- Obtains the last element of the given node list or, if the node list + -- has no items, then Empty is returned. It is an error to call Last with + -- a Node_Id or No_List. (No_List is not considered to be the same as an + -- empty node list). + + function Last_Non_Pragma (List : List_Id) return Node_Id; + -- Obtains the last element of a given node list that is not a pragma. + -- If the list is empty, or if it contains only pragmas, then Empty is + -- returned. It is an error to call Last_Non_Pragma with a Node_Id or + -- No_List. (No_List is not considered to be the same as an empty list). + + function List_Length (List : List_Id) return Nat; + pragma Inline (List_Length); + -- Returns number of items in the given list. It is an error to call + -- this function with No_List (No_List is not considered to be the same + -- as an empty list). + + function Next (Node : Node_Id) return Node_Id; + pragma Inline (Next); + -- This function returns the next node on a node list, or Empty if Node is + -- the last element of the node list. The argument must be a member of a + -- node list. + + procedure Next (Node : in out Node_Id); + pragma Inline (Next); + -- Equivalent to Node := Next (Node); + + function Next_Non_Pragma (Node : Node_Id) return Node_Id; + -- This function returns the next node on a node list, skipping past any + -- pragmas, or Empty if there is no non-pragma entry left. The argument + -- must be a member of a node list. This function also skips N_Null nodes + -- which can result from rewriting unrecognized or incorrect pragmas. + + procedure Next_Non_Pragma (Node : in out Node_Id); + pragma Inline (Next_Non_Pragma); + -- Equivalent to Node := Next_Non_Pragma (Node); + + function Prev (Node : Node_Id) return Node_Id; + pragma Inline (Prev); + -- This function returns the previous node on a node list list, or Empty if + -- Node is the first element of the node list. The argument must be a + -- member of a node list. Note that the implementation does not maintain + -- back pointers, so this function potentially requires traversal of the + -- entire list, or more accurately of the part of the list preceding Node. + + function Pick (List : List_Id; Index : Pos) return Node_Id; + -- Given a list, picks out the Index'th entry (1 = first entry). The + -- caller must ensure that Index is in range. + + procedure Prev (Node : in out Node_Id); + pragma Inline (Prev); + -- Equivalent to Node := Prev (Node); + + function Prev_Non_Pragma (Node : Node_Id) return Node_Id; + pragma Inline (Prev_Non_Pragma); + -- This function returns the previous node on a node list, skipping any + -- pragmas. If Node is the first element of the list, or if the only + -- elements preceding it are pragmas, then Empty is returned. The + -- argument must be a member of a node list. Like Prev, this function + -- may require expensive traversal of the head section of the list. + + procedure Prev_Non_Pragma (Node : in out Node_Id); + pragma Inline (Prev_Non_Pragma); + -- Equivalent to Node := Prev_Non_Pragma (Node); + + function Is_Empty_List (List : List_Id) return Boolean; + pragma Inline (Is_Empty_List); + -- This function determines if a given list id references a node list that + -- contains no items. No_List is a not a legitimate argument. + + function Is_Non_Empty_List (List : List_Id) return Boolean; + pragma Inline (Is_Non_Empty_List); + -- This function determines if a given list id references a node list that + -- contains at least one item. No_List as an argument returns False. + + function Is_List_Member (Node : Node_Id) return Boolean; + pragma Inline (Is_List_Member); + -- This function determines if a given node is a member of a node list. + -- It is an error for Node to be Empty, or to be a node list. + + function List_Containing (Node : Node_Id) return List_Id; + pragma Inline (List_Containing); + -- This function provides a pointer to the node list containing Node. + -- Node must be a member of a node list. + + procedure Append (Node : Node_Id; To : List_Id); + -- Appends Node at the end of node list To. Node must be a non-empty node + -- that is not already a member of a node list, and To must be a + -- node list. An attempt to append an error node is ignored without + -- complaint and the list is unchanged. + + procedure Append_To (To : List_Id; Node : Node_Id); + pragma Inline (Append_To); + -- Like Append, but arguments are the other way round + + procedure Append_List (List : List_Id; To : List_Id); + -- Appends node list List to the end of node list To. On return, + -- List is reset to be empty. + + procedure Append_List_To (To : List_Id; List : List_Id); + pragma Inline (Append_List_To); + -- Like Append_List, but arguments are the other way round + + procedure Insert_After (After : Node_Id; Node : Node_Id); + -- Insert Node, which must be a non-empty node that is not already a + -- member of a node list, immediately past node After, which must be a + -- node that is currently a member of a node list. An attempt to insert + -- an error node is ignored without complaint (and the list is unchanged). + + procedure Insert_List_After (After : Node_Id; List : List_Id); + -- Inserts the entire contents of node list List immediately after node + -- After, which must be a member of a node list. On return, the node list + -- List is reset to be the empty node list. + + procedure Insert_Before (Before : Node_Id; Node : Node_Id); + -- Insert Node, which must be a non-empty node that is not already a + -- member of a node list, immediately before Before, which must be a node + -- that is currently a member of a node list. An attempt to insert an + -- error node is ignored without complaint (and the list is unchanged). + + procedure Insert_List_Before (Before : Node_Id; List : List_Id); + -- Inserts the entire contents of node list List immediately before node + -- Before, which must be a member of a node list. On return, the node list + -- List is reset to be the empty node list. + + procedure Prepend (Node : Node_Id; To : List_Id); + pragma Inline (Prepend); + -- Prepends Node at the start of node list To. Node must be a non-empty + -- node that is not already a member of a node list, and To must be a + -- node list. An attempt to prepend an error node is ignored without + -- complaint and the list is unchanged. + + procedure Prepend_To (To : List_Id; Node : Node_Id); + pragma Inline (Prepend_To); + -- Like Prepend, but arguments are the other way round + + procedure Remove (Node : Node_Id); + -- Removes Node, which must be a node that is a member of a node list, + -- from this node list. The contents of Node are not otherwise affected. + + function Remove_Head (List : List_Id) return Node_Id; + -- Removes the head element of a node list, and returns the node (whose + -- contents are not otherwise affected) as the result. If the node list + -- is empty, then Empty is returned. + + function Remove_Next (Node : Node_Id) return Node_Id; + pragma Inline (Remove_Next); + -- Removes the item immediately following the given node, and returns it + -- as the result. If Node is the last element of the list, then Empty is + -- returned. Node must be a member of a list. Unlike Remove, Remove_Next + -- is fast and does not involve any list traversal. + + procedure Initialize; + -- Called at the start of compilation of each new main source file to + -- initialize the allocation of the list table. Note that Initialize + -- must not be called if Tree_Read is used. + + procedure Lock; + -- Called to lock tables before back end is called + + procedure Tree_Read; + -- Initializes internal tables from current tree file using Tree_Read. + -- Note that Initialize should not be called if Tree_Read is used. + -- Tree_Read includes all necessary initialization. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using Tree_Write + + function Parent (List : List_Id) return Node_Id; + pragma Inline (Parent); + -- Node lists may have a parent in the same way as a node. The function + -- accesses the Parent value, which is either Empty when a list header + -- is first created, or the value that has been set by Set_Parent. + + procedure Set_Parent (List : List_Id; Node : Node_Id); + pragma Inline (Set_Parent); + -- Sets the parent field of the given list to reference the given node + + function No (List : List_Id) return Boolean; + pragma Inline (No); + -- Tests given Id for equality with No_List. This allows notations like + -- "if No (Statements)" as opposed to "if Statements = No_List". + + function Present (List : List_Id) return Boolean; + pragma Inline (Present); + -- Tests given Id for inequality with No_List. This allows notations like + -- "if Present (Statements)" as opposed to "if Statements /= No_List". + + procedure Allocate_List_Tables (N : Node_Id); + -- Called when nodes table is expanded to include node N. This call + -- makes sure that list structures internal to Nlists are adjusted + -- apropriately to reflect this increase in the size of the nodes table. + + function Next_Node_Address return System.Address; + function Prev_Node_Address return System.Address; + -- These functions return the addresses of the Next_Node and Prev_Node + -- tables (used in Back_End for Gigi). + + procedure Delete_List (L : List_Id); + -- Removes all elements of the given list, and calls Delete_Tree on each + + function p (U : Union_Id) return Node_Id; + -- This function is intended for use from the debugger, it determines + -- whether U is a Node_Id or List_Id, and calls the appropriate Parent + -- function and returns the parent Node in either case. This is shorter + -- to type, and avoids the overloading problem of using Parent. It + -- should NEVER be used except from the debugger. If p is called with + -- other than a node or list id value, it returns 99_999_999. + +end Nlists; diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h new file mode 100644 index 00000000000..2080feac4d2 --- /dev/null +++ b/gcc/ada/nlists.h @@ -0,0 +1,144 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * N L I S T S * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This is the C header corresponding to the Ada package specification for + Nlists. It also contains the implementations of inlined functions from the + the package body for Nlists. It was generated manually from nlists.ads and + nlists.adb and must be kept synchronized with changes in these files. + + Note that only routines for reading the tree are included, since the + tree transformer is not supposed to modify the tree in any way. */ + +/* The following is the structure used for the list headers table */ + +struct List_Header +{ + Node_Id first; + Node_Id last; + Node_Id parent; +}; + +/* The list headers are stored in an array. The pointer to this array is + passed as a parameter to gigi and stored in the global variable + List_Headers_Ptr after adjusting it by subtracting List_First_Entry, + so that List_Id values can be used as subscripts. */ + +extern struct List_Header *List_Headers_Ptr; + +/* The previous and next links for lists are held in two arrays, Next_Node + and Prev_Node. The pointers to these arrays are passed as parameters + to gigi and stored in the global variables Prev_Node_Ptr and Next_Node_Ptr + after adjusting them by subtracting First_Node_Id so that Node_Id values + can be used as subscripts. */ + +extern Node_Id *Next_Node_Ptr; +extern Node_Id *Prev_Node_Ptr; + +/* Node List Access Functions */ + +static Node_Id First PARAMS ((List_Id)); + +INLINE Node_Id +First (List) + List_Id List; +{ + return List_Headers_Ptr [List].first; +} + +#define First_Non_Pragma nlists__first_non_pragma +extern Node_Id First_Non_Pragma PARAMS((Node_Id)); + +static Node_Id Last PARAMS ((List_Id)); + +INLINE Node_Id +Last (List) + List_Id List; +{ + return List_Headers_Ptr [List].last; +} + +#define First_Non_Pragma nlists__first_non_pragma +extern Node_Id First_Non_Pragma PARAMS((List_Id)); + +static Node_Id Next PARAMS ((Node_Id)); + +INLINE Node_Id +Next (Node) + Node_Id Node; +{ + return Next_Node_Ptr [Node]; +} + +#define Next_Non_Pragma nlists__next_non_pragma +extern Node_Id Next_Non_Pragma PARAMS((List_Id)); + +static Node_Id Prev PARAMS ((Node_Id)); + +INLINE Node_Id +Prev (Node) + Node_Id Node; +{ + return Prev_Node_Ptr [Node]; +} + + +#define Prev_Non_Pragma nlists__prev_non_pragma +extern Node_Id Prev_Non_Pragma PARAMS((Node_Id)); + +static Boolean Is_Empty_List PARAMS ((List_Id)); +static Boolean Is_Non_Empty_List PARAMS ((List_Id)); +static Boolean Is_List_Member PARAMS ((Node_Id)); +static List_Id List_Containing PARAMS ((Node_Id)); + +INLINE Boolean +Is_Empty_List (Id) + List_Id Id; +{ + return (First (Id) == Empty); +} + +INLINE Boolean +Is_Non_Empty_List (Id) + List_Id Id; +{ + return (Present (Id) && First (Id) != Empty); +} + +INLINE Boolean +Is_List_Member (Node) + Node_Id Node; +{ + return Nodes_Ptr [Node].U.K.in_list; +} + +INLINE List_Id +List_Containing (Node) + Node_Id Node; +{ + return Nodes_Ptr [Node].V.NX.link; +} diff --git a/gcc/ada/nmake.adb b/gcc/ada/nmake.adb new file mode 100644 index 00000000000..92bb4986f3f --- /dev/null +++ b/gcc/ada/nmake.adb @@ -0,0 +1,2846 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N M A K E -- +-- -- +-- B o d y -- +-- -- +-- Generated by xnmake revision 1.25 using -- +-- sinfo.ads revision 1.430 -- +-- nmake.adt revision 1.12 -- +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram order checking, since the routines here are +-- generated automatically in order. + + +with Atree; use Atree; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; + +package body Nmake is + + function Make_Unused_At_Start (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Unused_At_Start, Sloc); + begin + return N; + end Make_Unused_At_Start; + + function Make_Unused_At_End (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Unused_At_End, Sloc); + begin + return N; + end Make_Unused_At_End; + + function Make_Identifier (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Identifier, Sloc); + begin + Set_Chars (N, Chars); + return N; + end Make_Identifier; + + function Make_Integer_Literal (Sloc : Source_Ptr; + Intval : Uint) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Integer_Literal, Sloc); + begin + Set_Intval (N, Intval); + return N; + end Make_Integer_Literal; + + function Make_Real_Literal (Sloc : Source_Ptr; + Realval : Ureal) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Real_Literal, Sloc); + begin + Set_Realval (N, Realval); + return N; + end Make_Real_Literal; + + function Make_Character_Literal (Sloc : Source_Ptr; + Chars : Name_Id; + Char_Literal_Value : Char_Code) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Character_Literal, Sloc); + begin + Set_Chars (N, Chars); + Set_Char_Literal_Value (N, Char_Literal_Value); + return N; + end Make_Character_Literal; + + function Make_String_Literal (Sloc : Source_Ptr; + Strval : String_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_String_Literal, Sloc); + begin + Set_Strval (N, Strval); + return N; + end Make_String_Literal; + + function Make_Pragma (Sloc : Source_Ptr; + Chars : Name_Id; + Pragma_Argument_Associations : List_Id := No_List; + Debug_Statement : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Pragma, Sloc); + begin + Set_Chars (N, Chars); + Set_Pragma_Argument_Associations + (N, Pragma_Argument_Associations); + Set_Debug_Statement (N, Debug_Statement); + return N; + end Make_Pragma; + + function Make_Pragma_Argument_Association (Sloc : Source_Ptr; + Chars : Name_Id := No_Name; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Pragma_Argument_Association, Sloc); + begin + Set_Chars (N, Chars); + Set_Expression (N, Expression); + return N; + end Make_Pragma_Argument_Association; + + function Make_Defining_Identifier (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id + is + N : constant Node_Id := + New_Entity (N_Defining_Identifier, Sloc); + begin + Set_Chars (N, Chars); + return N; + end Make_Defining_Identifier; + + function Make_Full_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Type_Definition : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Full_Type_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discriminant_Specifications (N, Discriminant_Specifications); + Set_Type_Definition (N, Type_Definition); + return N; + end Make_Full_Type_Declaration; + + function Make_Subtype_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Subtype_Indication : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subtype_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Subtype_Indication (N, Subtype_Indication); + return N; + end Make_Subtype_Declaration; + + function Make_Subtype_Indication (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Constraint : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subtype_Indication, Sloc); + begin + Set_Subtype_Mark (N, Subtype_Mark); + Set_Constraint (N, Constraint); + return N; + end Make_Subtype_Indication; + + function Make_Object_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Aliased_Present : Boolean := False; + Constant_Present : Boolean := False; + Object_Definition : Node_Id; + Expression : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Object_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Aliased_Present (N, Aliased_Present); + Set_Constant_Present (N, Constant_Present); + Set_Object_Definition (N, Object_Definition); + Set_Expression (N, Expression); + return N; + end Make_Object_Declaration; + + function Make_Number_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Number_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Expression (N, Expression); + return N; + end Make_Number_Declaration; + + function Make_Derived_Type_Definition (Sloc : Source_Ptr; + Abstract_Present : Boolean := False; + Subtype_Indication : Node_Id; + Record_Extension_Part : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Derived_Type_Definition, Sloc); + begin + Set_Abstract_Present (N, Abstract_Present); + Set_Subtype_Indication (N, Subtype_Indication); + Set_Record_Extension_Part (N, Record_Extension_Part); + return N; + end Make_Derived_Type_Definition; + + function Make_Range_Constraint (Sloc : Source_Ptr; + Range_Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Range_Constraint, Sloc); + begin + Set_Range_Expression (N, Range_Expression); + return N; + end Make_Range_Constraint; + + function Make_Range (Sloc : Source_Ptr; + Low_Bound : Node_Id; + High_Bound : Node_Id; + Includes_Infinities : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Range, Sloc); + begin + Set_Low_Bound (N, Low_Bound); + Set_High_Bound (N, High_Bound); + Set_Includes_Infinities (N, Includes_Infinities); + return N; + end Make_Range; + + function Make_Enumeration_Type_Definition (Sloc : Source_Ptr; + Literals : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Enumeration_Type_Definition, Sloc); + begin + Set_Literals (N, Literals); + return N; + end Make_Enumeration_Type_Definition; + + function Make_Defining_Character_Literal (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id + is + N : constant Node_Id := + New_Entity (N_Defining_Character_Literal, Sloc); + begin + Set_Chars (N, Chars); + return N; + end Make_Defining_Character_Literal; + + function Make_Signed_Integer_Type_Definition (Sloc : Source_Ptr; + Low_Bound : Node_Id; + High_Bound : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Signed_Integer_Type_Definition, Sloc); + begin + Set_Low_Bound (N, Low_Bound); + Set_High_Bound (N, High_Bound); + return N; + end Make_Signed_Integer_Type_Definition; + + function Make_Modular_Type_Definition (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Modular_Type_Definition, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Modular_Type_Definition; + + function Make_Floating_Point_Definition (Sloc : Source_Ptr; + Digits_Expression : Node_Id; + Real_Range_Specification : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Floating_Point_Definition, Sloc); + begin + Set_Digits_Expression (N, Digits_Expression); + Set_Real_Range_Specification (N, Real_Range_Specification); + return N; + end Make_Floating_Point_Definition; + + function Make_Real_Range_Specification (Sloc : Source_Ptr; + Low_Bound : Node_Id; + High_Bound : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Real_Range_Specification, Sloc); + begin + Set_Low_Bound (N, Low_Bound); + Set_High_Bound (N, High_Bound); + return N; + end Make_Real_Range_Specification; + + function Make_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr; + Delta_Expression : Node_Id; + Real_Range_Specification : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Ordinary_Fixed_Point_Definition, Sloc); + begin + Set_Delta_Expression (N, Delta_Expression); + Set_Real_Range_Specification (N, Real_Range_Specification); + return N; + end Make_Ordinary_Fixed_Point_Definition; + + function Make_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr; + Delta_Expression : Node_Id; + Digits_Expression : Node_Id; + Real_Range_Specification : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Decimal_Fixed_Point_Definition, Sloc); + begin + Set_Delta_Expression (N, Delta_Expression); + Set_Digits_Expression (N, Digits_Expression); + Set_Real_Range_Specification (N, Real_Range_Specification); + return N; + end Make_Decimal_Fixed_Point_Definition; + + function Make_Digits_Constraint (Sloc : Source_Ptr; + Digits_Expression : Node_Id; + Range_Constraint : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Digits_Constraint, Sloc); + begin + Set_Digits_Expression (N, Digits_Expression); + Set_Range_Constraint (N, Range_Constraint); + return N; + end Make_Digits_Constraint; + + function Make_Unconstrained_Array_Definition (Sloc : Source_Ptr; + Subtype_Marks : List_Id; + Aliased_Present : Boolean := False; + Subtype_Indication : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Unconstrained_Array_Definition, Sloc); + begin + Set_Subtype_Marks (N, Subtype_Marks); + Set_Aliased_Present (N, Aliased_Present); + Set_Subtype_Indication (N, Subtype_Indication); + return N; + end Make_Unconstrained_Array_Definition; + + function Make_Constrained_Array_Definition (Sloc : Source_Ptr; + Discrete_Subtype_Definitions : List_Id; + Aliased_Present : Boolean := False; + Subtype_Indication : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Constrained_Array_Definition, Sloc); + begin + Set_Discrete_Subtype_Definitions + (N, Discrete_Subtype_Definitions); + Set_Aliased_Present (N, Aliased_Present); + Set_Subtype_Indication (N, Subtype_Indication); + return N; + end Make_Constrained_Array_Definition; + + function Make_Discriminant_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Type : Node_Id; + Expression : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Discriminant_Specification, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discriminant_Type (N, Discriminant_Type); + Set_Expression (N, Expression); + return N; + end Make_Discriminant_Specification; + + function Make_Index_Or_Discriminant_Constraint (Sloc : Source_Ptr; + Constraints : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Index_Or_Discriminant_Constraint, Sloc); + begin + Set_Constraints (N, Constraints); + return N; + end Make_Index_Or_Discriminant_Constraint; + + function Make_Discriminant_Association (Sloc : Source_Ptr; + Selector_Names : List_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Discriminant_Association, Sloc); + begin + Set_Selector_Names (N, Selector_Names); + Set_Expression (N, Expression); + return N; + end Make_Discriminant_Association; + + function Make_Record_Definition (Sloc : Source_Ptr; + End_Label : Node_Id := Empty; + Abstract_Present : Boolean := False; + Tagged_Present : Boolean := False; + Limited_Present : Boolean := False; + Component_List : Node_Id; + Null_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Record_Definition, Sloc); + begin + Set_End_Label (N, End_Label); + Set_Abstract_Present (N, Abstract_Present); + Set_Tagged_Present (N, Tagged_Present); + Set_Limited_Present (N, Limited_Present); + Set_Component_List (N, Component_List); + Set_Null_Present (N, Null_Present); + return N; + end Make_Record_Definition; + + function Make_Component_List (Sloc : Source_Ptr; + Component_Items : List_Id; + Variant_Part : Node_Id := Empty; + Null_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Component_List, Sloc); + begin + Set_Component_Items (N, Component_Items); + Set_Variant_Part (N, Variant_Part); + Set_Null_Present (N, Null_Present); + return N; + end Make_Component_List; + + function Make_Component_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Aliased_Present : Boolean := False; + Subtype_Indication : Node_Id; + Expression : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Component_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Aliased_Present (N, Aliased_Present); + Set_Subtype_Indication (N, Subtype_Indication); + Set_Expression (N, Expression); + return N; + end Make_Component_Declaration; + + function Make_Variant_Part (Sloc : Source_Ptr; + Name : Node_Id; + Variants : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Variant_Part, Sloc); + begin + Set_Name (N, Name); + Set_Variants (N, Variants); + return N; + end Make_Variant_Part; + + function Make_Variant (Sloc : Source_Ptr; + Discrete_Choices : List_Id; + Component_List : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Variant, Sloc); + begin + Set_Discrete_Choices (N, Discrete_Choices); + Set_Component_List (N, Component_List); + return N; + end Make_Variant; + + function Make_Others_Choice (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Others_Choice, Sloc); + begin + return N; + end Make_Others_Choice; + + function Make_Access_To_Object_Definition (Sloc : Source_Ptr; + All_Present : Boolean := False; + Subtype_Indication : Node_Id; + Constant_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Access_To_Object_Definition, Sloc); + begin + Set_All_Present (N, All_Present); + Set_Subtype_Indication (N, Subtype_Indication); + Set_Constant_Present (N, Constant_Present); + return N; + end Make_Access_To_Object_Definition; + + function Make_Access_Function_Definition (Sloc : Source_Ptr; + Protected_Present : Boolean := False; + Parameter_Specifications : List_Id := No_List; + Subtype_Mark : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Access_Function_Definition, Sloc); + begin + Set_Protected_Present (N, Protected_Present); + Set_Parameter_Specifications (N, Parameter_Specifications); + Set_Subtype_Mark (N, Subtype_Mark); + return N; + end Make_Access_Function_Definition; + + function Make_Access_Procedure_Definition (Sloc : Source_Ptr; + Protected_Present : Boolean := False; + Parameter_Specifications : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Access_Procedure_Definition, Sloc); + begin + Set_Protected_Present (N, Protected_Present); + Set_Parameter_Specifications (N, Parameter_Specifications); + return N; + end Make_Access_Procedure_Definition; + + function Make_Access_Definition (Sloc : Source_Ptr; + Subtype_Mark : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Access_Definition, Sloc); + begin + Set_Subtype_Mark (N, Subtype_Mark); + return N; + end Make_Access_Definition; + + function Make_Incomplete_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Incomplete_Type_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discriminant_Specifications (N, Discriminant_Specifications); + Set_Unknown_Discriminants_Present + (N, Unknown_Discriminants_Present); + return N; + end Make_Incomplete_Type_Declaration; + + function Make_Explicit_Dereference (Sloc : Source_Ptr; + Prefix : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Explicit_Dereference, Sloc); + begin + Set_Prefix (N, Prefix); + return N; + end Make_Explicit_Dereference; + + function Make_Indexed_Component (Sloc : Source_Ptr; + Prefix : Node_Id; + Expressions : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Indexed_Component, Sloc); + begin + Set_Prefix (N, Prefix); + Set_Expressions (N, Expressions); + return N; + end Make_Indexed_Component; + + function Make_Slice (Sloc : Source_Ptr; + Prefix : Node_Id; + Discrete_Range : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Slice, Sloc); + begin + Set_Prefix (N, Prefix); + Set_Discrete_Range (N, Discrete_Range); + return N; + end Make_Slice; + + function Make_Selected_Component (Sloc : Source_Ptr; + Prefix : Node_Id; + Selector_Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Selected_Component, Sloc); + begin + Set_Prefix (N, Prefix); + Set_Selector_Name (N, Selector_Name); + return N; + end Make_Selected_Component; + + function Make_Attribute_Reference (Sloc : Source_Ptr; + Prefix : Node_Id; + Attribute_Name : Name_Id; + Expressions : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Attribute_Reference, Sloc); + begin + Set_Prefix (N, Prefix); + Set_Attribute_Name (N, Attribute_Name); + Set_Expressions (N, Expressions); + return N; + end Make_Attribute_Reference; + + function Make_Aggregate (Sloc : Source_Ptr; + Expressions : List_Id := No_List; + Component_Associations : List_Id := No_List; + Null_Record_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Aggregate, Sloc); + begin + Set_Expressions (N, Expressions); + Set_Component_Associations (N, Component_Associations); + Set_Null_Record_Present (N, Null_Record_Present); + return N; + end Make_Aggregate; + + function Make_Component_Association (Sloc : Source_Ptr; + Choices : List_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Component_Association, Sloc); + begin + Set_Choices (N, Choices); + Set_Expression (N, Expression); + return N; + end Make_Component_Association; + + function Make_Extension_Aggregate (Sloc : Source_Ptr; + Ancestor_Part : Node_Id; + Expressions : List_Id := No_List; + Component_Associations : List_Id := No_List; + Null_Record_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Extension_Aggregate, Sloc); + begin + Set_Ancestor_Part (N, Ancestor_Part); + Set_Expressions (N, Expressions); + Set_Component_Associations (N, Component_Associations); + Set_Null_Record_Present (N, Null_Record_Present); + return N; + end Make_Extension_Aggregate; + + function Make_Null (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Null, Sloc); + begin + return N; + end Make_Null; + + function Make_And_Then (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_And_Then, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + return N; + end Make_And_Then; + + function Make_Or_Else (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Or_Else, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + return N; + end Make_Or_Else; + + function Make_In (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_In, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + return N; + end Make_In; + + function Make_Not_In (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Not_In, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + return N; + end Make_Not_In; + + function Make_Op_And (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_And, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_And); + Set_Entity (N, Standard_Op_And); + return N; + end Make_Op_And; + + function Make_Op_Or (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Or, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Or); + Set_Entity (N, Standard_Op_Or); + return N; + end Make_Op_Or; + + function Make_Op_Xor (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Xor, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Xor); + Set_Entity (N, Standard_Op_Xor); + return N; + end Make_Op_Xor; + + function Make_Op_Eq (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Eq, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Eq); + Set_Entity (N, Standard_Op_Eq); + return N; + end Make_Op_Eq; + + function Make_Op_Ne (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Ne, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Ne); + Set_Entity (N, Standard_Op_Ne); + return N; + end Make_Op_Ne; + + function Make_Op_Lt (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Lt, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Lt); + Set_Entity (N, Standard_Op_Lt); + return N; + end Make_Op_Lt; + + function Make_Op_Le (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Le, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Le); + Set_Entity (N, Standard_Op_Le); + return N; + end Make_Op_Le; + + function Make_Op_Gt (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Gt, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Gt); + Set_Entity (N, Standard_Op_Gt); + return N; + end Make_Op_Gt; + + function Make_Op_Ge (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Ge, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Ge); + Set_Entity (N, Standard_Op_Ge); + return N; + end Make_Op_Ge; + + function Make_Op_Add (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Add, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Add); + Set_Entity (N, Standard_Op_Add); + return N; + end Make_Op_Add; + + function Make_Op_Subtract (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Subtract, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Subtract); + Set_Entity (N, Standard_Op_Subtract); + return N; + end Make_Op_Subtract; + + function Make_Op_Concat (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Concat, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Concat); + Set_Entity (N, Standard_Op_Concat); + return N; + end Make_Op_Concat; + + function Make_Op_Multiply (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Multiply, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Multiply); + Set_Entity (N, Standard_Op_Multiply); + return N; + end Make_Op_Multiply; + + function Make_Op_Divide (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Divide, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Divide); + Set_Entity (N, Standard_Op_Divide); + return N; + end Make_Op_Divide; + + function Make_Op_Mod (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Mod, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Mod); + Set_Entity (N, Standard_Op_Mod); + return N; + end Make_Op_Mod; + + function Make_Op_Rem (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Rem, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Rem); + Set_Entity (N, Standard_Op_Rem); + return N; + end Make_Op_Rem; + + function Make_Op_Expon (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Expon, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Expon); + Set_Entity (N, Standard_Op_Expon); + return N; + end Make_Op_Expon; + + function Make_Op_Plus (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Plus, Sloc); + begin + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Add); + Set_Entity (N, Standard_Op_Plus); + return N; + end Make_Op_Plus; + + function Make_Op_Minus (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Minus, Sloc); + begin + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Subtract); + Set_Entity (N, Standard_Op_Minus); + return N; + end Make_Op_Minus; + + function Make_Op_Abs (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Abs, Sloc); + begin + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Abs); + Set_Entity (N, Standard_Op_Abs); + return N; + end Make_Op_Abs; + + function Make_Op_Not (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Not, Sloc); + begin + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Op_Not); + Set_Entity (N, Standard_Op_Not); + return N; + end Make_Op_Not; + + function Make_Type_Conversion (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Type_Conversion, Sloc); + begin + Set_Subtype_Mark (N, Subtype_Mark); + Set_Expression (N, Expression); + return N; + end Make_Type_Conversion; + + function Make_Qualified_Expression (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Qualified_Expression, Sloc); + begin + Set_Subtype_Mark (N, Subtype_Mark); + Set_Expression (N, Expression); + return N; + end Make_Qualified_Expression; + + function Make_Allocator (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Allocator, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Allocator; + + function Make_Null_Statement (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Null_Statement, Sloc); + begin + return N; + end Make_Null_Statement; + + function Make_Label (Sloc : Source_Ptr; + Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Label, Sloc); + begin + Set_Identifier (N, Identifier); + return N; + end Make_Label; + + function Make_Assignment_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Assignment_Statement, Sloc); + begin + Set_Name (N, Name); + Set_Expression (N, Expression); + return N; + end Make_Assignment_Statement; + + function Make_If_Statement (Sloc : Source_Ptr; + Condition : Node_Id; + Then_Statements : List_Id; + Elsif_Parts : List_Id := No_List; + Else_Statements : List_Id := No_List; + End_Span : Uint := No_Uint) + return Node_Id + is + N : constant Node_Id := + New_Node (N_If_Statement, Sloc); + begin + Set_Condition (N, Condition); + Set_Then_Statements (N, Then_Statements); + Set_Elsif_Parts (N, Elsif_Parts); + Set_Else_Statements (N, Else_Statements); + Set_End_Span (N, End_Span); + return N; + end Make_If_Statement; + + function Make_Elsif_Part (Sloc : Source_Ptr; + Condition : Node_Id; + Then_Statements : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Elsif_Part, Sloc); + begin + Set_Condition (N, Condition); + Set_Then_Statements (N, Then_Statements); + return N; + end Make_Elsif_Part; + + function Make_Case_Statement (Sloc : Source_Ptr; + Expression : Node_Id; + Alternatives : List_Id; + End_Span : Uint := No_Uint) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Case_Statement, Sloc); + begin + Set_Expression (N, Expression); + Set_Alternatives (N, Alternatives); + Set_End_Span (N, End_Span); + return N; + end Make_Case_Statement; + + function Make_Case_Statement_Alternative (Sloc : Source_Ptr; + Discrete_Choices : List_Id; + Statements : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Case_Statement_Alternative, Sloc); + begin + Set_Discrete_Choices (N, Discrete_Choices); + Set_Statements (N, Statements); + return N; + end Make_Case_Statement_Alternative; + + function Make_Loop_Statement (Sloc : Source_Ptr; + Identifier : Node_Id := Empty; + Iteration_Scheme : Node_Id := Empty; + Statements : List_Id; + End_Label : Node_Id; + Has_Created_Identifier : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Loop_Statement, Sloc); + begin + Set_Identifier (N, Identifier); + Set_Iteration_Scheme (N, Iteration_Scheme); + Set_Statements (N, Statements); + Set_End_Label (N, End_Label); + Set_Has_Created_Identifier (N, Has_Created_Identifier); + return N; + end Make_Loop_Statement; + + function Make_Iteration_Scheme (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Loop_Parameter_Specification : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Iteration_Scheme, Sloc); + begin + Set_Condition (N, Condition); + Set_Loop_Parameter_Specification + (N, Loop_Parameter_Specification); + return N; + end Make_Iteration_Scheme; + + function Make_Loop_Parameter_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Reverse_Present : Boolean := False; + Discrete_Subtype_Definition : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Loop_Parameter_Specification, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Reverse_Present (N, Reverse_Present); + Set_Discrete_Subtype_Definition (N, Discrete_Subtype_Definition); + return N; + end Make_Loop_Parameter_Specification; + + function Make_Block_Statement (Sloc : Source_Ptr; + Identifier : Node_Id := Empty; + Declarations : List_Id := No_List; + Handled_Statement_Sequence : Node_Id; + Has_Created_Identifier : Boolean := False; + Is_Task_Allocation_Block : Boolean := False; + Is_Asynchronous_Call_Block : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Block_Statement, Sloc); + begin + Set_Identifier (N, Identifier); + Set_Declarations (N, Declarations); + Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); + Set_Has_Created_Identifier (N, Has_Created_Identifier); + Set_Is_Task_Allocation_Block (N, Is_Task_Allocation_Block); + Set_Is_Asynchronous_Call_Block (N, Is_Asynchronous_Call_Block); + return N; + end Make_Block_Statement; + + function Make_Exit_Statement (Sloc : Source_Ptr; + Name : Node_Id := Empty; + Condition : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Exit_Statement, Sloc); + begin + Set_Name (N, Name); + Set_Condition (N, Condition); + return N; + end Make_Exit_Statement; + + function Make_Goto_Statement (Sloc : Source_Ptr; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Goto_Statement, Sloc); + begin + Set_Name (N, Name); + return N; + end Make_Goto_Statement; + + function Make_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subprogram_Declaration, Sloc); + begin + Set_Specification (N, Specification); + return N; + end Make_Subprogram_Declaration; + + function Make_Abstract_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Abstract_Subprogram_Declaration, Sloc); + begin + Set_Specification (N, Specification); + return N; + end Make_Abstract_Subprogram_Declaration; + + function Make_Function_Specification (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Parameter_Specifications : List_Id := No_List; + Subtype_Mark : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Function_Specification, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Parameter_Specifications (N, Parameter_Specifications); + Set_Subtype_Mark (N, Subtype_Mark); + return N; + end Make_Function_Specification; + + function Make_Procedure_Specification (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Parameter_Specifications : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Procedure_Specification, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Parameter_Specifications (N, Parameter_Specifications); + return N; + end Make_Procedure_Specification; + + function Make_Designator (Sloc : Source_Ptr; + Name : Node_Id; + Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Designator, Sloc); + begin + Set_Name (N, Name); + Set_Identifier (N, Identifier); + return N; + end Make_Designator; + + function Make_Defining_Program_Unit_Name (Sloc : Source_Ptr; + Name : Node_Id; + Defining_Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Defining_Program_Unit_Name, Sloc); + begin + Set_Name (N, Name); + Set_Defining_Identifier (N, Defining_Identifier); + return N; + end Make_Defining_Program_Unit_Name; + + function Make_Operator_Symbol (Sloc : Source_Ptr; + Chars : Name_Id; + Strval : String_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Operator_Symbol, Sloc); + begin + Set_Chars (N, Chars); + Set_Strval (N, Strval); + return N; + end Make_Operator_Symbol; + + function Make_Defining_Operator_Symbol (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id + is + N : constant Node_Id := + New_Entity (N_Defining_Operator_Symbol, Sloc); + begin + Set_Chars (N, Chars); + return N; + end Make_Defining_Operator_Symbol; + + function Make_Parameter_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + In_Present : Boolean := False; + Out_Present : Boolean := False; + Parameter_Type : Node_Id; + Expression : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Parameter_Specification, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_In_Present (N, In_Present); + Set_Out_Present (N, Out_Present); + Set_Parameter_Type (N, Parameter_Type); + Set_Expression (N, Expression); + return N; + end Make_Parameter_Specification; + + function Make_Subprogram_Body (Sloc : Source_Ptr; + Specification : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id; + Bad_Is_Detected : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subprogram_Body, Sloc); + begin + Set_Specification (N, Specification); + Set_Declarations (N, Declarations); + Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); + Set_Bad_Is_Detected (N, Bad_Is_Detected); + return N; + end Make_Subprogram_Body; + + function Make_Procedure_Call_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Parameter_Associations : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Procedure_Call_Statement, Sloc); + begin + Set_Name (N, Name); + Set_Parameter_Associations (N, Parameter_Associations); + return N; + end Make_Procedure_Call_Statement; + + function Make_Function_Call (Sloc : Source_Ptr; + Name : Node_Id; + Parameter_Associations : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Function_Call, Sloc); + begin + Set_Name (N, Name); + Set_Parameter_Associations (N, Parameter_Associations); + return N; + end Make_Function_Call; + + function Make_Parameter_Association (Sloc : Source_Ptr; + Selector_Name : Node_Id; + Explicit_Actual_Parameter : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Parameter_Association, Sloc); + begin + Set_Selector_Name (N, Selector_Name); + Set_Explicit_Actual_Parameter (N, Explicit_Actual_Parameter); + return N; + end Make_Parameter_Association; + + function Make_Return_Statement (Sloc : Source_Ptr; + Expression : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Return_Statement, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Return_Statement; + + function Make_Package_Declaration (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Package_Declaration, Sloc); + begin + Set_Specification (N, Specification); + return N; + end Make_Package_Declaration; + + function Make_Package_Specification (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Visible_Declarations : List_Id; + Private_Declarations : List_Id := No_List; + End_Label : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Package_Specification, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Visible_Declarations (N, Visible_Declarations); + Set_Private_Declarations (N, Private_Declarations); + Set_End_Label (N, End_Label); + return N; + end Make_Package_Specification; + + function Make_Package_Body (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Package_Body, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Declarations (N, Declarations); + Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); + return N; + end Make_Package_Body; + + function Make_Private_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False; + Abstract_Present : Boolean := False; + Tagged_Present : Boolean := False; + Limited_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Private_Type_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discriminant_Specifications (N, Discriminant_Specifications); + Set_Unknown_Discriminants_Present + (N, Unknown_Discriminants_Present); + Set_Abstract_Present (N, Abstract_Present); + Set_Tagged_Present (N, Tagged_Present); + Set_Limited_Present (N, Limited_Present); + return N; + end Make_Private_Type_Declaration; + + function Make_Private_Extension_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False; + Abstract_Present : Boolean := False; + Subtype_Indication : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Private_Extension_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discriminant_Specifications (N, Discriminant_Specifications); + Set_Unknown_Discriminants_Present + (N, Unknown_Discriminants_Present); + Set_Abstract_Present (N, Abstract_Present); + Set_Subtype_Indication (N, Subtype_Indication); + return N; + end Make_Private_Extension_Declaration; + + function Make_Use_Package_Clause (Sloc : Source_Ptr; + Names : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Use_Package_Clause, Sloc); + begin + Set_Names (N, Names); + return N; + end Make_Use_Package_Clause; + + function Make_Use_Type_Clause (Sloc : Source_Ptr; + Subtype_Marks : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Use_Type_Clause, Sloc); + begin + Set_Subtype_Marks (N, Subtype_Marks); + return N; + end Make_Use_Type_Clause; + + function Make_Object_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Subtype_Mark : Node_Id; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Object_Renaming_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Subtype_Mark (N, Subtype_Mark); + Set_Name (N, Name); + return N; + end Make_Object_Renaming_Declaration; + + function Make_Exception_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Exception_Renaming_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Name (N, Name); + return N; + end Make_Exception_Renaming_Declaration; + + function Make_Package_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Package_Renaming_Declaration, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Name (N, Name); + return N; + end Make_Package_Renaming_Declaration; + + function Make_Subprogram_Renaming_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subprogram_Renaming_Declaration, Sloc); + begin + Set_Specification (N, Specification); + Set_Name (N, Name); + return N; + end Make_Subprogram_Renaming_Declaration; + + function Make_Generic_Package_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Generic_Package_Renaming_Declaration, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Name (N, Name); + return N; + end Make_Generic_Package_Renaming_Declaration; + + function Make_Generic_Procedure_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Generic_Procedure_Renaming_Declaration, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Name (N, Name); + return N; + end Make_Generic_Procedure_Renaming_Declaration; + + function Make_Generic_Function_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Generic_Function_Renaming_Declaration, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Name (N, Name); + return N; + end Make_Generic_Function_Renaming_Declaration; + + function Make_Task_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Task_Definition : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Task_Type_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discriminant_Specifications (N, Discriminant_Specifications); + Set_Task_Definition (N, Task_Definition); + return N; + end Make_Task_Type_Declaration; + + function Make_Single_Task_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Task_Definition : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Single_Task_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Task_Definition (N, Task_Definition); + return N; + end Make_Single_Task_Declaration; + + function Make_Task_Definition (Sloc : Source_Ptr; + Visible_Declarations : List_Id; + Private_Declarations : List_Id := No_List; + End_Label : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Task_Definition, Sloc); + begin + Set_Visible_Declarations (N, Visible_Declarations); + Set_Private_Declarations (N, Private_Declarations); + Set_End_Label (N, End_Label); + return N; + end Make_Task_Definition; + + function Make_Task_Body (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Task_Body, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Declarations (N, Declarations); + Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); + return N; + end Make_Task_Body; + + function Make_Protected_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Protected_Definition : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Protected_Type_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discriminant_Specifications (N, Discriminant_Specifications); + Set_Protected_Definition (N, Protected_Definition); + return N; + end Make_Protected_Type_Declaration; + + function Make_Single_Protected_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Protected_Definition : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Single_Protected_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Protected_Definition (N, Protected_Definition); + return N; + end Make_Single_Protected_Declaration; + + function Make_Protected_Definition (Sloc : Source_Ptr; + Visible_Declarations : List_Id; + Private_Declarations : List_Id := No_List; + End_Label : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Protected_Definition, Sloc); + begin + Set_Visible_Declarations (N, Visible_Declarations); + Set_Private_Declarations (N, Private_Declarations); + Set_End_Label (N, End_Label); + return N; + end Make_Protected_Definition; + + function Make_Protected_Body (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Declarations : List_Id; + End_Label : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Protected_Body, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Declarations (N, Declarations); + Set_End_Label (N, End_Label); + return N; + end Make_Protected_Body; + + function Make_Entry_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discrete_Subtype_Definition : Node_Id := Empty; + Parameter_Specifications : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Entry_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discrete_Subtype_Definition (N, Discrete_Subtype_Definition); + Set_Parameter_Specifications (N, Parameter_Specifications); + return N; + end Make_Entry_Declaration; + + function Make_Accept_Statement (Sloc : Source_Ptr; + Entry_Direct_Name : Node_Id; + Entry_Index : Node_Id := Empty; + Parameter_Specifications : List_Id := No_List; + Handled_Statement_Sequence : Node_Id; + Declarations : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Accept_Statement, Sloc); + begin + Set_Entry_Direct_Name (N, Entry_Direct_Name); + Set_Entry_Index (N, Entry_Index); + Set_Parameter_Specifications (N, Parameter_Specifications); + Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); + Set_Declarations (N, Declarations); + return N; + end Make_Accept_Statement; + + function Make_Entry_Body (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Entry_Body_Formal_Part : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Entry_Body, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Entry_Body_Formal_Part (N, Entry_Body_Formal_Part); + Set_Declarations (N, Declarations); + Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); + return N; + end Make_Entry_Body; + + function Make_Entry_Body_Formal_Part (Sloc : Source_Ptr; + Entry_Index_Specification : Node_Id := Empty; + Parameter_Specifications : List_Id := No_List; + Condition : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Entry_Body_Formal_Part, Sloc); + begin + Set_Entry_Index_Specification (N, Entry_Index_Specification); + Set_Parameter_Specifications (N, Parameter_Specifications); + Set_Condition (N, Condition); + return N; + end Make_Entry_Body_Formal_Part; + + function Make_Entry_Index_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discrete_Subtype_Definition : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Entry_Index_Specification, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Discrete_Subtype_Definition (N, Discrete_Subtype_Definition); + return N; + end Make_Entry_Index_Specification; + + function Make_Entry_Call_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Parameter_Associations : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Entry_Call_Statement, Sloc); + begin + Set_Name (N, Name); + Set_Parameter_Associations (N, Parameter_Associations); + return N; + end Make_Entry_Call_Statement; + + function Make_Requeue_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Abort_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Requeue_Statement, Sloc); + begin + Set_Name (N, Name); + Set_Abort_Present (N, Abort_Present); + return N; + end Make_Requeue_Statement; + + function Make_Delay_Until_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Delay_Until_Statement, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Delay_Until_Statement; + + function Make_Delay_Relative_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Delay_Relative_Statement, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Delay_Relative_Statement; + + function Make_Selective_Accept (Sloc : Source_Ptr; + Select_Alternatives : List_Id; + Else_Statements : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Selective_Accept, Sloc); + begin + Set_Select_Alternatives (N, Select_Alternatives); + Set_Else_Statements (N, Else_Statements); + return N; + end Make_Selective_Accept; + + function Make_Accept_Alternative (Sloc : Source_Ptr; + Accept_Statement : Node_Id; + Condition : Node_Id := Empty; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Accept_Alternative, Sloc); + begin + Set_Accept_Statement (N, Accept_Statement); + Set_Condition (N, Condition); + Set_Statements (N, Statements); + Set_Pragmas_Before (N, Pragmas_Before); + return N; + end Make_Accept_Alternative; + + function Make_Delay_Alternative (Sloc : Source_Ptr; + Delay_Statement : Node_Id; + Condition : Node_Id := Empty; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Delay_Alternative, Sloc); + begin + Set_Delay_Statement (N, Delay_Statement); + Set_Condition (N, Condition); + Set_Statements (N, Statements); + Set_Pragmas_Before (N, Pragmas_Before); + return N; + end Make_Delay_Alternative; + + function Make_Terminate_Alternative (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Pragmas_Before : List_Id := No_List; + Pragmas_After : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Terminate_Alternative, Sloc); + begin + Set_Condition (N, Condition); + Set_Pragmas_Before (N, Pragmas_Before); + Set_Pragmas_After (N, Pragmas_After); + return N; + end Make_Terminate_Alternative; + + function Make_Timed_Entry_Call (Sloc : Source_Ptr; + Entry_Call_Alternative : Node_Id; + Delay_Alternative : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Timed_Entry_Call, Sloc); + begin + Set_Entry_Call_Alternative (N, Entry_Call_Alternative); + Set_Delay_Alternative (N, Delay_Alternative); + return N; + end Make_Timed_Entry_Call; + + function Make_Entry_Call_Alternative (Sloc : Source_Ptr; + Entry_Call_Statement : Node_Id; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Entry_Call_Alternative, Sloc); + begin + Set_Entry_Call_Statement (N, Entry_Call_Statement); + Set_Statements (N, Statements); + Set_Pragmas_Before (N, Pragmas_Before); + return N; + end Make_Entry_Call_Alternative; + + function Make_Conditional_Entry_Call (Sloc : Source_Ptr; + Entry_Call_Alternative : Node_Id; + Else_Statements : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Conditional_Entry_Call, Sloc); + begin + Set_Entry_Call_Alternative (N, Entry_Call_Alternative); + Set_Else_Statements (N, Else_Statements); + return N; + end Make_Conditional_Entry_Call; + + function Make_Asynchronous_Select (Sloc : Source_Ptr; + Triggering_Alternative : Node_Id; + Abortable_Part : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Asynchronous_Select, Sloc); + begin + Set_Triggering_Alternative (N, Triggering_Alternative); + Set_Abortable_Part (N, Abortable_Part); + return N; + end Make_Asynchronous_Select; + + function Make_Triggering_Alternative (Sloc : Source_Ptr; + Triggering_Statement : Node_Id; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Triggering_Alternative, Sloc); + begin + Set_Triggering_Statement (N, Triggering_Statement); + Set_Statements (N, Statements); + Set_Pragmas_Before (N, Pragmas_Before); + return N; + end Make_Triggering_Alternative; + + function Make_Abortable_Part (Sloc : Source_Ptr; + Statements : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Abortable_Part, Sloc); + begin + Set_Statements (N, Statements); + return N; + end Make_Abortable_Part; + + function Make_Abort_Statement (Sloc : Source_Ptr; + Names : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Abort_Statement, Sloc); + begin + Set_Names (N, Names); + return N; + end Make_Abort_Statement; + + function Make_Compilation_Unit (Sloc : Source_Ptr; + Context_Items : List_Id; + Private_Present : Boolean := False; + Unit : Node_Id; + Aux_Decls_Node : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Compilation_Unit, Sloc); + begin + Set_Context_Items (N, Context_Items); + Set_Private_Present (N, Private_Present); + Set_Unit (N, Unit); + Set_Aux_Decls_Node (N, Aux_Decls_Node); + return N; + end Make_Compilation_Unit; + + function Make_Compilation_Unit_Aux (Sloc : Source_Ptr; + Declarations : List_Id := No_List; + Actions : List_Id := No_List; + Pragmas_After : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Compilation_Unit_Aux, Sloc); + begin + Set_Declarations (N, Declarations); + Set_Actions (N, Actions); + Set_Pragmas_After (N, Pragmas_After); + return N; + end Make_Compilation_Unit_Aux; + + function Make_With_Clause (Sloc : Source_Ptr; + Name : Node_Id; + First_Name : Boolean := True; + Last_Name : Boolean := True) + return Node_Id + is + N : constant Node_Id := + New_Node (N_With_Clause, Sloc); + begin + Set_Name (N, Name); + Set_First_Name (N, First_Name); + Set_Last_Name (N, Last_Name); + return N; + end Make_With_Clause; + + function Make_With_Type_Clause (Sloc : Source_Ptr; + Name : Node_Id; + Tagged_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_With_Type_Clause, Sloc); + begin + Set_Name (N, Name); + Set_Tagged_Present (N, Tagged_Present); + return N; + end Make_With_Type_Clause; + + function Make_Subprogram_Body_Stub (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subprogram_Body_Stub, Sloc); + begin + Set_Specification (N, Specification); + return N; + end Make_Subprogram_Body_Stub; + + function Make_Package_Body_Stub (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Package_Body_Stub, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + return N; + end Make_Package_Body_Stub; + + function Make_Task_Body_Stub (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Task_Body_Stub, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + return N; + end Make_Task_Body_Stub; + + function Make_Protected_Body_Stub (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Protected_Body_Stub, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + return N; + end Make_Protected_Body_Stub; + + function Make_Subunit (Sloc : Source_Ptr; + Name : Node_Id; + Proper_Body : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subunit, Sloc); + begin + Set_Name (N, Name); + Set_Proper_Body (N, Proper_Body); + return N; + end Make_Subunit; + + function Make_Exception_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Exception_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + return N; + end Make_Exception_Declaration; + + function Make_Handled_Sequence_Of_Statements (Sloc : Source_Ptr; + Statements : List_Id; + End_Label : Node_Id := Empty; + Exception_Handlers : List_Id := No_List; + At_End_Proc : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Handled_Sequence_Of_Statements, Sloc); + begin + Set_Statements (N, Statements); + Set_End_Label (N, End_Label); + Set_Exception_Handlers (N, Exception_Handlers); + Set_At_End_Proc (N, At_End_Proc); + return N; + end Make_Handled_Sequence_Of_Statements; + + function Make_Exception_Handler (Sloc : Source_Ptr; + Choice_Parameter : Node_Id := Empty; + Exception_Choices : List_Id; + Statements : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Exception_Handler, Sloc); + begin + Set_Choice_Parameter (N, Choice_Parameter); + Set_Exception_Choices (N, Exception_Choices); + Set_Statements (N, Statements); + return N; + end Make_Exception_Handler; + + function Make_Raise_Statement (Sloc : Source_Ptr; + Name : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Raise_Statement, Sloc); + begin + Set_Name (N, Name); + return N; + end Make_Raise_Statement; + + function Make_Generic_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Generic_Formal_Declarations : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Generic_Subprogram_Declaration, Sloc); + begin + Set_Specification (N, Specification); + Set_Generic_Formal_Declarations (N, Generic_Formal_Declarations); + return N; + end Make_Generic_Subprogram_Declaration; + + function Make_Generic_Package_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Generic_Formal_Declarations : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Generic_Package_Declaration, Sloc); + begin + Set_Specification (N, Specification); + Set_Generic_Formal_Declarations (N, Generic_Formal_Declarations); + return N; + end Make_Generic_Package_Declaration; + + function Make_Package_Instantiation (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Package_Instantiation, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Name (N, Name); + Set_Generic_Associations (N, Generic_Associations); + return N; + end Make_Package_Instantiation; + + function Make_Procedure_Instantiation (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Procedure_Instantiation, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Name (N, Name); + Set_Generic_Associations (N, Generic_Associations); + return N; + end Make_Procedure_Instantiation; + + function Make_Function_Instantiation (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Function_Instantiation, Sloc); + begin + Set_Defining_Unit_Name (N, Defining_Unit_Name); + Set_Name (N, Name); + Set_Generic_Associations (N, Generic_Associations); + return N; + end Make_Function_Instantiation; + + function Make_Generic_Association (Sloc : Source_Ptr; + Selector_Name : Node_Id := Empty; + Explicit_Generic_Actual_Parameter : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Generic_Association, Sloc); + begin + Set_Selector_Name (N, Selector_Name); + Set_Explicit_Generic_Actual_Parameter + (N, Explicit_Generic_Actual_Parameter); + return N; + end Make_Generic_Association; + + function Make_Formal_Object_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + In_Present : Boolean := False; + Out_Present : Boolean := False; + Subtype_Mark : Node_Id; + Expression : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Object_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_In_Present (N, In_Present); + Set_Out_Present (N, Out_Present); + Set_Subtype_Mark (N, Subtype_Mark); + Set_Expression (N, Expression); + return N; + end Make_Formal_Object_Declaration; + + function Make_Formal_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Formal_Type_Definition : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Type_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Formal_Type_Definition (N, Formal_Type_Definition); + Set_Discriminant_Specifications (N, Discriminant_Specifications); + Set_Unknown_Discriminants_Present + (N, Unknown_Discriminants_Present); + return N; + end Make_Formal_Type_Declaration; + + function Make_Formal_Private_Type_Definition (Sloc : Source_Ptr; + Abstract_Present : Boolean := False; + Tagged_Present : Boolean := False; + Limited_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Private_Type_Definition, Sloc); + begin + Set_Abstract_Present (N, Abstract_Present); + Set_Tagged_Present (N, Tagged_Present); + Set_Limited_Present (N, Limited_Present); + return N; + end Make_Formal_Private_Type_Definition; + + function Make_Formal_Derived_Type_Definition (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Private_Present : Boolean := False; + Abstract_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Derived_Type_Definition, Sloc); + begin + Set_Subtype_Mark (N, Subtype_Mark); + Set_Private_Present (N, Private_Present); + Set_Abstract_Present (N, Abstract_Present); + return N; + end Make_Formal_Derived_Type_Definition; + + function Make_Formal_Discrete_Type_Definition (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Discrete_Type_Definition, Sloc); + begin + return N; + end Make_Formal_Discrete_Type_Definition; + + function Make_Formal_Signed_Integer_Type_Definition (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Signed_Integer_Type_Definition, Sloc); + begin + return N; + end Make_Formal_Signed_Integer_Type_Definition; + + function Make_Formal_Modular_Type_Definition (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Modular_Type_Definition, Sloc); + begin + return N; + end Make_Formal_Modular_Type_Definition; + + function Make_Formal_Floating_Point_Definition (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Floating_Point_Definition, Sloc); + begin + return N; + end Make_Formal_Floating_Point_Definition; + + function Make_Formal_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Sloc); + begin + return N; + end Make_Formal_Ordinary_Fixed_Point_Definition; + + function Make_Formal_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Decimal_Fixed_Point_Definition, Sloc); + begin + return N; + end Make_Formal_Decimal_Fixed_Point_Definition; + + function Make_Formal_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Default_Name : Node_Id := Empty; + Box_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Subprogram_Declaration, Sloc); + begin + Set_Specification (N, Specification); + Set_Default_Name (N, Default_Name); + Set_Box_Present (N, Box_Present); + return N; + end Make_Formal_Subprogram_Declaration; + + function Make_Formal_Package_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List; + Box_Present : Boolean := False) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Formal_Package_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + Set_Name (N, Name); + Set_Generic_Associations (N, Generic_Associations); + Set_Box_Present (N, Box_Present); + return N; + end Make_Formal_Package_Declaration; + + function Make_Attribute_Definition_Clause (Sloc : Source_Ptr; + Name : Node_Id; + Chars : Name_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Attribute_Definition_Clause, Sloc); + begin + Set_Name (N, Name); + Set_Chars (N, Chars); + Set_Expression (N, Expression); + return N; + end Make_Attribute_Definition_Clause; + + function Make_Enumeration_Representation_Clause (Sloc : Source_Ptr; + Identifier : Node_Id; + Array_Aggregate : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Enumeration_Representation_Clause, Sloc); + begin + Set_Identifier (N, Identifier); + Set_Array_Aggregate (N, Array_Aggregate); + return N; + end Make_Enumeration_Representation_Clause; + + function Make_Record_Representation_Clause (Sloc : Source_Ptr; + Identifier : Node_Id; + Mod_Clause : Node_Id := Empty; + Component_Clauses : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Record_Representation_Clause, Sloc); + begin + Set_Identifier (N, Identifier); + Set_Mod_Clause (N, Mod_Clause); + Set_Component_Clauses (N, Component_Clauses); + return N; + end Make_Record_Representation_Clause; + + function Make_Component_Clause (Sloc : Source_Ptr; + Component_Name : Node_Id; + Position : Node_Id; + First_Bit : Node_Id; + Last_Bit : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Component_Clause, Sloc); + begin + Set_Component_Name (N, Component_Name); + Set_Position (N, Position); + Set_First_Bit (N, First_Bit); + Set_Last_Bit (N, Last_Bit); + return N; + end Make_Component_Clause; + + function Make_Code_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Code_Statement, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Code_Statement; + + function Make_Op_Rotate_Left (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Rotate_Left, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Rotate_Left); + Set_Entity (N, Standard_Op_Rotate_Left); + return N; + end Make_Op_Rotate_Left; + + function Make_Op_Rotate_Right (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Rotate_Right, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Rotate_Right); + Set_Entity (N, Standard_Op_Rotate_Right); + return N; + end Make_Op_Rotate_Right; + + function Make_Op_Shift_Left (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Shift_Left, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Shift_Left); + Set_Entity (N, Standard_Op_Shift_Left); + return N; + end Make_Op_Shift_Left; + + function Make_Op_Shift_Right_Arithmetic (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Shift_Right_Arithmetic, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Shift_Right_Arithmetic); + Set_Entity (N, Standard_Op_Shift_Right_Arithmetic); + return N; + end Make_Op_Shift_Right_Arithmetic; + + function Make_Op_Shift_Right (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Op_Shift_Right, Sloc); + begin + Set_Left_Opnd (N, Left_Opnd); + Set_Right_Opnd (N, Right_Opnd); + Set_Chars (N, Name_Shift_Right); + Set_Entity (N, Standard_Op_Shift_Right); + return N; + end Make_Op_Shift_Right; + + function Make_Delta_Constraint (Sloc : Source_Ptr; + Delta_Expression : Node_Id; + Range_Constraint : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Delta_Constraint, Sloc); + begin + Set_Delta_Expression (N, Delta_Expression); + Set_Range_Constraint (N, Range_Constraint); + return N; + end Make_Delta_Constraint; + + function Make_At_Clause (Sloc : Source_Ptr; + Identifier : Node_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_At_Clause, Sloc); + begin + Set_Identifier (N, Identifier); + Set_Expression (N, Expression); + return N; + end Make_At_Clause; + + function Make_Mod_Clause (Sloc : Source_Ptr; + Expression : Node_Id; + Pragmas_Before : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Mod_Clause, Sloc); + begin + Set_Expression (N, Expression); + Set_Pragmas_Before (N, Pragmas_Before); + return N; + end Make_Mod_Clause; + + function Make_Conditional_Expression (Sloc : Source_Ptr; + Expressions : List_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Conditional_Expression, Sloc); + begin + Set_Expressions (N, Expressions); + return N; + end Make_Conditional_Expression; + + function Make_Expanded_Name (Sloc : Source_Ptr; + Chars : Name_Id; + Prefix : Node_Id; + Selector_Name : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Expanded_Name, Sloc); + begin + Set_Chars (N, Chars); + Set_Prefix (N, Prefix); + Set_Selector_Name (N, Selector_Name); + return N; + end Make_Expanded_Name; + + function Make_Free_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Free_Statement, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Free_Statement; + + function Make_Freeze_Entity (Sloc : Source_Ptr; + Actions : List_Id := No_List) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Freeze_Entity, Sloc); + begin + Set_Actions (N, Actions); + return N; + end Make_Freeze_Entity; + + function Make_Implicit_Label_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Implicit_Label_Declaration, Sloc); + begin + Set_Defining_Identifier (N, Defining_Identifier); + return N; + end Make_Implicit_Label_Declaration; + + function Make_Itype_Reference (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Itype_Reference, Sloc); + begin + return N; + end Make_Itype_Reference; + + function Make_Raise_Constraint_Error (Sloc : Source_Ptr; + Condition : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Raise_Constraint_Error, Sloc); + begin + Set_Condition (N, Condition); + return N; + end Make_Raise_Constraint_Error; + + function Make_Raise_Program_Error (Sloc : Source_Ptr; + Condition : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Raise_Program_Error, Sloc); + begin + Set_Condition (N, Condition); + return N; + end Make_Raise_Program_Error; + + function Make_Raise_Storage_Error (Sloc : Source_Ptr; + Condition : Node_Id := Empty) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Raise_Storage_Error, Sloc); + begin + Set_Condition (N, Condition); + return N; + end Make_Raise_Storage_Error; + + function Make_Reference (Sloc : Source_Ptr; + Prefix : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Reference, Sloc); + begin + Set_Prefix (N, Prefix); + return N; + end Make_Reference; + + function Make_Subprogram_Info (Sloc : Source_Ptr; + Identifier : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Subprogram_Info, Sloc); + begin + Set_Identifier (N, Identifier); + return N; + end Make_Subprogram_Info; + + function Make_Unchecked_Expression (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Unchecked_Expression, Sloc); + begin + Set_Expression (N, Expression); + return N; + end Make_Unchecked_Expression; + + function Make_Unchecked_Type_Conversion (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Expression : Node_Id) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Unchecked_Type_Conversion, Sloc); + begin + Set_Subtype_Mark (N, Subtype_Mark); + Set_Expression (N, Expression); + return N; + end Make_Unchecked_Type_Conversion; + + function Make_Validate_Unchecked_Conversion (Sloc : Source_Ptr) + return Node_Id + is + N : constant Node_Id := + New_Node (N_Validate_Unchecked_Conversion, Sloc); + begin + return N; + end Make_Validate_Unchecked_Conversion; + +end Nmake; diff --git a/gcc/ada/nmake.ads b/gcc/ada/nmake.ads new file mode 100644 index 00000000000..55f57c40bdd --- /dev/null +++ b/gcc/ada/nmake.ads @@ -0,0 +1,1343 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N M A K E -- +-- -- +-- S p e c -- +-- -- +-- Generated by xnmake revision 1.25 using -- +-- sinfo.ads revision 1.430 -- +-- nmake.adt revision 1.12 -- +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram order checking, since the routines here are +-- generated automatically in order. + + +with Nlists; use Nlists; +with Types; use Types; +with Uintp; use Uintp; +with Urealp; use Urealp; + +package Nmake is + +-- This package contains a set of routines used to construct tree nodes +-- using a functional style. There is one routine for each node type defined +-- in Sinfo with the general interface: + +-- function Make_xxx (Sloc : Source_Ptr, +-- Field_Name_1 : Field_Name_1_Type [:= default] +-- Field_Name_2 : Field_Name_2_Type [:= default] +-- ...) +-- return Node_Id + +-- Only syntactic fields are included (i.e. fields marked as "-Sem" or "-Lib" +-- in the Sinfo spec are excluded). In addition, the following four syntactic +-- fields are excluded: + +-- Prev_Ids +-- More_Ids +-- Comes_From_Source +-- Paren_Count + +-- since they are very rarely set in expanded code. If they need to be set, +-- to other than the default values (False, False, False, zero), then the +-- appropriate Set_xxx procedures must be used on the returned value. + +-- Default values are provided only for flag fields (where the default is +-- False), and for optional fields. An optional field is one where the +-- comment line describing the field contains the string "(set to xxx if". +-- For such fields, a default value of xxx is provided." + +-- Warning: since calls to Make_xxx routines are normal function calls, the +-- arguments can be evaluated in any order. This means that at most one such +-- argument can have side effects (e.g. be a call to a parse routine). + + function Make_Unused_At_Start (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Unused_At_Start); + + function Make_Unused_At_End (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Unused_At_End); + + function Make_Identifier (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id; + pragma Inline (Make_Identifier); + + function Make_Integer_Literal (Sloc : Source_Ptr; + Intval : Uint) + return Node_Id; + pragma Inline (Make_Integer_Literal); + + function Make_Real_Literal (Sloc : Source_Ptr; + Realval : Ureal) + return Node_Id; + pragma Inline (Make_Real_Literal); + + function Make_Character_Literal (Sloc : Source_Ptr; + Chars : Name_Id; + Char_Literal_Value : Char_Code) + return Node_Id; + pragma Inline (Make_Character_Literal); + + function Make_String_Literal (Sloc : Source_Ptr; + Strval : String_Id) + return Node_Id; + pragma Inline (Make_String_Literal); + + function Make_Pragma (Sloc : Source_Ptr; + Chars : Name_Id; + Pragma_Argument_Associations : List_Id := No_List; + Debug_Statement : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Pragma); + + function Make_Pragma_Argument_Association (Sloc : Source_Ptr; + Chars : Name_Id := No_Name; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Pragma_Argument_Association); + + function Make_Defining_Identifier (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id; + pragma Inline (Make_Defining_Identifier); + + function Make_Full_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Type_Definition : Node_Id) + return Node_Id; + pragma Inline (Make_Full_Type_Declaration); + + function Make_Subtype_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Subtype_Indication : Node_Id) + return Node_Id; + pragma Inline (Make_Subtype_Declaration); + + function Make_Subtype_Indication (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Constraint : Node_Id) + return Node_Id; + pragma Inline (Make_Subtype_Indication); + + function Make_Object_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Aliased_Present : Boolean := False; + Constant_Present : Boolean := False; + Object_Definition : Node_Id; + Expression : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Object_Declaration); + + function Make_Number_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Number_Declaration); + + function Make_Derived_Type_Definition (Sloc : Source_Ptr; + Abstract_Present : Boolean := False; + Subtype_Indication : Node_Id; + Record_Extension_Part : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Derived_Type_Definition); + + function Make_Range_Constraint (Sloc : Source_Ptr; + Range_Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Range_Constraint); + + function Make_Range (Sloc : Source_Ptr; + Low_Bound : Node_Id; + High_Bound : Node_Id; + Includes_Infinities : Boolean := False) + return Node_Id; + pragma Inline (Make_Range); + + function Make_Enumeration_Type_Definition (Sloc : Source_Ptr; + Literals : List_Id) + return Node_Id; + pragma Inline (Make_Enumeration_Type_Definition); + + function Make_Defining_Character_Literal (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id; + pragma Inline (Make_Defining_Character_Literal); + + function Make_Signed_Integer_Type_Definition (Sloc : Source_Ptr; + Low_Bound : Node_Id; + High_Bound : Node_Id) + return Node_Id; + pragma Inline (Make_Signed_Integer_Type_Definition); + + function Make_Modular_Type_Definition (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Modular_Type_Definition); + + function Make_Floating_Point_Definition (Sloc : Source_Ptr; + Digits_Expression : Node_Id; + Real_Range_Specification : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Floating_Point_Definition); + + function Make_Real_Range_Specification (Sloc : Source_Ptr; + Low_Bound : Node_Id; + High_Bound : Node_Id) + return Node_Id; + pragma Inline (Make_Real_Range_Specification); + + function Make_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr; + Delta_Expression : Node_Id; + Real_Range_Specification : Node_Id) + return Node_Id; + pragma Inline (Make_Ordinary_Fixed_Point_Definition); + + function Make_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr; + Delta_Expression : Node_Id; + Digits_Expression : Node_Id; + Real_Range_Specification : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Decimal_Fixed_Point_Definition); + + function Make_Digits_Constraint (Sloc : Source_Ptr; + Digits_Expression : Node_Id; + Range_Constraint : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Digits_Constraint); + + function Make_Unconstrained_Array_Definition (Sloc : Source_Ptr; + Subtype_Marks : List_Id; + Aliased_Present : Boolean := False; + Subtype_Indication : Node_Id) + return Node_Id; + pragma Inline (Make_Unconstrained_Array_Definition); + + function Make_Constrained_Array_Definition (Sloc : Source_Ptr; + Discrete_Subtype_Definitions : List_Id; + Aliased_Present : Boolean := False; + Subtype_Indication : Node_Id) + return Node_Id; + pragma Inline (Make_Constrained_Array_Definition); + + function Make_Discriminant_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Type : Node_Id; + Expression : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Discriminant_Specification); + + function Make_Index_Or_Discriminant_Constraint (Sloc : Source_Ptr; + Constraints : List_Id) + return Node_Id; + pragma Inline (Make_Index_Or_Discriminant_Constraint); + + function Make_Discriminant_Association (Sloc : Source_Ptr; + Selector_Names : List_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Discriminant_Association); + + function Make_Record_Definition (Sloc : Source_Ptr; + End_Label : Node_Id := Empty; + Abstract_Present : Boolean := False; + Tagged_Present : Boolean := False; + Limited_Present : Boolean := False; + Component_List : Node_Id; + Null_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Record_Definition); + + function Make_Component_List (Sloc : Source_Ptr; + Component_Items : List_Id; + Variant_Part : Node_Id := Empty; + Null_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Component_List); + + function Make_Component_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Aliased_Present : Boolean := False; + Subtype_Indication : Node_Id; + Expression : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Component_Declaration); + + function Make_Variant_Part (Sloc : Source_Ptr; + Name : Node_Id; + Variants : List_Id) + return Node_Id; + pragma Inline (Make_Variant_Part); + + function Make_Variant (Sloc : Source_Ptr; + Discrete_Choices : List_Id; + Component_List : Node_Id) + return Node_Id; + pragma Inline (Make_Variant); + + function Make_Others_Choice (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Others_Choice); + + function Make_Access_To_Object_Definition (Sloc : Source_Ptr; + All_Present : Boolean := False; + Subtype_Indication : Node_Id; + Constant_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Access_To_Object_Definition); + + function Make_Access_Function_Definition (Sloc : Source_Ptr; + Protected_Present : Boolean := False; + Parameter_Specifications : List_Id := No_List; + Subtype_Mark : Node_Id) + return Node_Id; + pragma Inline (Make_Access_Function_Definition); + + function Make_Access_Procedure_Definition (Sloc : Source_Ptr; + Protected_Present : Boolean := False; + Parameter_Specifications : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Access_Procedure_Definition); + + function Make_Access_Definition (Sloc : Source_Ptr; + Subtype_Mark : Node_Id) + return Node_Id; + pragma Inline (Make_Access_Definition); + + function Make_Incomplete_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Incomplete_Type_Declaration); + + function Make_Explicit_Dereference (Sloc : Source_Ptr; + Prefix : Node_Id) + return Node_Id; + pragma Inline (Make_Explicit_Dereference); + + function Make_Indexed_Component (Sloc : Source_Ptr; + Prefix : Node_Id; + Expressions : List_Id) + return Node_Id; + pragma Inline (Make_Indexed_Component); + + function Make_Slice (Sloc : Source_Ptr; + Prefix : Node_Id; + Discrete_Range : Node_Id) + return Node_Id; + pragma Inline (Make_Slice); + + function Make_Selected_Component (Sloc : Source_Ptr; + Prefix : Node_Id; + Selector_Name : Node_Id) + return Node_Id; + pragma Inline (Make_Selected_Component); + + function Make_Attribute_Reference (Sloc : Source_Ptr; + Prefix : Node_Id; + Attribute_Name : Name_Id; + Expressions : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Attribute_Reference); + + function Make_Aggregate (Sloc : Source_Ptr; + Expressions : List_Id := No_List; + Component_Associations : List_Id := No_List; + Null_Record_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Aggregate); + + function Make_Component_Association (Sloc : Source_Ptr; + Choices : List_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Component_Association); + + function Make_Extension_Aggregate (Sloc : Source_Ptr; + Ancestor_Part : Node_Id; + Expressions : List_Id := No_List; + Component_Associations : List_Id := No_List; + Null_Record_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Extension_Aggregate); + + function Make_Null (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Null); + + function Make_And_Then (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_And_Then); + + function Make_Or_Else (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Or_Else); + + function Make_In (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_In); + + function Make_Not_In (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Not_In); + + function Make_Op_And (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_And); + + function Make_Op_Or (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Or); + + function Make_Op_Xor (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Xor); + + function Make_Op_Eq (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Eq); + + function Make_Op_Ne (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Ne); + + function Make_Op_Lt (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Lt); + + function Make_Op_Le (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Le); + + function Make_Op_Gt (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Gt); + + function Make_Op_Ge (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Ge); + + function Make_Op_Add (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Add); + + function Make_Op_Subtract (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Subtract); + + function Make_Op_Concat (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Concat); + + function Make_Op_Multiply (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Multiply); + + function Make_Op_Divide (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Divide); + + function Make_Op_Mod (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Mod); + + function Make_Op_Rem (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Rem); + + function Make_Op_Expon (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Expon); + + function Make_Op_Plus (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Plus); + + function Make_Op_Minus (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Minus); + + function Make_Op_Abs (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Abs); + + function Make_Op_Not (Sloc : Source_Ptr; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Not); + + function Make_Type_Conversion (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Type_Conversion); + + function Make_Qualified_Expression (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Qualified_Expression); + + function Make_Allocator (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Allocator); + + function Make_Null_Statement (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Null_Statement); + + function Make_Label (Sloc : Source_Ptr; + Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Label); + + function Make_Assignment_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Assignment_Statement); + + function Make_If_Statement (Sloc : Source_Ptr; + Condition : Node_Id; + Then_Statements : List_Id; + Elsif_Parts : List_Id := No_List; + Else_Statements : List_Id := No_List; + End_Span : Uint := No_Uint) + return Node_Id; + pragma Inline (Make_If_Statement); + + function Make_Elsif_Part (Sloc : Source_Ptr; + Condition : Node_Id; + Then_Statements : List_Id) + return Node_Id; + pragma Inline (Make_Elsif_Part); + + function Make_Case_Statement (Sloc : Source_Ptr; + Expression : Node_Id; + Alternatives : List_Id; + End_Span : Uint := No_Uint) + return Node_Id; + pragma Inline (Make_Case_Statement); + + function Make_Case_Statement_Alternative (Sloc : Source_Ptr; + Discrete_Choices : List_Id; + Statements : List_Id) + return Node_Id; + pragma Inline (Make_Case_Statement_Alternative); + + function Make_Loop_Statement (Sloc : Source_Ptr; + Identifier : Node_Id := Empty; + Iteration_Scheme : Node_Id := Empty; + Statements : List_Id; + End_Label : Node_Id; + Has_Created_Identifier : Boolean := False) + return Node_Id; + pragma Inline (Make_Loop_Statement); + + function Make_Iteration_Scheme (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Loop_Parameter_Specification : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Iteration_Scheme); + + function Make_Loop_Parameter_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Reverse_Present : Boolean := False; + Discrete_Subtype_Definition : Node_Id) + return Node_Id; + pragma Inline (Make_Loop_Parameter_Specification); + + function Make_Block_Statement (Sloc : Source_Ptr; + Identifier : Node_Id := Empty; + Declarations : List_Id := No_List; + Handled_Statement_Sequence : Node_Id; + Has_Created_Identifier : Boolean := False; + Is_Task_Allocation_Block : Boolean := False; + Is_Asynchronous_Call_Block : Boolean := False) + return Node_Id; + pragma Inline (Make_Block_Statement); + + function Make_Exit_Statement (Sloc : Source_Ptr; + Name : Node_Id := Empty; + Condition : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Exit_Statement); + + function Make_Goto_Statement (Sloc : Source_Ptr; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Goto_Statement); + + function Make_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id; + pragma Inline (Make_Subprogram_Declaration); + + function Make_Abstract_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id; + pragma Inline (Make_Abstract_Subprogram_Declaration); + + function Make_Function_Specification (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Parameter_Specifications : List_Id := No_List; + Subtype_Mark : Node_Id) + return Node_Id; + pragma Inline (Make_Function_Specification); + + function Make_Procedure_Specification (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Parameter_Specifications : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Procedure_Specification); + + function Make_Designator (Sloc : Source_Ptr; + Name : Node_Id; + Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Designator); + + function Make_Defining_Program_Unit_Name (Sloc : Source_Ptr; + Name : Node_Id; + Defining_Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Defining_Program_Unit_Name); + + function Make_Operator_Symbol (Sloc : Source_Ptr; + Chars : Name_Id; + Strval : String_Id) + return Node_Id; + pragma Inline (Make_Operator_Symbol); + + function Make_Defining_Operator_Symbol (Sloc : Source_Ptr; + Chars : Name_Id) + return Node_Id; + pragma Inline (Make_Defining_Operator_Symbol); + + function Make_Parameter_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + In_Present : Boolean := False; + Out_Present : Boolean := False; + Parameter_Type : Node_Id; + Expression : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Parameter_Specification); + + function Make_Subprogram_Body (Sloc : Source_Ptr; + Specification : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id; + Bad_Is_Detected : Boolean := False) + return Node_Id; + pragma Inline (Make_Subprogram_Body); + + function Make_Procedure_Call_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Parameter_Associations : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Procedure_Call_Statement); + + function Make_Function_Call (Sloc : Source_Ptr; + Name : Node_Id; + Parameter_Associations : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Function_Call); + + function Make_Parameter_Association (Sloc : Source_Ptr; + Selector_Name : Node_Id; + Explicit_Actual_Parameter : Node_Id) + return Node_Id; + pragma Inline (Make_Parameter_Association); + + function Make_Return_Statement (Sloc : Source_Ptr; + Expression : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Return_Statement); + + function Make_Package_Declaration (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id; + pragma Inline (Make_Package_Declaration); + + function Make_Package_Specification (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Visible_Declarations : List_Id; + Private_Declarations : List_Id := No_List; + End_Label : Node_Id) + return Node_Id; + pragma Inline (Make_Package_Specification); + + function Make_Package_Body (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Package_Body); + + function Make_Private_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False; + Abstract_Present : Boolean := False; + Tagged_Present : Boolean := False; + Limited_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Private_Type_Declaration); + + function Make_Private_Extension_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False; + Abstract_Present : Boolean := False; + Subtype_Indication : Node_Id) + return Node_Id; + pragma Inline (Make_Private_Extension_Declaration); + + function Make_Use_Package_Clause (Sloc : Source_Ptr; + Names : List_Id) + return Node_Id; + pragma Inline (Make_Use_Package_Clause); + + function Make_Use_Type_Clause (Sloc : Source_Ptr; + Subtype_Marks : List_Id) + return Node_Id; + pragma Inline (Make_Use_Type_Clause); + + function Make_Object_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Subtype_Mark : Node_Id; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Object_Renaming_Declaration); + + function Make_Exception_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Exception_Renaming_Declaration); + + function Make_Package_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Package_Renaming_Declaration); + + function Make_Subprogram_Renaming_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Subprogram_Renaming_Declaration); + + function Make_Generic_Package_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Generic_Package_Renaming_Declaration); + + function Make_Generic_Procedure_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Generic_Procedure_Renaming_Declaration); + + function Make_Generic_Function_Renaming_Declaration (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id) + return Node_Id; + pragma Inline (Make_Generic_Function_Renaming_Declaration); + + function Make_Task_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Task_Definition : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Task_Type_Declaration); + + function Make_Single_Task_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Task_Definition : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Single_Task_Declaration); + + function Make_Task_Definition (Sloc : Source_Ptr; + Visible_Declarations : List_Id; + Private_Declarations : List_Id := No_List; + End_Label : Node_Id) + return Node_Id; + pragma Inline (Make_Task_Definition); + + function Make_Task_Body (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id) + return Node_Id; + pragma Inline (Make_Task_Body); + + function Make_Protected_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Protected_Definition : Node_Id) + return Node_Id; + pragma Inline (Make_Protected_Type_Declaration); + + function Make_Single_Protected_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Protected_Definition : Node_Id) + return Node_Id; + pragma Inline (Make_Single_Protected_Declaration); + + function Make_Protected_Definition (Sloc : Source_Ptr; + Visible_Declarations : List_Id; + Private_Declarations : List_Id := No_List; + End_Label : Node_Id) + return Node_Id; + pragma Inline (Make_Protected_Definition); + + function Make_Protected_Body (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Declarations : List_Id; + End_Label : Node_Id) + return Node_Id; + pragma Inline (Make_Protected_Body); + + function Make_Entry_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discrete_Subtype_Definition : Node_Id := Empty; + Parameter_Specifications : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Entry_Declaration); + + function Make_Accept_Statement (Sloc : Source_Ptr; + Entry_Direct_Name : Node_Id; + Entry_Index : Node_Id := Empty; + Parameter_Specifications : List_Id := No_List; + Handled_Statement_Sequence : Node_Id; + Declarations : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Accept_Statement); + + function Make_Entry_Body (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Entry_Body_Formal_Part : Node_Id; + Declarations : List_Id; + Handled_Statement_Sequence : Node_Id) + return Node_Id; + pragma Inline (Make_Entry_Body); + + function Make_Entry_Body_Formal_Part (Sloc : Source_Ptr; + Entry_Index_Specification : Node_Id := Empty; + Parameter_Specifications : List_Id := No_List; + Condition : Node_Id) + return Node_Id; + pragma Inline (Make_Entry_Body_Formal_Part); + + function Make_Entry_Index_Specification (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Discrete_Subtype_Definition : Node_Id) + return Node_Id; + pragma Inline (Make_Entry_Index_Specification); + + function Make_Entry_Call_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Parameter_Associations : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Entry_Call_Statement); + + function Make_Requeue_Statement (Sloc : Source_Ptr; + Name : Node_Id; + Abort_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Requeue_Statement); + + function Make_Delay_Until_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Delay_Until_Statement); + + function Make_Delay_Relative_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Delay_Relative_Statement); + + function Make_Selective_Accept (Sloc : Source_Ptr; + Select_Alternatives : List_Id; + Else_Statements : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Selective_Accept); + + function Make_Accept_Alternative (Sloc : Source_Ptr; + Accept_Statement : Node_Id; + Condition : Node_Id := Empty; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Accept_Alternative); + + function Make_Delay_Alternative (Sloc : Source_Ptr; + Delay_Statement : Node_Id; + Condition : Node_Id := Empty; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Delay_Alternative); + + function Make_Terminate_Alternative (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Pragmas_Before : List_Id := No_List; + Pragmas_After : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Terminate_Alternative); + + function Make_Timed_Entry_Call (Sloc : Source_Ptr; + Entry_Call_Alternative : Node_Id; + Delay_Alternative : Node_Id) + return Node_Id; + pragma Inline (Make_Timed_Entry_Call); + + function Make_Entry_Call_Alternative (Sloc : Source_Ptr; + Entry_Call_Statement : Node_Id; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Entry_Call_Alternative); + + function Make_Conditional_Entry_Call (Sloc : Source_Ptr; + Entry_Call_Alternative : Node_Id; + Else_Statements : List_Id) + return Node_Id; + pragma Inline (Make_Conditional_Entry_Call); + + function Make_Asynchronous_Select (Sloc : Source_Ptr; + Triggering_Alternative : Node_Id; + Abortable_Part : Node_Id) + return Node_Id; + pragma Inline (Make_Asynchronous_Select); + + function Make_Triggering_Alternative (Sloc : Source_Ptr; + Triggering_Statement : Node_Id; + Statements : List_Id := Empty_List; + Pragmas_Before : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Triggering_Alternative); + + function Make_Abortable_Part (Sloc : Source_Ptr; + Statements : List_Id) + return Node_Id; + pragma Inline (Make_Abortable_Part); + + function Make_Abort_Statement (Sloc : Source_Ptr; + Names : List_Id) + return Node_Id; + pragma Inline (Make_Abort_Statement); + + function Make_Compilation_Unit (Sloc : Source_Ptr; + Context_Items : List_Id; + Private_Present : Boolean := False; + Unit : Node_Id; + Aux_Decls_Node : Node_Id) + return Node_Id; + pragma Inline (Make_Compilation_Unit); + + function Make_Compilation_Unit_Aux (Sloc : Source_Ptr; + Declarations : List_Id := No_List; + Actions : List_Id := No_List; + Pragmas_After : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Compilation_Unit_Aux); + + function Make_With_Clause (Sloc : Source_Ptr; + Name : Node_Id; + First_Name : Boolean := True; + Last_Name : Boolean := True) + return Node_Id; + pragma Inline (Make_With_Clause); + + function Make_With_Type_Clause (Sloc : Source_Ptr; + Name : Node_Id; + Tagged_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_With_Type_Clause); + + function Make_Subprogram_Body_Stub (Sloc : Source_Ptr; + Specification : Node_Id) + return Node_Id; + pragma Inline (Make_Subprogram_Body_Stub); + + function Make_Package_Body_Stub (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Package_Body_Stub); + + function Make_Task_Body_Stub (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Task_Body_Stub); + + function Make_Protected_Body_Stub (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Protected_Body_Stub); + + function Make_Subunit (Sloc : Source_Ptr; + Name : Node_Id; + Proper_Body : Node_Id) + return Node_Id; + pragma Inline (Make_Subunit); + + function Make_Exception_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Exception_Declaration); + + function Make_Handled_Sequence_Of_Statements (Sloc : Source_Ptr; + Statements : List_Id; + End_Label : Node_Id := Empty; + Exception_Handlers : List_Id := No_List; + At_End_Proc : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Handled_Sequence_Of_Statements); + + function Make_Exception_Handler (Sloc : Source_Ptr; + Choice_Parameter : Node_Id := Empty; + Exception_Choices : List_Id; + Statements : List_Id) + return Node_Id; + pragma Inline (Make_Exception_Handler); + + function Make_Raise_Statement (Sloc : Source_Ptr; + Name : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Raise_Statement); + + function Make_Generic_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Generic_Formal_Declarations : List_Id) + return Node_Id; + pragma Inline (Make_Generic_Subprogram_Declaration); + + function Make_Generic_Package_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Generic_Formal_Declarations : List_Id) + return Node_Id; + pragma Inline (Make_Generic_Package_Declaration); + + function Make_Package_Instantiation (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Package_Instantiation); + + function Make_Procedure_Instantiation (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Procedure_Instantiation); + + function Make_Function_Instantiation (Sloc : Source_Ptr; + Defining_Unit_Name : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Function_Instantiation); + + function Make_Generic_Association (Sloc : Source_Ptr; + Selector_Name : Node_Id := Empty; + Explicit_Generic_Actual_Parameter : Node_Id) + return Node_Id; + pragma Inline (Make_Generic_Association); + + function Make_Formal_Object_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + In_Present : Boolean := False; + Out_Present : Boolean := False; + Subtype_Mark : Node_Id; + Expression : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Formal_Object_Declaration); + + function Make_Formal_Type_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Formal_Type_Definition : Node_Id; + Discriminant_Specifications : List_Id := No_List; + Unknown_Discriminants_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Formal_Type_Declaration); + + function Make_Formal_Private_Type_Definition (Sloc : Source_Ptr; + Abstract_Present : Boolean := False; + Tagged_Present : Boolean := False; + Limited_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Formal_Private_Type_Definition); + + function Make_Formal_Derived_Type_Definition (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Private_Present : Boolean := False; + Abstract_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Formal_Derived_Type_Definition); + + function Make_Formal_Discrete_Type_Definition (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Formal_Discrete_Type_Definition); + + function Make_Formal_Signed_Integer_Type_Definition (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Formal_Signed_Integer_Type_Definition); + + function Make_Formal_Modular_Type_Definition (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Formal_Modular_Type_Definition); + + function Make_Formal_Floating_Point_Definition (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Formal_Floating_Point_Definition); + + function Make_Formal_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Formal_Ordinary_Fixed_Point_Definition); + + function Make_Formal_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Formal_Decimal_Fixed_Point_Definition); + + function Make_Formal_Subprogram_Declaration (Sloc : Source_Ptr; + Specification : Node_Id; + Default_Name : Node_Id := Empty; + Box_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Formal_Subprogram_Declaration); + + function Make_Formal_Package_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id; + Name : Node_Id; + Generic_Associations : List_Id := No_List; + Box_Present : Boolean := False) + return Node_Id; + pragma Inline (Make_Formal_Package_Declaration); + + function Make_Attribute_Definition_Clause (Sloc : Source_Ptr; + Name : Node_Id; + Chars : Name_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Attribute_Definition_Clause); + + function Make_Enumeration_Representation_Clause (Sloc : Source_Ptr; + Identifier : Node_Id; + Array_Aggregate : Node_Id) + return Node_Id; + pragma Inline (Make_Enumeration_Representation_Clause); + + function Make_Record_Representation_Clause (Sloc : Source_Ptr; + Identifier : Node_Id; + Mod_Clause : Node_Id := Empty; + Component_Clauses : List_Id) + return Node_Id; + pragma Inline (Make_Record_Representation_Clause); + + function Make_Component_Clause (Sloc : Source_Ptr; + Component_Name : Node_Id; + Position : Node_Id; + First_Bit : Node_Id; + Last_Bit : Node_Id) + return Node_Id; + pragma Inline (Make_Component_Clause); + + function Make_Code_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Code_Statement); + + function Make_Op_Rotate_Left (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Rotate_Left); + + function Make_Op_Rotate_Right (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Rotate_Right); + + function Make_Op_Shift_Left (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Shift_Left); + + function Make_Op_Shift_Right_Arithmetic (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Shift_Right_Arithmetic); + + function Make_Op_Shift_Right (Sloc : Source_Ptr; + Left_Opnd : Node_Id; + Right_Opnd : Node_Id) + return Node_Id; + pragma Inline (Make_Op_Shift_Right); + + function Make_Delta_Constraint (Sloc : Source_Ptr; + Delta_Expression : Node_Id; + Range_Constraint : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Delta_Constraint); + + function Make_At_Clause (Sloc : Source_Ptr; + Identifier : Node_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_At_Clause); + + function Make_Mod_Clause (Sloc : Source_Ptr; + Expression : Node_Id; + Pragmas_Before : List_Id) + return Node_Id; + pragma Inline (Make_Mod_Clause); + + function Make_Conditional_Expression (Sloc : Source_Ptr; + Expressions : List_Id) + return Node_Id; + pragma Inline (Make_Conditional_Expression); + + function Make_Expanded_Name (Sloc : Source_Ptr; + Chars : Name_Id; + Prefix : Node_Id; + Selector_Name : Node_Id) + return Node_Id; + pragma Inline (Make_Expanded_Name); + + function Make_Free_Statement (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Free_Statement); + + function Make_Freeze_Entity (Sloc : Source_Ptr; + Actions : List_Id := No_List) + return Node_Id; + pragma Inline (Make_Freeze_Entity); + + function Make_Implicit_Label_Declaration (Sloc : Source_Ptr; + Defining_Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Implicit_Label_Declaration); + + function Make_Itype_Reference (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Itype_Reference); + + function Make_Raise_Constraint_Error (Sloc : Source_Ptr; + Condition : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Raise_Constraint_Error); + + function Make_Raise_Program_Error (Sloc : Source_Ptr; + Condition : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Raise_Program_Error); + + function Make_Raise_Storage_Error (Sloc : Source_Ptr; + Condition : Node_Id := Empty) + return Node_Id; + pragma Inline (Make_Raise_Storage_Error); + + function Make_Reference (Sloc : Source_Ptr; + Prefix : Node_Id) + return Node_Id; + pragma Inline (Make_Reference); + + function Make_Subprogram_Info (Sloc : Source_Ptr; + Identifier : Node_Id) + return Node_Id; + pragma Inline (Make_Subprogram_Info); + + function Make_Unchecked_Expression (Sloc : Source_Ptr; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Unchecked_Expression); + + function Make_Unchecked_Type_Conversion (Sloc : Source_Ptr; + Subtype_Mark : Node_Id; + Expression : Node_Id) + return Node_Id; + pragma Inline (Make_Unchecked_Type_Conversion); + + function Make_Validate_Unchecked_Conversion (Sloc : Source_Ptr) + return Node_Id; + pragma Inline (Make_Validate_Unchecked_Conversion); + +end Nmake; diff --git a/gcc/ada/nmake.adt b/gcc/ada/nmake.adt new file mode 100644 index 00000000000..bc7f1c4e24a --- /dev/null +++ b/gcc/ada/nmake.adt @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N M A K E -- +-- -- +-- T e m p l a t e -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram order checking, since the routines here are +-- generated automatically in order. + +-- This file is a template used as input to the utility program XNmake, +-- which reads this template, and the spec of Sinfo (sinfo.ads) and +-- generates the body and/or the spec for the Nmake package (files +-- nmake.ads and nmake.adb) + +with Atree; use Atree; -- body only +with Nlists; use Nlists; -- spec only +with Sinfo; use Sinfo; -- body only +with Snames; use Snames; -- body only +with Stand; use Stand; -- body only +with Types; use Types; -- spec only +with Uintp; use Uintp; -- spec only +with Urealp; use Urealp; -- spec only + +package Nmake is + +-- This package contains a set of routines used to construct tree nodes +-- using a functional style. There is one routine for each node type defined +-- in Sinfo with the general interface: + +-- function Make_xxx (Sloc : Source_Ptr, +-- Field_Name_1 : Field_Name_1_Type [:= default] +-- Field_Name_2 : Field_Name_2_Type [:= default] +-- ...) +-- return Node_Id + +-- Only syntactic fields are included (i.e. fields marked as "-Sem" or "-Lib" +-- in the Sinfo spec are excluded). In addition, the following four syntactic +-- fields are excluded: + +-- Prev_Ids +-- More_Ids +-- Comes_From_Source +-- Paren_Count + +-- since they are very rarely set in expanded code. If they need to be set, +-- to other than the default values (False, False, False, zero), then the +-- appropriate Set_xxx procedures must be used on the returned value. + +-- Default values are provided only for flag fields (where the default is +-- False), and for optional fields. An optional field is one where the +-- comment line describing the field contains the string "(set to xxx if". +-- For such fields, a default value of xxx is provided." + +-- Warning: since calls to Make_xxx routines are normal function calls, the +-- arguments can be evaluated in any order. This means that at most one such +-- argument can have side effects (e.g. be a call to a parse routine). + +!!TEMPLATE INSERTION POINT + +end Nmake; diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb new file mode 100644 index 00000000000..933c8ec9403 --- /dev/null +++ b/gcc/ada/opt.adb @@ -0,0 +1,224 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O P T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.29 $ +-- -- +-- Copyright (C) 1992-2000, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; +with Gnatvsn; use Gnatvsn; +with System; use System; +with Tree_IO; use Tree_IO; + +package body Opt is + + Tree_Version_String : String (Gnat_Version_String'Range); + -- Used to store the compiler version string read from a tree file to + -- check if it is the same as stored in the version ctring in Gnatvsn. + -- Therefore its length is taken directly from the version string in + -- Gnatvsn. If the length of the version string stored in the three is + -- different, then versions are for sure different. + + Immediate_Errors : Boolean := True; + -- This is an obsolete flag that is no longer present in opt.ads. We + -- retain it here because this flag was written to the tree and there + -- is no point in making trees incomaptible just for the sake of saving + -- one byte of data. The value written is ignored. + + ---------------------------------- + -- Register_Opt_Config_Switches -- + ---------------------------------- + + procedure Register_Opt_Config_Switches is + begin + Ada_83_Config := Ada_83; + Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; + Extensions_Allowed_Config := Extensions_Allowed; + External_Name_Exp_Casing_Config := External_Name_Exp_Casing; + External_Name_Imp_Casing_Config := External_Name_Imp_Casing; + Polling_Required_Config := Polling_Required; + Use_VADS_Size_Config := Use_VADS_Size; + end Register_Opt_Config_Switches; + + --------------------------------- + -- Restore_Opt_Config_Switches -- + --------------------------------- + + procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type) is + begin + Ada_83 := Save.Ada_83; + Ada_95 := not Ada_83; + Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; + Extensions_Allowed := Save.Extensions_Allowed; + External_Name_Exp_Casing := Save.External_Name_Exp_Casing; + External_Name_Imp_Casing := Save.External_Name_Imp_Casing; + Polling_Required := Save.Polling_Required; + Use_VADS_Size := Save.Use_VADS_Size; + end Restore_Opt_Config_Switches; + + ------------------------------ + -- Save_Opt_Config_Switches -- + ------------------------------ + + procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type) is + begin + Save.Ada_83 := Ada_83; + Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; + Save.Extensions_Allowed := Extensions_Allowed; + Save.External_Name_Exp_Casing := External_Name_Exp_Casing; + Save.External_Name_Imp_Casing := External_Name_Imp_Casing; + Save.Polling_Required := Polling_Required; + Save.Use_VADS_Size := Use_VADS_Size; + end Save_Opt_Config_Switches; + + ----------------------------- + -- Set_Opt_Config_Switches -- + ----------------------------- + + procedure Set_Opt_Config_Switches (Internal_Unit : Boolean) is + begin + if Internal_Unit then + Ada_83 := False; + Ada_95 := True; + Dynamic_Elaboration_Checks := False; + Extensions_Allowed := True; + External_Name_Exp_Casing := As_Is; + External_Name_Imp_Casing := Lowercase; + Use_VADS_Size := False; + + else + Ada_83 := Ada_83_Config; + Ada_95 := not Ada_83_Config; + Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; + Extensions_Allowed := Extensions_Allowed_Config; + External_Name_Exp_Casing := External_Name_Exp_Casing_Config; + External_Name_Imp_Casing := External_Name_Imp_Casing_Config; + Use_VADS_Size := Use_VADS_Size_Config; + end if; + + Polling_Required := Polling_Required_Config; + end Set_Opt_Config_Switches; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + Tree_Version_String_Len : Nat; + + begin + Tree_Read_Bool (Brief_Output); + Tree_Read_Bool (GNAT_Mode); + Tree_Read_Char (Identifier_Character_Set); + Tree_Read_Int (Maximum_File_Name_Length); + Tree_Read_Data (Suppress_Options'Address, + Suppress_Record'Object_Size / Storage_Unit); + Tree_Read_Bool (Verbose_Mode); + Tree_Read_Data (Warning_Mode'Address, + Warning_Mode_Type'Object_Size / Storage_Unit); + Tree_Read_Bool (Ada_83_Config); + Tree_Read_Bool (All_Errors_Mode); + Tree_Read_Bool (Assertions_Enabled); + Tree_Read_Bool (Full_List); + + -- Read and check version string + + Tree_Read_Int (Tree_Version_String_Len); + + if Tree_Version_String_Len = Tree_Version_String'Length then + Tree_Read_Data + (Tree_Version_String'Address, Tree_Version_String'Length); + end if; + + if Tree_Version_String_Len /= Tree_Version_String'Length + or else Tree_Version_String /= Gnat_Version_String + then + Raise_Exception + (Program_Error'Identity, "Inconsistent versions of GNAT and ASIS"); + end if; + + Tree_Read_Data (Distribution_Stub_Mode'Address, + Distribution_Stub_Mode_Type'Object_Size / Storage_Unit); + Tree_Read_Bool (Immediate_Errors); + Tree_Read_Bool (Inline_Active); + Tree_Read_Bool (Inline_Processing_Required); + Tree_Read_Bool (List_Units); + Tree_Read_Bool (No_Run_Time); + Tree_Read_Data (Operating_Mode'Address, + Operating_Mode_Type'Object_Size / Storage_Unit); + Tree_Read_Bool (Software_Overflow_Checking); + Tree_Read_Bool (Try_Semantics); + Tree_Read_Data (Wide_Character_Encoding_Method'Address, + WC_Encoding_Method'Object_Size / Storage_Unit); + Tree_Read_Bool (Upper_Half_Encoding); + Tree_Read_Bool (Force_ALI_Tree_File); + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Tree_Write_Bool (Brief_Output); + Tree_Write_Bool (GNAT_Mode); + Tree_Write_Char (Identifier_Character_Set); + Tree_Write_Int (Maximum_File_Name_Length); + Tree_Write_Data (Suppress_Options'Address, + Suppress_Record'Object_Size / Storage_Unit); + Tree_Write_Bool (Verbose_Mode); + Tree_Write_Data (Warning_Mode'Address, + Warning_Mode_Type'Object_Size / Storage_Unit); + Tree_Write_Bool (Ada_83_Config); + Tree_Write_Bool (All_Errors_Mode); + Tree_Write_Bool (Assertions_Enabled); + Tree_Write_Bool (Full_List); + Tree_Write_Int (Int (Gnat_Version_String'Length)); + Tree_Write_Data (Gnat_Version_String'Address, + Gnat_Version_String'Length); + Tree_Write_Data (Distribution_Stub_Mode'Address, + Distribution_Stub_Mode_Type'Object_Size / Storage_Unit); + Tree_Write_Bool (Immediate_Errors); + Tree_Write_Bool (Inline_Active); + Tree_Write_Bool (Inline_Processing_Required); + Tree_Write_Bool (List_Units); + Tree_Write_Bool (No_Run_Time); + Tree_Write_Data (Operating_Mode'Address, + Operating_Mode_Type'Object_Size / Storage_Unit); + Tree_Write_Bool (Software_Overflow_Checking); + Tree_Write_Bool (Try_Semantics); + Tree_Write_Data (Wide_Character_Encoding_Method'Address, + WC_Encoding_Method'Object_Size / Storage_Unit); + Tree_Write_Bool (Upper_Half_Encoding); + Tree_Write_Bool (Force_ALI_Tree_File); + end Tree_Write; + +end Opt; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads new file mode 100644 index 00000000000..7ba1c43d209 --- /dev/null +++ b/gcc/ada/opt.ads @@ -0,0 +1,876 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O P T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.194 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains global switches set by the initialization +-- routine from the command line and referenced throughout the compiler, +-- the binder or gnatmake. The comments indicate which options are used by +-- which programs (GNAT, GNATBIND, GNATMAKE). + +with Hostparm; use Hostparm; +with Types; use Types; +with System.WCh_Con; use System.WCh_Con; + +package Opt is + + ---------------------------------------------- + -- Settings of Modes for Current Processing -- + ---------------------------------------------- + + -- The following mode values represent the current state of processing. + -- The values set here are the default values. Unless otherwise noted, + -- the value may be reset in Switch with an appropropiate switch. In + -- some cases, the values can also be modified by pragmas, and in the + -- case of some binder variables, Gnatbind.Scan_Bind_Arg may modify + -- the default values. + + Ada_Bind_File : Boolean := True; + -- GNATBIND + -- Set True if binder file to be generated in Ada rather than C + + Ada_95 : Boolean := True; + -- GNAT + -- Set True if operating in Ada 95 mode + -- Set False if operating in Ada 83 mode + + Ada_83 : Boolean := False; + -- GNAT + -- Set True if operating in Ada 83 mode + -- Set False if operating in Ada 95 mode + + Ada_Final_Suffix : constant String := "final"; + -- GNATBIND + -- The suffix of the name of the finalization procedure. This variable + -- may be modified by Gnatbind.Scan_Bind_Arg. + + Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix); + -- GNATBIND + -- The name of the procedure that performs the finalization at the end of + -- execution. This variable may be modified by Gnatbind.Scan_Bind_Arg. + + Ada_Init_Suffix : constant String := "init"; + -- GNATBIND + -- The suffix of the name of the initialization procedure. This variable + -- may be modified by Gnatbind.Scan_Bind_Arg. + + Ada_Init_Name : String_Ptr := new String'("ada" & Ada_Init_Suffix); + -- GNATBIND + -- The name of the procedure that performs initialization at the start + -- of execution. This variable may be modified by Gnatbind.Scan_Bind_Arg. + + Ada_Main_Name_Suffix : constant String := "main"; + -- GNATBIND + -- The suffix for Ada_Main_Name. Defined as a constant here so that it + -- can be referenced in a uniform manner to create either the default + -- value of Ada_Main_Name (declared below), or the non-default name + -- set by Gnatbind.Scan_Bind_Arg. + + Ada_Main_Name : String_Ptr := new String'("ada_" & Ada_Main_Name_Suffix); + -- GNATBIND + -- The name of the Ada package generated by the binder (when in Ada mode). + -- This variable may be modified by Gnatbind.Scan_Bind_Arg. + + Address_Clause_Overlay_Warnings : Boolean := True; + -- GNAT + -- Set False to disable address clause warnings + + All_Errors_Mode : Boolean := False; + -- GNAT + -- Flag set to force display of multiple errors on a single line and + -- also repeated error messages for references to undefined identifiers + -- and certain other repeated error messages. + + All_Sources : Boolean := False; + -- GNATBIND + -- Set to True to require all source files to be present. This flag is + -- directly modified by gnatmake to affect the shared binder routines. + + Alternate_Main_Name : String_Ptr := null; + -- Set to non null when Bind_Alternate_Main_Name is True. This value + -- is modified as needed by Gnatbind.Scan_Bind_Arg. + + Assertions_Enabled : Boolean := False; + -- GNAT + -- Enable assertions made using pragma Assert. + + Back_Annotate_Rep_Info : Boolean := False; + -- GNAT + -- If set True (by use of -gnatB), enables back annotation of + -- representation information by gigi, even in -gnatc mode. + + Bind_Alternate_Main_Name : Boolean := False; + -- GNATBIND + -- Set to True if main should be called Alternate_Main_Name.all. This + -- variable may be set to True by Gnatbind.Scan_Bind_Arg. + + Bind_Main_Program : Boolean := True; + -- GNATBIND + -- Set to False if not binding main Ada program. + + Bind_For_Library : Boolean := False; + -- GNATBIND + -- Set to True if the binder needs to generate a file designed for + -- building a library. May be set to True by Gnatbind.Scan_Bind_Arg. + + Brief_Output : Boolean := False; + -- GNAT, GNATBIND + -- Force brief error messages to standard error, even if verbose mode is + -- set (so that main error messages go to standard output). + + Check_Object_Consistency : Boolean := False; + -- GNATBIND, GNATMAKE + -- Set to True to check whether every object file is consistent with + -- with its corresponding ada library information (ali) file. An object + -- file is inconsistent with the corresponding ali file if the object + -- file does not exist or if it has an older time stamp than the ali file. + -- Default above is for GNATBIND. GNATMAKE overrides this default to + -- True (see Make.Initialize) since we do not need to check source + -- consistencies in gnatmake in this sense. + + Check_Only : Boolean := False; + -- GNATBIND + -- Set to True to do checks only, no output of binder file. + + Check_Readonly_Files : Boolean := False; + -- GNATMAKE + -- Set to True to check readonly files during the make process. + + Check_Source_Files : Boolean := True; + -- GNATBIND + -- Set to True to enable consistency checking for any source files that + -- are present (i.e. date must match the date in the library info file). + -- Set to False for object file consistency check only. This flag is + -- directly modified by gnatmake, to affect the shared binder routines. + + Check_Switches : Boolean := False; + -- GNATMAKE + -- Set to True to check compiler options during the make process. + + Check_Unreferenced : Boolean := False; + -- GNAT + -- Set to True to enable checking for unreferenced variables + + Check_Withs : Boolean := False; + -- GNAT + -- Set to True to enable checking for unused withs, and also the case + -- of withing a package and using none of the entities in the package. + + Compile_Only : Boolean := False; + -- GNATMAKE + -- Set to True to skip bind and link step. + + Compress_Debug_Names : Boolean := False; + -- GNATMAKE + -- Set to True if the option to compress debug information is set (-gnatC) + + Config_File : Boolean := True; + -- GNAT + -- Set to False to inhibit reading and processing of gnat.adc file + + Config_File_Name : String_Ptr := null; + -- GNAT + -- File name of configuration pragmas file (given by switch -gnatec) + + Constant_Condition_Warnings : Boolean := False; + -- GNAT + -- Set to True to activate warnings on constant conditions + + subtype Debug_Level_Value is Nat range 0 .. 3; + Debugger_Level : Debug_Level_Value := 0; + -- GNATBIND + -- The value given to the -g parameter. + -- The default value for -g with no value is 2 + -- This is usually ignored by GNATBIND, except in the VMS version + -- where it is passed as an argument to __gnat_initialize to trigger + -- the activation of the remote debugging interface (is this true???). + + Debug_Generated_Code : Boolean := False; + -- GNAT + -- Set True (-gnatD switch) to debug generated expanded code instead + -- of the original source code. Causes debugging information to be + -- written with respect to the generated code file that is written. + + Display_Compilation_Progress : Boolean := False; + -- GNATMAKE + -- Set True (-d switch) to display information on progress while compiling + -- files. Internal switch to be used in conjunction with an IDE such as + -- Glide. + + type Distribution_Stub_Mode_Type is + -- GNAT + (No_Stubs, + -- Normal mode, no generation/compilation of distribution stubs + + Generate_Receiver_Stub_Body, + -- The unit being compiled is the RCI body, and the compiler will + -- generate the body for the receiver stubs and compile it. + + Generate_Caller_Stub_Body); + -- The unit being compiled is the RCI spec, and the compiler will + -- generate the body for the caller stubs and compile it. + + Distribution_Stub_Mode : Distribution_Stub_Mode_Type := No_Stubs; + -- GNAT + -- This enumeration variable indicates the five states of distribution + -- annex stub generation/compilation. + + Do_Not_Execute : Boolean := False; + -- GNATMAKE + -- Set to True if no actual compilations should be undertaken. + + Dynamic_Elaboration_Checks : Boolean := False; + -- GNAT + -- Set True for dynamic elaboration checking mode, as set by the -gnatE + -- switch or by the use of pragma Elaboration_Checks (Dynamic). + + Elab_Dependency_Output : Boolean := False; + -- GNATBIND + -- Set to True to output complete list of elaboration constraints + + Elab_Order_Output : Boolean := False; + -- GNATBIND + -- Set to True to output chosen elaboration order + + Elab_Warnings : Boolean := False; + -- GNAT + -- Set to True to generate full elaboration warnings (-gnatwl) + + type Exception_Mechanism_Type is (Setjmp_Longjmp, Front_End_ZCX, GCC_ZCX); + Exception_Mechanism : Exception_Mechanism_Type := Setjmp_Longjmp; + -- GNAT + -- Set to the appropriate value depending on the default as given in + -- system.ads (ZCX_By_Default, GCC_ZCX_Support, Front_End_ZCX_Support) + -- and the use of -gnatL -gnatZ (and -gnatdX) + + Exception_Tracebacks : Boolean := False; + -- GNATBIND + -- Set to True to store tracebacks in exception occurrences (-E) + + Extensions_Allowed : Boolean := False; + -- GNAT + + type External_Casing_Type is ( + As_Is, -- External names cased as they appear in the Ada source + Uppercase, -- External names forced to all uppercase letters + Lowercase); -- External names forced to all lowercase letters + + External_Name_Imp_Casing : External_Casing_Type := Lowercase; + -- The setting of this switch determines the casing of external names + -- when the name is implicitly derived from an entity name (i.e. either + -- no explicit External_Name or Link_Name argument is used, or, in the + -- case of extended DEC pragmas, the external name is given using an + -- identifier. The As_Is setting is not permitted here (since this would + -- create Ada source programs that were case sensitive). + + External_Name_Exp_Casing : External_Casing_Type := As_Is; + -- The setting of this switch determines the casing of an external name + -- specified explicitly with a string literal. As_Is means the string + -- literal is used as given with no modification to the casing. If + -- Lowercase or Uppercase is set, then the string is forced to all + -- lowercase or all uppercase letters as appropriate. Note that this + -- setting has no effect if the external name is given using an identifier + -- in the case of extended DEC import/export pragmas (in this case the + -- casing is controlled by External_Name_Imp_Casing), and also has no + -- effect if an explicit Link_Name is supplied (a link name is always + -- used exactly as given). + + Float_Format : Character := ' '; + -- GNAT + -- A non-blank value indicates that a Float_Format pragma has been + -- processed, in which case this variable is set to 'I' for IEEE or + -- to 'V' for VAX. The setting of 'V' is only possible on OpenVMS + -- versions of GNAT. + + Float_Format_Long : Character := ' '; + -- GNAT + -- A non-blank value indicates that a Long_Float pragma has been + -- processed (this pragma is recognized only in OpenVMS versions + -- of GNAT), in which case this variable is set to D or G for + -- D_Float or G_Float. + + Force_ALI_Tree_File : Boolean := False; + -- GNAT + -- Force generation of ali file even if errors are encountered. + -- Also forces generation of tree file if -gnatt is also set. + + Force_Compilations : Boolean := False; + -- GNATMAKE + -- Set to force recompilations even when the objects are up-to-date. + + Force_RM_Elaboration_Order : Boolean := False; + -- GNATBIND + -- True if binding with forced RM elaboration order (-f switch set) + + Full_List : Boolean := False; + -- GNAT + -- Set True to generate full source listing with embedded errors + + Global_Discard_Names : Boolean := False; + -- GNAT + -- Set true if a pragma Discard_Names applies to the current unit + + GNAT_Mode : Boolean := False; + -- GNAT + -- True if compiling in GNAT system mode (-g switch set) + + HLO_Active : Boolean := False; + -- GNAT + -- True if High Level Optimizer is activated + + Implementation_Unit_Warnings : Boolean := True; + -- GNAT + -- Set True to active warnings for use of implementation internal units. + -- Can be controlled by use of -gnatwi/-gnatwI. + + Identifier_Character_Set : Character; + -- GNAT + -- This variable indicates the character set to be used for identifiers. + -- The possible settings are: + -- '1' Latin-1 + -- '2' Latin-2 + -- '3' Latin-3 + -- '4' Latin-4 + -- 'p' PC (US, IBM page 437) + -- '8' PC (European, IBM page 850) + -- 'f' Full upper set (all distinct) + -- 'n' No upper characters (Ada/83 rules) + -- 'w' Latin-1 plus wide characters allowed in identifiers + -- + -- The setting affects the set of letters allowed in identifiers and the + -- upper/lower case equivalences. It does not affect the interpretation of + -- character and string literals, which are always stored using the actual + -- coding in the source program. This variable is initialized to the + -- default value appropriate to the system (in Osint.Initialize), and then + -- reset if a command line switch is used to change the setting. + + Ineffective_Inline_Warnings : Boolean := False; + -- GNAT + -- Set True to activate warnings if front-end inlining (-gnatN) is not + -- able to actually inline a particular call (or all calls). Can be + -- controlled by use of -gnatwp/-gnatwP. + + Init_Or_Norm_Scalars : Boolean := False; + -- GNAT + -- Set True if a pragma Initialize_Scalars applies to the current unit. + -- Also set True if a pragma Normalize_Scalars applies. + + Initialize_Scalars : Boolean := False; + -- GNAT + -- Set True if a pragma Initialize_Scalars applies to the current unit. + -- Note that Init_Or_Norm_Scalars is also set to True if this is True. + + Initialize_Scalars_Mode : Character := 'I'; + -- GNATBIND + -- Set to 'I' for -Sin (default), 'L' for -Slo, 'H' for -Shi, 'X' for -Sxx + + Initialize_Scalars_Val : String (1 .. 2); + -- GNATBIND + -- Valid only if Initialize_Scalars_Mode is set to 'X' (-Shh). Contains + -- the two hex bytes from the -Shh switch. + + Inline_Active : Boolean := False; + -- GNAT + -- Set True to activate pragma Inline processing across modules. Default + -- for now is not to inline across module boundaries. + + Front_End_Inlining : Boolean := False; + -- GNAT + -- Set True to activate inlining by front-end expansion. + + Inline_Processing_Required : Boolean := False; + -- GNAT + -- Set True if inline processing is required. Inline processing is + -- required if an active Inline pragma is processed. The flag is set + -- for a pragma Inline or Inline_Always that is actually active. + + In_Place_Mode : Boolean := False; + -- GNATMAKE + -- Set True to store ALI and object files in place ie in the object + -- directory if these files already exist or in the source directory + -- if not. + + Keep_Going : Boolean := False; + -- GNATMAKE + -- When True signals gnatmake to ignore compilation errors and keep + -- processing sources until there is no more work. + + List_Units : Boolean := False; + -- GNAT + -- List units in the active library + + List_Dependencies : Boolean := False; + -- GNATMAKE + -- When True gnatmake verifies that the objects are up to date and + -- outputs the list of object dependencies. This list can be used + -- directly in a Makefile. + + List_Representation_Info : Int range 0 .. 3 := 0; + -- GNAT + -- Set true by -gnatR switch to list representation information. + -- The settings are as follows: + -- + -- 0 = no listing of representation information (default as above) + -- 1 = list rep info for user defined record and array types + -- 2 = list rep info for all user defined types and objects + -- 3 = like 2, but variable fields are decoded symbolically + + Locking_Policy : Character := ' '; + -- GNAT + -- Set to ' ' for the default case (no locking policy specified). + -- Reset to first character (uppercase) of locking policy name if a + -- valid pragma Locking_Policy is encountered. + + Look_In_Primary_Dir : Boolean := True; + -- GNAT, GNATBIND, GNATMAKE + -- Set to False if a -I- was present on the command line. + -- When True we are allowed to look in the primary directory to locate + -- other source or library files. + + Maximum_Errors : Int := 9999; + -- GNAT, GNATBIND + -- Maximum number of errors before compilation is terminated + + Maximum_File_Name_Length : Int; + -- GNAT, GNATBIND + -- Maximum number of characters allowed in a file name, not counting the + -- extension, as set by the appropriate switch. If no switch is given, + -- then this value is initialized by Osint to the appropriate value. + + Maximum_Processes : Positive := 1; + -- GNATMAKE + -- Maximum number of processes that should be spawned to carry out + -- compilations. + + Minimal_Recompilation : Boolean := False; + -- GNATMAKE + -- Set to True if minimal recompilation mode requested. + + No_Stdlib : Boolean := False; + -- GNATMAKE + -- Set to True if no default library search dirs added to search list. + + No_Stdinc : Boolean := False; + -- GNATMAKE + -- Set to True if no default source search dirs added to search list. + + No_Main_Subprogram : Boolean := False; + -- GNATMAKE, GNATBIND + -- Set to True if compilation/binding of a program without main + -- subprogram requested. + + Normalize_Scalars : Boolean := False; + -- GNAT + -- Set True if a pragma Normalize_Scalars applies to the current unit. + -- Note that Init_Or_Norm_Scalars is also set to True if this is True. + + No_Run_Time : Boolean := False; + -- GNAT + -- Set True if a valid pragma No_Run_Time is processed or if the + -- flag Targparm.High_Integrity_Mode_On_Target is set True. + + type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code); + Operating_Mode : Operating_Mode_Type := Generate_Code; + -- GNAT + -- Indicates the operating mode of the compiler. The default is generate + -- code, which runs the parser, semantics and backend. Switches can be + -- used to set syntax checking only mode, or syntax and semantics checking + -- only mode. Operating_Mode can also be modified as a result of detecting + -- errors during the compilation process. In particular if any error is + -- detected then this flag is reset from Generate_Code to Check_Semantics + -- after generating an error message. + + Output_File_Name_Present : Boolean := False; + -- GNATBIND, GNAT + -- Set to True when the output C file name is given with option -o + -- for GNATBIND or when the object file name is given with option + -- -gnatO for GNAT. + + Output_Linker_Option_List : Boolean := False; + -- GNATBIND + -- True if output of list of linker options is requested (-K switch set) + + Output_Object_List : Boolean := False; + -- GNATBIND + -- True if output of list of objects is requested (-O switch set) + + Pessimistic_Elab_Order : Boolean := False; + -- GNATBIND + -- True if pessimistic elaboration order is to be chosen (-p switch set) + + Polling_Required : Boolean := False; + -- GNAT + -- Set to True if polling for asynchronous abort is enabled by using + -- the -gnatP option for GNAT. + + Print_Generated_Code : Boolean := False; + -- GNAT + -- Set to True to enable output of generated code in source form. This + -- flag is set by the -gnatG switch. + + Propagate_Exceptions : Boolean := False; + -- GNAT + -- Indicates if subprogram descriptor exception tables should be + -- built for imported subprograms. Set True if a Propagate_Exceptions + -- pragma applies to the extended main unit. + + Queuing_Policy : Character := ' '; + -- GNAT + -- Set to ' ' for the default case (no queuing policy specified). Reset to + -- Reset to first character (uppercase) of locking policy name if a valid + -- Queuing_Policy pragma is encountered. + + Quiet_Output : Boolean := False; + -- GNATMAKE + -- Set to True if the list of compilation commands should not be output. + + Shared_Libgnat : Boolean; + -- GNATBIND + -- Set to True if a shared libgnat is requested by using the -shared + -- option for GNATBIND and to False when using the -static option. The + -- value of this switch is set by Gnatbind.Scan_Bind_Arg. + + Software_Overflow_Checking : Boolean; + -- GNAT + -- Set to True by Osint.Initialize if the target requires the software + -- approach to integer arithmetic overflow checking (i.e. the use of + -- double length arithmetic followed by a range check). Set to False + -- if the target implements hardware overflow checking. + + Stack_Checking_Enabled : Boolean; + -- GNAT + -- Set to indicate if -fstack-check switch is set for the compilation. + -- True means that the switch is set, so that stack checking is enabled. + -- False means that the switch is not set (no stack checking). This + -- value is obtained from the external imported value flag_stack_check + -- in the gcc backend (see Frontend) and may be referenced throughout + -- the compilation phases. + + Strict_Math : aliased Boolean := False; + -- GNAT + -- This switch is set True if the current unit is to be compiled in + -- strict math mode. The effect is to cause certain library file name + -- substitutions to implement strict math semantics. See the routine + -- Adjust_File_Name_For_Configuration, and also the configuration + -- in the body of Opt. + -- + -- Note: currently this switch is always False. Eventually it will be + -- settable by a switch and a configuration pragma. + + Style_Check : Boolean := False; + -- GNAT + -- Set True to perform style checks. Activates checks carried out + -- in package Style (see body of this package for details of checks) + -- This flag is set True by either the -gnatg or -gnaty switches. + + System_Extend_Pragma_Arg : Node_Id := Empty; + -- GNAT + -- Set non-empty if and only if a correct Extend_System pragma was present + -- in which case it points to the argument of the pragma, and the name can + -- be located as Chars (Expression (System_Extend_Pragma_Arg)). + + Subunits_Missing : Boolean := False; + -- This flag is set true if missing subunits are detected with code + -- generation active. This causes code generation to be skipped. + + Suppress_Options : Suppress_Record; + -- GNAT + -- Flags set True to suppress corresponding check, i.e. add an implicit + -- pragma Suppress at the outer level of each unit compiled. Note that + -- these suppress actions can be overridden by the use of the Unsuppress + -- pragma. This variable is initialized by Osint.Initialize. + + Table_Factor : Int := 1; + -- Factor by which all initial table sizes set in Alloc are multiplied. + -- Used in Table to calculate initial table sizes (the initial table + -- size is the value in Alloc, used as the Table_Initial parameter + -- value, multiplied by the factor given here. The default value is + -- used if no -gnatT switch appears. + + Task_Dispatching_Policy : Character := ' '; + -- GNAT + -- Set to ' ' for the default case (no task dispatching policy specified). + -- Reset to first character (uppercase) of task dispatching policy name + -- if a valid Task_Dispatching_Policy pragma is encountered. + + Tasking_Used : Boolean := False; + -- Set True if any tasking construct is encountered. Used to activate the + -- output of the Q, L and T lines in ali files. + + Time_Slice_Set : Boolean := False; + -- Set True if a pragma Time_Slice is processed in the main unit, or + -- if the T switch is present to set a time slice value. + + Time_Slice_Value : Nat; + -- Time slice value. Valid only if Time_Slice_Set is True, i.e. if a + -- Time_Slice pragma has been processed. Set to the time slice value + -- in microseconds. Negative values are stored as zero, and the value + -- is not larger than 1_000_000_000 (1000 seconds). Values larger than + -- this are reset to this maximum. + + Tolerate_Consistency_Errors : Boolean := False; + -- GNATBIND + -- Tolerate time stamp and other consistency errors. If this switch is + -- set true, then inconsistencies result in warnings rather than errors. + + Tree_Output : Boolean := False; + -- GNAT + -- Set True to generate output tree file + + Try_Semantics : Boolean := False; + -- GNAT + -- Flag set to force attempt at semantic analysis, even if parser errors + -- occur. This will probably cause blowups at this stage in the game. On + -- the other hand, most such blowups will be caught cleanly and simply + -- say compilation abandoned. + + Unique_Error_Tag : Boolean := Tag_Errors; + -- GNAT + -- Indicates if error messages are to be prefixed by the string error: + -- Initialized from Tag_Errors, can be forced on with the -gnatU switch. + + Unreserve_All_Interrupts : Boolean := False; + -- GNAT, GNATBIND + -- Normally set False, set True if a valid Unreserve_All_Interrupts + -- pragma appears anywhere in the main unit for GNAT, or if any ALI + -- file has the corresponding attribute set in GNATBIND. + + Upper_Half_Encoding : Boolean := False; + -- GNAT + -- Normally set False, indicating that upper half ASCII characters are + -- used in the normal way to represent themselves. If the wide character + -- encoding method uses the upper bit for this encoding, then this flag + -- is set True, and upper half characters in the source indicate the + -- start of a wide character sequence. + + Usage_Requested : Boolean := False; + -- GNAT, GNATBIND, GNATMAKE + -- Set to True if h switch encountered requesting usage information + + Use_VADS_Size : Boolean := False; + -- GNAT + -- Set to True if a valid pragma Use_VADS_Size is processed + + Validity_Checks_On : Boolean := True; + -- This flag determines if validity checking is on or off. The initial + -- state is on, and the required default validity checks are active. The + -- actual set of checks that is performed if Validity_Checks_On is set + -- is defined by the switches in package Sem_Val. The Validity_Checks_On + -- switch is controlled by pragma Validity_Checks (On | Off), and also + -- some generated compiler code (typically code that has to do with + -- validity check generation) is compiled with this switch set to False. + + Verbose_Mode : Boolean := False; + -- GNAT, GNATBIND + -- Set to True to get verbose mode (full error message text and location + -- information sent to standard output, also header, copyright and summary) + + Warn_On_Biased_Rounding : Boolean := False; + -- GNAT + -- Set to True to generate warnings for static constants that are rounded + -- in a manner inconsistent with unbiased rounding (round to even). Can + -- be modified by use of -gnatwb/B. + + Warn_On_Hiding : Boolean := False; + -- GNAT + -- Set to True to generate warnings if a declared entity hides another + -- entity. The default is that this warning is suppressed. + + Warn_On_Redundant_Constructs : Boolean := False; + -- GNAT + -- Set to True to generate warnings for redundant constructs (e.g. useless + -- assignments/conversions). The default is that this warning is disabled. + + type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); + Warning_Mode : Warning_Mode_Type := Normal; + -- GNAT, GNATBIND + -- Controls treatment of warning messages. If set to Suppress, warning + -- messages are not generated at all. In Normal mode, they are generated + -- but do not count as errors. In Treat_As_Error mode, warning messages + -- are generated and are treated as errors. + + Wide_Character_Encoding_Method : WC_Encoding_Method := WCEM_Brackets; + -- GNAT + -- Method used for encoding wide characters in the source program. See + -- description of type in unit System.WCh_Con for a list of the methods + -- that are currently supported. Note that brackets notation is always + -- recognized in source programs regardless of the setting of this + -- variable. The default setting causes only the brackets notation + -- to be recognized. If this is the main unit, this setting also + -- controls the output of the W=? parameter in the ali file, which + -- is used to provide the default for Wide_Text_IO files. + + Xref_Active : Boolean := True; + -- GNAT + -- Set if cross-referencing is enabled (i.e. xref info in ali files) + + Zero_Cost_Exceptions_Val : Boolean; + Zero_Cost_Exceptions_Set : Boolean := False; + -- GNAT + -- These values are to record the setting of the zero cost exception + -- handling mode set by argument switches (-gnatZ/-gnatL). If the + -- value is set by one of these switches, then Zero_Cost_Exceptions_Set + -- is set to True, and Zero_Cost_Exceptions_Val indicates the setting. + -- This value is used to reset ZCX_By_Default_On_Target. + + ---------------------------- + -- Configuration Settings -- + ---------------------------- + + -- These are settings that are used to establish the mode at the start + -- of each unit. The values defined below can be affected either by + -- command line switches, or by the use of appropriate configuration + -- pragmas in the gnat.adc file. + + Ada_83_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch for Ada 83 mode, as set + -- by the command line switch -gnat83, and possibly modified by the use + -- of configuration pragmas Ada_95 and Ada_83 in the gnat.adc file. This + -- switch is used to set the initial value for Ada_83 mode at the start + -- of analysis of a unit. Note however, that the setting of this switch + -- is ignored for internal and predefined units (which are always compiled + -- in Ada 95 mode). + + Dynamic_Elaboration_Checks_Config : Boolean := False; + -- GNAT + -- Set True for dynamic elaboration checking mode, as set by the -gnatE + -- switch or by the use of pragma Elaboration_Checking (Dynamic). + + Extensions_Allowed_Config : Boolean; + -- GNAT + -- This is the switch that indicates whether extensions are allowed. + -- It can be set True either by use of the -gnatX switch, or by use + -- of the configuration pragma Extensions_Allowed (On). It is always + -- set to True for internal GNAT units, since extensions are always + -- permitted in such units. + + External_Name_Exp_Casing_Config : External_Casing_Type; + -- GNAT + -- This is the value of the configuration switch that controls casing + -- of external symbols for which an explicit external name is given. It + -- can be set to Uppercase by the command line switch -gnatF, and further + -- modified by the use of the configuration pragma External_Name_Casing + -- in the gnat.adc file. This switch is used to set the initial value + -- for External_Name_Exp_Casing at the start of analyzing each unit. + -- Note however that the setting of this switch is ignored for internal + -- and predefined units (which are always compiled with As_Is mode). + + External_Name_Imp_Casing_Config : External_Casing_Type; + -- GNAT + -- This is the value of the configuration switch that controls casing + -- of external symbols where the external name is implicitly given. It + -- can be set to Uppercase by the command line switch -gnatF, and further + -- modified by the use of the configuration pragma External_Name_Casing + -- in the gnat.adc file. This switch is used to set the initial value + -- for External_Name_Imp_Casing at the start of analyzing each unit. + -- Note however that the setting of this switch is ignored for internal + -- and predefined units (which are always compiled with Lowercase mode). + + Polling_Required_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that controls polling + -- mode. It can be set True by the command line switch -gnatP, and then + -- further modified by the use of pragma Polling in the gnat.adc file. + -- This switch is used to set the initial value for Polling_Required + -- at the start of analyzing each unit. + + Use_VADS_Size_Config : Boolean; + -- GNAT + -- This is the value of the configuration switch that controls the use + -- of VADS_Size instead of Size whereever the attribute Size is used. + -- It can be set True by the use of the pragma Use_VADS_Size in the + -- gnat.adc file. This switch is used to set the initial value for + -- Use_VADS_Size at the start of analyzing each unit. Note however that + -- the setting of this switch is ignored for internal and predefined + -- units (which are always compiled with the standard Size semantics). + + type Config_Switches_Type is private; + -- Type used to save values of the switches set from Config values + + procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type); + -- This procedure saves the current values of the switches which are + -- initialized from the above Config values, and then resets these + -- switches according to the Config value settings. + + procedure Set_Opt_Config_Switches (Internal_Unit : Boolean); + -- This procedure sets the switches to the appropriate initial values. + -- The parameter Internal_Unit is True for an internal or predefined + -- unit, and affects the way the switches are set (see above). + + procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type); + -- This procedure restores a set of switch values previously saved + -- by a call to Save_Opt_Switches. + + procedure Register_Opt_Config_Switches; + -- This procedure is called after processing the gnat.adc file to record + -- the values of the Config switches, as possibly modified by the use + -- of command line switches and configuration pragmas. + + ------------------------ + -- Other Global Flags -- + ------------------------ + + Expander_Active : Boolean := False; + -- A flag that indicates if expansion is active (True) or deactivated + -- (False). When expansion is deactivated all calls to expander routines + -- have no effect. Note that the initial setting of False is merely to + -- prevent saving of an undefined value for an initial call to the + -- Expander_Mode_Save_And_Set procedure. For more information on the + -- use of this flag, see package Expander. Indeed this flag might more + -- logically be in the spec of Expander, but it is referenced by Errout, + -- and it really seems wrong for Errout to depend on Expander. + + ----------------------- + -- Tree I/O Routines -- + ----------------------- + + procedure Tree_Read; + -- Reads switch settings from current tree file using Tree_Read + + procedure Tree_Write; + -- Writes out switch settings to current tree file using Tree_Write + +private + + type Config_Switches_Type is record + Ada_83 : Boolean; + Dynamic_Elaboration_Checks : Boolean; + Extensions_Allowed : Boolean; + External_Name_Exp_Casing : External_Casing_Type; + External_Name_Imp_Casing : External_Casing_Type; + Polling_Required : Boolean; + Use_VADS_Size : Boolean; + end record; + +end Opt; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb new file mode 100644 index 00000000000..5d5bf72c231 --- /dev/null +++ b/gcc/ada/osint.adb @@ -0,0 +1,2722 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.258 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sdefault; use Sdefault; +with Table; +with Tree_IO; use Tree_IO; + +with Unchecked_Conversion; + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.HTable; + +package body Osint is + + ------------------------------------- + -- Use of Name_Find and Name_Enter -- + ------------------------------------- + + -- This package creates a number of source, ALI and object file names + -- that are used to locate the actual file and for the purpose of + -- message construction. These names need not be accessible by Name_Find, + -- and can be therefore created by using routine Name_Enter. The files in + -- question are file names with a prefix directory (ie the files not + -- in the current directory). File names without a prefix directory are + -- entered with Name_Find because special values might be attached to + -- the various Info fields of the corresponding name table entry. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Append_Suffix_To_File_Name + (Name : Name_Id; + Suffix : String) + return Name_Id; + -- Appends Suffix to Name and returns the new name. + + function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; + -- Convert OS format time to GNAT format time stamp + + procedure Create_File_And_Check + (Fdesc : out File_Descriptor; + Fmode : Mode); + -- Create file whose name (NUL terminated) is in Name_Buffer (with the + -- length in Name_Len), and place the resulting descriptor in Fdesc. + -- Issue message and exit with fatal error if file cannot be created. + -- The Fmode parameter is set to either Text or Binary (see description + -- of GNAT.OS_Lib.Create_File). + + procedure Set_Library_Info_Name; + -- Sets a default ali file name from the main compiler source name. + -- This is used by Create_Output_Library_Info, and by the version of + -- Read_Library_Info that takes a default file name. + + procedure Write_Info (Info : String); + -- Implementation of Write_Binder_Info, Write_Debug_Info and + -- Write_Library_Info (identical) + + procedure Write_With_Check (A : Address; N : Integer); + -- Writes N bytes from buffer starting at address A to file whose FD is + -- stored in Output_FD, and whose file name is stored as a File_Name_Type + -- in Output_File_Name. A check is made for disk full, and if this is + -- detected, the file being written is deleted, and a fatal error is + -- signalled. + + function More_Files return Boolean; + -- Implements More_Source_Files and More_Lib_Files. + + function Next_Main_File return File_Name_Type; + -- Implements Next_Main_Source and Next_Main_Lib_File. + + function Locate_File + (N : File_Name_Type; + T : File_Type; + Dir : Natural; + Name : String) + return File_Name_Type; + -- See if the file N whose name is Name exists in directory Dir. Dir is + -- an index into the Lib_Search_Directories table if T = Library. + -- Otherwise if T = Source, Dir is an index into the + -- Src_Search_Directories table. Returns the File_Name_Type of the + -- full file name if file found, or No_File if not found. + + function C_String_Length (S : Address) return Integer; + -- Returns length of a C string. Returns zero for a null address. + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) + return String_Access; + -- Converts a C String to an Ada String. Are we doing this to avoid + -- withing Interfaces.C.Strings ??? + + ------------------------------ + -- Other Local Declarations -- + ------------------------------ + + ALI_Suffix : constant String_Ptr := new String'("ali"); + -- The suffix used for the library files (also known as ALI files). + + Object_Suffix : constant String := Get_Object_Suffix.all; + -- The suffix used for the object files. + + EOL : constant Character := ASCII.LF; + -- End of line character + + Argument_Count : constant Integer := Arg_Count - 1; + -- Number of arguments (excluding program name) + + type File_Name_Array is array (Int range <>) of String_Ptr; + type File_Name_Array_Ptr is access File_Name_Array; + File_Names : File_Name_Array_Ptr := + new File_Name_Array (1 .. Int (Argument_Count) + 2); + -- As arguments are scanned in Initialize, file names are stored + -- in this array. The string does not contain a terminating NUL. + -- The array is "extensible" because when using project files, + -- there may be more file names than argument on the command line. + + Number_File_Names : Int := 0; + -- The total number of file names found on command line and placed in + -- File_Names. + + Current_File_Name_Index : Int := 0; + -- The index in File_Names of the last file opened by Next_Main_Source + -- or Next_Main_Lib_File. The value 0 indicates that no files have been + -- opened yet. + + Current_Main : File_Name_Type := No_File; + -- Used to save a simple file name between calls to Next_Main_Source and + -- Read_Source_File. If the file name argument to Read_Source_File is + -- No_File, that indicates that the file whose name was returned by the + -- last call to Next_Main_Source (and stored here) is to be read. + + Look_In_Primary_Directory_For_Current_Main : Boolean := False; + -- When this variable is True, Find_File will only look in + -- the Primary_Directory for the Current_Main file. + -- This variable is always True for the compiler. + -- It is also True for gnatmake, when the soucr name given + -- on the command line has directory information. + + Current_Full_Source_Name : File_Name_Type := No_File; + Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp; + Current_Full_Lib_Name : File_Name_Type := No_File; + Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp; + Current_Full_Obj_Name : File_Name_Type := No_File; + Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp; + -- Respectively full name (with directory info) and time stamp of + -- the latest source, library and object files opened by Read_Source_File + -- and Read_Library_Info. + + Old_Binder_Output_Time_Stamp : Time_Stamp_Type; + New_Binder_Output_Time_Stamp : Time_Stamp_Type; + Recording_Time_From_Last_Bind : Boolean := False; + Binder_Output_Time_Stamps_Set : Boolean := False; + + In_Binder : Boolean := False; + In_Compiler : Boolean := False; + In_Make : Boolean := False; + -- Exactly one of these flags is set True to indicate which program + -- is bound and executing with Osint, which is used by all these programs. + + Output_FD : File_Descriptor; + -- The file descriptor for the current library info, tree or binder output + + Output_File_Name : File_Name_Type; + -- File_Name_Type for name of open file whose FD is in Output_FD, the name + -- stored does not include the trailing NUL character. + + Output_Object_File_Name : String_Ptr; + -- Argument of -o compiler option, if given. This is needed to + -- verify consistency with the ALI file name. + + ------------------ + -- Search Paths -- + ------------------ + + Primary_Directory : constant := 0; + -- This is index in the tables created below for the first directory to + -- search in for source or library information files. This is the + -- directory containing the latest main input file (a source file for + -- the compiler or a library file for the binder). + + package Src_Search_Directories is new Table.Table ( + Table_Component_Type => String_Ptr, + Table_Index_Type => Natural, + Table_Low_Bound => Primary_Directory, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Osint.Src_Search_Directories"); + -- Table of names of directories in which to search for source (Compiler) + -- files. This table is filled in the order in which the directories are + -- to be searched, and then used in that order. + + package Lib_Search_Directories is new Table.Table ( + Table_Component_Type => String_Ptr, + Table_Index_Type => Natural, + Table_Low_Bound => Primary_Directory, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Osint.Lib_Search_Directories"); + -- Table of names of directories in which to search for library (Binder) + -- files. This table is filled in the order in which the directories are + -- to be searched and then used in that order. The reason for having two + -- distinct tables is that we need them both in gnatmake. + + --------------------- + -- File Hash Table -- + --------------------- + + -- The file hash table is provided to free the programmer from any + -- efficiency concern when retrieving full file names or time stamps of + -- source files. If the programmer calls Source_File_Data (Cache => True) + -- he is guaranteed that the price to retrieve the full name (ie with + -- directory info) or time stamp of the file will be payed only once, + -- the first time the full name is actually searched (or the first time + -- the time stamp is actually retrieved). This is achieved by employing + -- a hash table that stores as a key the File_Name_Type of the file and + -- associates to that File_Name_Type the full file name of the file and its + -- time stamp. + + File_Cache_Enabled : Boolean := False; + -- Set to true if you want the enable the file data caching mechanism. + + type File_Hash_Num is range 0 .. 1020; + + function File_Hash (F : File_Name_Type) return File_Hash_Num; + -- Compute hash index for use by Simple_HTable + + package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( + Header_Num => File_Hash_Num, + Element => File_Name_Type, + No_Element => No_File, + Key => File_Name_Type, + Hash => File_Hash, + Equal => "="); + + package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable ( + Header_Num => File_Hash_Num, + Element => Time_Stamp_Type, + No_Element => Empty_Time_Stamp, + Key => File_Name_Type, + Hash => File_Hash, + Equal => "="); + + function Smart_Find_File + (N : File_Name_Type; + T : File_Type) + return File_Name_Type; + -- Exactly like Find_File except that if File_Cache_Enabled is True this + -- routine looks first in the hash table to see if the full name of the + -- file is already available. + + function Smart_File_Stamp + (N : File_Name_Type; + T : File_Type) + return Time_Stamp_Type; + -- Takes the same parameter as the routine above (N is a file name + -- without any prefix directory information) and behaves like File_Stamp + -- except that if File_Cache_Enabled is True this routine looks first in + -- the hash table to see if the file stamp of the file is already + -- available. + + ----------------------------- + -- Add_Default_Search_Dirs -- + ----------------------------- + + procedure Add_Default_Search_Dirs is + Search_Dir : String_Access; + Search_Path : String_Access; + + procedure Add_Search_Dir + (Search_Dir : String_Access; + Additional_Source_Dir : Boolean); + -- Needs documentation ??? + + function Get_Libraries_From_Registry return String_Ptr; + -- On Windows systems, get the list of installed standard libraries + -- from the registry key: + -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\ + -- GNAT\Standard Libraries + -- Return an empty string on other systems + + function Update_Path (Path : String_Ptr) return String_Ptr; + -- Update the specified path to replace the prefix with + -- the location where GNAT is installed. See the file prefix.c + -- in GCC for more details. + + -------------------- + -- Add_Search_Dir -- + -------------------- + + procedure Add_Search_Dir + (Search_Dir : String_Access; + Additional_Source_Dir : Boolean) + is + begin + if Additional_Source_Dir then + Add_Src_Search_Dir (Search_Dir.all); + else + Add_Lib_Search_Dir (Search_Dir.all); + end if; + end Add_Search_Dir; + + --------------------------------- + -- Get_Libraries_From_Registry -- + --------------------------------- + + function Get_Libraries_From_Registry return String_Ptr is + function C_Get_Libraries_From_Registry return Address; + pragma Import (C, C_Get_Libraries_From_Registry, + "__gnat_get_libraries_from_registry"); + function Strlen (Str : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + procedure Strncpy (X : Address; Y : Address; Length : Integer); + pragma Import (C, Strncpy, "strncpy"); + Result_Ptr : Address; + Result_Length : Integer; + Out_String : String_Ptr; + + begin + Result_Ptr := C_Get_Libraries_From_Registry; + Result_Length := Strlen (Result_Ptr); + + Out_String := new String (1 .. Result_Length); + Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); + return Out_String; + end Get_Libraries_From_Registry; + + ----------------- + -- Update_Path -- + ----------------- + + function Update_Path (Path : String_Ptr) return String_Ptr is + + function C_Update_Path (Path, Component : Address) return Address; + pragma Import (C, C_Update_Path, "update_path"); + + function Strlen (Str : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + procedure Strncpy (X : Address; Y : Address; Length : Integer); + pragma Import (C, Strncpy, "strncpy"); + + In_Length : constant Integer := Path'Length; + In_String : String (1 .. In_Length + 1); + Component_Name : aliased String := "GNAT" & ASCII.NUL; + Result_Ptr : Address; + Result_Length : Integer; + Out_String : String_Ptr; + + begin + In_String (1 .. In_Length) := Path.all; + In_String (In_Length + 1) := ASCII.NUL; + Result_Ptr := C_Update_Path (In_String'Address, + Component_Name'Address); + Result_Length := Strlen (Result_Ptr); + + Out_String := new String (1 .. Result_Length); + Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); + return Out_String; + end Update_Path; + + -- Start of processing for Add_Default_Search_Dirs + + begin + -- After the locations specified on the command line, the next places + -- to look for files are the directories specified by the appropriate + -- environment variable. Get this value, extract the directory names + -- and store in the tables. + + -- On VMS, don't expand the logical name (e.g. environment variable), + -- just put it into Unix (e.g. canonical) format. System services + -- will handle the expansion as part of the file processing. + + for Additional_Source_Dir in False .. True loop + + if Additional_Source_Dir then + Search_Path := Getenv ("ADA_INCLUDE_PATH"); + if Search_Path'Length > 0 then + if Hostparm.OpenVMS then + Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:"); + else + Search_Path := To_Canonical_Path_Spec (Search_Path.all); + end if; + end if; + else + Search_Path := Getenv ("ADA_OBJECTS_PATH"); + if Search_Path'Length > 0 then + if Hostparm.OpenVMS then + Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:"); + else + Search_Path := To_Canonical_Path_Spec (Search_Path.all); + end if; + end if; + end if; + + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, Additional_Source_Dir); + end loop; + end loop; + + if not Opt.No_Stdinc then + -- For WIN32 systems, look for any system libraries defined in + -- the registry. These are added to both source and object + -- directories. + + Search_Path := String_Access (Get_Libraries_From_Registry); + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, False); + Add_Search_Dir (Search_Dir, True); + end loop; + + -- The last place to look are the defaults + + Search_Path := Read_Default_Search_Dirs + (String_Access (Update_Path (Search_Dir_Prefix)), + Include_Search_File, + String_Access (Update_Path (Include_Dir_Default_Name))); + + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, True); + end loop; + end if; + + if not Opt.No_Stdlib then + Search_Path := Read_Default_Search_Dirs + (String_Access (Update_Path (Search_Dir_Prefix)), + Objects_Search_File, + String_Access (Update_Path (Object_Dir_Default_Name))); + + Get_Next_Dir_In_Path_Init (Search_Path); + loop + Search_Dir := Get_Next_Dir_In_Path (Search_Path); + exit when Search_Dir = null; + Add_Search_Dir (Search_Dir, False); + end loop; + end if; + + end Add_Default_Search_Dirs; + + -------------- + -- Add_File -- + -------------- + + procedure Add_File (File_Name : String) is + begin + Number_File_Names := Number_File_Names + 1; + + -- As Add_File may be called for mains specified inside + -- a project file, File_Names may be too short and needs + -- to be extended. + + if Number_File_Names > File_Names'Last then + File_Names := new File_Name_Array'(File_Names.all & File_Names.all); + end if; + + File_Names (Number_File_Names) := new String'(File_Name); + end Add_File; + + ------------------------ + -- Add_Lib_Search_Dir -- + ------------------------ + + procedure Add_Lib_Search_Dir (Dir : String) is + begin + if Dir'Length = 0 then + Fail ("missing library directory name"); + end if; + + Lib_Search_Directories.Increment_Last; + Lib_Search_Directories.Table (Lib_Search_Directories.Last) := + Normalize_Directory_Name (Dir); + end Add_Lib_Search_Dir; + + ------------------------ + -- Add_Src_Search_Dir -- + ------------------------ + + procedure Add_Src_Search_Dir (Dir : String) is + begin + if Dir'Length = 0 then + Fail ("missing source directory name"); + end if; + + Src_Search_Directories.Increment_Last; + Src_Search_Directories.Table (Src_Search_Directories.Last) := + Normalize_Directory_Name (Dir); + end Add_Src_Search_Dir; + + -------------------------------- + -- Append_Suffix_To_File_Name -- + -------------------------------- + + function Append_Suffix_To_File_Name + (Name : Name_Id; + Suffix : String) + return Name_Id + is + begin + Get_Name_String (Name); + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + return Name_Find; + end Append_Suffix_To_File_Name; + + --------------------- + -- C_String_Length -- + --------------------- + + function C_String_Length (S : Address) return Integer is + function Strlen (S : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + begin + if S = Null_Address then + return 0; + else + return Strlen (S); + end if; + end C_String_Length; + + ------------------------------ + -- Canonical_Case_File_Name -- + ------------------------------ + + -- For now, we only deal with the case of a-z. Eventually we should + -- worry about other Latin-1 letters on systems that support this ??? + + procedure Canonical_Case_File_Name (S : in out String) is + begin + if not File_Names_Case_Sensitive then + for J in S'Range loop + if S (J) in 'A' .. 'Z' then + S (J) := Character'Val ( + Character'Pos (S (J)) + + Character'Pos ('a') - + Character'Pos ('A')); + end if; + end loop; + end if; + end Canonical_Case_File_Name; + + ------------------------- + -- Close_Binder_Output -- + ------------------------- + + procedure Close_Binder_Output is + begin + pragma Assert (In_Binder); + Close (Output_FD); + + if Recording_Time_From_Last_Bind then + New_Binder_Output_Time_Stamp := File_Stamp (Output_File_Name); + Binder_Output_Time_Stamps_Set := True; + end if; + end Close_Binder_Output; + + ---------------------- + -- Close_Debug_File -- + ---------------------- + + procedure Close_Debug_File is + begin + pragma Assert (In_Compiler); + Close (Output_FD); + end Close_Debug_File; + + ------------------------------- + -- Close_Output_Library_Info -- + ------------------------------- + + procedure Close_Output_Library_Info is + begin + pragma Assert (In_Compiler); + Close (Output_FD); + end Close_Output_Library_Info; + + -------------------------- + -- Create_Binder_Output -- + -------------------------- + + procedure Create_Binder_Output + (Output_File_Name : String; + Typ : Character; + Bfile : out Name_Id) + is + File_Name : String_Ptr; + Findex1 : Natural; + Findex2 : Natural; + Flength : Natural; + + begin + pragma Assert (In_Binder); + + if Output_File_Name /= "" then + Name_Buffer (Output_File_Name'Range) := Output_File_Name; + Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL; + + if Typ = 's' then + Name_Buffer (Output_File_Name'Last) := 's'; + end if; + + Name_Len := Output_File_Name'Last; + + else + Name_Buffer (1) := 'b'; + File_Name := File_Names (Current_File_Name_Index); + + Findex1 := File_Name'First; + + -- The ali file might be specified by a full path name. However, + -- the binder generated file should always be created in the + -- current directory, so the path might need to be stripped away. + -- In addition to the default directory_separator allow the '/' to + -- act as separator since this is allowed in MS-DOS and OS2 ports. + + for J in reverse File_Name'Range loop + if File_Name (J) = Directory_Separator + or else File_Name (J) = '/' + then + Findex1 := J + 1; + exit; + end if; + end loop; + + Findex2 := File_Name'Last; + while File_Name (Findex2) /= '.' loop + Findex2 := Findex2 - 1; + end loop; + + Flength := Findex2 - Findex1; + + if Maximum_File_Name_Length > 0 then + + -- Make room for the extra two characters in "b?" + + while Int (Flength) > Maximum_File_Name_Length - 2 loop + Findex2 := Findex2 - 1; + Flength := Findex2 - Findex1; + end loop; + end if; + + Name_Buffer (3 .. Flength + 2) := File_Name (Findex1 .. Findex2 - 1); + Name_Buffer (Flength + 3) := '.'; + + -- C bind file, name is b_xxx.c + + if Typ = 'c' then + Name_Buffer (2) := '_'; + Name_Buffer (Flength + 4) := 'c'; + Name_Buffer (Flength + 5) := ASCII.NUL; + Name_Len := Flength + 4; + + -- Ada bind file, name is b~xxx.adb or b~xxx.ads + -- (with $ instead of ~ in VMS) + + else + if Hostparm.OpenVMS then + Name_Buffer (2) := '$'; + else + Name_Buffer (2) := '~'; + end if; + + Name_Buffer (Flength + 4) := 'a'; + Name_Buffer (Flength + 5) := 'd'; + Name_Buffer (Flength + 6) := Typ; + Name_Buffer (Flength + 7) := ASCII.NUL; + Name_Len := Flength + 6; + end if; + end if; + + Bfile := Name_Find; + + if Recording_Time_From_Last_Bind then + Old_Binder_Output_Time_Stamp := File_Stamp (Bfile); + end if; + + Create_File_And_Check (Output_FD, Text); + end Create_Binder_Output; + + ----------------------- + -- Create_Debug_File -- + ----------------------- + + function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is + Result : File_Name_Type; + + begin + Get_Name_String (Src); + if Hostparm.OpenVMS then + Name_Buffer (Name_Len + 1 .. Name_Len + 3) := "_dg"; + else + Name_Buffer (Name_Len + 1 .. Name_Len + 3) := ".dg"; + end if; + Name_Len := Name_Len + 3; + Result := Name_Find; + Name_Buffer (Name_Len + 1) := ASCII.NUL; + Create_File_And_Check (Output_FD, Text); + return Result; + end Create_Debug_File; + + --------------------------- + -- Create_File_And_Check -- + --------------------------- + + procedure Create_File_And_Check + (Fdesc : out File_Descriptor; + Fmode : Mode) + is + begin + Output_File_Name := Name_Enter; + Fdesc := Create_File (Name_Buffer'Address, Fmode); + + if Fdesc = Invalid_FD then + Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len)); + end if; + end Create_File_And_Check; + + -------------------------------- + -- Create_Output_Library_Info -- + -------------------------------- + + procedure Create_Output_Library_Info is + begin + Set_Library_Info_Name; + Create_File_And_Check (Output_FD, Text); + end Create_Output_Library_Info; + + -------------------------------- + -- Current_Library_File_Stamp -- + -------------------------------- + + function Current_Library_File_Stamp return Time_Stamp_Type is + begin + return Current_Full_Lib_Stamp; + end Current_Library_File_Stamp; + + ------------------------------- + -- Current_Object_File_Stamp -- + ------------------------------- + + function Current_Object_File_Stamp return Time_Stamp_Type is + begin + return Current_Full_Obj_Stamp; + end Current_Object_File_Stamp; + + ------------------------------- + -- Current_Source_File_Stamp -- + ------------------------------- + + function Current_Source_File_Stamp return Time_Stamp_Type is + begin + return Current_Full_Source_Stamp; + end Current_Source_File_Stamp; + + --------------------------- + -- Debug_File_Eol_Length -- + --------------------------- + + function Debug_File_Eol_Length return Nat is + begin + -- There has to be a cleaner way to do this! ??? + + if Directory_Separator = '/' then + return 1; + else + return 2; + end if; + end Debug_File_Eol_Length; + + ---------------------------- + -- Dir_In_Obj_Search_Path -- + ---------------------------- + + function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is + begin + if Opt.Look_In_Primary_Dir then + return + Lib_Search_Directories.Table (Primary_Directory + Position - 1); + else + return Lib_Search_Directories.Table (Primary_Directory + Position); + end if; + end Dir_In_Obj_Search_Path; + + ---------------------------- + -- Dir_In_Src_Search_Path -- + ---------------------------- + + function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is + begin + if Opt.Look_In_Primary_Dir then + return + Src_Search_Directories.Table (Primary_Directory + Position - 1); + else + return Src_Search_Directories.Table (Primary_Directory + Position); + end if; + end Dir_In_Src_Search_Path; + + --------------------- + -- Executable_Name -- + --------------------- + + function Executable_Name (Name : File_Name_Type) return File_Name_Type is + Exec_Suffix : String_Access; + + begin + if Name = No_File then + return No_File; + end if; + + Get_Name_String (Name); + Exec_Suffix := Get_Executable_Suffix; + + for J in Exec_Suffix.all'Range loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Exec_Suffix.all (J); + end loop; + + return Name_Enter; + end Executable_Name; + + ------------------ + -- Exit_Program -- + ------------------ + + procedure Exit_Program (Exit_Code : Exit_Code_Type) is + begin + -- The program will exit with the following status: + -- 0 if the object file has been generated (with or without warnings) + -- 1 if recompilation was not needed (smart recompilation) + -- 2 if gnat1 has been killed by a signal (detected by GCC) + -- 3 if no code has been generated (spec) + -- 4 for a fatal error + -- 5 if there were errors + + case Exit_Code is + when E_Success => OS_Exit (0); + when E_Warnings => OS_Exit (0); + when E_No_Compile => OS_Exit (1); + when E_No_Code => OS_Exit (3); + when E_Fatal => OS_Exit (4); + when E_Errors => OS_Exit (5); + when E_Abort => OS_Abort; + end case; + end Exit_Program; + + ---------- + -- Fail -- + ---------- + + procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is + begin + Set_Standard_Error; + Osint.Write_Program_Name; + Write_Str (": "); + Write_Str (S1); + Write_Str (S2); + Write_Str (S3); + Write_Eol; + + -- ??? Using Output is ugly, should do direct writes + -- ??? shouldn't this go to standard error instead of stdout? + + Exit_Program (E_Fatal); + end Fail; + + --------------- + -- File_Hash -- + --------------- + + function File_Hash (F : File_Name_Type) return File_Hash_Num is + begin + return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length); + end File_Hash; + + ---------------- + -- File_Stamp -- + ---------------- + + function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is + begin + if Name = No_File then + return Empty_Time_Stamp; + end if; + + Get_Name_String (Name); + + if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then + return Empty_Time_Stamp; + else + Name_Buffer (Name_Len + 1) := ASCII.NUL; + return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer)); + end if; + end File_Stamp; + + --------------- + -- Find_File -- + --------------- + + function Find_File + (N : File_Name_Type; + T : File_Type) + return File_Name_Type + is + begin + Get_Name_String (N); + + declare + File_Name : String renames Name_Buffer (1 .. Name_Len); + File : File_Name_Type := No_File; + Last_Dir : Natural; + + begin + -- If we are looking for a config file, look only in the current + -- directory, i.e. return input argument unchanged. Also look + -- only in the current directory if we are looking for a .dg + -- file (happens in -gnatD mode) + + if T = Config + or else (Debug_Generated_Code + and then Name_Len > 3 + and then + (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg" + or else + (Hostparm.OpenVMS and then + Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg"))) + then + return N; + + -- If we are trying to find the current main file just look in the + -- directory where the user said it was. + + elsif Look_In_Primary_Directory_For_Current_Main + and then Current_Main = N then + return Locate_File (N, T, Primary_Directory, File_Name); + + -- Otherwise do standard search for source file + + else + -- First place to look is in the primary directory (i.e. the same + -- directory as the source) unless this has been disabled with -I- + + if Opt.Look_In_Primary_Dir then + File := Locate_File (N, T, Primary_Directory, File_Name); + + if File /= No_File then + return File; + end if; + end if; + + -- Finally look in directories specified with switches -I/-aI/-aO + + if T = Library then + Last_Dir := Lib_Search_Directories.Last; + else + Last_Dir := Src_Search_Directories.Last; + end if; + + for D in Primary_Directory + 1 .. Last_Dir loop + File := Locate_File (N, T, D, File_Name); + + if File /= No_File then + return File; + end if; + end loop; + + return No_File; + end if; + end; + end Find_File; + + ----------------------- + -- Find_Program_Name -- + ----------------------- + + procedure Find_Program_Name is + Command_Name : String (1 .. Len_Arg (0)); + Cindex1 : Integer := Command_Name'First; + Cindex2 : Integer := Command_Name'Last; + + begin + Fill_Arg (Command_Name'Address, 0); + + -- The program name might be specified by a full path name. However, + -- we don't want to print that all out in an error message, so the + -- path might need to be stripped away. + + for J in reverse Cindex1 .. Cindex2 loop + if Is_Directory_Separator (Command_Name (J)) then + Cindex1 := J + 1; + exit; + end if; + end loop; + + for J in reverse Cindex1 .. Cindex2 loop + if Command_Name (J) = '.' then + Cindex2 := J - 1; + exit; + end if; + end loop; + + Name_Len := Cindex2 - Cindex1 + 1; + Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2); + end Find_Program_Name; + + ------------------------ + -- Full_Lib_File_Name -- + ------------------------ + + function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is + begin + return Find_File (N, Library); + end Full_Lib_File_Name; + + ---------------------------- + -- Full_Library_Info_Name -- + ---------------------------- + + function Full_Library_Info_Name return File_Name_Type is + begin + return Current_Full_Lib_Name; + end Full_Library_Info_Name; + + --------------------------- + -- Full_Object_File_Name -- + --------------------------- + + function Full_Object_File_Name return File_Name_Type is + begin + return Current_Full_Obj_Name; + end Full_Object_File_Name; + + ---------------------- + -- Full_Source_Name -- + ---------------------- + + function Full_Source_Name return File_Name_Type is + begin + return Current_Full_Source_Name; + end Full_Source_Name; + + ---------------------- + -- Full_Source_Name -- + ---------------------- + + function Full_Source_Name (N : File_Name_Type) return File_Name_Type is + begin + return Smart_Find_File (N, Source); + end Full_Source_Name; + + ------------------- + -- Get_Directory -- + ------------------- + + function Get_Directory (Name : File_Name_Type) return File_Name_Type is + begin + Get_Name_String (Name); + + for J in reverse 1 .. Name_Len loop + if Is_Directory_Separator (Name_Buffer (J)) then + Name_Len := J; + return Name_Find; + end if; + end loop; + + Name_Len := Hostparm.Normalized_CWD'Length; + Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD; + return Name_Find; + end Get_Directory; + + -------------------------- + -- Get_Next_Dir_In_Path -- + -------------------------- + + Search_Path_Pos : Integer; + -- Keeps track of current position in search path. Initialized by the + -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path. + + function Get_Next_Dir_In_Path + (Search_Path : String_Access) + return String_Access + is + Lower_Bound : Positive := Search_Path_Pos; + Upper_Bound : Positive; + + begin + loop + while Lower_Bound <= Search_Path'Last + and then Search_Path.all (Lower_Bound) = Path_Separator + loop + Lower_Bound := Lower_Bound + 1; + end loop; + + exit when Lower_Bound > Search_Path'Last; + + Upper_Bound := Lower_Bound; + while Upper_Bound <= Search_Path'Last + and then Search_Path.all (Upper_Bound) /= Path_Separator + loop + Upper_Bound := Upper_Bound + 1; + end loop; + + Search_Path_Pos := Upper_Bound; + return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1)); + end loop; + + return null; + end Get_Next_Dir_In_Path; + + ------------------------------- + -- Get_Next_Dir_In_Path_Init -- + ------------------------------- + + procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is + begin + Search_Path_Pos := Search_Path'First; + end Get_Next_Dir_In_Path_Init; + + -------------------------------------- + -- Get_Primary_Src_Search_Directory -- + -------------------------------------- + + function Get_Primary_Src_Search_Directory return String_Ptr is + begin + return Src_Search_Directories.Table (Primary_Directory); + end Get_Primary_Src_Search_Directory; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (P : Program_Type) is + function Get_Default_Identifier_Character_Set return Character; + pragma Import (C, Get_Default_Identifier_Character_Set, + "__gnat_get_default_identifier_character_set"); + -- Function to determine the default identifier character set, + -- which is system dependent. See Opt package spec for a list of + -- the possible character codes and their interpretations. + + function Get_Maximum_File_Name_Length return Int; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + -- Function to get maximum file name length for system + + procedure Adjust_OS_Resource_Limits; + pragma Import (C, Adjust_OS_Resource_Limits, + "__gnat_adjust_os_resource_limits"); + -- Procedure to make system specific adjustments to make GNAT + -- run better. + + -- Start of processing for Initialize + + begin + Program := P; + + case Program is + when Binder => In_Binder := True; + when Compiler => In_Compiler := True; + when Make => In_Make := True; + end case; + + if In_Compiler then + Adjust_OS_Resource_Limits; + end if; + + Src_Search_Directories.Init; + Lib_Search_Directories.Init; + + Identifier_Character_Set := Get_Default_Identifier_Character_Set; + Maximum_File_Name_Length := Get_Maximum_File_Name_Length; + + -- Following should be removed by having above function return + -- Integer'Last as indication of no maximum instead of -1 ??? + + if Maximum_File_Name_Length = -1 then + Maximum_File_Name_Length := Int'Last; + end if; + + -- Start off by setting all suppress options to False, these will + -- be reset later (turning some on if -gnato is not specified, and + -- turning all of them on if -gnatp is specified). + + Suppress_Options := (others => False); + + -- Set software overflow check flag. For now all targets require the + -- use of software overflow checks. Later on, this will have to be + -- specialized to the backend target. Also, if software overflow + -- checking mode is set, then the default for suppressing overflow + -- checks is True, since the software approach is expensive. + + Software_Overflow_Checking := True; + Suppress_Options.Overflow_Checks := True; + + -- Reserve the first slot in the search paths table. This is the + -- directory of the main source file or main library file and is + -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with + -- the directory specified for this main source or library file. This + -- is the directory which is searched first by default. This default + -- search is inhibited by the option -I- for both source and library + -- files. + + Src_Search_Directories.Set_Last (Primary_Directory); + Src_Search_Directories.Table (Primary_Directory) := new String'(""); + + Lib_Search_Directories.Set_Last (Primary_Directory); + Lib_Search_Directories.Table (Primary_Directory) := new String'(""); + + end Initialize; + + ---------------------------- + -- Is_Directory_Separator -- + ---------------------------- + + function Is_Directory_Separator (C : Character) return Boolean is + begin + -- In addition to the default directory_separator allow the '/' to + -- act as separator since this is allowed in MS-DOS, Windows 95/NT, + -- and OS2 ports. On VMS, the situation is more complicated because + -- there are two characters to check for. + + return + C = Directory_Separator + or else C = '/' + or else (Hostparm.OpenVMS + and then (C = ']' or else C = ':')); + end Is_Directory_Separator; + + ------------------------- + -- Is_Readonly_Library -- + ------------------------- + + function Is_Readonly_Library (File : in File_Name_Type) return Boolean is + begin + Get_Name_String (File); + + pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali"); + + return not Is_Writable_File (Name_Buffer (1 .. Name_Len)); + end Is_Readonly_Library; + + ------------------- + -- Lib_File_Name -- + ------------------- + + function Lib_File_Name + (Source_File : File_Name_Type) + return File_Name_Type + is + Fptr : Natural; + -- Pointer to location to set extension in place + + begin + Get_Name_String (Source_File); + Fptr := Name_Len + 1; + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Fptr := J; + exit; + end if; + end loop; + + Name_Buffer (Fptr) := '.'; + Name_Buffer (Fptr + 1 .. Fptr + ALI_Suffix'Length) := ALI_Suffix.all; + Name_Buffer (Fptr + ALI_Suffix'Length + 1) := ASCII.NUL; + Name_Len := Fptr + ALI_Suffix'Length; + return Name_Find; + end Lib_File_Name; + + ------------------------ + -- Library_File_Stamp -- + ------------------------ + + function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is + begin + return File_Stamp (Find_File (N, Library)); + end Library_File_Stamp; + + ----------------- + -- Locate_File -- + ----------------- + + function Locate_File + (N : File_Name_Type; + T : File_Type; + Dir : Natural; + Name : String) + return File_Name_Type + is + Dir_Name : String_Ptr; + + begin + if T = Library then + Dir_Name := Lib_Search_Directories.Table (Dir); + + else pragma Assert (T = Source); + Dir_Name := Src_Search_Directories.Table (Dir); + end if; + + declare + Full_Name : String (1 .. Dir_Name'Length + Name'Length); + + begin + Full_Name (1 .. Dir_Name'Length) := Dir_Name.all; + Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name; + + if not Is_Regular_File (Full_Name) then + return No_File; + + else + -- If the file is in the current directory then return N itself + + if Dir_Name'Length = 0 then + return N; + else + Name_Len := Full_Name'Length; + Name_Buffer (1 .. Name_Len) := Full_Name; + return Name_Enter; + end if; + end if; + end; + end Locate_File; + + ------------------------------- + -- Matching_Full_Source_Name -- + ------------------------------- + + function Matching_Full_Source_Name + (N : File_Name_Type; + T : Time_Stamp_Type) + return File_Name_Type + is + begin + Get_Name_String (N); + + declare + File_Name : constant String := Name_Buffer (1 .. Name_Len); + File : File_Name_Type := No_File; + Last_Dir : Natural; + + begin + if Opt.Look_In_Primary_Dir then + File := Locate_File (N, Source, Primary_Directory, File_Name); + + if File /= No_File and then T = File_Stamp (N) then + return File; + end if; + end if; + + Last_Dir := Src_Search_Directories.Last; + + for D in Primary_Directory + 1 .. Last_Dir loop + File := Locate_File (N, Source, D, File_Name); + + if File /= No_File and then T = File_Stamp (File) then + return File; + end if; + end loop; + + return No_File; + end; + end Matching_Full_Source_Name; + + ---------------- + -- More_Files -- + ---------------- + + function More_Files return Boolean is + begin + return (Current_File_Name_Index < Number_File_Names); + end More_Files; + + -------------------- + -- More_Lib_Files -- + -------------------- + + function More_Lib_Files return Boolean is + begin + pragma Assert (In_Binder); + return More_Files; + end More_Lib_Files; + + ----------------------- + -- More_Source_Files -- + ----------------------- + + function More_Source_Files return Boolean is + begin + pragma Assert (In_Compiler or else In_Make); + return More_Files; + end More_Source_Files; + + ------------------------------- + -- Nb_Dir_In_Obj_Search_Path -- + ------------------------------- + + function Nb_Dir_In_Obj_Search_Path return Natural is + begin + if Opt.Look_In_Primary_Dir then + return Lib_Search_Directories.Last - Primary_Directory + 1; + else + return Lib_Search_Directories.Last - Primary_Directory; + end if; + end Nb_Dir_In_Obj_Search_Path; + + ------------------------------- + -- Nb_Dir_In_Src_Search_Path -- + ------------------------------- + + function Nb_Dir_In_Src_Search_Path return Natural is + begin + if Opt.Look_In_Primary_Dir then + return Src_Search_Directories.Last - Primary_Directory + 1; + else + return Src_Search_Directories.Last - Primary_Directory; + end if; + end Nb_Dir_In_Src_Search_Path; + + -------------------- + -- Next_Main_File -- + -------------------- + + function Next_Main_File return File_Name_Type is + File_Name : String_Ptr; + Dir_Name : String_Ptr; + Fptr : Natural; + + begin + pragma Assert (More_Files); + + Current_File_Name_Index := Current_File_Name_Index + 1; + + -- Get the file and directory name + + File_Name := File_Names (Current_File_Name_Index); + Fptr := File_Name'First; + + for J in reverse File_Name'Range loop + if File_Name (J) = Directory_Separator + or else File_Name (J) = '/' + then + if J = File_Name'Last then + Fail ("File name missing"); + end if; + + Fptr := J + 1; + exit; + end if; + end loop; + + -- Save name of directory in which main unit resides for use in + -- locating other units + + Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1)); + + if In_Compiler then + Src_Search_Directories.Table (Primary_Directory) := Dir_Name; + Look_In_Primary_Directory_For_Current_Main := True; + + elsif In_Make then + Src_Search_Directories.Table (Primary_Directory) := Dir_Name; + if Fptr > File_Name'First then + Look_In_Primary_Directory_For_Current_Main := True; + end if; + + else pragma Assert (In_Binder); + Dir_Name := Normalize_Directory_Name (Dir_Name.all); + Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; + end if; + + Name_Len := File_Name'Last - Fptr + 1; + Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Current_Main := File_Name_Type (Name_Find); + + -- In the gnatmake case, the main file may have not have the + -- extension. Try ".adb" first then ".ads" + + if In_Make then + declare + Orig_Main : File_Name_Type := Current_Main; + + begin + if Strip_Suffix (Orig_Main) = Orig_Main then + Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb"); + + if Full_Source_Name (Current_Main) = No_File then + Current_Main := + Append_Suffix_To_File_Name (Orig_Main, ".ads"); + + if Full_Source_Name (Current_Main) = No_File then + Current_Main := Orig_Main; + end if; + end if; + end if; + end; + end if; + + return Current_Main; + end Next_Main_File; + + ------------------------ + -- Next_Main_Lib_File -- + ------------------------ + + function Next_Main_Lib_File return File_Name_Type is + begin + pragma Assert (In_Binder); + return Next_Main_File; + end Next_Main_Lib_File; + + ---------------------- + -- Next_Main_Source -- + ---------------------- + + function Next_Main_Source return File_Name_Type is + Main_File : File_Name_Type := Next_Main_File; + + begin + pragma Assert (In_Compiler or else In_Make); + return Main_File; + end Next_Main_Source; + + ------------------------------ + -- Normalize_Directory_Name -- + ------------------------------ + + function Normalize_Directory_Name (Directory : String) return String_Ptr is + Result : String_Ptr; + + begin + if Directory'Length = 0 then + Result := new String'(Hostparm.Normalized_CWD); + + elsif Is_Directory_Separator (Directory (Directory'Last)) then + Result := new String'(Directory); + else + Result := new String (1 .. Directory'Length + 1); + Result (1 .. Directory'Length) := Directory; + Result (Directory'Length + 1) := Directory_Separator; + end if; + + return Result; + end Normalize_Directory_Name; + + --------------------- + -- Number_Of_Files -- + --------------------- + + function Number_Of_Files return Int is + begin + return Number_File_Names; + end Number_Of_Files; + + ---------------------- + -- Object_File_Name -- + ---------------------- + + function Object_File_Name (N : File_Name_Type) return File_Name_Type is + begin + if N = No_File then + return No_File; + end if; + + Get_Name_String (N); + Name_Len := Name_Len - ALI_Suffix'Length - 1; + + for J in Object_Suffix'Range loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Object_Suffix (J); + end loop; + + return Name_Enter; + end Object_File_Name; + + -------------------------- + -- OS_Time_To_GNAT_Time -- + -------------------------- + + function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is + GNAT_Time : Time_Stamp_Type; + + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + + begin + GM_Split (T, Y, Mo, D, H, Mn, S); + Make_Time_Stamp + (Year => Nat (Y), + Month => Nat (Mo), + Day => Nat (D), + Hour => Nat (H), + Minutes => Nat (Mn), + Seconds => Nat (S), + TS => GNAT_Time); + + return GNAT_Time; + end OS_Time_To_GNAT_Time; + + ------------------ + -- Program_Name -- + ------------------ + + function Program_Name (Nam : String) return String_Access is + Res : String_Access; + + begin + -- Get the name of the current program being executed + + Find_Program_Name; + + -- Find the target prefix if any, for the cross compilation case + -- for instance in "alpha-dec-vxworks-gcc" the target prefix is + -- "alpha-dec-vxworks-" + + while Name_Len > 0 loop + if Name_Buffer (Name_Len) = '-' then + exit; + end if; + + Name_Len := Name_Len - 1; + end loop; + + -- Create the new program name + + Res := new String (1 .. Name_Len + Nam'Length); + Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam; + return Res; + end Program_Name; + + ------------------------------ + -- Read_Default_Search_Dirs -- + ------------------------------ + + function Read_Default_Search_Dirs + (Search_Dir_Prefix : String_Access; + Search_File : String_Access; + Search_Dir_Default_Name : String_Access) + return String_Access + is + Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length; + Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1); + File_FD : File_Descriptor; + S, S1 : String_Access; + Len : Integer; + Curr : Integer; + Actual_Len : Integer; + J1 : Integer; + + Prev_Was_Separator : Boolean; + Nb_Relative_Dir : Integer; + + begin + + -- Construct a C compatible character string buffer. + + Buffer (1 .. Search_Dir_Prefix.all'Length) + := Search_Dir_Prefix.all; + Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) + := Search_File.all; + Buffer (Buffer'Last) := ASCII.NUL; + + File_FD := Open_Read (Buffer'Address, Binary); + if File_FD = Invalid_FD then + return Search_Dir_Default_Name; + end if; + + Len := Integer (File_Length (File_FD)); + + -- An extra character for a trailing Path_Separator is allocated + + S := new String (1 .. Len + 1); + S (Len + 1) := Path_Separator; + + -- Read the file. Note that the loop is not necessary since the + -- whole file is read at once except on VMS. + + Curr := 1; + Actual_Len := Len; + while Actual_Len /= 0 loop + Actual_Len := Read (File_FD, S (Curr)'Address, Len); + Curr := Curr + Actual_Len; + end loop; + + -- Process the file, translating line and file ending + -- control characters to a path separator character. + + Prev_Was_Separator := True; + Nb_Relative_Dir := 0; + for J in 1 .. Len loop + if S (J) in ASCII.NUL .. ASCII.US + or else S (J) = ' ' + then + S (J) := Path_Separator; + end if; + + if S (J) = Path_Separator then + Prev_Was_Separator := True; + else + if Prev_Was_Separator and S (J) /= Directory_Separator then + Nb_Relative_Dir := Nb_Relative_Dir + 1; + end if; + Prev_Was_Separator := False; + end if; + end loop; + + if Nb_Relative_Dir = 0 then + return S; + end if; + + -- Add the Search_Dir_Prefix to all relative paths + + S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len); + J1 := 1; + Prev_Was_Separator := True; + for J in 1 .. Len + 1 loop + if S (J) = Path_Separator then + Prev_Was_Separator := True; + + else + if Prev_Was_Separator and S (J) /= Directory_Separator then + S1 (J1 .. J1 + Prefix_Len) := Search_Dir_Prefix.all; + J1 := J1 + Prefix_Len; + end if; + + Prev_Was_Separator := False; + end if; + S1 (J1) := S (J); + J1 := J1 + 1; + end loop; + + Free (S); + return S1; + end Read_Default_Search_Dirs; + + ----------------------- + -- Read_Library_Info -- + ----------------------- + + function Read_Library_Info + (Lib_File : File_Name_Type; + Fatal_Err : Boolean := False) + return Text_Buffer_Ptr + is + Lib_FD : File_Descriptor; + -- The file descriptor for the current library file. A negative value + -- indicates failure to open the specified source file. + + Text : Text_Buffer_Ptr; + -- Allocated text buffer. + + begin + Current_Full_Lib_Name := Find_File (Lib_File, Library); + Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name); + + if Current_Full_Lib_Name = No_File then + if Fatal_Err then + Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len)); + else + Current_Full_Obj_Stamp := Empty_Time_Stamp; + return null; + end if; + end if; + + Get_Name_String (Current_Full_Lib_Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + -- Open the library FD, note that we open in binary mode, because as + -- documented in the spec, the caller is expected to handle either + -- DOS or Unix mode files, and there is no point in wasting time on + -- text translation when it is not required. + + Lib_FD := Open_Read (Name_Buffer'Address, Binary); + + if Lib_FD = Invalid_FD then + if Fatal_Err then + Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len)); + else + Current_Full_Obj_Stamp := Empty_Time_Stamp; + return null; + end if; + end if; + + -- Check for object file consistency if requested + + if Opt.Check_Object_Consistency then + Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name); + Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); + + if Current_Full_Obj_Stamp (1) = ' ' then + + -- When the library is readonly, always assume that + -- the object is consistent. + + if Is_Readonly_Library (Current_Full_Lib_Name) then + Current_Full_Obj_Stamp := Current_Full_Lib_Stamp; + + elsif Fatal_Err then + Get_Name_String (Current_Full_Obj_Name); + Close (Lib_FD); + Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len)); + + else + Current_Full_Obj_Stamp := Empty_Time_Stamp; + Close (Lib_FD); + return null; + end if; + end if; + + -- Object file exists, compare object and ALI time stamps + + if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then + if Fatal_Err then + Get_Name_String (Current_Full_Obj_Name); + Close (Lib_FD); + Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len)); + else + Current_Full_Obj_Stamp := Empty_Time_Stamp; + Close (Lib_FD); + return null; + end if; + end if; + end if; + + -- Read data from the file + + declare + Len : Integer := Integer (File_Length (Lib_FD)); + -- Length of source file text. If it doesn't fit in an integer + -- we're probably stuck anyway (>2 gigs of source seems a lot!) + + Actual_Len : Integer := 0; + + Lo : Text_Ptr := 0; + -- Low bound for allocated text buffer + + Hi : Text_Ptr := Text_Ptr (Len); + -- High bound for allocated text buffer. Note length is Len + 1 + -- which allows for extra EOF character at the end of the buffer. + + begin + -- Allocate text buffer. Note extra character at end for EOF + + Text := new Text_Buffer (Lo .. Hi); + + -- Some systems (e.g. VMS) have file types that require one + -- read per line, so read until we get the Len bytes or until + -- there are no more characters. + + Hi := Lo; + loop + Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); + Hi := Hi + Text_Ptr (Actual_Len); + exit when Actual_Len = Len or Actual_Len <= 0; + end loop; + + Text (Hi) := EOF; + end; + + -- Read is complete, close file and we are done + + Close (Lib_FD); + return Text; + + end Read_Library_Info; + + -- Version with default file name + + procedure Read_Library_Info + (Name : out File_Name_Type; + Text : out Text_Buffer_Ptr) + is + begin + Set_Library_Info_Name; + Name := Name_Find; + Text := Read_Library_Info (Name, Fatal_Err => False); + end Read_Library_Info; + + ---------------------- + -- Read_Source_File -- + ---------------------- + + procedure Read_Source_File + (N : File_Name_Type; + Lo : Source_Ptr; + Hi : out Source_Ptr; + Src : out Source_Buffer_Ptr; + T : File_Type := Source) + is + Source_File_FD : File_Descriptor; + -- The file descriptor for the current source file. A negative value + -- indicates failure to open the specified source file. + + Len : Integer; + -- Length of file. Assume no more than 2 gigabytes of source! + + Actual_Len : Integer; + + begin + Current_Full_Source_Name := Find_File (N, T); + Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name); + + if Current_Full_Source_Name = No_File then + + -- If we were trying to access the main file and we could not + -- find it we have an error. + + if N = Current_Main then + Get_Name_String (N); + Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len)); + end if; + + Src := null; + Hi := No_Location; + return; + end if; + + Get_Name_String (Current_Full_Source_Name); + Name_Buffer (Name_Len + 1) := ASCII.NUL; + + -- Open the source FD, note that we open in binary mode, because as + -- documented in the spec, the caller is expected to handle either + -- DOS or Unix mode files, and there is no point in wasting time on + -- text translation when it is not required. + + Source_File_FD := Open_Read (Name_Buffer'Address, Binary); + + if Source_File_FD = Invalid_FD then + Src := null; + Hi := No_Location; + return; + end if; + + -- Prepare to read data from the file + + Len := Integer (File_Length (Source_File_FD)); + + -- Set Hi so that length is one more than the physical length, + -- allowing for the extra EOF character at the end of the buffer + + Hi := Lo + Source_Ptr (Len); + + -- Do the actual read operation + + declare + subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); + -- Physical buffer allocated + + type Actual_Source_Ptr is access Actual_Source_Buffer; + -- This is the pointer type for the physical buffer allocated + + Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer; + -- And this is the actual physical buffer + + begin + -- Allocate source buffer, allowing extra character at end for EOF + + -- Some systems (e.g. VMS) have file types that require one + -- read per line, so read until we get the Len bytes or until + -- there are no more characters. + + Hi := Lo; + loop + Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); + Hi := Hi + Source_Ptr (Actual_Len); + exit when Actual_Len = Len or Actual_Len <= 0; + end loop; + + Actual_Ptr (Hi) := EOF; + + -- Now we need to work out the proper virtual origin pointer to + -- return. This is exactly Actual_Ptr (0)'Address, but we have + -- to be careful to suppress checks to compute this address. + + declare + pragma Suppress (All_Checks); + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + begin + Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); + end; + end; + + -- Read is complete, get time stamp and close file and we are done + + Close (Source_File_FD); + + end Read_Source_File; + + -------------------------------- + -- Record_Time_From_Last_Bind -- + -------------------------------- + + procedure Record_Time_From_Last_Bind is + begin + Recording_Time_From_Last_Bind := True; + end Record_Time_From_Last_Bind; + + --------------------------- + -- Set_Library_Info_Name -- + --------------------------- + + procedure Set_Library_Info_Name is + Dot_Index : Natural; + + begin + pragma Assert (In_Compiler); + Get_Name_String (Current_Main); + + -- Find last dot since we replace the existing extension by .ali. The + -- initialization to Name_Len + 1 provides for simply adding the .ali + -- extension if the source file name has no extension. + + Dot_Index := Name_Len + 1; + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Make sure that the output file name matches the source file name. + -- To compare them, remove file name directories and extensions. + + if Output_Object_File_Name /= null then + declare + Name : constant String := Name_Buffer (1 .. Dot_Index); + Len : constant Natural := Dot_Index; + + begin + Name_Buffer (1 .. Output_Object_File_Name'Length) + := Output_Object_File_Name.all; + Dot_Index := 0; + + for J in reverse Output_Object_File_Name'Range loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + pragma Assert (Dot_Index /= 0); + -- We check for the extension elsewhere + + if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then + Fail ("incorrect object file name"); + end if; + end; + end if; + + Name_Buffer (Dot_Index) := '.'; + Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + end Set_Library_Info_Name; + + --------------------------------- + -- Set_Output_Object_File_Name -- + --------------------------------- + + procedure Set_Output_Object_File_Name (Name : String) is + Ext : constant String := Object_Suffix; + NL : constant Natural := Name'Length; + EL : constant Natural := Ext'Length; + + begin + -- Make sure that the object file has the expected extension. + + if NL <= EL + or else Name (NL - EL + Name'First .. Name'Last) /= Ext + then + Fail ("incorrect object file extension"); + end if; + + Output_Object_File_Name := new String'(Name); + end Set_Output_Object_File_Name; + + ------------------------ + -- Set_Main_File_Name -- + ------------------------ + + procedure Set_Main_File_Name (Name : String) is + begin + Number_File_Names := Number_File_Names + 1; + File_Names (Number_File_Names) := new String'(Name); + end Set_Main_File_Name; + + ---------------------- + -- Smart_File_Stamp -- + ---------------------- + + function Smart_File_Stamp + (N : File_Name_Type; + T : File_Type) + return Time_Stamp_Type + is + Time_Stamp : Time_Stamp_Type; + + begin + if not File_Cache_Enabled then + return File_Stamp (Find_File (N, T)); + end if; + + Time_Stamp := File_Stamp_Hash_Table.Get (N); + + if Time_Stamp (1) = ' ' then + Time_Stamp := File_Stamp (Smart_Find_File (N, T)); + File_Stamp_Hash_Table.Set (N, Time_Stamp); + end if; + + return Time_Stamp; + end Smart_File_Stamp; + + --------------------- + -- Smart_Find_File -- + --------------------- + + function Smart_Find_File + (N : File_Name_Type; + T : File_Type) + return File_Name_Type + is + Full_File_Name : File_Name_Type; + + begin + if not File_Cache_Enabled then + return Find_File (N, T); + end if; + + Full_File_Name := File_Name_Hash_Table.Get (N); + + if Full_File_Name = No_File then + Full_File_Name := Find_File (N, T); + File_Name_Hash_Table.Set (N, Full_File_Name); + end if; + + return Full_File_Name; + end Smart_Find_File; + + ---------------------- + -- Source_File_Data -- + ---------------------- + + procedure Source_File_Data (Cache : Boolean) is + begin + File_Cache_Enabled := Cache; + end Source_File_Data; + + ----------------------- + -- Source_File_Stamp -- + ----------------------- + + function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is + begin + return Smart_File_Stamp (N, Source); + end Source_File_Stamp; + + --------------------- + -- Strip_Directory -- + --------------------- + + function Strip_Directory (Name : File_Name_Type) return File_Name_Type is + begin + Get_Name_String (Name); + + declare + S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Fptr : Natural := S'First; + + begin + for J in reverse S'Range loop + if Is_Directory_Separator (S (J)) then + Fptr := J + 1; + exit; + end if; + end loop; + + if Fptr = S'First then + return Name; + end if; + + Name_Buffer (1 .. S'Last - Fptr + 1) := S (Fptr .. S'Last); + Name_Len := S'Last - Fptr + 1; + return Name_Find; + end; + end Strip_Directory; + + ------------------ + -- Strip_Suffix -- + ------------------ + + function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is + begin + Get_Name_String (Name); + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + return Name_Enter; + end if; + end loop; + + return Name; + end Strip_Suffix; + + ------------------------- + -- Time_From_Last_Bind -- + ------------------------- + + function Time_From_Last_Bind return Nat is + Old_Y : Nat; + Old_M : Nat; + Old_D : Nat; + Old_H : Nat; + Old_Mi : Nat; + Old_S : Nat; + New_Y : Nat; + New_M : Nat; + New_D : Nat; + New_H : Nat; + New_Mi : Nat; + New_S : Nat; + + type Month_Data is array (Int range 1 .. 12) of Int; + Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7); + -- Represents the difference in days from a period compared to the + -- same period if all months had 31 days, i.e: + -- + -- Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01) + + Res : Int; + + begin + if not Recording_Time_From_Last_Bind + or else not Binder_Output_Time_Stamps_Set + or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp + then + return Nat'Last; + end if; + + Split_Time_Stamp + (Old_Binder_Output_Time_Stamp, + Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S); + + Split_Time_Stamp + (New_Binder_Output_Time_Stamp, + New_Y, New_M, New_D, New_H, New_Mi, New_S); + + Res := New_Mi - Old_Mi; + + -- 60 minutes in an hour + + Res := Res + 60 * (New_H - Old_H); + + -- 24 hours in a day + + Res := Res + 60 * 24 * (New_D - Old_D); + + -- Almost 31 days in a month + + Res := Res + 60 * 24 * + (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M)); + + -- 365 days in a year + + Res := Res + 60 * 24 * 365 * (New_Y - Old_Y); + + return Res; + end Time_From_Last_Bind; + + --------------------------- + -- To_Canonical_Dir_Spec -- + --------------------------- + + function To_Canonical_Dir_Spec + (Host_Dir : String; + Prefix_Style : Boolean) + return String_Access + is + function To_Canonical_Dir_Spec + (Host_Dir : Address; + Prefix_Flag : Integer) + return Address; + pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec"); + + C_Host_Dir : String (1 .. Host_Dir'Length + 1); + Canonical_Dir_Addr : Address; + Canonical_Dir_Len : Integer; + + begin + C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir; + C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL; + + if Prefix_Style then + Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1); + else + Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0); + end if; + Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr); + + if Canonical_Dir_Len = 0 then + return null; + else + return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len); + end if; + + exception + when others => + Fail ("erroneous directory spec: ", Host_Dir); + return null; + end To_Canonical_Dir_Spec; + + --------------------------- + -- To_Canonical_File_List -- + --------------------------- + + function To_Canonical_File_List + (Wildcard_Host_File : String; + Only_Dirs : Boolean) + return String_Access_List_Access + is + function To_Canonical_File_List_Init + (Host_File : Address; + Only_Dirs : Integer) + return Integer; + pragma Import (C, To_Canonical_File_List_Init, + "__gnat_to_canonical_file_list_init"); + + function To_Canonical_File_List_Next return Address; + pragma Import (C, To_Canonical_File_List_Next, + "__gnat_to_canonical_file_list_next"); + + procedure To_Canonical_File_List_Free; + pragma Import (C, To_Canonical_File_List_Free, + "__gnat_to_canonical_file_list_free"); + + Num_Files : Integer; + C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1); + + begin + C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) := + Wildcard_Host_File; + C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL; + + -- Do the expansion and say how many there are + + Num_Files := To_Canonical_File_List_Init + (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs)); + + declare + Canonical_File_List : String_Access_List (1 .. Num_Files); + Canonical_File_Addr : Address; + Canonical_File_Len : Integer; + + begin + -- Retrieve the expanded directoy names and build the list + + for J in 1 .. Num_Files loop + Canonical_File_Addr := To_Canonical_File_List_Next; + Canonical_File_Len := C_String_Length (Canonical_File_Addr); + Canonical_File_List (J) := To_Path_String_Access + (Canonical_File_Addr, Canonical_File_Len); + end loop; + + -- Free up the storage + + To_Canonical_File_List_Free; + + return new String_Access_List'(Canonical_File_List); + end; + end To_Canonical_File_List; + + ---------------------------- + -- To_Canonical_File_Spec -- + ---------------------------- + + function To_Canonical_File_Spec + (Host_File : String) + return String_Access + is + function To_Canonical_File_Spec (Host_File : Address) return Address; + pragma Import + (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); + + C_Host_File : String (1 .. Host_File'Length + 1); + Canonical_File_Addr : Address; + Canonical_File_Len : Integer; + + begin + C_Host_File (1 .. Host_File'Length) := Host_File; + C_Host_File (C_Host_File'Last) := ASCII.NUL; + + Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address); + Canonical_File_Len := C_String_Length (Canonical_File_Addr); + + if Canonical_File_Len = 0 then + return null; + else + return To_Path_String_Access + (Canonical_File_Addr, Canonical_File_Len); + end if; + + exception + when others => + Fail ("erroneous file spec: ", Host_File); + return null; + end To_Canonical_File_Spec; + + ---------------------------- + -- To_Canonical_Path_Spec -- + ---------------------------- + + function To_Canonical_Path_Spec + (Host_Path : String) + return String_Access + is + function To_Canonical_Path_Spec (Host_Path : Address) return Address; + pragma Import + (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec"); + + C_Host_Path : String (1 .. Host_Path'Length + 1); + Canonical_Path_Addr : Address; + Canonical_Path_Len : Integer; + + begin + C_Host_Path (1 .. Host_Path'Length) := Host_Path; + C_Host_Path (C_Host_Path'Last) := ASCII.NUL; + + Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address); + Canonical_Path_Len := C_String_Length (Canonical_Path_Addr); + + -- Return a null string (vice a null) for zero length paths, for + -- compatibility with getenv(). + + return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len); + + exception + when others => + Fail ("erroneous path spec: ", Host_Path); + return null; + end To_Canonical_Path_Spec; + + --------------------------- + -- To_Host_Dir_Spec -- + --------------------------- + + function To_Host_Dir_Spec + (Canonical_Dir : String; + Prefix_Style : Boolean) + return String_Access + is + function To_Host_Dir_Spec + (Canonical_Dir : Address; + Prefix_Flag : Integer) + return Address; + pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec"); + + C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1); + Host_Dir_Addr : Address; + Host_Dir_Len : Integer; + + begin + C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir; + C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL; + + if Prefix_Style then + Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1); + else + Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0); + end if; + Host_Dir_Len := C_String_Length (Host_Dir_Addr); + + if Host_Dir_Len = 0 then + return null; + else + return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len); + end if; + end To_Host_Dir_Spec; + + ---------------------------- + -- To_Host_File_Spec -- + ---------------------------- + + function To_Host_File_Spec + (Canonical_File : String) + return String_Access + is + function To_Host_File_Spec (Canonical_File : Address) return Address; + pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec"); + + C_Canonical_File : String (1 .. Canonical_File'Length + 1); + Host_File_Addr : Address; + Host_File_Len : Integer; + + begin + C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File; + C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL; + + Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address); + Host_File_Len := C_String_Length (Host_File_Addr); + + if Host_File_Len = 0 then + return null; + else + return To_Path_String_Access + (Host_File_Addr, Host_File_Len); + end if; + end To_Host_File_Spec; + + --------------------------- + -- To_Path_String_Access -- + --------------------------- + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) + return String_Access + is + subtype Path_String is String (1 .. Path_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Unchecked_Conversion (Source => Address, + Target => Path_String_Access); + + Path_Access : Path_String_Access := Address_To_Access (Path_Addr); + + Return_Val : String_Access; + + begin + Return_Val := new String (1 .. Path_Len); + + for J in 1 .. Path_Len loop + Return_Val (J) := Path_Access (J); + end loop; + + return Return_Val; + end To_Path_String_Access; + + ---------------- + -- Tree_Close -- + ---------------- + + procedure Tree_Close is + begin + pragma Assert (In_Compiler); + Tree_Write_Terminate; + Close (Output_FD); + end Tree_Close; + + ----------------- + -- Tree_Create -- + ----------------- + + procedure Tree_Create is + Dot_Index : Natural; + + begin + pragma Assert (In_Compiler); + Get_Name_String (Current_Main); + + -- If an object file has been specified, then the ALI file + -- will be in the same directory as the object file; + -- so, we put the tree file in this same directory, + -- even though no object file needs to be generated. + + if Output_Object_File_Name /= null then + Name_Len := Output_Object_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; + end if; + + Dot_Index := 0; + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Should be impossible to not have an extension + + pragma Assert (Dot_Index /= 0); + + -- Change exctension to adt + + Name_Buffer (Dot_Index + 1) := 'a'; + Name_Buffer (Dot_Index + 2) := 'd'; + Name_Buffer (Dot_Index + 3) := 't'; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + Create_File_And_Check (Output_FD, Binary); + + Tree_Write_Initialize (Output_FD); + end Tree_Create; + + ---------------- + -- Write_Info -- + ---------------- + + procedure Write_Info (Info : String) is + begin + pragma Assert (In_Binder or In_Compiler); + Write_With_Check (Info'Address, Info'Length); + Write_With_Check (EOL'Address, 1); + end Write_Info; + + ----------------------- + -- Write_Binder_Info -- + ----------------------- + + procedure Write_Binder_Info (Info : String) renames Write_Info; + + ----------------------- + -- Write_Debug_Info -- + ----------------------- + + procedure Write_Debug_Info (Info : String) renames Write_Info; + + ------------------------ + -- Write_Library_Info -- + ------------------------ + + procedure Write_Library_Info (Info : String) renames Write_Info; + + ------------------------ + -- Write_Program_Name -- + ------------------------ + + procedure Write_Program_Name is + Save_Buffer : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + + begin + + Find_Program_Name; + + -- Convert the name to lower case so error messages are the same on + -- all systems. + + for J in 1 .. Name_Len loop + if Name_Buffer (J) in 'A' .. 'Z' then + Name_Buffer (J) := + Character'Val (Character'Pos (Name_Buffer (J)) + 32); + end if; + end loop; + + Write_Str (Name_Buffer (1 .. Name_Len)); + + -- Restore Name_Buffer which was clobbered by the call to + -- Find_Program_Name + + Name_Len := Save_Buffer'Last; + Name_Buffer (1 .. Name_Len) := Save_Buffer; + end Write_Program_Name; + + ---------------------- + -- Write_With_Check -- + ---------------------- + + procedure Write_With_Check (A : Address; N : Integer) is + Ignore : Boolean; + + begin + if N = Write (Output_FD, A, N) then + return; + + else + Write_Str ("error: disk full writing "); + Write_Name_Decoded (Output_File_Name); + Write_Eol; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.NUL; + Delete_File (Name_Buffer'Address, Ignore); + Exit_Program (E_Fatal); + end if; + end Write_With_Check; + +end Osint; diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads new file mode 100644 index 00000000000..842c353fe2b --- /dev/null +++ b/gcc/ada/osint.ads @@ -0,0 +1,671 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.108 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the low level, operating system routines used in +-- the GNAT compiler and binder for command line processing and file input +-- output. The specification is suitable for use with MS-DOS, Unix, and +-- similar systems. Note that for input source and library information +-- files, the line terminator may be either CR/LF or LF alone, and the +-- DOS-style EOF (16#1A#) character marking the end of the text in a +-- file may be used in all systems including Unix. This allows for more +-- convenient processing of DOS files in a Unix environment. + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with System; use System; +with Types; use Types; + +package Osint is + + procedure Set_Main_File_Name (Name : String); + -- Set the main file name for Gnatmake. + + function Normalize_Directory_Name (Directory : String) return String_Ptr; + -- Verify and normalize a directory name. If directory name is invalid, + -- this will return an empty string. Otherwise it will insure a trailing + -- slash and make other normalizations. + + type File_Type is (Source, Library, Config); + + function Find_File + (N : File_Name_Type; + T : File_Type) + return File_Name_Type; + -- Finds a source or library file depending on the value of T following + -- the directory search order rules unless N is the name of the file + -- just read with Next_Main_File and already contains directiory + -- information, in which case just look in the Primary_Directory. + -- Returns File_Name_Type of the full file name if found, No_File if + -- file not found. Note that for the special case of gnat.adc, only the + -- compilation environment directory is searched, i.e. the directory + -- where the ali and object files are written. Another special case is + -- when Debug_Generated_Code is set and the file name ends on ".dg", + -- in which case we look for the generated file only in the current + -- directory, since that is where it is always built. + + function Get_Switch_Character return Character; + pragma Import (C, Get_Switch_Character, "__gnat_get_switch_character"); + Switch_Character : constant Character := Get_Switch_Character; + -- Set to the default switch character (note that minus is always an + -- acceptable alternative switch character) + + function Get_File_Names_Case_Sensitive return Int; + pragma Import (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + File_Names_Case_Sensitive : constant Boolean := + Get_File_Names_Case_Sensitive /= 0; + -- Set to indicate whether the operating system convention is for file + -- names to be case sensitive (e.g., in Unix, set True), or non case + -- sensitive (e.g., in OS/2, set False). + + procedure Canonical_Case_File_Name (S : in out String); + -- Given a file name, converts it to canonical case form. For systems + -- where file names are case sensitive, this procedure has no effect. + -- If file names are not case sensitive (i.e. for example if you have + -- the file "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then + -- this call converts the given string to canonical all lower case form, + -- so that two file names compare equal if they refer to the same file. + + function Number_Of_Files return Int; + -- gives the total number of filenames found on the command line. + + procedure Add_File (File_Name : String); + -- Called by the subprogram processing the command line for each + -- file name found. + + procedure Set_Output_Object_File_Name (Name : String); + -- Called by the subprogram processing the command line when an + -- output object file name is found. + + type Program_Type is (Compiler, Binder, Make); + Program : Program_Type; + -- Program currently running (set by Initialize below) + + procedure Initialize (P : Program_Type); + -- This routine scans parameters and initializes for the first call to + -- Next_Main_Source (Compiler or Make) or Next_Main_Lib_File (Binder). + -- It also resets any of the variables in package Opt in response to + -- command switch settings. + -- + -- Initialize may terminate execution if the parameters are invalid or some + -- other fatal error is encountered. The interface is set up to + -- accomodate scanning a series of files (e.g. as the result of + -- wild card references in DOS, or an expanded list of source files + -- in Unix). Of course it is perfectly possible to ignore this in + -- the implementation and provide for opening only one file. + -- The parameter P is the program (Compiler, Binder or Make) that is + -- actually running. + + procedure Find_Program_Name; + -- Put simple name of current program being run (excluding the directory + -- path) in Name_Buffer, with the length in Name_Len. + + function Program_Name (Nam : String) return String_Access; + -- In the native compilation case, Create a string containing Nam. In + -- the cross compilation case, looks at the prefix of the current + -- program being run and prepend it to Nam. For instance if the program + -- being run is <target>-gnatmake and Nam is "gcc", the returned value + -- will be a pointer to "<target>-gcc". This function clobbers + -- Name_Buffer and Name_Len. + + procedure Write_Program_Name; + -- Writes name of program as invoked to standard output + + procedure Fail (S1 : String; S2 : String := ""; S3 : String := ""); + -- Outputs error messages S1 & S2 & S3 preceeded by the name of the + -- executing program and exits with E_Fatal. + + function Is_Directory_Separator (C : Character) return Boolean; + -- Returns True if C is a directory separator + + function Get_Directory (Name : File_Name_Type) return File_Name_Type; + -- Get the prefix directory name (if any) from Name. The last separator + -- is preserved. Return No_File if there is no directory part in the + -- name. + + function Is_Readonly_Library (File : File_Name_Type) return Boolean; + -- Check if this library file is a read-only file. + + function Strip_Directory (Name : File_Name_Type) return File_Name_Type; + -- Strips the prefix directory name (if any) from Name. Returns the + -- stripped name. + + function Strip_Suffix (Name : File_Name_Type) return File_Name_Type; + -- Strips the suffix (the '.' and whatever comes after it) from Name. + -- Returns the stripped name. + + function Executable_Name (Name : File_Name_Type) return File_Name_Type; + -- Given a file name it adds the appropriate suffix at the end so that + -- it becomes the name of the executable on the system at end. For + -- instance under DOS it adds the ".exe" suffix, whereas under UNIX no + -- suffix is added. + + function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type; + -- Returns the time stamp of file Name. Name should include relative + -- path information in order to locate it. If the source file cannot be + -- opened, or Name = No_File, and all blank time stamp is returned (this is + -- not an error situation). + + procedure Record_Time_From_Last_Bind; + -- Trigger the computing of the time from the last bind of the same + -- program. + + function Time_From_Last_Bind return Nat; + -- This function give an approximate number of minute from the last bind. + -- It bases its computation on file stamp and therefore does gibe not + -- any meaningful result before the new output binder file is written. + -- So it returns Nat'last if + -- - it is the first bind of this specific program + -- - Record_Time_From_Last_Bind was not Called first + -- - Close_Binder_Output was not called first + -- otherwise returns the number of minutes + -- till the last bind. The computation does not try to be completely + -- accurate and in particular does not take leap years into account. + + type String_Access_List is array (Positive range <>) of String_Access; + -- Deferenced type used to return a list of file specs in + -- To_Canonical_File_List. + + type String_Access_List_Access is access all String_Access_List; + -- Type used to return a String_Access_List without dragging in secondary + -- stack. + + function To_Canonical_File_List + (Wildcard_Host_File : String; Only_Dirs : Boolean) + return String_Access_List_Access; + -- Expand a wildcard host syntax file or directory specification (e.g. on + -- a VMS host, any file or directory spec that contains: + -- "*", or "%", or "...") + -- and return a list of valid Unix syntax file or directory specs. + -- If Only_Dirs is True, then only return directories. + + function To_Canonical_Dir_Spec + (Host_Dir : String; + Prefix_Style : Boolean) + return String_Access; + -- Convert a host syntax directory specification (e.g. on a VMS host: + -- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir"). + -- If Prefix_Style then make it a valid file specification prefix. + -- A file specification prefix is a directory specification that + -- can be appended with a simple file specification to yield a valid + -- absolute or relative path to a file. On a conversion to Unix syntax + -- this simply means the spec has a trailing slash ("/"). + + function To_Canonical_File_Spec + (Host_File : String) + return String_Access; + -- Convert a host syntax file specification (e.g. on a VMS host: + -- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g. + -- "/sys$device/dir/file.ext.69"). + + function To_Canonical_Path_Spec + (Host_Path : String) + return String_Access; + -- Convert a host syntax Path specification (e.g. on a VMS host: + -- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g. + -- "/sys$device/foo:disk$user/foo"). + + function To_Host_Dir_Spec + (Canonical_Dir : String; + Prefix_Style : Boolean) + return String_Access; + -- Convert a canonical syntax directory specification to host syntax. + -- The Prefix_Style flag is currently ignored but should be set to + -- False. + + function To_Host_File_Spec + (Canonical_File : String) + return String_Access; + -- Convert a canonical syntax file specification to host syntax. + + ------------------------- + -- Search Dir Routines -- + ------------------------- + + procedure Add_Default_Search_Dirs; + -- This routine adds the default search dirs indicated by the + -- environment variables and sdefault package. + + procedure Add_Lib_Search_Dir (Dir : String); + -- Add Dir at the end of the library file search path + + procedure Add_Src_Search_Dir (Dir : String); + -- Add Dir at the end of the source file search path + + procedure Get_Next_Dir_In_Path_Init + (Search_Path : String_Access); + function Get_Next_Dir_In_Path + (Search_Path : String_Access) + return String_Access; + -- These subprograms are used to parse out the directory names in a + -- search path specified by a Search_Path argument. The procedure + -- initializes an internal pointer to point to the initial directory + -- name, and calls to the function return sucessive directory names, + -- with a null pointer marking the end of the list. + + function Get_Primary_Src_Search_Directory return String_Ptr; + -- Retrieved the primary directory (directory containing the main source + -- file for Gnatmake. + + function Nb_Dir_In_Src_Search_Path return Natural; + function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr; + -- Functions to access the directory names in the source search path + + function Nb_Dir_In_Obj_Search_Path return Natural; + function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr; + -- Functions to access the directory names in the Object search path + + Include_Search_File : constant String_Access + := new String'("ada_source_path"); + Objects_Search_File : constant String_Access + := new String'("ada_object_path"); + + -- Files containg the default include or objects search directories. + + function Read_Default_Search_Dirs + (Search_Dir_Prefix : String_Access; + Search_File : String_Access; + Search_Dir_Default_Name : String_Access) + return String_Access; + -- Read and return the default search directories from the file located + -- in Search_Dir_Prefix (as modified by update_path) and named Search_File. + -- If no such file exists or an error occurs then instead return the + -- Search_Dir_Default_Name (as modified by update_path). + + ----------------------- + -- Source File Input -- + ----------------------- + + -- Source file input routines are used by the compiler to read the main + -- source files and the subsidiary source files (e.g. with'ed units), and + -- also by the binder to check presence/time stamps of sources. + + function More_Source_Files return Boolean; + -- Indicates whether more source file remain to be processed. Returns + -- False right away if no source files, or if all source files have + -- been processed. + + function Next_Main_Source return File_Name_Type; + -- This function returns the name of the next main source file specified + -- on the command line. It is an error to call Next_Main_Source if no more + -- source files exist (i.e. Next_Main_Source may be called only if a + -- previous call to More_Source_Files returned True). This name is the + -- simple file name (without any directory information). + + procedure Read_Source_File + (N : File_Name_Type; + Lo : Source_Ptr; + Hi : out Source_Ptr; + Src : out Source_Buffer_Ptr; + T : File_Type := Source); + -- Allocates a Source_Buffer of appropriate length and then reads the + -- entire contents of the source file N into the buffer. The address of + -- the allocated buffer is returned in Src. + -- + -- Each line of text is terminated by one of the sequences: + -- + -- CR + -- CR/LF + -- LF/CR + -- LF + + -- The source is terminated by an EOF (16#1A#) character, which is + -- the last charcater of the returned source bufer (note that any + -- EOF characters in positions other than the last source character + -- are treated as representing blanks). + -- + -- The logical lower bound of the source buffer is the input value of Lo, + -- and on exit Hi is set to the logical upper bound of the source buffer. + -- Note that the returned value in Src points to an array with a physical + -- lower bound of zero. This virtual origin addressing approach means that + -- a constrained array pointer can be used with a low bound of zero which + -- results in more efficient code. + -- + -- If the given file cannot be opened, then the action depends on whether + -- this file is the current main unit (i.e. its name matches the name + -- returned by the most recent call to Next_Main_Source). If so, then the + -- failure to find the file is a fatal error, an error message is output, + -- and program execution is terminated. Otherwise (for the case of a + -- subsidiary source loaded directly or indirectly using with), a file + -- not found condition causes null to be set as the result value. + -- + -- Note that the name passed to this function is the simple file name, + -- without any directory information. The implementation is responsible + -- for searching for the file in the appropriate directories. + -- + -- Note the special case that if the file name is gnat.adc, then the + -- search for the file is done ONLY in the directory corresponding to + -- the current compilation environment, i.e. in the same directory + -- where the ali and object files will be written. + + function Full_Source_Name return File_Name_Type; + function Current_Source_File_Stamp return Time_Stamp_Type; + -- Returns the full name/time stamp of the source file most recently read + -- using Read_Source_File. Calling this routine entails no source file + -- directory lookup penalty. + + function Full_Source_Name (N : File_Name_Type) return File_Name_Type; + function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type; + -- Returns the full name/time stamp of the source file whose simple name + -- is N which should not include path information. Note that if the file + -- cannot be located No_File is returned for the first routine and an + -- all blank time stamp is returned for the second (this is not an error + -- situation). The full name includes the appropriate directory + -- information. The source file directory lookup penalty is incurred + -- every single time the routines are called unless you have previously + -- called Source_File_Data (Cache => True). See below. + + function Matching_Full_Source_Name + (N : File_Name_Type; + T : Time_Stamp_Type) + return File_Name_Type; + -- Same semantics than Full_Source_Name but will search on the source + -- path until a source file with time stamp matching T is found. If + -- none is found returns No_File. + + procedure Source_File_Data (Cache : Boolean); + -- By default source file data (full source file name and time stamp) + -- are looked up every time a call to Full_Source_Name (N) or + -- Source_File_Stamp (N) is made. This may be undesirable in certain + -- applications as this is uselessly slow if source file data does not + -- change during program execution. When this procedure is called with + -- Cache => True access to source file data does not encurr a penalty if + -- this data was previously retrieved. + + ------------------------------------------- + -- Representation of Library Information -- + ------------------------------------------- + + -- Associated with each compiled source file is library information, + -- a string of bytes whose exact format is described in the body of + -- Lib.Writ. Compiling a source file generates this library information + -- for the compiled unit, and access the library information for units + -- that were compiled previously on which the unit being compiled depends. + + -- How this information is stored is up to the implementation of this + -- package. At the interface level, this information is simply associated + -- with its corresponding source. + + -- Several different implementations are possible: + + -- 1. The information could be directly associated with the source file, + -- e.g. placed in a resource fork of this file on the Mac, or on + -- MS-DOS, written to the source file after the end of file mark. + + -- 2. The information could be written into the generated object module + -- if the system supports the inclusion of arbitrary informational + -- byte streams into object files. In this case there must be a naming + -- convention that allows object files to be located given the name of + -- the corresponding source file. + + -- 3. The information could be written to a separate file, whose name is + -- related to the name of the source file by a fixed convention. + + -- Which of these three methods is chosen depends on the contraints of the + -- host operating system. The interface described here is independent of + -- which of these approaches is used. + + ------------------------------- + -- Library Information Input -- + ------------------------------- + + -- These subprograms are used by the binder to read library information + -- files, see section above for representation of these files. + + function More_Lib_Files return Boolean; + -- Indicates whether more library information files remain to be processed. + -- Returns False right away if no source files, or if all source files + -- have been processed. + + function Next_Main_Lib_File return File_Name_Type; + -- This function returns the name of the next library info file specified + -- on the command line. It is an error to call Next_Main_Lib_File if no + -- more library information files exist (i.e. Next_Main_Lib_File may be + -- called only if a previous call to More_Lib_Files returned True). This + -- name is the simple name, excluding any directory information. + + function Read_Library_Info + (Lib_File : File_Name_Type; + Fatal_Err : Boolean := False) + return Text_Buffer_Ptr; + -- Allocates a Text_Buffer of appropriate length and reads in the entire + -- source of the library information from the library information file + -- whose name is given by the parameter Name. + -- + -- See description of Read_Source_File for details on the format of the + -- returned text buffer (the format is identical). THe lower bound of + -- the Text_Buffer is always zero + -- + -- If the specified file cannot be opened, then the action depends on + -- Fatal_Err. If Fatal_Err is True, an error message is given and the + -- compilation is abandoned. Otherwise if Fatal_Err is False, then null + -- is returned. Note that the Lib_File is a simple name which does not + -- include any directory information. The implementation is responsible + -- for searching for the file in appropriate directories. + -- + -- If Opt.Check_Object_Consistency is set to True then this routine + -- checks whether the object file corresponding to the Lib_File is + -- consistent with it. The object file is inconsistent if the object + -- does not exist or if it has an older time stamp than Lib_File. + -- This check is not performed when the Lib_File is "locked" (i.e. + -- read/only) because in this case the object file may be buried + -- in a library. In case of inconsistencies Read_Library_Info + -- behaves as if it did not find Lib_File (namely if Fatal_Err is + -- False, null is returned). + + procedure Read_Library_Info + (Name : out File_Name_Type; + Text : out Text_Buffer_Ptr); + -- The procedure version of Read_Library_Info is used from the compiler + -- to read an existing ali file associated with the main unit. If the + -- ALI file exists, then its file name is returned in Name, and its + -- text is returned in Text. If the file does not exist, then Text is + -- set to null. + + function Full_Library_Info_Name return File_Name_Type; + function Full_Object_File_Name return File_Name_Type; + -- Returns the full name of the library/object file most recently read + -- using Read_Library_Info, including appropriate directory information. + -- Calling this routine entails no library file directory lookup + -- penalty. Note that the object file corresponding to a library file + -- is not actually read. Its time stamp is fected when the flag + -- Opt.Check_Object_Consistency is set. + + function Current_Library_File_Stamp return Time_Stamp_Type; + function Current_Object_File_Stamp return Time_Stamp_Type; + -- The time stamps of the files returned by the previous two routines. + -- It is an error to call Current_Object_File_Stamp if + -- Opt.Check_Object_Consistency is set to False. + + function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type; + function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type; + -- Returns the full name/time stamp of library file N. N should not + -- include path information. Note that if the file cannot be located + -- No_File is returned for the first routine and an all blank time stamp + -- is returned for the second (this is not an error situation). The + -- full name includes the appropriate directory information. The library + -- file directory lookup penalty is incurred every single time this + -- routine is called. + + function Object_File_Name (N : File_Name_Type) return File_Name_Type; + -- Constructs the name of the object file corresponding to library + -- file N. If N is a full file name than the returned file name will + -- also be a full file name. Note that no lookup in the library file + -- directories is done for this file. This routine merely constructs + -- the name. + + -------------------------------- + -- Library Information Output -- + -------------------------------- + + -- These routines are used by the compiler to generate the library + -- information file for the main source file being compiled. See section + -- above for a discussion of how library information files are stored. + + procedure Create_Output_Library_Info; + -- Creates the output library information file for the source file which + -- is currently being compiled (i.e. the file which was most recently + -- returned by Next_Main_Source). + + procedure Write_Library_Info (Info : String); + -- Writes the contents of the referenced string to the library information + -- file for the main source file currently being compiled (i.e. the file + -- which was most recently opened with a call to Read_Next_File). Info + -- represents a single line in the file, but does not contain any line + -- termination characters. The implementation of Write_Library_Info is + -- responsible for adding necessary end of line and end of file control + -- characters to the generated file. + + procedure Close_Output_Library_Info; + -- Closes the file created by Create_Output_Library_Info, flushing any + -- buffers etc from writes by Write_Library_Info. + + function Lib_File_Name (Source_File : File_Name_Type) return File_Name_Type; + -- Given the name of a source file, returns the name of the corresponding + -- library information file. This may be the name of the object file, or + -- of a separate file used to store the library information. In either case + -- the returned result is suitable for use in a call to Read_Library_Info. + -- Note: this subprogram is in this section because it is used by the + -- compiler to determine the proper library information names to be placed + -- in the generated library information file. + + ------------------------------ + -- Debug Source File Output -- + ------------------------------ + + -- These routines are used by the compiler to generate the debug source + -- file for the Debug_Generated_Code (-gnatD switch) option. Note that + -- debug source file writing occurs at a completely different point in + -- the processing from library information output, so the code in the + -- body can assume these functions are never used at the same time. + + function Create_Debug_File (Src : File_Name_Type) return File_Name_Type; + -- Given the simple name of a source file, this routine creates the + -- corresponding debug file, and returns its full name. + + procedure Write_Debug_Info (Info : String); + -- Writes contents of given string as next line of the current debug + -- source file created by the most recent call to Get_Debug_Name. Info + -- does not contain any end of line or other formatting characters. + + procedure Close_Debug_File; + -- Close current debug file created by the most recent call to + -- Get_Debug_Name. + + function Debug_File_Eol_Length return Nat; + -- Returns the number of characters (1 for NL, 2 for CR/LF) written + -- at the end of each line by Write_Debug_Info. + + -------------------------------- + -- Semantic Tree Input-Output -- + -------------------------------- + + procedure Tree_Create; + -- Creates the tree output file for the source file which is currently + -- being compiled (i.e. the file which was most recently returned by + -- Next_Main_Source), and initializes Tree_IO.Tree_Write for output. + + procedure Tree_Close; + -- Closes the file previously opened by Tree_Create + + ------------------- + -- Binder Output -- + ------------------- + + -- These routines are used by the binder to generate the C source file + -- containing the binder output. The format of this file is described + -- in the package Bindfmt. + + procedure Create_Binder_Output + (Output_File_Name : String; + Typ : Character; + Bfile : out Name_Id); + -- Creates the binder output file. Typ is one of + -- + -- 'c' create output file for case of generating C + -- 'b' create body file for case of generating Ada + -- 's' create spec file for case of generating Ada + -- + -- If Output_File_Name is null, then a default name is used based on + -- the name of the most recently accessed main source file name. If + -- Output_File_Name is non-null then it is the full path name of the + -- file to be output (in the case of Ada, it must have an extension + -- of adb, and the spec file is created by changing the last character + -- from b to s. On return, Bfile also contains the Name_Id for the + -- generated file name. + + procedure Write_Binder_Info (Info : String); + -- Writes the contents of the referenced string to the binder output file + -- created by a previous call to Create_Binder_Output. Info represents a + -- single line in the file, but does not contain any line termination + -- characters. The implementation of Write_Binder_Info is responsible + -- for adding necessary end of line and end of file control characters + -- as required by the operating system. + + procedure Close_Binder_Output; + -- Closes the file created by Create_Binder_Output, flushing any + -- buffers etc from writes by Write_Binder_Info. + + ----------------- + -- Termination -- + ----------------- + + type Exit_Code_Type is ( + E_Success, -- No warnings or errors + E_Warnings, -- Compiler warnings generated + E_No_Code, -- No code generated + E_No_Compile, -- Compilation not needed (smart recompilation) + E_Errors, -- Compiler error messages generated + E_Fatal, -- Fatal (serious) error, e.g. source file not found + E_Abort); -- Internally detected compiler error + + procedure Exit_Program (Exit_Code : Exit_Code_Type); + -- A call to Exit_Program terminates execution with the given status. + -- A status of zero indicates normal completion, a non-zero status + -- indicates abnormal termination. + + ------------------------- + -- Command Line Access -- + ------------------------- + + -- Direct interface to command line parameters. (We don't want to use + -- the predefined command line package because it defines functions + -- returning string) + + function Arg_Count return Natural; + pragma Import (C, Arg_Count, "__gnat_arg_count"); + -- Get number of arguments (note: optional globbing may be enabled) + + procedure Fill_Arg (A : System.Address; Arg_Num : Integer); + pragma Import (C, Fill_Arg, "__gnat_fill_arg"); + -- Store one argument + + function Len_Arg (Arg_Num : Integer) return Integer; + pragma Import (C, Len_Arg, "__gnat_len_arg"); + -- Get length of argument + +end Osint; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb new file mode 100644 index 00000000000..af23afc6db9 --- /dev/null +++ b/gcc/ada/output.adb @@ -0,0 +1,215 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O U T P U T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.43 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body Output is + + Current_FD : File_Descriptor := Standout; + -- File descriptor for current output + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + procedure Flush_Buffer; + -- Flush buffer if non-empty and reset column counter + + ------------------ + -- Flush_Buffer -- + ------------------ + + procedure Flush_Buffer is + Len : constant Natural := Natural (Column - 1); + + begin + if Len /= 0 then + if Len /= Write (Current_FD, Buffer'Address, Len) then + Set_Standard_Error; + Write_Line ("fatal error: disk full"); + OS_Exit (2); + end if; + + Column := 1; + end if; + end Flush_Buffer; + + ------------------------ + -- Set_Standard_Error -- + ------------------------ + + procedure Set_Standard_Error is + begin + Flush_Buffer; + Current_FD := Standerr; + Column := 1; + end Set_Standard_Error; + + ------------------------- + -- Set_Standard_Output -- + ------------------------- + + procedure Set_Standard_Output is + begin + Flush_Buffer; + Current_FD := Standout; + Column := 1; + end Set_Standard_Output; + + ------- + -- w -- + ------- + + procedure w (C : Character) is + begin + Write_Char ('''); + Write_Char (C); + Write_Char ('''); + Write_Eol; + end w; + + procedure w (S : String) is + begin + Write_Str (S); + Write_Eol; + end w; + + procedure w (V : Int) is + begin + Write_Int (V); + Write_Eol; + end w; + + procedure w (B : Boolean) is + begin + if B then + w ("True"); + else + w ("False"); + end if; + end w; + + procedure w (L : String; C : Character) is + begin + Write_Str (L); + Write_Char (' '); + w (C); + end w; + + procedure w (L : String; S : String) is + begin + Write_Str (L); + Write_Char (' '); + w (S); + end w; + + procedure w (L : String; V : Int) is + begin + Write_Str (L); + Write_Char (' '); + w (V); + end w; + + procedure w (L : String; B : Boolean) is + begin + Write_Str (L); + Write_Char (' '); + w (B); + end w; + + ---------------- + -- Write_Char -- + ---------------- + + procedure Write_Char (C : Character) is + begin + if Column < Buffer'Length then + Buffer (Natural (Column)) := C; + Column := Column + 1; + end if; + end Write_Char; + + --------------- + -- Write_Eol -- + --------------- + + procedure Write_Eol is + begin + Buffer (Natural (Column)) := ASCII.LF; + Column := Column + 1; + Flush_Buffer; + end Write_Eol; + + --------------- + -- Write_Int -- + --------------- + + procedure Write_Int (Val : Int) is + begin + if Val < 0 then + Write_Char ('-'); + Write_Int (-Val); + + else + if Val > 9 then + Write_Int (Val / 10); + end if; + + Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0'))); + end if; + end Write_Int; + + ---------------- + -- Write_Line -- + ---------------- + + procedure Write_Line (S : String) is + begin + Write_Str (S); + Write_Eol; + end Write_Line; + + --------------- + -- Write_Str -- + --------------- + + procedure Write_Str (S : String) is + begin + for J in S'Range loop + Write_Char (S (J)); + end loop; + end Write_Str; + +end Output; diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads new file mode 100644 index 00000000000..bc61989fd87 --- /dev/null +++ b/gcc/ada/output.ads @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O U T P U T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.28 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains low level output routines used by the compiler +-- for writing error messages and informational output. It is also used +-- by the debug source file output routines (see Sprintf.Print_Eol). + +with Types; use Types; + +package Output is +pragma Elaborate_Body (Output); + + ------------------------- + -- Line Buffer Control -- + ------------------------- + + -- Note: the following buffer and column position are maintained by + -- the subprograms defined in this package, and are not normally + -- directly modified or accessed by a client. However, a client is + -- permitted to modify these values, using the knowledge that only + -- Write_Eol actually generates any output. + + Buffer_Max : constant := 8192; + Buffer : String (1 .. Buffer_Max + 1); + -- Buffer used to build output line. We do line buffering because it + -- is needed for the support of the debug-generated-code option (-gnatD). + -- Historically it was first added because on VMS, line buffering is + -- needed with certain file formats. So in any case line buffering must + -- be retained for this purpose, even if other reasons disappear. Note + -- any attempt to write more output to a line than can fit in the buffer + -- will be silently ignored. + + Column : Pos range 1 .. Buffer'Length + 1 := 1; + -- Column about to be written. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Set_Standard_Error; + -- Sets subsequent output to appear on the standard error file (whatever + -- that might mean for the host operating system, if anything). + + procedure Set_Standard_Output; + -- Sets subsequent output to appear on the standard output file (whatever + -- that might mean for the host operating system, if anything). This is + -- the default mode before any call to either of the Set procedures. + + procedure Write_Char (C : Character); + -- Write one character to the standard output file. Note that the + -- character should not be LF or CR (use Write_Eol for end of line) + + procedure Write_Eol; + -- Write an end of line (whatever is required by the system in use, + -- e.g. CR/LF for DOS, or LF for Unix) to the standard output file. + -- This routine also empties the line buffer, actually writing it + -- to the file. Note that Write_Eol is the only routine that causes + -- any actual output to be written. + + procedure Write_Int (Val : Int); + -- Write an integer value with no leading blanks or zeroes. Negative + -- values are preceded by a minus sign). + + procedure Write_Str (S : String); + -- Write a string of characters to the standard output file. Note that + -- end of line is handled separately using WRITE_EOL, so the string + -- should not contain either of the characters LF or CR, but it may + -- contain horizontal tab characters. + + procedure Write_Line (S : String); + -- Equivalent to Write_Str (S) followed by Write_Eol; + + -------------------------- + -- Debugging Procedures -- + -------------------------- + + -- The following procedures are intended only for debugging purposes, + -- for temporary insertion into the text in environments where a debugger + -- is not available. They all have non-standard very short lower case + -- names, precisely to make sure that they are only used for debugging! + + procedure w (C : Character); + -- Dump quote, character quote, followed by line return + + procedure w (S : String); + -- Dump string followed by line return + + procedure w (V : Int); + -- Dump integer followed by line return + + procedure w (B : Boolean); + -- Dump Boolean followed by line return + + procedure w (L : String; C : Character); + -- Dump contents of string followed by blank, quote, character, quote + + procedure w (L : String; S : String); + -- Dump two strings separated by blanks, followed by line return + + procedure w (L : String; V : Int); + -- Dump contents of string followed by blank, integer, line return + + procedure w (L : String; B : Boolean); + -- Dump contents of string followed by blank, Boolean, line return + +end Output; |