Commit 998429d6 by Arnaud Charlet

[multiple changes]

2017-04-25  Bob Duff  <duff@adacore.com>

	* uname.ads, uname.adb (Is_Predefined_Unit_Name,
	Is_Internal_Unit_Name): New functions for operating on unit
	names, as opposed to file names. There's some duplicated code
	with fname.adb, which is unfortunate, but it seems like we don't
	want to add dependencies here.
	* fname-uf.adb (Get_File_Name): Change Is_Predefined_File_Name
	to Is_Predefined_Unit_Name; the former was wrong, because Uname
	is not a file name at all.
	* fname.ads, fname.adb: Document the fact that
	Is_Predefined_File_Name and Is_Internal_File_Name can be called
	for ALI files, and fix the code so it works properly for ALI
	files. E.g. these should return True for "system.ali".

2017-04-25  Justin Squirek  <squirek@adacore.com>

	* exp_util.adb (Add_Invariant): Removed,
	code moved to Add_Invariant_Check, Add_Inherited_Invariant,
	and Add_Own_Invariant.	(Add_Invariant_Check): Used
	for adding runtime checks from any kind of invariant.
	(Add_Inherited_Invariant): Generates invariant checks for
	class-wide invariants (Add_Interface_Invariants): Removed, code
	moved to Build_Invariant_Procedure_Body (Add_Own_Invariant):
	Create a types own invariant procedure (Add_Parent_Invariants):
	Removed, code moved to Build_Invariant_Procedure_Body
	(Build_Invariant_Procedure_Body): Add refactored calls
	and integrated code from Add_Parent_Invariants and
	Add_Interface_Invariants.
	(Process_Type): Removed, the
	relavant code was inlined into both Add_Own_Invariant and
	Add_Inherited_Invariant.

