[multiple changes]
2016-06-20 Hristian Kirtchev <kirtchev@adacore.com> * s-regpat.adb, sem_prag.adb, pprint.adb, sem_ch13.adb: Minor reformatting. 2016-06-20 Tristan Gingold <gingold@adacore.com> * make.adb (Check_Standard_Library): Consider system.ads if s-stalib.adb is not available. * gnatbind.adb (Add_Artificial_ALI_File): New procedure extracted from gnatbind. 2016-06-20 Thomas Quinot <quinot@adacore.com> * g-socket.adb (Is_IP_Address): A string consisting in digits only is not a dotted quad. 2016-06-20 Arnaud Charlet <charlet@adacore.com> * exp_ch7.adb (Build_Invariant_Procedure_Body): decorate invariant procedure body with typical properties of procedure entityes. 2016-06-20 Arnaud Charlet <charlet@adacore.com> * a-exetim-darwin.adb: New file. From-SVN: r237598
This commit is contained in:
parent
61f17a5c5a
commit
2f8d7dfe21
|
@ -1,3 +1,30 @@
|
||||||
|
2016-06-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* s-regpat.adb, sem_prag.adb, pprint.adb, sem_ch13.adb: Minor
|
||||||
|
reformatting.
|
||||||
|
|
||||||
|
2016-06-20 Tristan Gingold <gingold@adacore.com>
|
||||||
|
|
||||||
|
* make.adb (Check_Standard_Library): Consider system.ads
|
||||||
|
if s-stalib.adb is not available.
|
||||||
|
* gnatbind.adb (Add_Artificial_ALI_File): New procedure extracted from
|
||||||
|
gnatbind.
|
||||||
|
|
||||||
|
2016-06-20 Thomas Quinot <quinot@adacore.com>
|
||||||
|
|
||||||
|
* g-socket.adb (Is_IP_Address): A string consisting in digits only is
|
||||||
|
not a dotted quad.
|
||||||
|
|
||||||
|
2016-06-20 Arnaud Charlet <charlet@adacore.com>
|
||||||
|
|
||||||
|
* exp_ch7.adb (Build_Invariant_Procedure_Body):
|
||||||
|
decorate invariant procedure body with typical properties of
|
||||||
|
procedure entityes.
|
||||||
|
|
||||||
|
2016-06-20 Arnaud Charlet <charlet@adacore.com>
|
||||||
|
|
||||||
|
* a-exetim-darwin.adb: New file.
|
||||||
|
|
||||||
2016-06-16 Hristian Kirtchev <kirtchev@adacore.com>
|
2016-06-16 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
* atree.ads, atree.adb (Elist29): New routine.
|
* atree.ads, atree.adb (Elist29): New routine.
|
||||||
|
|
|
@ -0,0 +1,210 @@
|
||||||
|
------------------------------------------------------------------------------
|
||||||
|
-- --
|
||||||
|
-- GNAT RUN-TIME COMPONENTS --
|
||||||
|
-- --
|
||||||
|
-- A D A . E X E C U T I O N _ T I M E --
|
||||||
|
-- --
|
||||||
|
-- B o d y --
|
||||||
|
-- --
|
||||||
|
-- Copyright (C) 2007-2016, 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 3, or (at your option) any later ver- --
|
||||||
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||||
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||||
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||||
|
-- --
|
||||||
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||||
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||||
|
-- version 3.1, as published by the Free Software Foundation. --
|
||||||
|
-- --
|
||||||
|
-- You should have received a copy of the GNU General Public License and --
|
||||||
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||||
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||||
|
-- <http://www.gnu.org/licenses/>. --
|
||||||
|
-- --
|
||||||
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||||
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||||
|
-- --
|
||||||
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- This is the Darwin version of this package
|
||||||
|
|
||||||
|
with Ada.Task_Identification; use Ada.Task_Identification;
|
||||||
|
with Ada.Unchecked_Conversion;
|
||||||
|
|
||||||
|
with System.Tasking;
|
||||||
|
with System.OS_Interface; use System.OS_Interface;
|
||||||
|
with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
|
||||||
|
|
||||||
|
with Interfaces.C; use Interfaces.C;
|
||||||
|
|
||||||
|
package body Ada.Execution_Time is
|
||||||
|
|
||||||
|
---------
|
||||||
|
-- "+" --
|
||||||
|
---------
|
||||||
|
|
||||||
|
function "+"
|
||||||
|
(Left : CPU_Time;
|
||||||
|
Right : Ada.Real_Time.Time_Span) return CPU_Time
|
||||||
|
is
|
||||||
|
use type Ada.Real_Time.Time;
|
||||||
|
begin
|
||||||
|
return CPU_Time (Ada.Real_Time.Time (Left) + Right);
|
||||||
|
end "+";
|
||||||
|
|
||||||
|
function "+"
|
||||||
|
(Left : Ada.Real_Time.Time_Span;
|
||||||
|
Right : CPU_Time) return CPU_Time
|
||||||
|
is
|
||||||
|
use type Ada.Real_Time.Time;
|
||||||
|
begin
|
||||||
|
return CPU_Time (Left + Ada.Real_Time.Time (Right));
|
||||||
|
end "+";
|
||||||
|
|
||||||
|
---------
|
||||||
|
-- "-" --
|
||||||
|
---------
|
||||||
|
|
||||||
|
function "-"
|
||||||
|
(Left : CPU_Time;
|
||||||
|
Right : Ada.Real_Time.Time_Span) return CPU_Time
|
||||||
|
is
|
||||||
|
use type Ada.Real_Time.Time;
|
||||||
|
begin
|
||||||
|
return CPU_Time (Ada.Real_Time.Time (Left) - Right);
|
||||||
|
end "-";
|
||||||
|
|
||||||
|
function "-"
|
||||||
|
(Left : CPU_Time;
|
||||||
|
Right : CPU_Time) return Ada.Real_Time.Time_Span
|
||||||
|
is
|
||||||
|
use type Ada.Real_Time.Time;
|
||||||
|
begin
|
||||||
|
return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
|
||||||
|
end "-";
|
||||||
|
|
||||||
|
-----------
|
||||||
|
-- Clock --
|
||||||
|
-----------
|
||||||
|
|
||||||
|
function Clock
|
||||||
|
(T : Ada.Task_Identification.Task_Id :=
|
||||||
|
Ada.Task_Identification.Current_Task) return CPU_Time
|
||||||
|
is
|
||||||
|
function Convert_Ids is new
|
||||||
|
Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
|
||||||
|
|
||||||
|
function To_CPU_Time is
|
||||||
|
new Ada.Unchecked_Conversion (Duration, CPU_Time);
|
||||||
|
-- Time is equal to Duration (although it is a private type) and
|
||||||
|
-- CPU_Time is equal to Time.
|
||||||
|
|
||||||
|
subtype integer_t is Interfaces.C.int;
|
||||||
|
subtype mach_port_t is integer_t;
|
||||||
|
-- Type definition for Mach.
|
||||||
|
|
||||||
|
type time_value_t is record
|
||||||
|
seconds : integer_t;
|
||||||
|
microseconds : integer_t;
|
||||||
|
end record;
|
||||||
|
pragma Convention (C, time_value_t);
|
||||||
|
-- Mach time_value_t
|
||||||
|
|
||||||
|
type thread_basic_info_t is record
|
||||||
|
user_time : time_value_t;
|
||||||
|
system_time : time_value_t;
|
||||||
|
cpu_usage : integer_t;
|
||||||
|
policy : integer_t;
|
||||||
|
run_state : integer_t;
|
||||||
|
flags : integer_t;
|
||||||
|
suspend_count : integer_t;
|
||||||
|
sleep_time : integer_t;
|
||||||
|
end record;
|
||||||
|
pragma Convention (C, thread_basic_info_t);
|
||||||
|
-- Mach structure from thread_info.h
|
||||||
|
|
||||||
|
THREAD_BASIC_INFO : constant := 3;
|
||||||
|
THREAD_BASIC_INFO_COUNT : constant := 10;
|
||||||
|
-- Flavors for basic info
|
||||||
|
|
||||||
|
function thread_info (Target : mach_port_t;
|
||||||
|
Flavor : integer_t;
|
||||||
|
Thread_Info : System.Address;
|
||||||
|
Count : System.Address) return integer_t;
|
||||||
|
pragma Import (C, thread_info);
|
||||||
|
-- Mach call to get info on a thread
|
||||||
|
|
||||||
|
function pthread_mach_thread_np (Thread : pthread_t) return mach_port_t;
|
||||||
|
pragma Import (C, pthread_mach_thread_np);
|
||||||
|
-- Get Mach thread from posix thread
|
||||||
|
|
||||||
|
Result : Interfaces.C.int;
|
||||||
|
Thread : pthread_t;
|
||||||
|
Port : mach_port_t;
|
||||||
|
Ti : thread_basic_info_t;
|
||||||
|
Count : integer_t;
|
||||||
|
begin
|
||||||
|
if T = Ada.Task_Identification.Null_Task_Id then
|
||||||
|
raise Program_Error;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Thread := Get_Thread_Id (Convert_Ids (T));
|
||||||
|
Port := pthread_mach_thread_np (Thread);
|
||||||
|
pragma Assert (Port > 0);
|
||||||
|
|
||||||
|
Count := THREAD_BASIC_INFO_COUNT;
|
||||||
|
Result := thread_info (Port, THREAD_BASIC_INFO,
|
||||||
|
Ti'Address, Count'Address);
|
||||||
|
pragma Assert (Result = 0);
|
||||||
|
pragma Assert (Count = THREAD_BASIC_INFO_COUNT);
|
||||||
|
|
||||||
|
return To_CPU_Time
|
||||||
|
(Duration (Ti.user_time.seconds + Ti.system_time.seconds)
|
||||||
|
+ Duration (Ti.user_time.microseconds
|
||||||
|
+ Ti.system_time.microseconds) / 1E6);
|
||||||
|
end Clock;
|
||||||
|
|
||||||
|
--------------------------
|
||||||
|
-- Clock_For_Interrupts --
|
||||||
|
--------------------------
|
||||||
|
|
||||||
|
function Clock_For_Interrupts return CPU_Time is
|
||||||
|
begin
|
||||||
|
-- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
|
||||||
|
-- is set to False the function raises Program_Error.
|
||||||
|
|
||||||
|
raise Program_Error;
|
||||||
|
return CPU_Time_First;
|
||||||
|
end Clock_For_Interrupts;
|
||||||
|
|
||||||
|
-----------
|
||||||
|
-- Split --
|
||||||
|
-----------
|
||||||
|
|
||||||
|
procedure Split
|
||||||
|
(T : CPU_Time;
|
||||||
|
SC : out Ada.Real_Time.Seconds_Count;
|
||||||
|
TS : out Ada.Real_Time.Time_Span)
|
||||||
|
is
|
||||||
|
use type Ada.Real_Time.Time;
|
||||||
|
begin
|
||||||
|
Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
|
||||||
|
end Split;
|
||||||
|
|
||||||
|
-------------
|
||||||
|
-- Time_Of --
|
||||||
|
-------------
|
||||||
|
|
||||||
|
function Time_Of
|
||||||
|
(SC : Ada.Real_Time.Seconds_Count;
|
||||||
|
TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
|
||||||
|
return CPU_Time
|
||||||
|
is
|
||||||
|
begin
|
||||||
|
return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
|
||||||
|
end Time_Of;
|
||||||
|
|
||||||
|
end Ada.Execution_Time;
|
|
@ -4769,6 +4769,10 @@ package body Exp_Ch7 is
|
||||||
Statements => Stmts));
|
Statements => Stmts));
|
||||||
Proc_Body_Id := Defining_Entity (Proc_Body);
|
Proc_Body_Id := Defining_Entity (Proc_Body);
|
||||||
|
|
||||||
|
Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
|
||||||
|
Set_Etype (Proc_Body_Id, Standard_Void_Type);
|
||||||
|
Set_Scope (Proc_Body_Id, Scope (Typ));
|
||||||
|
|
||||||
-- Link both spec and body to avoid generating duplicates
|
-- Link both spec and body to avoid generating duplicates
|
||||||
|
|
||||||
Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
|
Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
|
||||||
|
|
|
@ -150,7 +150,7 @@ package body GNAT.Sockets is
|
||||||
-- Output an array of inet address components in hex or decimal mode
|
-- Output an array of inet address components in hex or decimal mode
|
||||||
|
|
||||||
function Is_IP_Address (Name : String) return Boolean;
|
function Is_IP_Address (Name : String) return Boolean;
|
||||||
-- Return true when Name is an IP address in standard dot notation
|
-- Return true when Name is an IPv4 address in dotted quad notation
|
||||||
|
|
||||||
procedure Netdb_Lock;
|
procedure Netdb_Lock;
|
||||||
pragma Inline (Netdb_Lock);
|
pragma Inline (Netdb_Lock);
|
||||||
|
@ -996,7 +996,8 @@ package body GNAT.Sockets is
|
||||||
|
|
||||||
function Get_Host_By_Name (Name : String) return Host_Entry_Type is
|
function Get_Host_By_Name (Name : String) return Host_Entry_Type is
|
||||||
begin
|
begin
|
||||||
-- Detect IP address name and redirect to Inet_Addr
|
-- If the given name actually is the string representation of
|
||||||
|
-- an IP address, use Get_Host_By_Address instead.
|
||||||
|
|
||||||
if Is_IP_Address (Name) then
|
if Is_IP_Address (Name) then
|
||||||
return Get_Host_By_Address (Inet_Addr (Name));
|
return Get_Host_By_Address (Inet_Addr (Name));
|
||||||
|
@ -1503,16 +1504,37 @@ package body GNAT.Sockets is
|
||||||
-------------------
|
-------------------
|
||||||
|
|
||||||
function Is_IP_Address (Name : String) return Boolean is
|
function Is_IP_Address (Name : String) return Boolean is
|
||||||
|
Dots : Natural := 0;
|
||||||
begin
|
begin
|
||||||
|
-- Perform a cursory check for a dotted quad: we must have 1 to 3
|
||||||
|
-- dots, and there must be at least one digit around each.
|
||||||
|
|
||||||
for J in Name'Range loop
|
for J in Name'Range loop
|
||||||
if Name (J) /= '.'
|
if Name (J) = '.' then
|
||||||
and then Name (J) not in '0' .. '9'
|
|
||||||
then
|
-- Check that the dot is not in first or last position, and
|
||||||
|
-- that it is followed by a digit. Note that we already know
|
||||||
|
-- that it is preceded by a digit, or we would have returned
|
||||||
|
-- earlier on.
|
||||||
|
|
||||||
|
if J in Name'First + 1 .. Name'Last - 1
|
||||||
|
and then Name (J + 1) in '0' .. '9'
|
||||||
|
then
|
||||||
|
Dots := Dots + 1;
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
-- Definitely not a proper dotted quad
|
||||||
|
|
||||||
|
return False;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
elsif Name (J) not in '0' .. '9' then
|
||||||
return False;
|
return False;
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
return True;
|
return Dots in 1 .. 3;
|
||||||
end Is_IP_Address;
|
end Is_IP_Address;
|
||||||
|
|
||||||
-------------
|
-------------
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2015, 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- --
|
||||||
|
@ -89,6 +89,9 @@ procedure Gnatbind is
|
||||||
-- Table to record the sources in the closure, to avoid duplications. Used
|
-- Table to record the sources in the closure, to avoid duplications. Used
|
||||||
-- only with switch -R.
|
-- only with switch -R.
|
||||||
|
|
||||||
|
procedure Add_Artificial_ALI_File (Name : String);
|
||||||
|
-- Artificially add ALI file Name in the closure.
|
||||||
|
|
||||||
function Gnatbind_Supports_Auto_Init return Boolean;
|
function Gnatbind_Supports_Auto_Init return Boolean;
|
||||||
-- Indicates if automatic initialization of elaboration procedure
|
-- Indicates if automatic initialization of elaboration procedure
|
||||||
-- through the constructor mechanism is possible on the platform.
|
-- through the constructor mechanism is possible on the platform.
|
||||||
|
@ -113,6 +116,30 @@ procedure Gnatbind is
|
||||||
function Is_Cross_Compiler return Boolean;
|
function Is_Cross_Compiler return Boolean;
|
||||||
-- Returns True iff this is a cross-compiler
|
-- Returns True iff this is a cross-compiler
|
||||||
|
|
||||||
|
-----------------------------
|
||||||
|
-- Add_Artificial_ALI_File --
|
||||||
|
-----------------------------
|
||||||
|
|
||||||
|
procedure Add_Artificial_ALI_File (Name : String) is
|
||||||
|
Id : ALI_Id;
|
||||||
|
pragma Warnings (Off, Id);
|
||||||
|
begin
|
||||||
|
Name_Len := Name'Length;
|
||||||
|
Name_Buffer (1 .. Name_Len) := Name;
|
||||||
|
Std_Lib_File := Name_Find;
|
||||||
|
Text := Read_Library_Info (Std_Lib_File, True);
|
||||||
|
|
||||||
|
Id :=
|
||||||
|
Scan_ALI
|
||||||
|
(F => Std_Lib_File,
|
||||||
|
T => Text,
|
||||||
|
Ignore_ED => False,
|
||||||
|
Err => False,
|
||||||
|
Ignore_Errors => Debug_Flag_I);
|
||||||
|
|
||||||
|
Free (Text);
|
||||||
|
end Add_Artificial_ALI_File;
|
||||||
|
|
||||||
---------------------------------
|
---------------------------------
|
||||||
-- Gnatbind_Supports_Auto_Init --
|
-- Gnatbind_Supports_Auto_Init --
|
||||||
---------------------------------
|
---------------------------------
|
||||||
|
@ -740,29 +767,15 @@ begin
|
||||||
|
|
||||||
-- Add System.Standard_Library to list to ensure that these files are
|
-- Add System.Standard_Library to list to ensure that these files are
|
||||||
-- included in the bind, even if not directly referenced from Ada code
|
-- included in the bind, even if not directly referenced from Ada code
|
||||||
-- This is suppressed if the appropriate targparm switch is set.
|
-- This is suppressed if the appropriate targparm switch is set. Be sure
|
||||||
|
-- in any case that System is in the closure, as it may contains linker
|
||||||
|
-- options. Note that it will be automatically added if s-stalib is
|
||||||
|
-- added.
|
||||||
|
|
||||||
if not Suppress_Standard_Library_On_Target then
|
if not Suppress_Standard_Library_On_Target then
|
||||||
Name_Buffer (1 .. 12) := "s-stalib.ali";
|
Add_Artificial_ALI_File ("s-stalib.ali");
|
||||||
Name_Len := 12;
|
else
|
||||||
Std_Lib_File := Name_Find;
|
Add_Artificial_ALI_File ("system.ali");
|
||||||
Text := Read_Library_Info (Std_Lib_File, True);
|
|
||||||
|
|
||||||
declare
|
|
||||||
Id : ALI_Id;
|
|
||||||
pragma Warnings (Off, Id);
|
|
||||||
|
|
||||||
begin
|
|
||||||
Id :=
|
|
||||||
Scan_ALI
|
|
||||||
(F => Std_Lib_File,
|
|
||||||
T => Text,
|
|
||||||
Ignore_ED => False,
|
|
||||||
Err => False,
|
|
||||||
Ignore_Errors => Debug_Flag_I);
|
|
||||||
end;
|
|
||||||
|
|
||||||
Free (Text);
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Load ALIs for all dependent units
|
-- Load ALIs for all dependent units
|
||||||
|
|
|
@ -84,8 +84,11 @@ package body Make is
|
||||||
-- Make control characters visible
|
-- Make control characters visible
|
||||||
|
|
||||||
Standard_Library_Package_Body_Name : constant String := "s-stalib.adb";
|
Standard_Library_Package_Body_Name : constant String := "s-stalib.adb";
|
||||||
-- Every program depends on this package, that must then be checked,
|
System_Package_Spec_Name : constant String := "system.ads";
|
||||||
-- especially when -f and -a are used.
|
-- Every program depends on one of these packages: usually the first one,
|
||||||
|
-- or if Supress_Standard_Library is true on the second one. The dependency
|
||||||
|
-- is not always explicit and considering it is important when -f and -a
|
||||||
|
-- are used.
|
||||||
|
|
||||||
type Sigint_Handler is access procedure;
|
type Sigint_Handler is access procedure;
|
||||||
pragma Convention (C, Sigint_Handler);
|
pragma Convention (C, Sigint_Handler);
|
||||||
|
@ -2701,39 +2704,43 @@ package body Make is
|
||||||
begin
|
begin
|
||||||
Need_To_Check_Standard_Library := False;
|
Need_To_Check_Standard_Library := False;
|
||||||
|
|
||||||
|
Name_Len := 0;
|
||||||
|
|
||||||
if not Targparm.Suppress_Standard_Library_On_Target then
|
if not Targparm.Suppress_Standard_Library_On_Target then
|
||||||
declare
|
Add_Str_To_Name_Buffer (Standard_Library_Package_Body_Name);
|
||||||
Sfile : File_Name_Type;
|
else
|
||||||
Add_It : Boolean := True;
|
Add_Str_To_Name_Buffer (System_Package_Spec_Name);
|
||||||
|
end if;
|
||||||
|
|
||||||
begin
|
declare
|
||||||
Name_Len := 0;
|
Sfile : File_Name_Type;
|
||||||
Add_Str_To_Name_Buffer (Standard_Library_Package_Body_Name);
|
Add_It : Boolean := True;
|
||||||
Sfile := Name_Enter;
|
|
||||||
|
|
||||||
-- If we have a special runtime, we add the standard
|
begin
|
||||||
-- library only if we can find it.
|
Sfile := Name_Enter;
|
||||||
|
|
||||||
if RTS_Switch then
|
-- If we have a special runtime, we add the standard library only
|
||||||
Add_It := Full_Source_Name (Sfile) /= No_File;
|
-- if we can find it.
|
||||||
end if;
|
|
||||||
|
|
||||||
if Add_It then
|
if RTS_Switch then
|
||||||
if not Queue.Insert
|
Add_It := Full_Source_Name (Sfile) /= No_File;
|
||||||
((Format => Format_Gnatmake,
|
end if;
|
||||||
File => Sfile,
|
|
||||||
Unit => No_Unit_Name,
|
if Add_It then
|
||||||
Project => No_Project,
|
if not Queue.Insert
|
||||||
Index => 0,
|
((Format => Format_Gnatmake,
|
||||||
Sid => No_Source))
|
File => Sfile,
|
||||||
then
|
Unit => No_Unit_Name,
|
||||||
if Is_In_Obsoleted (Sfile) then
|
Project => No_Project,
|
||||||
Executable_Obsolete := True;
|
Index => 0,
|
||||||
end if;
|
Sid => No_Source))
|
||||||
|
then
|
||||||
|
if Is_In_Obsoleted (Sfile) then
|
||||||
|
Executable_Obsolete := True;
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end if;
|
||||||
end if;
|
end;
|
||||||
end Check_Standard_Library;
|
end Check_Standard_Library;
|
||||||
|
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
|
|
|
@ -555,8 +555,8 @@ package body Pprint is
|
||||||
|
|
||||||
if not Is_Scalar_Type (Etype (Expr))
|
if not Is_Scalar_Type (Etype (Expr))
|
||||||
or else not Is_Scalar_Type (Etype (Expression (Expr)))
|
or else not Is_Scalar_Type (Etype (Expression (Expr)))
|
||||||
or else Is_Modular_Integer_Type (Etype (Expr))
|
or else Is_Modular_Integer_Type (Etype (Expr)) /=
|
||||||
/= Is_Modular_Integer_Type (Etype (Expression (Expr)))
|
Is_Modular_Integer_Type (Etype (Expression (Expr)))
|
||||||
then
|
then
|
||||||
return Expr_Name (Subtype_Mark (Expr)) &
|
return Expr_Name (Subtype_Mark (Expr)) &
|
||||||
"(" & Expr_Name (Expression (Expr)) & ")";
|
"(" & Expr_Name (Expression (Expr)) & ")";
|
||||||
|
|
|
@ -2614,10 +2614,15 @@ package body System.Regpat is
|
||||||
exit State_Machine when Input_Pos /= BOL_Pos;
|
exit State_Machine when Input_Pos /= BOL_Pos;
|
||||||
|
|
||||||
when EOL =>
|
when EOL =>
|
||||||
|
|
||||||
-- A combination of MEOL and SEOL
|
-- A combination of MEOL and SEOL
|
||||||
|
|
||||||
if (Self.Flags and Multiple_Lines) = 0 then
|
if (Self.Flags and Multiple_Lines) = 0 then
|
||||||
-- single line mode
|
|
||||||
|
-- Single line mode
|
||||||
|
|
||||||
exit State_Machine when Input_Pos <= Data'Last;
|
exit State_Machine when Input_Pos <= Data'Last;
|
||||||
|
|
||||||
elsif Input_Pos <= Last_In_Data then
|
elsif Input_Pos <= Last_In_Data then
|
||||||
exit State_Machine when Data (Input_Pos) /= ASCII.LF;
|
exit State_Machine when Data (Input_Pos) /= ASCII.LF;
|
||||||
else
|
else
|
||||||
|
@ -2632,9 +2637,11 @@ package body System.Regpat is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
when SEOL =>
|
when SEOL =>
|
||||||
-- If we have a character before Data'Last (even if
|
|
||||||
-- Last_In_Data stops before then), we can't have
|
-- If there is a character before Data'Last (even if
|
||||||
-- the end of the line.
|
-- Last_In_Data stops before then), we can't have the
|
||||||
|
-- end of the line.
|
||||||
|
|
||||||
exit State_Machine when Input_Pos <= Data'Last;
|
exit State_Machine when Input_Pos <= Data'Last;
|
||||||
|
|
||||||
when BOUND | NBOUND =>
|
when BOUND | NBOUND =>
|
||||||
|
|
|
@ -13721,10 +13721,10 @@ package body Sem_Ch13 is
|
||||||
declare
|
declare
|
||||||
T : UC_Entry renames Unchecked_Conversions.Table (N);
|
T : UC_Entry renames Unchecked_Conversions.Table (N);
|
||||||
|
|
||||||
|
Act_Unit : constant Entity_Id := T.Act_Unit;
|
||||||
Eloc : constant Source_Ptr := T.Eloc;
|
Eloc : constant Source_Ptr := T.Eloc;
|
||||||
Source : constant Entity_Id := T.Source;
|
Source : constant Entity_Id := T.Source;
|
||||||
Target : constant Entity_Id := T.Target;
|
Target : constant Entity_Id := T.Target;
|
||||||
Act_Unit : constant Entity_Id := T.Act_Unit;
|
|
||||||
|
|
||||||
Source_Siz : Uint;
|
Source_Siz : Uint;
|
||||||
Target_Siz : Uint;
|
Target_Siz : Uint;
|
||||||
|
|
|
@ -23304,6 +23304,82 @@ package body Sem_Prag is
|
||||||
(N : Node_Id;
|
(N : Node_Id;
|
||||||
Freeze_Id : Entity_Id := Empty)
|
Freeze_Id : Entity_Id := Empty)
|
||||||
is
|
is
|
||||||
|
Disp_Typ : Entity_Id;
|
||||||
|
-- The dispatching type of the subprogram subject to the pre- or
|
||||||
|
-- postcondition.
|
||||||
|
|
||||||
|
function Check_References (Nod : Node_Id) return Traverse_Result;
|
||||||
|
-- Check that expression Nod does not mention non-primitives of the
|
||||||
|
-- type, global objects of the type, or other illegalities described
|
||||||
|
-- and implied by AI12-0113.
|
||||||
|
|
||||||
|
----------------------
|
||||||
|
-- Check_References --
|
||||||
|
----------------------
|
||||||
|
|
||||||
|
function Check_References (Nod : Node_Id) return Traverse_Result is
|
||||||
|
begin
|
||||||
|
if Nkind (Nod) = N_Function_Call
|
||||||
|
and then Is_Entity_Name (Name (Nod))
|
||||||
|
then
|
||||||
|
declare
|
||||||
|
Func : constant Entity_Id := Entity (Name (Nod));
|
||||||
|
Form : Entity_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
-- An operation of the type must be a primitive
|
||||||
|
|
||||||
|
if No (Find_Dispatching_Type (Func)) then
|
||||||
|
Form := First_Formal (Func);
|
||||||
|
while Present (Form) loop
|
||||||
|
if Etype (Form) = Disp_Typ then
|
||||||
|
Error_Msg_NE
|
||||||
|
("operation in class-wide condition must be "
|
||||||
|
& "primitive of &", Nod, Disp_Typ);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next_Formal (Form);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
-- A return object of the type is illegal as well
|
||||||
|
|
||||||
|
if Etype (Func) = Disp_Typ
|
||||||
|
or else Etype (Func) = Class_Wide_Type (Disp_Typ)
|
||||||
|
then
|
||||||
|
Error_Msg_NE
|
||||||
|
("operation in class-wide condition must be primitive "
|
||||||
|
& "of &", Nod, Disp_Typ);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
|
|
||||||
|
elsif Is_Entity_Name (Nod)
|
||||||
|
and then
|
||||||
|
(Etype (Nod) = Disp_Typ
|
||||||
|
or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
|
||||||
|
and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
|
||||||
|
then
|
||||||
|
Error_Msg_NE
|
||||||
|
("object in class-wide condition must be formal of type &",
|
||||||
|
Nod, Disp_Typ);
|
||||||
|
|
||||||
|
elsif Nkind (Nod) = N_Explicit_Dereference
|
||||||
|
and then (Etype (Nod) = Disp_Typ
|
||||||
|
or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
|
||||||
|
and then (not Is_Entity_Name (Prefix (Nod))
|
||||||
|
or else not Is_Formal (Entity (Prefix (Nod))))
|
||||||
|
then
|
||||||
|
Error_Msg_NE
|
||||||
|
("operation in class-wide condition must be primitive of &",
|
||||||
|
Nod, Disp_Typ);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return OK;
|
||||||
|
end Check_References;
|
||||||
|
|
||||||
|
procedure Check_Class_Wide_Condition is
|
||||||
|
new Traverse_Proc (Check_References);
|
||||||
|
|
||||||
-- Local variables
|
-- Local variables
|
||||||
|
|
||||||
Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
|
Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
|
||||||
|
@ -23313,77 +23389,8 @@ package body Sem_Prag is
|
||||||
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
|
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
|
||||||
|
|
||||||
Errors : Nat;
|
Errors : Nat;
|
||||||
Disp_Typ : Entity_Id;
|
|
||||||
Restore_Scope : Boolean := False;
|
Restore_Scope : Boolean := False;
|
||||||
|
|
||||||
function Check_References (N : Node_Id) return Traverse_Result;
|
|
||||||
-- Check that the expression does not mention non-primitives of
|
|
||||||
-- the type, global objects of the type, or other illegalities
|
|
||||||
-- described and implied by AI12-0113.
|
|
||||||
|
|
||||||
----------------------
|
|
||||||
-- Check_References --
|
|
||||||
----------------------
|
|
||||||
|
|
||||||
function Check_References (N : Node_Id) return Traverse_Result is
|
|
||||||
begin
|
|
||||||
if Nkind (N) = N_Function_Call
|
|
||||||
and then Is_Entity_Name (Name (N))
|
|
||||||
then
|
|
||||||
declare
|
|
||||||
Func : constant Entity_Id := Entity (Name (N));
|
|
||||||
Form : Entity_Id;
|
|
||||||
begin
|
|
||||||
|
|
||||||
-- An operation of the type must be a primitive.
|
|
||||||
|
|
||||||
if No (Find_Dispatching_Type (Func)) then
|
|
||||||
Form := First_Formal (Func);
|
|
||||||
while Present (Form) loop
|
|
||||||
if Etype (Form) = Disp_Typ then
|
|
||||||
Error_Msg_NE ("operation in class-wide condition "
|
|
||||||
& "must be primitive of&", N, Disp_Typ);
|
|
||||||
end if;
|
|
||||||
Next_Formal (Form);
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
-- A return object of the type is illegal as well.
|
|
||||||
|
|
||||||
if Etype (Func) = Disp_Typ
|
|
||||||
or else Etype (Func) = Class_Wide_Type (Disp_Typ)
|
|
||||||
then
|
|
||||||
Error_Msg_NE ("operation in class-wide condition "
|
|
||||||
& "must be primitive of&", N, Disp_Typ);
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end;
|
|
||||||
|
|
||||||
elsif Is_Entity_Name (N)
|
|
||||||
and then
|
|
||||||
(Etype (N) = Disp_Typ
|
|
||||||
or else Etype (N) = Class_Wide_Type (Disp_Typ))
|
|
||||||
and then Ekind_In (Entity (N), E_Variable, E_Constant)
|
|
||||||
then
|
|
||||||
Error_Msg_NE
|
|
||||||
("object in class-wide condition must be formal of type&",
|
|
||||||
N, Disp_Typ);
|
|
||||||
|
|
||||||
elsif Nkind (N) = N_Explicit_Dereference
|
|
||||||
and then (Etype (N) = Disp_Typ
|
|
||||||
or else Etype (N) = Class_Wide_Type (Disp_Typ))
|
|
||||||
and then (not Is_Entity_Name (Prefix (N))
|
|
||||||
or else not Is_Formal (Entity (Prefix (N))))
|
|
||||||
then
|
|
||||||
Error_Msg_NE ("operation in class-wide condition "
|
|
||||||
& "must be primitive of&", N, Disp_Typ);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return OK;
|
|
||||||
end Check_References;
|
|
||||||
|
|
||||||
procedure Check_Class_Wide_Condition is new
|
|
||||||
Traverse_Proc (Check_References);
|
|
||||||
|
|
||||||
-- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
|
-- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -23451,9 +23458,9 @@ package body Sem_Prag is
|
||||||
& "of a tagged type", N);
|
& "of a tagged type", N);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
else
|
-- Remaining semantic checks require a full tree traversal
|
||||||
-- Remaining semantic checks require a full tree traversal.
|
|
||||||
|
|
||||||
|
else
|
||||||
Check_Class_Wide_Condition (Expr);
|
Check_Class_Wide_Condition (Expr);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -26490,8 +26497,8 @@ package body Sem_Prag is
|
||||||
-- overridings between them.
|
-- overridings between them.
|
||||||
|
|
||||||
while Present (Decl) loop
|
while Present (Decl) loop
|
||||||
if Nkind_In (Decl,
|
if Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
|
||||||
N_Subprogram_Declaration, N_Abstract_Subprogram_Declaration)
|
N_Subprogram_Declaration)
|
||||||
then
|
then
|
||||||
Prim := Defining_Entity (Decl);
|
Prim := Defining_Entity (Decl);
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue