06effe875c
2004-02-04 Robert Dewar <dewar@gnat.com> * 5gtasinf.adb, 5gtasinf.ads, 5gtaprop.adb, ali.adb, ali.ads, gprcmd.adb: Minor reformatting * bindgen.adb: Output restrictions string for new style restrictions handling * impunit.adb: Add s-rident.ads (System.Rident) and s-restri (System.Restrictions) * lib-writ.adb: Fix bug in writing restrictions string (last few entries wrong) * s-restri.ads, s-restri.adb: Change name Restrictions to Run_Time_Restrictions to avoid conflict with package name. Add circuit to read and acquire run time restrictions. 2004-02-04 Jose Ruiz <ruiz@act-europe.fr> * restrict.ads, restrict.adb: Use the new restriction No_Task_Attributes_Package instead of the old No_Task_Attributes. * sem_prag.adb: No_Task_Attributes is a synonym of No_Task_Attributes_Package. * snames.ads, snames.adb: New entry for proper handling of No_Task_Attributes. * s-rident.ads: Adding restriction No_Task_Attributes_Package (AI-00249) that supersedes the GNAT specific restriction No_Task_Attributes. 2004-02-04 Ed Schonberg <schonberg@gnat.com> * sem_prag.adb: (Analyze_Pragma, case Warnings): In an inlined body, as in an instance body, an identifier may be wrapped in an unchecked conversion. 2004-02-04 Vincent Celier <celier@gnat.com> * lib-writ.ads: Comment update for the W lines * bld.adb: (Expression): An empty string list is static * fname-uf.adb: Minor comment update * fname-uf.ads: (Get_File_Name): Document new parameter May_Fail * gnatbind.adb: Initialize Cumulative_Restrictions with the restrictions on the target. From-SVN: r77233
545 lines
19 KiB
Ada
545 lines
19 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- F N A M E . U F --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2004, 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. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Alloc;
|
|
with Debug; use Debug;
|
|
with Fmap; use Fmap;
|
|
with Krunch;
|
|
with Namet; use Namet;
|
|
with Opt; use Opt;
|
|
with Osint; use Osint;
|
|
with Table;
|
|
with Widechar; use Widechar;
|
|
|
|
with GNAT.HTable;
|
|
|
|
package body Fname.UF is
|
|
|
|
--------------------------------------------------------
|
|
-- Declarations for Handling Source_File_Name pragmas --
|
|
--------------------------------------------------------
|
|
|
|
type SFN_Entry is record
|
|
U : Unit_Name_Type; -- Unit name
|
|
F : File_Name_Type; -- Spec/Body file name
|
|
end record;
|
|
-- Record single Unit_Name type call to Set_File_Name
|
|
|
|
package SFN_Table is new Table.Table (
|
|
Table_Component_Type => SFN_Entry,
|
|
Table_Index_Type => Int,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => Alloc.SFN_Table_Initial,
|
|
Table_Increment => Alloc.SFN_Table_Increment,
|
|
Table_Name => "SFN_Table");
|
|
-- Table recording all Unit_Name calls to Set_File_Name
|
|
|
|
type SFN_Header_Num is range 0 .. 100;
|
|
|
|
function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
|
|
-- Compute hash index for use by Simple_HTable
|
|
|
|
No_Entry : constant Int := -1;
|
|
-- Signals no entry in following table
|
|
|
|
package SFN_HTable is new GNAT.HTable.Simple_HTable (
|
|
Header_Num => SFN_Header_Num,
|
|
Element => Int,
|
|
No_Element => No_Entry,
|
|
Key => Unit_Name_Type,
|
|
Hash => SFN_Hash,
|
|
Equal => "=");
|
|
-- Hash table allowing rapid access to SFN_Table, the element value
|
|
-- is an index into this table.
|
|
|
|
type SFN_Pattern_Entry is record
|
|
Pat : String_Ptr; -- File name pattern (with asterisk in it)
|
|
Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit
|
|
Dot : String_Ptr; -- Dot_Separator string
|
|
Cas : Casing_Type; -- Upper/Lower/Mixed
|
|
end record;
|
|
-- Records single call to Set_File_Name_Patterm
|
|
|
|
package SFN_Patterns is new Table.Table (
|
|
Table_Component_Type => SFN_Pattern_Entry,
|
|
Table_Index_Type => Int,
|
|
Table_Low_Bound => 1,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100,
|
|
Table_Name => "SFN_Patterns");
|
|
-- Table recording all calls to Set_File_Name_Pattern. Note that the
|
|
-- first two entries are set to represent the standard GNAT rules
|
|
-- for file naming.
|
|
|
|
-----------------------
|
|
-- File_Name_Of_Body --
|
|
-----------------------
|
|
|
|
function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
|
|
begin
|
|
Get_Name_String (Name);
|
|
Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
|
|
Name_Len := Name_Len + 2;
|
|
return Get_File_Name (Name_Enter, Subunit => False);
|
|
end File_Name_Of_Body;
|
|
|
|
-----------------------
|
|
-- File_Name_Of_Spec --
|
|
-----------------------
|
|
|
|
function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
|
|
begin
|
|
Get_Name_String (Name);
|
|
Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
|
|
Name_Len := Name_Len + 2;
|
|
return Get_File_Name (Name_Enter, Subunit => False);
|
|
end File_Name_Of_Spec;
|
|
|
|
-------------------
|
|
-- Get_File_Name --
|
|
-------------------
|
|
|
|
function Get_File_Name
|
|
(Uname : Unit_Name_Type;
|
|
Subunit : Boolean;
|
|
May_Fail : Boolean := False) return File_Name_Type
|
|
is
|
|
Unit_Char : Character;
|
|
-- Set to 's' or 'b' for spec or body or to 'u' for a subunit
|
|
|
|
Unit_Char_Search : Character;
|
|
-- Same as Unit_Char, except that in the case of 'u' for a subunit,
|
|
-- we set Unit_Char_Search to 'b' if we do not find a subunit match.
|
|
|
|
N : Int;
|
|
|
|
Pname : File_Name_Type := No_File;
|
|
Fname : File_Name_Type := No_File;
|
|
-- Path name and File name for mapping
|
|
|
|
begin
|
|
-- Null or error name means that some previous error occurred
|
|
-- This is an unrecoverable error, so signal it.
|
|
|
|
if Uname <= Error_Name then
|
|
raise Unrecoverable_Error;
|
|
end if;
|
|
|
|
-- Look in the map from unit names to file names
|
|
|
|
Fname := Mapped_File_Name (Uname);
|
|
|
|
-- If the unit name is already mapped, return the corresponding
|
|
-- file name from the map.
|
|
|
|
if Fname /= No_File then
|
|
return Fname;
|
|
end if;
|
|
|
|
-- If there is a specific SFN pragma, return the corresponding file name
|
|
|
|
N := SFN_HTable.Get (Uname);
|
|
|
|
if N /= No_Entry then
|
|
return SFN_Table.Table (N).F;
|
|
end if;
|
|
|
|
-- Here for the case where the name was not found in the table
|
|
|
|
Get_Decoded_Name_String (Uname);
|
|
|
|
-- A special fudge, normally we don't have operator symbols present,
|
|
-- since it is always an error to do so. However, if we do, at this
|
|
-- stage it has a leading double quote.
|
|
|
|
-- What we do in this case is to go back to the undecoded name, which
|
|
-- is of the form, for example:
|
|
|
|
-- Oand%s
|
|
|
|
-- and build a file name that looks like:
|
|
|
|
-- _and_.ads
|
|
|
|
-- which is bit peculiar, but we keep it that way. This means that
|
|
-- we avoid bombs due to writing a bad file name, and w get expected
|
|
-- error processing downstream, e.g. a compilation following gnatchop.
|
|
|
|
if Name_Buffer (1) = '"' then
|
|
Get_Name_String (Uname);
|
|
Name_Len := Name_Len + 1;
|
|
Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1);
|
|
Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
|
|
Name_Buffer (Name_Len - 2) := '_';
|
|
Name_Buffer (1) := '_';
|
|
end if;
|
|
|
|
-- Deal with spec or body suffix
|
|
|
|
Unit_Char := Name_Buffer (Name_Len);
|
|
pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
|
|
pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
|
|
Name_Len := Name_Len - 2;
|
|
|
|
if Subunit then
|
|
Unit_Char := 'u';
|
|
end if;
|
|
|
|
-- Now we need to find the proper translation of the name
|
|
|
|
declare
|
|
Uname : constant String (1 .. Name_Len) :=
|
|
Name_Buffer (1 .. Name_Len);
|
|
|
|
Pent : Nat;
|
|
Plen : Natural;
|
|
Fnam : File_Name_Type := No_File;
|
|
J : Natural;
|
|
Dot : String_Ptr;
|
|
Dotl : Natural;
|
|
|
|
Is_Predef : Boolean;
|
|
-- Set True for predefined file
|
|
|
|
function C (N : Natural) return Character;
|
|
-- Return N'th character of pattern
|
|
|
|
function C (N : Natural) return Character is
|
|
begin
|
|
return SFN_Patterns.Table (Pent).Pat (N);
|
|
end C;
|
|
|
|
-- Start of search through pattern table
|
|
|
|
begin
|
|
-- Search pattern table to find a matching entry. In the general
|
|
-- case we do two complete searches. The first time through we
|
|
-- stop only if a matching file is found, the second time through
|
|
-- we accept the first match regardless. Note that there will
|
|
-- always be a match the second time around, because of the
|
|
-- default entries at the end of the table.
|
|
|
|
for No_File_Check in False .. True loop
|
|
Unit_Char_Search := Unit_Char;
|
|
|
|
<<Repeat_Search>>
|
|
-- The search is repeated with Unit_Char_Search set to b, if an
|
|
-- initial search for the subunit case fails to find any match.
|
|
|
|
Pent := SFN_Patterns.First;
|
|
while Pent <= SFN_Patterns.Last loop
|
|
if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
|
|
Name_Len := 0;
|
|
|
|
-- Determine if we have a predefined file name
|
|
|
|
Name_Len := Uname'Length;
|
|
Name_Buffer (1 .. Name_Len) := Uname;
|
|
Is_Predef :=
|
|
Is_Predefined_File_Name (Renamings_Included => True);
|
|
|
|
-- Found a match, execute the pattern
|
|
|
|
Name_Len := Uname'Length;
|
|
Name_Buffer (1 .. Name_Len) := Uname;
|
|
|
|
-- Apply casing, except that we do not do this for the case
|
|
-- of a predefined library file. For the latter, we always
|
|
-- use the all lower case name, regardless of the setting.
|
|
|
|
if not Is_Predef then
|
|
Set_Casing (SFN_Patterns.Table (Pent).Cas);
|
|
end if;
|
|
|
|
-- If dot translation required do it
|
|
|
|
Dot := SFN_Patterns.Table (Pent).Dot;
|
|
Dotl := Dot.all'Length;
|
|
|
|
if Dot.all /= "." then
|
|
J := 1;
|
|
|
|
while J <= Name_Len loop
|
|
if Name_Buffer (J) = '.' then
|
|
|
|
if Dotl = 1 then
|
|
Name_Buffer (J) := Dot (Dot'First);
|
|
|
|
else
|
|
Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
|
|
Name_Buffer (J + 1 .. Name_Len);
|
|
Name_Buffer (J .. J + Dotl - 1) := Dot.all;
|
|
Name_Len := Name_Len + Dotl - 1;
|
|
end if;
|
|
|
|
J := J + Dotl;
|
|
|
|
-- Skip past wide char sequences to avoid messing
|
|
-- with dot characters that are part of a sequence.
|
|
|
|
elsif Name_Buffer (J) = ASCII.ESC
|
|
or else (Upper_Half_Encoding
|
|
and then
|
|
Name_Buffer (J) in Upper_Half_Character)
|
|
then
|
|
Skip_Wide (Name_Buffer, J);
|
|
else
|
|
J := J + 1;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
-- Here move result to right if preinsertion before *
|
|
|
|
Plen := SFN_Patterns.Table (Pent).Pat'Length;
|
|
for K in 1 .. Plen loop
|
|
if C (K) = '*' then
|
|
if K /= 1 then
|
|
Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
|
|
Name_Buffer (1 .. Name_Len);
|
|
|
|
for L in 1 .. K - 1 loop
|
|
Name_Buffer (L) := C (L);
|
|
end loop;
|
|
|
|
Name_Len := Name_Len + K - 1;
|
|
end if;
|
|
|
|
for L in K + 1 .. Plen loop
|
|
Name_Len := Name_Len + 1;
|
|
Name_Buffer (Name_Len) := C (L);
|
|
end loop;
|
|
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Execute possible crunch on constructed name. The krunch
|
|
-- operation excludes any extension that may be present.
|
|
|
|
J := Name_Len;
|
|
while J > 1 loop
|
|
exit when Name_Buffer (J) = '.';
|
|
J := J - 1;
|
|
end loop;
|
|
|
|
-- Case of extension present
|
|
|
|
if J > 1 then
|
|
declare
|
|
Ext : constant String := Name_Buffer (J .. Name_Len);
|
|
|
|
begin
|
|
-- Remove extension
|
|
|
|
Name_Len := J - 1;
|
|
|
|
-- Krunch what's left
|
|
|
|
Krunch
|
|
(Name_Buffer,
|
|
Name_Len,
|
|
Integer (Maximum_File_Name_Length),
|
|
Debug_Flag_4);
|
|
|
|
-- Replace extension
|
|
|
|
Name_Buffer
|
|
(Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
|
|
Name_Len := Name_Len + Ext'Length;
|
|
end;
|
|
|
|
-- Case of no extension present, straight krunch on
|
|
-- the entire file name.
|
|
|
|
else
|
|
Krunch
|
|
(Name_Buffer,
|
|
Name_Len,
|
|
Integer (Maximum_File_Name_Length),
|
|
Debug_Flag_4);
|
|
end if;
|
|
|
|
Fnam := File_Name_Type (Name_Find);
|
|
|
|
-- If we are in the second search of the table, we accept
|
|
-- the file name without checking, because we know that
|
|
-- the file does not exist, except when May_Fail is True,
|
|
-- in which case we return No_File.
|
|
|
|
if No_File_Check then
|
|
if May_Fail then
|
|
return No_File;
|
|
else
|
|
return Fnam;
|
|
end if;
|
|
|
|
-- Otherwise we check if the file exists
|
|
|
|
else
|
|
Pname := Find_File (Fnam, Source);
|
|
|
|
-- If it does exist, we add it to the mappings and
|
|
-- return the file name.
|
|
|
|
if Pname /= No_File then
|
|
|
|
-- Add to mapping, so that we don't do another
|
|
-- path search in Find_File for this file name
|
|
-- and, if we use a mapping file, we are ready
|
|
-- to update it at the end of this compilation
|
|
-- for the benefit of other compilation processes.
|
|
|
|
Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
|
|
return Fnam;
|
|
|
|
-- If there are only two entries, they are those of
|
|
-- the default GNAT naming scheme. The file does
|
|
-- not exist, but there is no point doing the
|
|
-- second search, because we will end up with the
|
|
-- same file name. Just return the file name.
|
|
|
|
elsif SFN_Patterns.Last = 2 then
|
|
return Fnam;
|
|
|
|
-- The file does not exist, but there may be other
|
|
-- naming scheme. Keep on searching.
|
|
|
|
else
|
|
Fnam := No_File;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
Pent := Pent + 1;
|
|
end loop;
|
|
|
|
-- If search failed, and was for a subunit, repeat the search
|
|
-- with Unit_Char_Search reset to 'b', since in the normal case
|
|
-- we simply treat subunits as bodies.
|
|
|
|
if Fnam = No_File and then Unit_Char_Search = 'u' then
|
|
Unit_Char_Search := 'b';
|
|
goto Repeat_Search;
|
|
end if;
|
|
|
|
-- Repeat entire search in No_File_Check mode if necessary
|
|
|
|
end loop;
|
|
|
|
-- Something is wrong if search fails completely, since the
|
|
-- default entries should catch all possibilities at this stage.
|
|
|
|
raise Program_Error;
|
|
end;
|
|
end Get_File_Name;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize is
|
|
begin
|
|
SFN_Table.Init;
|
|
SFN_Patterns.Init;
|
|
|
|
-- Add default entries to SFN_Patterns.Table to represent the
|
|
-- standard default GNAT rules for file name translation.
|
|
|
|
SFN_Patterns.Append (New_Val =>
|
|
(Pat => new String'("*.ads"),
|
|
Typ => 's',
|
|
Dot => new String'("-"),
|
|
Cas => All_Lower_Case));
|
|
|
|
SFN_Patterns.Append (New_Val =>
|
|
(Pat => new String'("*.adb"),
|
|
Typ => 'b',
|
|
Dot => new String'("-"),
|
|
Cas => All_Lower_Case));
|
|
end Initialize;
|
|
|
|
----------
|
|
-- Lock --
|
|
----------
|
|
|
|
procedure Lock is
|
|
begin
|
|
SFN_Table.Locked := True;
|
|
SFN_Table.Release;
|
|
end Lock;
|
|
|
|
-------------------
|
|
-- Set_File_Name --
|
|
-------------------
|
|
|
|
procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type) is
|
|
begin
|
|
SFN_Table.Increment_Last;
|
|
SFN_Table.Table (SFN_Table.Last) := (U, F);
|
|
SFN_HTable.Set (U, SFN_Table.Last);
|
|
end Set_File_Name;
|
|
|
|
---------------------------
|
|
-- Set_File_Name_Pattern --
|
|
---------------------------
|
|
|
|
procedure Set_File_Name_Pattern
|
|
(Pat : String_Ptr;
|
|
Typ : Character;
|
|
Dot : String_Ptr;
|
|
Cas : Casing_Type)
|
|
is
|
|
L : constant Nat := SFN_Patterns.Last;
|
|
begin
|
|
SFN_Patterns.Increment_Last;
|
|
|
|
-- Move up the last two entries (the default ones) and then
|
|
-- put the new entry into the table just before them (we
|
|
-- always have the default entries be the last ones).
|
|
|
|
SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
|
|
SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1);
|
|
SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
|
|
end Set_File_Name_Pattern;
|
|
|
|
--------------
|
|
-- SFN_Hash --
|
|
--------------
|
|
|
|
function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
|
|
begin
|
|
return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
|
|
end SFN_Hash;
|
|
|
|
begin
|
|
|
|
-- We call the initialization routine from the package body, so that
|
|
-- Fname.Init only needs to be called explicitly to reinitialize.
|
|
|
|
Fname.UF.Initialize;
|
|
end Fname.UF;
|