From-SVN: r247154
parent 94d3a18d
2017-04-25 Bob Duff <duff@adacore.com>
* uname.ads, uname.adb (Is_Predefined_Unit_Name,
Is_Internal_Unit_Name): New functions for operating on unit
names, as opposed to file names. There's some duplicated code
with fname.adb, which is unfortunate, but it seems like we don't
want to add dependencies here.
* fname-uf.adb (Get_File_Name): Change Is_Predefined_File_Name
to Is_Predefined_Unit_Name; the former was wrong, because Uname
is not a file name at all.
* fname.ads, fname.adb: Document the fact that
Is_Predefined_File_Name and Is_Internal_File_Name can be called
for ALI files, and fix the code so it works properly for ALI
files. E.g. these should return True for "system.ali".
2017-04-25 Justin Squirek <squirek@adacore.com>
* exp_util.adb (Add_Invariant): Removed,
code moved to Add_Invariant_Check, Add_Inherited_Invariant,
and Add_Own_Invariant. (Add_Invariant_Check): Used
for adding runtime checks from any kind of invariant.
(Add_Inherited_Invariant): Generates invariant checks for
class-wide invariants (Add_Interface_Invariants): Removed, code
moved to Build_Invariant_Procedure_Body (Add_Own_Invariant):
Create a types own invariant procedure (Add_Parent_Invariants):
Removed, code moved to Build_Invariant_Procedure_Body
(Build_Invariant_Procedure_Body): Add refactored calls
and integrated code from Add_Parent_Invariants and
Add_Interface_Invariants.
(Process_Type): Removed, the
relavant code was inlined into both Add_Own_Invariant and
Add_Inherited_Invariant.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com> 2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* make.adb, par-ch2.adb, sem_util.adb, scans.ads, sem_ch8.adb, * make.adb, par-ch2.adb, sem_util.adb, scans.ads, sem_ch8.adb,
......
...@@ -231,7 +231,7 @@ package body Fname.UF is ...@@ -231,7 +231,7 @@ package body Fname.UF is
-- _and_.ads -- _and_.ads
-- which is bit peculiar, but we keep it that way. This means that we -- 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 -- avoid bombs due to writing a bad file name, and we get expected error
-- processing downstream, e.g. a compilation following gnatchop. -- processing downstream, e.g. a compilation following gnatchop.
if Name_Buffer (1) = '"' then if Name_Buffer (1) = '"' then
...@@ -298,12 +298,10 @@ package body Fname.UF is ...@@ -298,12 +298,10 @@ package body Fname.UF is
Pent := SFN_Patterns.First; Pent := SFN_Patterns.First;
while Pent <= SFN_Patterns.Last loop while Pent <= SFN_Patterns.Last loop
if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
Name_Len := 0;
-- Determine if we have a predefined file name -- Determine if we have a predefined file name
Is_Predef := Is_Predef :=
Is_Predefined_File_Name Is_Predefined_Unit_Name
(Uname, Renamings_Included => True); (Uname, Renamings_Included => True);
-- Found a match, execute the pattern -- Found a match, execute the pattern
......
...@@ -58,8 +58,9 @@ package body Fname is ...@@ -58,8 +58,9 @@ package body Fname is
Table_Name => "Fname_Dummy_Table"); Table_Name => "Fname_Dummy_Table");
function Has_Internal_Extension (Fname : String) return Boolean; function Has_Internal_Extension (Fname : String) return Boolean;
-- True if the extension is ".ads" or ".adb", as is always the case for -- True if the extension is appropriate for an internal/predefined
-- internal/predefined units. -- unit. That means ".ads" or ".adb" for source files, and ".ali" for
-- ALI files.
function Has_Prefix (X, Prefix : String) return Boolean; function Has_Prefix (X, Prefix : String) return Boolean;
-- True if Prefix is at the beginning of X. For example, -- True if Prefix is at the beginning of X. For example,
...@@ -76,7 +77,8 @@ package body Fname is ...@@ -76,7 +77,8 @@ package body Fname is
begin begin
return return
Has_Suffix (Fname, Suffix => ".ads") Has_Suffix (Fname, Suffix => ".ads")
or else Has_Suffix (Fname, Suffix => ".adb"); or else Has_Suffix (Fname, Suffix => ".adb")
or else Has_Suffix (Fname, Suffix => ".ali");
end Has_Internal_Extension; end Has_Internal_Extension;
---------------- ----------------
...@@ -139,10 +141,11 @@ package body Fname is ...@@ -139,10 +141,11 @@ package body Fname is
(Fname : File_Name_Type; (Fname : File_Name_Type;
Renamings_Included : Boolean := True) return Boolean Renamings_Included : Boolean := True) return Boolean
is is
Result : constant Boolean :=
Is_Internal_File_Name
(Get_Name_String (Fname), Renamings_Included);
begin begin
return return Result;
Is_Internal_File_Name
(Get_Name_String (Fname), Renamings_Included);
end Is_Internal_File_Name; end Is_Internal_File_Name;
----------------------------- -----------------------------
......
...@@ -68,15 +68,16 @@ package Fname is ...@@ -68,15 +68,16 @@ package Fname is
function Is_Predefined_File_Name function Is_Predefined_File_Name
(Fname : File_Name_Type; (Fname : File_Name_Type;
Renamings_Included : Boolean := True) return Boolean; Renamings_Included : Boolean := True) return Boolean;
-- These functions determine if the given file name (which must be a -- These functions determine if the given file name (which must be a simple
-- simple file name with no directory information) is the file name for -- file name with no directory information) is the source or ALI file name
-- one of the predefined library units (i.e. part of the Ada, System, or -- for one of the predefined library units (i.e. part of the Ada, System,
-- Interface hierarchies). Note that units in the GNAT hierarchy are not -- or Interface hierarchies). Note that units in the GNAT hierarchy are not
-- considered predefined (see Is_Internal_File_Name below). The -- considered predefined (see Is_Internal_File_Name below).
-- Renamings_Included parameter indicates whether annex J renamings such as --
-- Text_IO are to be considered as predefined. If Renamings_Included is -- The Renamings_Included parameter indicates whether annex J renamings
-- True, then Text_IO will return True, otherwise only children of Ada, -- such as Text_IO are to be considered as predefined. If
-- Interfaces and System return True. -- Renamings_Included is True, then Text_IO will return True, otherwise
-- only children of Ada, Interfaces and System return True.
function Is_Internal_File_Name function Is_Internal_File_Name
(Fname : String; (Fname : String;
......
...@@ -41,6 +41,10 @@ with Sinput; use Sinput; ...@@ -41,6 +41,10 @@ with Sinput; use Sinput;
package body Uname is package body Uname is
function Has_Prefix (X, Prefix : String) return Boolean;
-- True if Prefix is at the beginning of X. For example,
-- Has_Prefix("a-filename.ads", Prefix => "a-") is True.
------------------- -------------------
-- Get_Body_Name -- -- Get_Body_Name --
------------------- -------------------
...@@ -472,6 +476,23 @@ package body Uname is ...@@ -472,6 +476,23 @@ package body Uname is
end if; end if;
end Get_Unit_Name_String; end Get_Unit_Name_String;
----------------
-- Has_Prefix --
----------------
function Has_Prefix (X, Prefix : String) return Boolean is
begin
if X'Length >= Prefix'Length then
declare
Slice : String renames
X (X'First .. X'First + Prefix'Length - 1);
begin
return Slice = Prefix;
end;
end if;
return False;
end Has_Prefix;
------------------ ------------------
-- Is_Body_Name -- -- Is_Body_Name --
------------------ ------------------
...@@ -506,6 +527,72 @@ package body Uname is ...@@ -506,6 +527,72 @@ package body Uname is
return True; return True;
end Is_Child_Name; end Is_Child_Name;
---------------------------
-- Is_Internal_Unit_Name --
---------------------------
function Is_Internal_Unit_Name
(Name : String;
Renamings_Included : Boolean := True) return Boolean
is
Gnat : constant String := "gnat";
begin
if Name = Gnat then
return True;
end if;
if Has_Prefix (Name, Prefix => Gnat & ".") then
return True;
end if;
return Is_Predefined_Unit_Name (Name, Renamings_Included);
end Is_Internal_Unit_Name;
-----------------------------
-- Is_Predefined_Unit_Name --
-----------------------------
function Is_Predefined_Unit_Name
(Name : String;
Renamings_Included : Boolean := True) return Boolean
is
Ada : constant String := "ada";
Interfaces : constant String := "interfaces";
System : constant String := "system";
begin
if Name = Ada
or else Name = Interfaces
or else Name = System
then
return True;
end if;
if Has_Prefix (Name, Prefix => Ada & ".")
or else Has_Prefix (Name, Prefix => Interfaces & ".")
or else Has_Prefix (Name, Prefix => System & ".")
then
return True;
end if;
if not Renamings_Included then
return False;
end if;
-- The following are the predefined renamings
return
Name = "calendar"
or else Name = "machine_code"
or else Name = "unchecked_conversion"
or else Name = "unchecked_deallocation"
or else Name = "direct_io"
or else Name = "io_exceptions"
or else Name = "sequential_io"
or else Name = "text_io";
end Is_Predefined_Unit_Name;
------------------ ------------------
-- Is_Spec_Name -- -- Is_Spec_Name --
------------------ ------------------
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -133,6 +133,18 @@ package Uname is ...@@ -133,6 +133,18 @@ package Uname is
-- Returns True iff the given name is a child unit name (of either a -- Returns True iff the given name is a child unit name (of either a
-- body or a spec). -- body or a spec).
function Is_Internal_Unit_Name
(Name : String;
Renamings_Included : Boolean := True) return Boolean;
-- Same as Fname.Is_Internal_File_Name, except it works with the name of
-- the unit, rather than the file name.
function Is_Predefined_Unit_Name
(Name : String;
Renamings_Included : Boolean := True) return Boolean;
-- Same as Fname.Is_Predefined_File_Name, except it works with the name of
-- the unit, rather than the file name.
function Is_Spec_Name (N : Unit_Name_Type) return Boolean; function Is_Spec_Name (N : Unit_Name_Type) return Boolean;
-- Returns True iff the given name is the unit name of a specification -- Returns True iff the given name is the unit name of a specification
-- (i.e. if it ends with the characters %s). -- (i.e. if it ends with the characters %s).
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment