--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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"
+
+\f
+/* 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));
--- /dev/null
+/****************************************************************************
+ * *
+ * 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 *));
+\f
+/* 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);
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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 *[]));
+\f
+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);
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+-----------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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); }
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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).
--- /dev/null
+/****************************************************************************
+ * *
+ * 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"},
+
+
--- /dev/null
+/****************************************************************************
+ * *
+ * 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}}}} "},
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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));
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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;
+}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / gcc.git / commitdiff