[multiple changes]
2004-03-18 Arnaud Charlet <charlet@act-europe.fr> * 5atpopsp.adb: Remove RTEMS from list of platforms using this file. Code clean up: * 5ataprop.adb, 5ftaprop.adb, 5htaprop.adb, 5itaprop.adb, 5staprop.adb, 5vtaprop.adb, 5wtaprop.adb, 7staprop.adb (Finalize_TCB): Use Specific.Set instead of direct call to e.g pthread_setspecific. 2004-03-18 Thomas Quinot <quinot@act-europe.fr> * adaint.c: Update comments. * Makefile.in: set PREFIX_OBJS, SYMLIB, THREADSLIB, and GNATLIB_SHARED for FreeBSD. 2004-03-18 Jose Ruiz <ruiz@act-europe.fr> * init.c [VxWorks]: Do not fix the stack size for the environment task. When needed (stack checking) the stack size is retrieved from the VxWorks kernel. * Makefile.in: Flag -nostdinc is required when building the run time for avoiding looking for files in the base compiler. Add the VxWorks specific version of the package body for System.Stack_checking.Operations (5zstchop.adb). * Make-lang.in: Add the object file for System.Stack_Checking.Operations. * Makefile.rtl: Add object file for the package System.Stack_Checking.Operations. * s-stchop.ads, s-stchop.adb, 5zstchop.adb: New files. * s-stache.ads, s-stache.adb: Move the operations related to stack checking from this package to package System.Stack_Checking.Operations. This way, stack checking operations are only linked in the final executable when using the -fstack-check flag. 2004-03-18 Doug Rupp <rupp@gnat.com> * Makefile.in [VMS]: Handle 64 bit specs (5qsystem.ads, 5xcrtl.ads). Reorganize ifeq's. * 5qsystem.ads, 5xcrtl.ads: New files. 2004-03-18 Vincent Celier <celier@gnat.com> * prj.adb (Reset): Reset hash table Files_Htable * prj-env.adb (Source_Paths, Object_Paths): New tables. (Add_To_Source_Path, Add_To_Object_Path): New procedures, to replace the procedures Add_To_Path_File. (Set_Ada_Paths): Accumulate source and object dirs in the tables, making sure that each directory is present only once and, for object dirs, when a directory already present is added, the duplicate is removed and the directory is always put as the last in the table. Write the path files at the end of these accumulations. * prj-nmsc.adb (Record_Source): Add source file name in hash table Files_Htable for all sources. * prj-proc.adb (Process): Remove restrictions between not directly related extending projects. 2004-03-18 Emmanuel Briot <briot@act-europe.fr> * prj-nmsc.ads, prj-nmsc.adb (Ada_Check): New parameter Trusted_Mode. (Find_Sources): Minor speed optimization. * prj-proc.ads, prj-proc.adb (Check, Recursive_Check, Process): New parameter Trusted_Mode. 2004-03-18 Sergey Rybin <rybin@act-europe.fr> * scn.adb (Determine_License): Take into account a degenerated case when the source contains only comments. 2004-03-18 Ed Schonberg <schonberg@gnat.com> * sem_warn.adb (Check_References): For a warning on a selected component that does not come from source, locate an uninitialized component of the record type to produce a more precise error message. From-SVN: r79623
This commit is contained in:
Arnaud Charlet
parent
214ee4a2c6
commit
a336eacaf1
|
|
@ -921,8 +921,8 @@ package body System.Task_Primitives.Operations is
|
|||
------------------
|
||||
|
||||
procedure Finalize_TCB (T : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Is_Self : constant Boolean := T = Self;
|
||||
|
||||
procedure Free is new
|
||||
|
|
@ -944,10 +944,8 @@ package body System.Task_Primitives.Operations is
|
|||
Free (Tmp);
|
||||
|
||||
if Is_Self then
|
||||
Result := pthread_setspecific (ATCB_Key, System.Null_Address);
|
||||
pragma Assert (Result = 0);
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
|
||||
end Finalize_TCB;
|
||||
|
||||
---------------
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@
|
|||
-- This is a POSIX version of this package where foreign threads are
|
||||
-- recognized.
|
||||
|
||||
-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread,
|
||||
-- GNU/Linux threads, and RTEMS use this version.
|
||||
-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and
|
||||
-- GNU/Linux threads use this version.
|
||||
|
||||
separate (System.Task_Primitives.Operations)
|
||||
package body Specific is
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2004, Free Software Foundation, 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- --
|
||||
|
|
@ -916,8 +916,8 @@ package body System.Task_Primitives.Operations is
|
|||
------------------
|
||||
|
||||
procedure Finalize_TCB (T : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Is_Self : constant Boolean := T = Self;
|
||||
|
||||
procedure Free is new
|
||||
|
|
@ -939,10 +939,8 @@ package body System.Task_Primitives.Operations is
|
|||
Free (Tmp);
|
||||
|
||||
if Is_Self then
|
||||
Result := pthread_setspecific (ATCB_Key, System.Null_Address);
|
||||
pragma Assert (Result = 0);
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
|
||||
end Finalize_TCB;
|
||||
|
||||
---------------
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2004, Free Software Foundation, 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- --
|
||||
|
|
@ -862,8 +862,8 @@ package body System.Task_Primitives.Operations is
|
|||
------------------
|
||||
|
||||
procedure Finalize_TCB (T : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Is_Self : constant Boolean := T = Self;
|
||||
|
||||
procedure Free is new
|
||||
|
|
@ -885,10 +885,8 @@ package body System.Task_Primitives.Operations is
|
|||
Free (Tmp);
|
||||
|
||||
if Is_Self then
|
||||
Result := pthread_setspecific (ATCB_Key, System.Null_Address);
|
||||
pragma Assert (Result = 0);
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
|
||||
end Finalize_TCB;
|
||||
|
||||
---------------
|
||||
|
|
|
|||
|
|
@ -891,8 +891,8 @@ package body System.Task_Primitives.Operations is
|
|||
------------------
|
||||
|
||||
procedure Finalize_TCB (T : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Is_Self : constant Boolean := T = Self;
|
||||
|
||||
procedure Free is new
|
||||
|
|
@ -914,10 +914,8 @@ package body System.Task_Primitives.Operations is
|
|||
Free (Tmp);
|
||||
|
||||
if Is_Self then
|
||||
Result := pthread_setspecific (ATCB_Key, System.Null_Address);
|
||||
pragma Assert (Result = 0);
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
|
||||
end Finalize_TCB;
|
||||
|
||||
---------------
|
||||
|
|
|
|||
|
|
@ -0,0 +1,236 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (OpenVMS 64bit GCC_ZCX DEC Threads Version) --
|
||||
-- --
|
||||
-- Copyright (C) 2004 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. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package System is
|
||||
pragma Pure (System);
|
||||
-- Note that we take advantage of the implementation permission to
|
||||
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
|
||||
|
||||
type Name is (SYSTEM_NAME_GNAT);
|
||||
System_Name : constant Name := SYSTEM_NAME_GNAT;
|
||||
|
||||
-- System-Dependent Named Numbers
|
||||
|
||||
Min_Int : constant := Long_Long_Integer'First;
|
||||
Max_Int : constant := Long_Long_Integer'Last;
|
||||
|
||||
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
|
||||
Max_Nonbinary_Modulus : constant := Integer'Last;
|
||||
|
||||
Max_Base_Digits : constant := Long_Long_Float'Digits;
|
||||
Max_Digits : constant := Long_Long_Float'Digits;
|
||||
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := 0.01;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 64;
|
||||
Memory_Size : constant := 2 ** 64;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
function "<" (Left, Right : Address) return Boolean;
|
||||
function "<=" (Left, Right : Address) return Boolean;
|
||||
function ">" (Left, Right : Address) return Boolean;
|
||||
function ">=" (Left, Right : Address) return Boolean;
|
||||
function "=" (Left, Right : Address) return Boolean;
|
||||
|
||||
pragma Import (Intrinsic, "<");
|
||||
pragma Import (Intrinsic, "<=");
|
||||
pragma Import (Intrinsic, ">");
|
||||
pragma Import (Intrinsic, ">=");
|
||||
pragma Import (Intrinsic, "=");
|
||||
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order := Low_Order_First;
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer range 0 .. 31;
|
||||
subtype Priority is Any_Priority range 0 .. 30;
|
||||
subtype Interrupt_Priority is Any_Priority range 31 .. 31;
|
||||
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
type Address is mod Memory_Size;
|
||||
Null_Address : constant Address := 0;
|
||||
|
||||
--------------------------------------
|
||||
-- System Implementation Parameters --
|
||||
--------------------------------------
|
||||
|
||||
-- These parameters provide information about the target that is used
|
||||
-- by the compiler. They are in the private part of System, where they
|
||||
-- can be accessed using the special circuitry in the Targparm unit
|
||||
-- whose source should be consulted for more detailed descriptions
|
||||
-- of the individual switch values.
|
||||
|
||||
AAMP : constant Boolean := False;
|
||||
Backend_Divide_Checks : constant Boolean := False;
|
||||
Backend_Overflow_Checks : constant Boolean := False;
|
||||
Command_Line_Args : constant Boolean := True;
|
||||
Configurable_Run_Time : constant Boolean := False;
|
||||
Denorm : constant Boolean := False;
|
||||
Duration_32_Bits : constant Boolean := False;
|
||||
Exit_Status_Supported : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Machine_Overflows : constant Boolean := False;
|
||||
Machine_Rounds : constant Boolean := True;
|
||||
OpenVMS : constant Boolean := True;
|
||||
Signed_Zeros : constant Boolean := True;
|
||||
Stack_Check_Default : constant Boolean := True;
|
||||
Stack_Check_Probes : constant Boolean := True;
|
||||
Support_64_Bit_Divides : constant Boolean := True;
|
||||
Support_Aggregates : constant Boolean := True;
|
||||
Support_Composite_Assign : constant Boolean := True;
|
||||
Support_Composite_Compare : constant Boolean := True;
|
||||
Support_Long_Shifts : constant Boolean := True;
|
||||
Suppress_Standard_Library : constant Boolean := False;
|
||||
Use_Ada_Main_Program_Name : constant Boolean := False;
|
||||
ZCX_By_Default : constant Boolean := True;
|
||||
GCC_ZCX_Support : constant Boolean := True;
|
||||
Front_End_ZCX_Support : constant Boolean := False;
|
||||
|
||||
-- Obsolete entries, to be removed eventually (bootstrap issues!)
|
||||
|
||||
High_Integrity_Mode : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := False;
|
||||
|
||||
--------------------------
|
||||
-- Underlying Priorities --
|
||||
---------------------------
|
||||
|
||||
-- Important note: this section of the file must come AFTER the
|
||||
-- definition of the system implementation parameters to ensure
|
||||
-- that the value of these parameters is available for analysis
|
||||
-- of the declarations here (using Rtsfind at compile time).
|
||||
|
||||
-- The underlying priorities table provides a generalized mechanism
|
||||
-- for mapping from Ada priorities to system priorities. In some
|
||||
-- cases a 1-1 mapping is not the convenient or optimal choice.
|
||||
|
||||
-- For DEC Threads OpenVMS, we use the full range of 31 priorities
|
||||
-- in the Ada model, but map them by compression onto the more limited
|
||||
-- range of priorities available in OpenVMS.
|
||||
|
||||
-- To replace the default values of the Underlying_Priorities mapping,
|
||||
-- copy this source file into your build directory, edit the file to
|
||||
-- reflect your desired behavior, and recompile with the command:
|
||||
|
||||
-- $ gcc -c -O3 -gnatpgn system.ads
|
||||
|
||||
-- then recompile the run-time parts that depend on this package:
|
||||
|
||||
-- $ gnatmake -a -gnatn -O3 <your application>
|
||||
|
||||
-- then force rebuilding your application if you need different options:
|
||||
|
||||
-- $ gnatmake -f <your options> <your application>
|
||||
|
||||
type Priorities_Mapping is array (Any_Priority) of Integer;
|
||||
pragma Suppress_Initialization (Priorities_Mapping);
|
||||
-- Suppress initialization in case gnat.adc specifies Normalize_Scalars
|
||||
|
||||
Underlying_Priorities : constant Priorities_Mapping :=
|
||||
|
||||
(Priority'First => 16,
|
||||
|
||||
1 => 17,
|
||||
2 => 18,
|
||||
3 => 18,
|
||||
4 => 18,
|
||||
5 => 18,
|
||||
6 => 19,
|
||||
7 => 19,
|
||||
8 => 19,
|
||||
9 => 20,
|
||||
10 => 20,
|
||||
11 => 21,
|
||||
12 => 21,
|
||||
13 => 22,
|
||||
14 => 23,
|
||||
|
||||
Default_Priority => 24,
|
||||
|
||||
16 => 25,
|
||||
17 => 25,
|
||||
18 => 25,
|
||||
19 => 26,
|
||||
20 => 26,
|
||||
21 => 26,
|
||||
22 => 27,
|
||||
23 => 27,
|
||||
24 => 27,
|
||||
25 => 28,
|
||||
26 => 28,
|
||||
27 => 29,
|
||||
28 => 29,
|
||||
29 => 30,
|
||||
|
||||
Priority'Last => 30,
|
||||
|
||||
Interrupt_Priority => 31);
|
||||
|
||||
----------------------------
|
||||
-- Special VMS Interfaces --
|
||||
----------------------------
|
||||
|
||||
procedure Lib_Stop (I : in Integer);
|
||||
pragma Interface (C, Lib_Stop);
|
||||
pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
|
||||
-- Interface to VMS condition handling. Used by RTSfind and pragma
|
||||
-- {Import,Export}_Exception. Put here because this is the only
|
||||
-- VMS specific package that doesn't drag in tasking.
|
||||
|
||||
end System;
|
||||
|
|
@ -882,7 +882,6 @@ package body System.Task_Primitives.Operations is
|
|||
-----------------------------
|
||||
|
||||
function Register_Foreign_Thread return Task_ID is
|
||||
|
||||
begin
|
||||
if Is_Valid_Task then
|
||||
return Self;
|
||||
|
|
@ -1037,7 +1036,6 @@ package body System.Task_Primitives.Operations is
|
|||
if Is_Self then
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
|
||||
end Finalize_TCB;
|
||||
|
||||
---------------
|
||||
|
|
|
|||
|
|
@ -879,8 +879,7 @@ package body System.Task_Primitives.Operations is
|
|||
Free (Tmp);
|
||||
|
||||
if Is_Self then
|
||||
Result := pthread_setspecific (ATCB_Key, System.Null_Address);
|
||||
pragma Assert (Result = 0);
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
end Finalize_TCB;
|
||||
|
||||
|
|
|
|||
|
|
@ -913,7 +913,7 @@ package body System.Task_Primitives.Operations is
|
|||
Self_ID : Task_ID := T;
|
||||
Result : DWORD;
|
||||
Succeeded : BOOL;
|
||||
Is_Self : constant Boolean := T = Self;
|
||||
Is_Self : constant Boolean := T = Self;
|
||||
|
||||
procedure Free is new
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
|
@ -943,8 +943,7 @@ package body System.Task_Primitives.Operations is
|
|||
Free (Self_ID);
|
||||
|
||||
if Is_Self then
|
||||
Succeeded := TlsSetValue (TlsIndex, System.Null_Address);
|
||||
pragma Assert (Succeeded = True);
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
end Finalize_TCB;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,159 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . C R T L --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 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. --
|
||||
-- --
|
||||
-- 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. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides the low level interface to the C Run Time Library
|
||||
-- on 64 bit VMS
|
||||
|
||||
with System.Parameters;
|
||||
package System.CRTL is
|
||||
pragma Preelaborate (CRTL);
|
||||
|
||||
subtype chars is System.Address;
|
||||
-- Pointer to null-terminated array of characters
|
||||
|
||||
subtype FILEs is System.Address;
|
||||
-- Corresponds to the C type FILE*
|
||||
|
||||
subtype int is Integer;
|
||||
|
||||
type long is range -(2 ** (System.Parameters.long_bits - 1))
|
||||
.. +(2 ** (System.Parameters.long_bits - 1)) - 1;
|
||||
|
||||
subtype off_t is Integer;
|
||||
|
||||
type size_t is mod 2 ** Standard'Address_Size;
|
||||
|
||||
function atoi (A : System.Address) return Integer;
|
||||
pragma Import (C, atoi, "decc$atoi");
|
||||
|
||||
procedure clearerr (stream : FILEs);
|
||||
pragma Import (C, clearerr, "decc$clearerr");
|
||||
|
||||
function fclose (stream : FILEs) return int;
|
||||
pragma Import (C, fclose, "decc$fclose");
|
||||
|
||||
function fdopen (handle : int; mode : chars) return FILEs;
|
||||
pragma Import (C, fdopen, "decc$fdopen");
|
||||
|
||||
function fflush (stream : FILEs) return int;
|
||||
pragma Import (C, fflush, "decc$fflush");
|
||||
|
||||
function fgetc (stream : FILEs) return int;
|
||||
pragma Import (C, fgetc, "decc$fgetc");
|
||||
|
||||
function fgets (strng : chars; n : int; stream : FILEs) return chars;
|
||||
pragma Import (C, fgets, "decc$fgets");
|
||||
|
||||
function fopen (filename : chars; Mode : chars) return FILEs;
|
||||
pragma Import (C, fopen, "decc$fopen");
|
||||
|
||||
function fputc (C : int; stream : FILEs) return int;
|
||||
pragma Import (C, fputc, "decc$fputc");
|
||||
|
||||
function fputs (Strng : chars; Stream : FILEs) return int;
|
||||
pragma Import (C, fputs, "decc$fputs");
|
||||
|
||||
procedure free (Ptr : System.Address);
|
||||
pragma Import (C, free, "decc$free");
|
||||
|
||||
function freopen
|
||||
(filename : chars;
|
||||
mode : chars;
|
||||
stream : FILEs)
|
||||
return FILEs;
|
||||
pragma Import (C, freopen, "decc$freopen");
|
||||
|
||||
function fseek
|
||||
(stream : FILEs;
|
||||
offset : long;
|
||||
origin : int)
|
||||
return int;
|
||||
pragma Import (C, fseek, "decc$fseek");
|
||||
|
||||
function ftell (stream : FILEs) return long;
|
||||
pragma Import (C, ftell, "decc$ftell");
|
||||
|
||||
function getenv (S : String) return System.Address;
|
||||
pragma Import (C, getenv, "decc$getenv");
|
||||
|
||||
function isatty (handle : int) return int;
|
||||
pragma Import (C, isatty, "decc$isatty");
|
||||
|
||||
function lseek (fd : int; offset : off_t; direction : int) return off_t;
|
||||
pragma Import (C, lseek, "decc$lseek");
|
||||
|
||||
function malloc (Size : size_t) return System.Address;
|
||||
pragma Import (C, malloc, "decc$_malloc64");
|
||||
|
||||
procedure memcpy (S1 : System.Address; S2 : System.Address; N : size_t);
|
||||
pragma Import (C, memcpy, "decc$_memcpy64");
|
||||
|
||||
procedure memmove (S1 : System.Address; S2 : System.Address; N : size_t);
|
||||
pragma Import (C, memmove, "decc$_memmove64");
|
||||
|
||||
procedure mktemp (template : chars);
|
||||
pragma Import (C, mktemp, "decc$_mktemp64");
|
||||
|
||||
function read (fd : int; buffer : chars; nbytes : int) return int;
|
||||
pragma Import (C, read, "decc$read");
|
||||
|
||||
function realloc
|
||||
(Ptr : System.Address; Size : size_t) return System.Address;
|
||||
pragma Import (C, realloc, "decc$_realloc64");
|
||||
|
||||
procedure rewind (stream : FILEs);
|
||||
pragma Import (C, rewind, "decc$rewind");
|
||||
|
||||
function setvbuf
|
||||
(stream : FILEs;
|
||||
buffer : chars;
|
||||
mode : int;
|
||||
size : size_t)
|
||||
return int;
|
||||
pragma Import (C, setvbuf, "decc$setvbuf");
|
||||
|
||||
procedure tmpnam (string : chars);
|
||||
pragma Import (C, tmpnam, "decc$_tmpnam64");
|
||||
|
||||
function tmpfile return FILEs;
|
||||
pragma Import (C, tmpfile, "decc$tmpfile");
|
||||
|
||||
function ungetc (c : int; stream : FILEs) return int;
|
||||
pragma Import (C, ungetc, "decc$ungetc");
|
||||
|
||||
function unlink (filename : chars) return int;
|
||||
pragma Import (C, unlink, "decc$unlink");
|
||||
|
||||
function write (fd : int; buffer : chars; nbytes : int) return int;
|
||||
pragma Import (C, write, "decc$write");
|
||||
end System.CRTL;
|
||||
|
|
@ -0,0 +1,255 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2004 Free Software Foundation, 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. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the VxWorks version of this package.
|
||||
-- This file should be kept synchronized with the general implementation
|
||||
-- provided by s-stchop.adb.
|
||||
|
||||
pragma Restrictions (No_Elaboration_Code);
|
||||
-- We want to guarantee the absence of elaboration code because the
|
||||
-- binder does not handle references to this package.
|
||||
|
||||
with Ada.Exceptions;
|
||||
|
||||
with System.Storage_Elements; use System.Storage_Elements;
|
||||
with System.Parameters; use System.Parameters;
|
||||
with System.Soft_Links;
|
||||
with Interfaces.C;
|
||||
with System.OS_Interface;
|
||||
|
||||
package body System.Stack_Checking.Operations is
|
||||
|
||||
-- In order to have stack checking working appropriately on
|
||||
-- VxWorks we need to extract the stack size information from the
|
||||
-- VxWorks kernel itself. It means that the library for showing
|
||||
-- task-related information needs to be linked into the VxWorks
|
||||
-- system, when using stack checking. The TaskShow library can be
|
||||
-- linked into the VxWorks system by either:
|
||||
-- * defining INCLUDE_SHOW_ROUTINES in config.h when using
|
||||
-- configuration header files, or
|
||||
-- * selecting INCLUDE_TASK_SHOW when using the Tornado project
|
||||
-- facility.
|
||||
|
||||
function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
|
||||
|
||||
-- The function Set_Stack_Info is the actual function that updates
|
||||
-- the cache containing a pointer to the Stack_Info. It may also
|
||||
-- be used for detecting asynchronous abort in combination with
|
||||
-- Invalidate_Self_Cache.
|
||||
|
||||
-- Set_Stack_Info should do the following things in order:
|
||||
-- 1) Get the Stack_Access value for the current task
|
||||
-- 2) Set Stack.all to the value obtained in 1)
|
||||
-- 3) Optionally Poll to check for asynchronous abort
|
||||
|
||||
-- This order is important because if at any time a write to
|
||||
-- the stack cache is pending, that write should be followed
|
||||
-- by a Poll to prevent loosing signals.
|
||||
|
||||
-- Note: This function must be compiled with Polling turned off
|
||||
|
||||
-- Note: on systems like VxWorks and OS/2 with real thread-local storage,
|
||||
-- Set_Stack_Info should return an access value for such local
|
||||
-- storage. In those cases the cache will always be up-to-date.
|
||||
|
||||
-- The following constants should be imported from some system-specific
|
||||
-- constants package. The constants must be static for performance reasons.
|
||||
|
||||
----------------------------
|
||||
-- Invalidate_Stack_Cache --
|
||||
----------------------------
|
||||
|
||||
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
|
||||
pragma Warnings (Off, Any_Stack);
|
||||
begin
|
||||
Cache := Null_Stack;
|
||||
end Invalidate_Stack_Cache;
|
||||
|
||||
--------------------
|
||||
-- Set_Stack_Info --
|
||||
--------------------
|
||||
|
||||
function Set_Stack_Info
|
||||
(Stack : access Stack_Access) return Stack_Access
|
||||
is
|
||||
|
||||
-- Task descriptor that is handled internally by the VxWorks kernel
|
||||
type Task_Descriptor is record
|
||||
T_Id : Interfaces.C.int; -- task identifier
|
||||
Td_Name : System.Address; -- task name
|
||||
Td_Priority : Interfaces.C.int; -- task priority
|
||||
Td_Status : Interfaces.C.int; -- task status
|
||||
Td_Options : Interfaces.C.int; -- task option bits (see below)
|
||||
Td_Entry : System.Address; -- original entry point of task
|
||||
Td_Sp : System.Address; -- saved stack pointer
|
||||
Td_PStackBase : System.Address; -- the bottom of the stack
|
||||
Td_PStackLimit : System.Address; -- the effective end of the stack
|
||||
Td_PStackEnd : System.Address; -- the actual end of the stack
|
||||
Td_StackSize : Interfaces.C.int; -- size of stack in bytes
|
||||
Td_StackCurrent : Interfaces.C.int; -- current stack usage in bytes
|
||||
Td_StackHigh : Interfaces.C.int; -- maximum stack usage in bytes
|
||||
Td_StackMargin : Interfaces.C.int; -- current stack margin in bytes
|
||||
Td_ErrorStatus : Interfaces.C.int; -- most recent task error status
|
||||
Td_Delay : Interfaces.C.int; -- delay/timeout ticks
|
||||
end record;
|
||||
|
||||
-- This VxWorks procedure fills in a specified task descriptor
|
||||
-- for a specified task.
|
||||
procedure TaskInfoGet (T_Id : System.OS_Interface.t_id;
|
||||
Task_Desc : access Task_Descriptor);
|
||||
pragma Import (C, TaskInfoGet, "taskInfoGet");
|
||||
|
||||
My_Stack : Stack_Access;
|
||||
Task_Desc : aliased Task_Descriptor;
|
||||
|
||||
begin
|
||||
-- The order of steps 1 .. 3 is important, see specification.
|
||||
|
||||
-- 1) Get the Stack_Access value for the current task
|
||||
|
||||
My_Stack := Soft_Links.Get_Stack_Info.all;
|
||||
|
||||
if My_Stack.Base = Null_Address then
|
||||
|
||||
-- First invocation. Ask the VxWorks kernel about stack
|
||||
-- values.
|
||||
TaskInfoGet (System.OS_Interface.taskIdSelf, Task_Desc'Access);
|
||||
|
||||
My_Stack.Size := System.Storage_Elements.Storage_Offset
|
||||
(Task_Desc.Td_StackSize);
|
||||
My_Stack.Base := Task_Desc.Td_PStackBase;
|
||||
My_Stack.Limit := Task_Desc.Td_PStackLimit;
|
||||
|
||||
end if;
|
||||
|
||||
-- 2) Set Stack.all to the value obtained in 1)
|
||||
|
||||
Stack.all := My_Stack;
|
||||
|
||||
-- 3) Optionally Poll to check for asynchronous abort
|
||||
|
||||
if Soft_Links.Check_Abort_Status.all /= 0 then
|
||||
raise Standard'Abort_Signal;
|
||||
end if;
|
||||
|
||||
return My_Stack; -- Never trust the cached value, but return local copy!
|
||||
end Set_Stack_Info;
|
||||
|
||||
--------------------
|
||||
-- Set_Stack_Size --
|
||||
--------------------
|
||||
|
||||
-- Specify the stack size for the current frame.
|
||||
|
||||
procedure Set_Stack_Size
|
||||
(Stack_Size : System.Storage_Elements.Storage_Offset)
|
||||
is
|
||||
My_Stack : Stack_Access;
|
||||
Frame_Address : constant System.Address := My_Stack'Address;
|
||||
|
||||
begin
|
||||
My_Stack := Stack_Check (Frame_Address);
|
||||
|
||||
if Stack_Grows_Down then
|
||||
My_Stack.Limit := My_Stack.Base - Stack_Size;
|
||||
else
|
||||
My_Stack.Limit := My_Stack.Base + Stack_Size;
|
||||
end if;
|
||||
end Set_Stack_Size;
|
||||
|
||||
-----------------
|
||||
-- Stack_Check --
|
||||
-----------------
|
||||
|
||||
function Stack_Check
|
||||
(Stack_Address : System.Address) return Stack_Access
|
||||
is
|
||||
type Frame_Marker is null record;
|
||||
Marker : Frame_Marker;
|
||||
Cached_Stack : constant Stack_Access := Cache;
|
||||
Frame_Address : constant System.Address := Marker'Address;
|
||||
|
||||
begin
|
||||
-- This function first does a "cheap" check which is correct
|
||||
-- if it succeeds. In case of failure, the full check is done.
|
||||
-- Ideally the cheap check should be done in an optimized manner,
|
||||
-- or be inlined.
|
||||
|
||||
if (Stack_Grows_Down and then
|
||||
(Frame_Address <= Cached_Stack.Base
|
||||
and
|
||||
Stack_Address > Cached_Stack.Limit))
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
(Frame_Address >= Cached_Stack.Base
|
||||
and
|
||||
Stack_Address < Cached_Stack.Limit))
|
||||
then
|
||||
-- Cached_Stack is valid as it passed the stack check
|
||||
return Cached_Stack;
|
||||
end if;
|
||||
|
||||
Full_Check :
|
||||
declare
|
||||
My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
|
||||
-- At this point Stack.all might already be invalid, so
|
||||
-- it is essential to use our local copy of Stack!
|
||||
|
||||
begin
|
||||
if (Stack_Grows_Down and then
|
||||
Stack_Address < My_Stack.Limit)
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
Stack_Address > My_Stack.Limit)
|
||||
then
|
||||
Ada.Exceptions.Raise_Exception
|
||||
(E => Storage_Error'Identity,
|
||||
Message => "stack overflow detected");
|
||||
end if;
|
||||
|
||||
return My_Stack;
|
||||
end Full_Check;
|
||||
end Stack_Check;
|
||||
|
||||
------------------------
|
||||
-- Update_Stack_Cache --
|
||||
------------------------
|
||||
|
||||
procedure Update_Stack_Cache (Stack : Stack_Access) is
|
||||
begin
|
||||
if not Multi_Processor then
|
||||
Cache := Stack;
|
||||
end if;
|
||||
end Update_Stack_Cache;
|
||||
|
||||
end System.Stack_Checking.Operations;
|
||||
|
|
@ -995,8 +995,8 @@ package body System.Task_Primitives.Operations is
|
|||
------------------
|
||||
|
||||
procedure Finalize_TCB (T : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Result : Interfaces.C.int;
|
||||
Tmp : Task_ID := T;
|
||||
Is_Self : constant Boolean := T = Self;
|
||||
|
||||
procedure Free is new
|
||||
|
|
@ -1018,10 +1018,8 @@ package body System.Task_Primitives.Operations is
|
|||
Free (Tmp);
|
||||
|
||||
if Is_Self then
|
||||
Result := pthread_setspecific (ATCB_Key, System.Null_Address);
|
||||
pragma Assert (Result = 0);
|
||||
Specific.Set (null);
|
||||
end if;
|
||||
|
||||
end Finalize_TCB;
|
||||
|
||||
---------------
|
||||
|
|
|
|||
|
|
@ -1,3 +1,88 @@
|
|||
2004-03-18 Arnaud Charlet <charlet@act-europe.fr>
|
||||
|
||||
* 5atpopsp.adb: Remove RTEMS from list of platforms using this file.
|
||||
|
||||
Code clean up:
|
||||
* 5ataprop.adb, 5ftaprop.adb, 5htaprop.adb, 5itaprop.adb, 5staprop.adb,
|
||||
5vtaprop.adb, 5wtaprop.adb, 7staprop.adb (Finalize_TCB): Use
|
||||
Specific.Set instead of direct call to e.g pthread_setspecific.
|
||||
|
||||
2004-03-18 Thomas Quinot <quinot@act-europe.fr>
|
||||
|
||||
* adaint.c: Update comments.
|
||||
|
||||
* Makefile.in: set PREFIX_OBJS, SYMLIB, THREADSLIB, and
|
||||
GNATLIB_SHARED for FreeBSD.
|
||||
|
||||
2004-03-18 Jose Ruiz <ruiz@act-europe.fr>
|
||||
|
||||
* init.c [VxWorks]: Do not fix the stack size for the environment task.
|
||||
When needed (stack checking) the stack size is retrieved
|
||||
from the VxWorks kernel.
|
||||
|
||||
* Makefile.in: Flag -nostdinc is required when building the run time
|
||||
for avoiding looking for files in the base compiler.
|
||||
Add the VxWorks specific version of the package body for
|
||||
System.Stack_checking.Operations (5zstchop.adb).
|
||||
|
||||
* Make-lang.in: Add the object file for
|
||||
System.Stack_Checking.Operations.
|
||||
|
||||
* Makefile.rtl: Add object file for the package
|
||||
System.Stack_Checking.Operations.
|
||||
|
||||
* s-stchop.ads, s-stchop.adb, 5zstchop.adb: New files.
|
||||
|
||||
* s-stache.ads, s-stache.adb: Move the operations related to stack
|
||||
checking from this package to package System.Stack_Checking.Operations.
|
||||
This way, stack checking operations are only linked in the final
|
||||
executable when using the -fstack-check flag.
|
||||
|
||||
2004-03-18 Doug Rupp <rupp@gnat.com>
|
||||
|
||||
* Makefile.in [VMS]: Handle 64 bit specs (5qsystem.ads, 5xcrtl.ads).
|
||||
Reorganize ifeq's.
|
||||
|
||||
* 5qsystem.ads, 5xcrtl.ads: New files.
|
||||
|
||||
2004-03-18 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* prj.adb (Reset): Reset hash table Files_Htable
|
||||
|
||||
* prj-env.adb (Source_Paths, Object_Paths): New tables.
|
||||
(Add_To_Source_Path, Add_To_Object_Path): New procedures, to replace
|
||||
the procedures Add_To_Path_File.
|
||||
(Set_Ada_Paths): Accumulate source and object dirs in the tables,
|
||||
making sure that each directory is present only once and, for object
|
||||
dirs, when a directory already present is added, the duplicate is
|
||||
removed and the directory is always put as the last in the table.
|
||||
Write the path files at the end of these accumulations.
|
||||
|
||||
* prj-nmsc.adb (Record_Source): Add source file name in hash table
|
||||
Files_Htable for all sources.
|
||||
|
||||
* prj-proc.adb (Process): Remove restrictions between not directly
|
||||
related extending projects.
|
||||
|
||||
2004-03-18 Emmanuel Briot <briot@act-europe.fr>
|
||||
|
||||
* prj-nmsc.ads, prj-nmsc.adb (Ada_Check): New parameter Trusted_Mode.
|
||||
(Find_Sources): Minor speed optimization.
|
||||
|
||||
* prj-proc.ads, prj-proc.adb (Check, Recursive_Check, Process): New
|
||||
parameter Trusted_Mode.
|
||||
|
||||
2004-03-18 Sergey Rybin <rybin@act-europe.fr>
|
||||
|
||||
* scn.adb (Determine_License): Take into account a degenerated case
|
||||
when the source contains only comments.
|
||||
|
||||
2004-03-18 Ed Schonberg <schonberg@gnat.com>
|
||||
|
||||
* sem_warn.adb (Check_References): For a warning on a selected
|
||||
component that does not come from source, locate an uninitialized
|
||||
component of the record type to produce a more precise error message.
|
||||
|
||||
2004-03-15 Jerome Guitton <guitton@act-europe.fr>
|
||||
|
||||
* 3zsoccon.ads: Fix multicast options.
|
||||
|
|
|
|||
|
|
@ -2795,7 +2795,7 @@ ada/s-sopco5.o : ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \
|
|||
|
||||
ada/s-stache.o : ada/ada.ads ada/a-except.ads ada/system.ads \
|
||||
ada/s-crtl.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \
|
||||
ada/s-stache.adb ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
|
||||
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
|
||||
ada/s-traent.ads ada/unchconv.ads
|
||||
|
||||
ada/s-stalib.o : ada/ada.ads ada/a-except.ads ada/system.ads \
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ ADA_CFLAGS =
|
|||
ADAFLAGS = -W -Wall -gnatpg -gnata
|
||||
SOME_ADAFLAGS =-gnata
|
||||
FORCE_DEBUG_ADAFLAGS = -g
|
||||
GNATLIBFLAGS = -gnatpg
|
||||
GNATLIBFLAGS = -gnatpg -nostdinc
|
||||
GNATLIBCFLAGS = -g -O2
|
||||
GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \
|
||||
-DIN_RTS
|
||||
|
|
@ -471,6 +471,7 @@ ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
|
|||
s-osinte.ads<5zosinte.ads \
|
||||
s-osprim.adb<5zosprim.adb \
|
||||
s-parame.ads<5zparame.ads \
|
||||
s-stchop.adb<5zstchop.adb \
|
||||
s-taprop.adb<5ztaprop.adb \
|
||||
s-tpopsp.adb<5ztpopsp.adb \
|
||||
s-taspri.ads<5ztaspri.ads \
|
||||
|
|
@ -498,6 +499,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
|
|||
s-osinte.ads<5zosinte.ads \
|
||||
s-osprim.adb<5zosprim.adb \
|
||||
s-parame.ads<5zparame.ads \
|
||||
s-stchop.adb<5zstchop.adb \
|
||||
s-taprop.adb<5ztaprop.adb \
|
||||
s-taspri.ads<5ztaspri.ads \
|
||||
s-tpopsp.adb<5ztpopsp.adb \
|
||||
|
|
@ -536,6 +538,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
|
|||
s-osinte.ads<5zosinte.ads \
|
||||
s-osprim.adb<5zosprim.adb \
|
||||
s-parame.ads<5zparame.ads \
|
||||
s-stchop.adb<5zstchop.adb \
|
||||
s-taprop.adb<5ztaprop.adb \
|
||||
s-taspri.ads<5ztaspri.ads \
|
||||
s-tpopsp.adb<5ztpopsp.adb \
|
||||
|
|
@ -621,6 +624,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
|
|||
s-osinte.ads<5zosinte.ads \
|
||||
s-osprim.adb<5zosprim.adb \
|
||||
s-parame.ads<5zparame.ads \
|
||||
s-stchop.adb<5zstchop.adb \
|
||||
s-taprop.adb<5ztaprop.adb \
|
||||
s-taspri.ads<5ztaspri.ads \
|
||||
s-tpopsp.adb<5ztpopsp.adb \
|
||||
|
|
@ -650,6 +654,7 @@ ifeq ($(strip $(filter-out xscale% coff wrs vx%,$(targ))),)
|
|||
s-osinte.ads<5zosinte.ads \
|
||||
s-osprim.adb<5zosprim.adb \
|
||||
s-parame.ads<5zparame.ads \
|
||||
s-stchop.adb<5zstchop.adb \
|
||||
s-taprop.adb<5ztaprop.adb \
|
||||
s-taspri.ads<5ztaspri.ads \
|
||||
s-tpopsp.adb<5ztpopsp.adb \
|
||||
|
|
@ -679,6 +684,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),)
|
|||
s-osinte.ads<5zosinte.ads \
|
||||
s-osprim.adb<5zosprim.adb \
|
||||
s-parame.ads<5zparame.ads \
|
||||
s-stchop.adb<5zstchop.adb \
|
||||
s-taprop.adb<5ztaprop.adb \
|
||||
s-taspri.ads<5ztaspri.ads \
|
||||
s-tpopsp.adb<5ztpopsp.adb \
|
||||
|
|
@ -870,7 +876,14 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
|
|||
s-tpopsp.adb<7stpopsp.adb \
|
||||
system.ads<56system.ads
|
||||
|
||||
THREADSLIB=
|
||||
TOOLS_TARGET_PAIRS = \
|
||||
mlib-tgt.adb<5lml-tgt.adb
|
||||
GNATLIB_SHARED = gnatlib-shared-dual
|
||||
|
||||
SYMLIB = $(ADDR2LINE_SYMLIB)
|
||||
THREADSLIB= -lc_r
|
||||
GMEM_LIB = gmemlib
|
||||
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
|
||||
LIBRARY_VERSION := $(LIB_VERSION)
|
||||
endif
|
||||
|
||||
|
|
@ -1125,7 +1138,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
|
|||
LIBRARY_VERSION := $(LIB_VERSION)
|
||||
endif
|
||||
|
||||
ifeq ($(strip $(filter-out alpha% ia64 dec vms% openvms% alphavms%,$(host))),)
|
||||
ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(host))),)
|
||||
|
||||
soext = .exe
|
||||
hyphen = _
|
||||
|
|
@ -1137,31 +1150,27 @@ hyphen = _
|
|||
endif
|
||||
|
||||
ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),)
|
||||
|
||||
ifeq ($(strip $(filter-out ia64% hp vms% openvms%,$(targ))),)
|
||||
LIBGNAT_TARGET_PAIRS_AUX = \
|
||||
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
|
||||
LIBGNAT_TARGET_PAIRS_AUX1 = \
|
||||
s-crtl.ads<5xcrtl.ads \
|
||||
s-osinte.adb<5xosinte.adb \
|
||||
s-osinte.ads<5xosinte.ads \
|
||||
s-parame.ads<5vparame.ads
|
||||
system.ads<5qsystem.ads
|
||||
else
|
||||
ifeq ($(strip $(filter-out alpha64% dec hp vms% openvms% alphavms%,$(targ))),)
|
||||
LIBGNAT_TARGET_PAIRS_AUX = \
|
||||
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
|
||||
LIBGNAT_TARGET_PAIRS_AUX1 = \
|
||||
s-crtl.ads<5vcrtl.ads \
|
||||
s-osinte.adb<5vosinte.adb \
|
||||
s-osinte.ads<5vosinte.ads \
|
||||
s-parame.ads<5vparame.ads
|
||||
else
|
||||
system.ads<5xsystem.ads
|
||||
endif
|
||||
endif
|
||||
ifeq ($(strip $(filter-out express EXPRESS,$(THREAD_KIND))),)
|
||||
LIBGNAT_TARGET_PAIRS_AUX = \
|
||||
s-osinte.adb<5vosinte.adb \
|
||||
s-osinte.ads<5vosinte.ads \
|
||||
LIBGNAT_TARGET_PAIRS_AUX2 = \
|
||||
s-parame.ads<5xparame.ads
|
||||
else
|
||||
LIBGNAT_TARGET_PAIRS_AUX = \
|
||||
s-osinte.adb<5vosinte.adb \
|
||||
s-osinte.ads<5vosinte.ads \
|
||||
LIBGNAT_TARGET_PAIRS_AUX2 = \
|
||||
s-parame.ads<5vparame.ads
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
LIBGNAT_TARGET_PAIRS = \
|
||||
|
|
@ -1180,7 +1189,6 @@ endif
|
|||
i-cpp.adb<6vcpp.adb \
|
||||
interfac.ads<6vinterf.ads \
|
||||
s-asthan.adb<5vasthan.adb \
|
||||
s-crtl.ads<5vcrtl.ads \
|
||||
s-inmaop.adb<5vinmaop.adb \
|
||||
s-interr.adb<5vinterr.adb \
|
||||
s-intman.adb<5vintman.adb \
|
||||
|
|
@ -1195,14 +1203,16 @@ endif
|
|||
s-traent.adb<5vtraent.adb \
|
||||
s-traent.ads<5vtraent.ads \
|
||||
s-vaflop.adb<5vvaflop.adb \
|
||||
system.ads<5xsystem.ads \
|
||||
$(LIBGNAT_TARGET_PAIRS_AUX)
|
||||
$(LIBGNAT_TARGET_PAIRS_AUX1) \
|
||||
$(LIBGNAT_TARGET_PAIRS_AUX2)
|
||||
|
||||
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5vml-tgt.adb
|
||||
|
||||
GNATLIB_SHARED=gnatlib-shared-vms
|
||||
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
|
||||
EXTRA_LIBGNAT_SRCS=vmshandler.asm
|
||||
EXTRA_LIBGNAT_OBJS=vmshandler.o
|
||||
endif
|
||||
EXTRA_GNATRTL_TASKING_OBJS=s-tpopde.o
|
||||
EXTRA_GNATTOOLS = \
|
||||
../../gnatlbr$(exeext) \
|
||||
|
|
|
|||
|
|
@ -406,6 +406,7 @@ GNATRTL_NONTASKING_OBJS= \
|
|||
s-sopco4$(objext) \
|
||||
s-sopco5$(objext) \
|
||||
s-stache$(objext) \
|
||||
s-stchop$(objext) \
|
||||
s-stalib$(objext) \
|
||||
s-stoele$(objext) \
|
||||
s-stopoo$(objext) \
|
||||
|
|
|
|||
|
|
@ -2390,6 +2390,7 @@ _flush_cache()
|
|||
#if defined (CROSS_COMPILE) \
|
||||
|| (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
|
||||
&& ! (defined (linux) && defined (i386)) \
|
||||
&& ! defined (__FreeBSD__) \
|
||||
&& ! defined (hpux) \
|
||||
&& ! defined (_AIX) \
|
||||
&& ! (defined (__alpha__) && defined (__osf__)) \
|
||||
|
|
|
|||
|
|
@ -1777,20 +1777,6 @@ __gnat_initialize (void)
|
|||
{
|
||||
__gnat_init_float ();
|
||||
|
||||
/* Assume an environment task stack size of 20kB.
|
||||
|
||||
Using a constant is necessary because we do not want each Ada application
|
||||
to depend on the optional taskShow library,
|
||||
which is required to get the actual stack information.
|
||||
|
||||
The consequence of this is that with -fstack-check
|
||||
the environment task must have an actual stack size
|
||||
of at least 20kB and the usable size will be about 14kB.
|
||||
*/
|
||||
|
||||
__gnat_set_stack_size (14336);
|
||||
/* Allow some head room for the stack checking code, and for
|
||||
stack space consumed during initialization */
|
||||
}
|
||||
|
||||
/********************************/
|
||||
|
|
|
|||
|
|
@ -87,6 +87,24 @@ package body Prj.Env is
|
|||
-- A Boolean array type used in Create_Mapping_File to select the projects
|
||||
-- in the closure of a specific project.
|
||||
|
||||
package Source_Paths is new Table.Table
|
||||
(Table_Component_Type => Name_Id,
|
||||
Table_Index_Type => Natural,
|
||||
Table_Low_Bound => 1,
|
||||
Table_Initial => 50,
|
||||
Table_Increment => 50,
|
||||
Table_Name => "Prj.Env.Source_Paths");
|
||||
-- A table to store the source dirs before creating the source path file
|
||||
|
||||
package Object_Paths is new Table.Table
|
||||
(Table_Component_Type => Name_Id,
|
||||
Table_Index_Type => Natural,
|
||||
Table_Low_Bound => 1,
|
||||
Table_Initial => 50,
|
||||
Table_Increment => 50,
|
||||
Table_Name => "Prj.Env.Source_Paths");
|
||||
-- A table to store the object dirs, before creating the object path file
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
|
@ -109,16 +127,13 @@ package body Prj.Env is
|
|||
-- If Ada_Path_Length /= 0, prepend a Path_Separator character to
|
||||
-- Path.
|
||||
|
||||
procedure Add_To_Path_File
|
||||
(Source_Dirs : String_List_Id;
|
||||
Path_File : File_Descriptor);
|
||||
-- Add to Ada_Path_Buffer all the source directories in string list
|
||||
procedure Add_To_Source_Path (Source_Dirs : String_List_Id);
|
||||
-- Add to Ada_Path_B all the source directories in string list
|
||||
-- Source_Dirs, if any. Increment Ada_Path_Length.
|
||||
|
||||
procedure Add_To_Path_File
|
||||
(Path : String;
|
||||
Path_File : File_Descriptor);
|
||||
-- Add Path to path file
|
||||
procedure Add_To_Object_Path (Object_Dir : Name_Id);
|
||||
-- Add Object_Dir to object path table. Make sure it is not duplicate
|
||||
-- and it is the last one in the current table.
|
||||
|
||||
procedure Create_New_Path_File
|
||||
(Path_FD : out File_Descriptor;
|
||||
|
|
@ -311,6 +326,34 @@ package body Prj.Env is
|
|||
return Projects.Table (Project).Ada_Objects_Path;
|
||||
end Ada_Objects_Path;
|
||||
|
||||
------------------------
|
||||
-- Add_To_Object_Path --
|
||||
------------------------
|
||||
|
||||
procedure Add_To_Object_Path (Object_Dir : Name_Id) is
|
||||
begin
|
||||
-- Check if the directory is already in the table
|
||||
|
||||
for Index in 1 .. Object_Paths.Last loop
|
||||
-- If it is, remove it, and add it as the last one
|
||||
|
||||
if Object_Paths.Table (Index) = Object_Dir then
|
||||
for Index2 in Index + 1 .. Object_Paths.Last loop
|
||||
Object_Paths.Table (Index2 - 1) :=
|
||||
Object_Paths.Table (Index2);
|
||||
end loop;
|
||||
|
||||
Object_Paths.Table (Object_Paths.Last) := Object_Dir;
|
||||
return;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- The directory is not already in the table, add it
|
||||
|
||||
Object_Paths.Increment_Last;
|
||||
Object_Paths.Table (Object_Paths.Last) := Object_Dir;
|
||||
end Add_To_Object_Path;
|
||||
|
||||
-----------------
|
||||
-- Add_To_Path --
|
||||
-----------------
|
||||
|
|
@ -402,41 +445,43 @@ package body Prj.Env is
|
|||
Ada_Path_Length := Ada_Path_Length + Dir'Length;
|
||||
end Add_To_Path;
|
||||
|
||||
----------------------
|
||||
-- Add_To_Path_File --
|
||||
----------------------
|
||||
------------------------
|
||||
-- Add_To_Source_Path --
|
||||
------------------------
|
||||
|
||||
procedure Add_To_Path_File
|
||||
(Source_Dirs : String_List_Id;
|
||||
Path_File : File_Descriptor)
|
||||
is
|
||||
procedure Add_To_Source_Path (Source_Dirs : String_List_Id) is
|
||||
Current : String_List_Id := Source_Dirs;
|
||||
Source_Dir : String_Element;
|
||||
Add_It : Boolean;
|
||||
|
||||
begin
|
||||
-- Add each source directory
|
||||
|
||||
while Current /= Nil_String loop
|
||||
Source_Dir := String_Elements.Table (Current);
|
||||
Add_To_Path_File (Get_Name_String (Source_Dir.Value), Path_File);
|
||||
Add_It := True;
|
||||
|
||||
-- Check if the source directory is already in the table
|
||||
|
||||
for Index in 1 .. Source_Paths.Last loop
|
||||
-- If it is already, no need to add it
|
||||
|
||||
if Source_Paths.Table (Index) = Source_Dir.Value then
|
||||
Add_It := False;
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if Add_It then
|
||||
Source_Paths.Increment_Last;
|
||||
Source_Paths.Table (Source_Paths.Last) := Source_Dir.Value;
|
||||
end if;
|
||||
|
||||
-- Next source directory
|
||||
|
||||
Current := Source_Dir.Next;
|
||||
end loop;
|
||||
end Add_To_Path_File;
|
||||
|
||||
procedure Add_To_Path_File
|
||||
(Path : String;
|
||||
Path_File : File_Descriptor)
|
||||
is
|
||||
Line : String (1 .. Path'Length + 1);
|
||||
Len : Natural;
|
||||
|
||||
begin
|
||||
Line (1 .. Path'Length) := Path;
|
||||
Line (Line'Last) := ASCII.LF;
|
||||
Len := Write (Path_File, Line (1)'Address, Line'Length);
|
||||
|
||||
if Len /= Line'Length then
|
||||
Prj.Com.Fail ("disk full");
|
||||
end if;
|
||||
end Add_To_Path_File;
|
||||
end Add_To_Source_Path;
|
||||
|
||||
-----------------------
|
||||
-- Body_Path_Name_Of --
|
||||
|
|
@ -1845,87 +1890,100 @@ package body Prj.Env is
|
|||
Status : Boolean;
|
||||
-- For calls to Close
|
||||
|
||||
procedure Add (Project : Project_Id);
|
||||
Len : Natural;
|
||||
|
||||
procedure Add (Proj : Project_Id);
|
||||
-- Add all the source/object directories of a project to the path only
|
||||
-- if this project has not been visited. Calls itself recursively for
|
||||
-- projects being extended, and imported projects.
|
||||
-- if this project has not been visited. Calls an internal procedure
|
||||
-- recursively for projects being extended, and imported projects.
|
||||
|
||||
---------
|
||||
-- Add --
|
||||
---------
|
||||
|
||||
procedure Add (Project : Project_Id) is
|
||||
begin
|
||||
-- If Seen is False, then the project has not yet been visited
|
||||
procedure Add (Proj : Project_Id) is
|
||||
|
||||
if not Projects.Table (Project).Seen then
|
||||
Projects.Table (Project).Seen := True;
|
||||
procedure Recursive_Add (Project : Project_Id);
|
||||
-- Recursive procedure to add the source/object paths of extended/
|
||||
-- imported projects.
|
||||
|
||||
declare
|
||||
Data : constant Project_Data := Projects.Table (Project);
|
||||
List : Project_List := Data.Imported_Projects;
|
||||
-------------------
|
||||
-- Recursive_Add --
|
||||
-------------------
|
||||
|
||||
begin
|
||||
if Process_Source_Dirs then
|
||||
procedure Recursive_Add (Project : Project_Id) is
|
||||
begin
|
||||
-- If Seen is False, then the project has not yet been visited
|
||||
|
||||
-- Add to path all source directories of this project
|
||||
-- if there are Ada sources.
|
||||
if not Projects.Table (Project).Seen then
|
||||
Projects.Table (Project).Seen := True;
|
||||
|
||||
if Projects.Table (Project).Sources_Present then
|
||||
Add_To_Path_File (Data.Source_Dirs, Source_FD);
|
||||
end if;
|
||||
end if;
|
||||
declare
|
||||
Data : constant Project_Data := Projects.Table (Project);
|
||||
List : Project_List := Data.Imported_Projects;
|
||||
|
||||
if Process_Object_Dirs then
|
||||
begin
|
||||
if Process_Source_Dirs then
|
||||
|
||||
-- Add to path the object directory of this project
|
||||
-- except if we don't include library project and
|
||||
-- this is a library project.
|
||||
-- Add to path all source directories of this project
|
||||
-- if there are Ada sources.
|
||||
|
||||
if (Data.Library and then Including_Libraries)
|
||||
or else
|
||||
(Data.Object_Directory /= No_Name
|
||||
and then
|
||||
(not Including_Libraries or else not Data.Library))
|
||||
then
|
||||
-- For a library project, add the library directory
|
||||
|
||||
if Data.Library then
|
||||
declare
|
||||
New_Path : constant String :=
|
||||
Get_Name_String (Data.Library_Dir);
|
||||
|
||||
begin
|
||||
Add_To_Path_File (New_Path, Object_FD);
|
||||
end;
|
||||
|
||||
else
|
||||
-- For a non library project, add the object directory
|
||||
|
||||
declare
|
||||
New_Path : constant String :=
|
||||
Get_Name_String (Data.Object_Directory);
|
||||
begin
|
||||
Add_To_Path_File (New_Path, Object_FD);
|
||||
end;
|
||||
if Projects.Table (Project).Sources_Present then
|
||||
Add_To_Source_Path (Data.Source_Dirs);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Call Add to the project being extended, if any
|
||||
if Process_Object_Dirs then
|
||||
|
||||
if Data.Extends /= No_Project then
|
||||
Add (Data.Extends);
|
||||
end if;
|
||||
-- Add to path the object directory of this project
|
||||
-- except if we don't include library project and
|
||||
-- this is a library project.
|
||||
|
||||
-- Call Add for each imported project, if any
|
||||
if (Data.Library and then Including_Libraries)
|
||||
or else
|
||||
(Data.Object_Directory /= No_Name
|
||||
and then
|
||||
(not Including_Libraries or else not Data.Library))
|
||||
then
|
||||
-- For a library project, add the library directory
|
||||
|
||||
while List /= Empty_Project_List loop
|
||||
Add (Project_Lists.Table (List).Project);
|
||||
List := Project_Lists.Table (List).Next;
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
if Data.Library then
|
||||
Add_To_Object_Path (Data.Library_Dir);
|
||||
|
||||
else
|
||||
-- For a non library project, add the object
|
||||
-- directory.
|
||||
|
||||
Add_To_Object_Path (Data.Object_Directory);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Call Add to the project being extended, if any
|
||||
|
||||
if Data.Extends /= No_Project then
|
||||
Recursive_Add (Data.Extends);
|
||||
end if;
|
||||
|
||||
-- Call Add for each imported project, if any
|
||||
|
||||
while List /= Empty_Project_List loop
|
||||
Recursive_Add (Project_Lists.Table (List).Project);
|
||||
List := Project_Lists.Table (List).Next;
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
end Recursive_Add;
|
||||
|
||||
begin
|
||||
Source_Paths.Set_Last (0);
|
||||
Object_Paths.Set_Last (0);
|
||||
|
||||
for Index in 1 .. Projects.Last loop
|
||||
Projects.Table (Index).Seen := False;
|
||||
end loop;
|
||||
|
||||
Recursive_Add (Proj);
|
||||
end Add;
|
||||
|
||||
-- Start of processing for Set_Ada_Paths
|
||||
|
|
@ -1966,16 +2024,23 @@ package body Prj.Env is
|
|||
-- then call the recursive procedure Add for Project.
|
||||
|
||||
if Process_Source_Dirs or Process_Object_Dirs then
|
||||
for Index in 1 .. Projects.Last loop
|
||||
Projects.Table (Index).Seen := False;
|
||||
end loop;
|
||||
|
||||
Add (Project);
|
||||
end if;
|
||||
|
||||
-- Close any file that has been created.
|
||||
-- Write and close any file that has been created.
|
||||
|
||||
if Source_FD /= Invalid_FD then
|
||||
for Index in 1 .. Source_Paths.Last loop
|
||||
Get_Name_String (Source_Paths.Table (Index));
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := ASCII.LF;
|
||||
Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
|
||||
|
||||
if Len /= Name_Len then
|
||||
Prj.Com.Fail ("disk full");
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Close (Source_FD, Status);
|
||||
|
||||
if not Status then
|
||||
|
|
@ -1984,6 +2049,17 @@ package body Prj.Env is
|
|||
end if;
|
||||
|
||||
if Object_FD /= Invalid_FD then
|
||||
for Index in 1 .. Object_Paths.Last loop
|
||||
Get_Name_String (Object_Paths.Table (Index));
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := ASCII.LF;
|
||||
Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
|
||||
|
||||
if Len /= Name_Len then
|
||||
Prj.Com.Fail ("disk full");
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Close (Object_FD, Status);
|
||||
|
||||
if not Status then
|
||||
|
|
|
|||
|
|
@ -587,7 +587,8 @@ package body Prj.Nmsc is
|
|||
|
||||
procedure Ada_Check
|
||||
(Project : Project_Id;
|
||||
Report_Error : Put_Line_Access)
|
||||
Report_Error : Put_Line_Access;
|
||||
Trusted_Mode : Boolean)
|
||||
is
|
||||
Data : Project_Data;
|
||||
Languages : Variable_Value := Nil_Variable_Value;
|
||||
|
|
@ -665,9 +666,12 @@ package body Prj.Nmsc is
|
|||
Source_Recorded := False;
|
||||
Element := String_Elements.Table (Source_Dir);
|
||||
if Element.Value /= No_Name then
|
||||
Get_Name_String (Element.Display_Value);
|
||||
declare
|
||||
Source_Directory : constant String :=
|
||||
Get_Name_String (Element.Display_Value);
|
||||
Name_Buffer (1 .. Name_Len) & Directory_Separator;
|
||||
Dir_Last : constant Natural :=
|
||||
Compute_Directory_Last (Source_Directory);
|
||||
|
||||
begin
|
||||
if Current_Verbosity = High then
|
||||
|
|
@ -677,7 +681,8 @@ package body Prj.Nmsc is
|
|||
|
||||
-- We look to every entry in the source directory
|
||||
|
||||
Open (Dir, Source_Directory);
|
||||
Open (Dir, Source_Directory
|
||||
(Source_Directory'First .. Dir_Last));
|
||||
|
||||
-- Canonical_Case_File_Name (Source_Directory);
|
||||
|
||||
|
|
@ -693,20 +698,16 @@ package body Prj.Nmsc is
|
|||
|
||||
declare
|
||||
File_Name : constant Name_Id := Name_Find;
|
||||
Dir : constant String :=
|
||||
Source_Directory &
|
||||
Directory_Separator;
|
||||
Dir_Last : constant Natural :=
|
||||
Compute_Directory_Last (Dir);
|
||||
Path : constant String :=
|
||||
Normalize_Pathname
|
||||
(Name => Name_Buffer (1 .. Name_Len),
|
||||
Directory => Dir (Dir'First .. Dir_Last));
|
||||
Directory => Source_Directory
|
||||
(Source_Directory'First .. Dir_Last),
|
||||
Resolve_Links => not Trusted_Mode);
|
||||
Path_Name : Name_Id;
|
||||
|
||||
begin
|
||||
if Is_Regular_File (Path) then
|
||||
|
||||
if Trusted_Mode or else Is_Regular_File (Path) then
|
||||
Name_Len := Path'Length;
|
||||
Name_Buffer (1 .. Name_Len) := Path;
|
||||
Path_Name := Name_Find;
|
||||
|
|
@ -3750,6 +3751,11 @@ package body Prj.Nmsc is
|
|||
(The_Unit_Data.File_Names (Unit_Kind).Name);
|
||||
end if;
|
||||
|
||||
-- Record the file name in the hash table Files_Htable
|
||||
|
||||
Unit_Prj := (Unit => The_Unit, Project => Project);
|
||||
Files_Htable.Set (Canonical_File_Name, Unit_Prj);
|
||||
|
||||
The_Unit_Data.File_Names (Unit_Kind) :=
|
||||
(Name => Canonical_File_Name,
|
||||
Display_Name => File_Name,
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2000-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- --
|
||||
|
|
@ -31,12 +31,17 @@ private package Prj.Nmsc is
|
|||
|
||||
procedure Ada_Check
|
||||
(Project : Project_Id;
|
||||
Report_Error : Put_Line_Access);
|
||||
Report_Error : Put_Line_Access;
|
||||
Trusted_Mode : Boolean);
|
||||
-- Call Language_Independent_Check.
|
||||
-- Check the naming scheme for Ada.
|
||||
-- Find the Ada source files if any.
|
||||
-- If Report_Error is null , use the standard error reporting mechanism
|
||||
-- (Errout). Otherwise, report errors using Report_Error.
|
||||
-- If Trusted_Mode is True, it is assumed that the project doesn't contain
|
||||
-- any file duplicated through symbolic links (although the latter are
|
||||
-- still valid if they point to a file which is outside of the project),
|
||||
-- and that no directory has a name which is a valid source name.
|
||||
|
||||
procedure Language_Independent_Check
|
||||
(Project : Project_Id;
|
||||
|
|
|
|||
|
|
@ -101,14 +101,16 @@ package body Prj.Proc is
|
|||
-- recursively for all imported projects and a extended project, if any.
|
||||
-- Then process the declarative items of the project.
|
||||
|
||||
procedure Check (Project : in out Project_Id);
|
||||
procedure Check (Project : in out Project_Id; Trusted_Mode : Boolean);
|
||||
-- Set all projects to not checked, then call Recursive_Check for the
|
||||
-- main project Project. Project is set to No_Project if errors occurred.
|
||||
-- See Prj.Nmsc.Ada_Check for information on Trusted_Mode.
|
||||
|
||||
procedure Recursive_Check (Project : Project_Id);
|
||||
procedure Recursive_Check (Project : Project_Id; Trusted_Mode : Boolean);
|
||||
-- If Project is not marked as checked, mark it as checked, call
|
||||
-- Check_Naming_Scheme for the project, then call itself for a
|
||||
-- possible extended project and all the imported projects of Project.
|
||||
-- See Prj.Nmsc.Ada_Check for information on Trusted_Mode
|
||||
|
||||
---------
|
||||
-- Add --
|
||||
|
|
@ -205,7 +207,7 @@ package body Prj.Proc is
|
|||
-- Check --
|
||||
-----------
|
||||
|
||||
procedure Check (Project : in out Project_Id) is
|
||||
procedure Check (Project : in out Project_Id; Trusted_Mode : Boolean) is
|
||||
begin
|
||||
-- Make sure that all projects are marked as not checked
|
||||
|
||||
|
|
@ -213,8 +215,7 @@ package body Prj.Proc is
|
|||
Projects.Table (Index).Checked := False;
|
||||
end loop;
|
||||
|
||||
Recursive_Check (Project);
|
||||
|
||||
Recursive_Check (Project, Trusted_Mode);
|
||||
end Check;
|
||||
|
||||
----------------
|
||||
|
|
@ -815,7 +816,8 @@ package body Prj.Proc is
|
|||
(Project : out Project_Id;
|
||||
Success : out Boolean;
|
||||
From_Project_Node : Project_Node_Id;
|
||||
Report_Error : Put_Line_Access)
|
||||
Report_Error : Put_Line_Access;
|
||||
Trusted_Mode : Boolean := False)
|
||||
is
|
||||
Obj_Dir : Name_Id;
|
||||
Extending : Project_Id;
|
||||
|
|
@ -839,7 +841,7 @@ package body Prj.Proc is
|
|||
Extended_By => No_Project);
|
||||
|
||||
if Project /= No_Project then
|
||||
Check (Project);
|
||||
Check (Project, Trusted_Mode);
|
||||
end if;
|
||||
|
||||
-- If main project is an extending all project, set the object
|
||||
|
|
@ -861,15 +863,15 @@ package body Prj.Proc is
|
|||
end;
|
||||
end if;
|
||||
|
||||
-- Check that no extended project shares its object directory with
|
||||
-- another extended project or with its extending project(s).
|
||||
-- Check that no extending project shares its object directory with
|
||||
-- the project(s) it extends.
|
||||
|
||||
if Project /= No_Project then
|
||||
for Extended in 1 .. Projects.Last loop
|
||||
Extending := Projects.Table (Extended).Extended_By;
|
||||
for Proj in 1 .. Projects.Last loop
|
||||
Extending := Projects.Table (Proj).Extended_By;
|
||||
|
||||
if Extending /= No_Project then
|
||||
Obj_Dir := Projects.Table (Extended).Object_Directory;
|
||||
Obj_Dir := Projects.Table (Proj).Object_Directory;
|
||||
|
||||
-- Check that a project being extended does not share its
|
||||
-- object directory with any project that extends it, directly
|
||||
|
|
@ -885,13 +887,13 @@ package body Prj.Proc is
|
|||
Projects.Table (Extending2).Object_Directory = Obj_Dir
|
||||
then
|
||||
if Projects.Table (Extending2).Virtual then
|
||||
Error_Msg_Name_1 := Projects.Table (Extended).Name;
|
||||
Error_Msg_Name_1 := Projects.Table (Proj).Name;
|
||||
|
||||
if Error_Report = null then
|
||||
Error_Msg
|
||||
("project % cannot be extended by a virtual " &
|
||||
"project with the same object directory",
|
||||
Projects.Table (Extended).Location);
|
||||
Projects.Table (Proj).Location);
|
||||
|
||||
else
|
||||
Error_Report
|
||||
|
|
@ -905,7 +907,7 @@ package body Prj.Proc is
|
|||
else
|
||||
Error_Msg_Name_1 :=
|
||||
Projects.Table (Extending2).Name;
|
||||
Error_Msg_Name_2 := Projects.Table (Extended).Name;
|
||||
Error_Msg_Name_2 := Projects.Table (Proj).Name;
|
||||
|
||||
if Error_Report = null then
|
||||
Error_Msg
|
||||
|
|
@ -933,70 +935,6 @@ package body Prj.Proc is
|
|||
|
||||
Extending2 := Projects.Table (Extending2).Extended_By;
|
||||
end loop;
|
||||
|
||||
-- Check that two projects being extended do not share their
|
||||
-- project directories.
|
||||
|
||||
for Prj in Extended + 1 .. Projects.Last loop
|
||||
Extending2 := Projects.Table (Prj).Extended_By;
|
||||
|
||||
if Extending2 /= No_Project
|
||||
and then Projects.Table (Prj).Sources_Present
|
||||
and then Projects.Table (Prj).Object_Directory = Obj_Dir
|
||||
and then not Projects.Table (Extending).Virtual
|
||||
then
|
||||
Error_Msg_Name_1 := Projects.Table (Extending).Name;
|
||||
Error_Msg_Name_2 := Projects.Table (Extended).Name;
|
||||
|
||||
if Error_Report = null then
|
||||
Error_Msg ("project % cannot extend project %",
|
||||
Projects.Table (Extending).Location);
|
||||
|
||||
else
|
||||
Error_Report
|
||||
("project """ &
|
||||
Get_Name_String (Error_Msg_Name_1) &
|
||||
""" cannot extend project """ &
|
||||
Get_Name_String (Error_Msg_Name_2) & '"',
|
||||
Project);
|
||||
end if;
|
||||
|
||||
Error_Msg_Name_1 := Projects.Table (Extended).Name;
|
||||
Error_Msg_Name_2 := Projects.Table (Prj).Name;
|
||||
|
||||
if Error_Report = null then
|
||||
Error_Msg
|
||||
("\project % has the same object directory " &
|
||||
"as project %",
|
||||
Projects.Table (Extending).Location);
|
||||
|
||||
else
|
||||
Error_Report
|
||||
("project """ &
|
||||
Get_Name_String (Error_Msg_Name_1) &
|
||||
""" has the same object directory as project """ &
|
||||
Get_Name_String (Error_Msg_Name_2) & """,",
|
||||
Project);
|
||||
end if;
|
||||
|
||||
Error_Msg_Name_1 := Projects.Table (Extending2).Name;
|
||||
|
||||
if Error_Report = null then
|
||||
Error_Msg
|
||||
("\which is extended by project %",
|
||||
Projects.Table (Extending).Location);
|
||||
|
||||
else
|
||||
Error_Report
|
||||
("which is extended by project """ &
|
||||
Get_Name_String (Error_Msg_Name_1) & '"',
|
||||
Project);
|
||||
end if;
|
||||
|
||||
Project := No_Project;
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
end if;
|
||||
end loop;
|
||||
end if;
|
||||
|
|
@ -1817,7 +1755,7 @@ package body Prj.Proc is
|
|||
-- Recursive_Check --
|
||||
---------------------
|
||||
|
||||
procedure Recursive_Check (Project : Project_Id) is
|
||||
procedure Recursive_Check (Project : Project_Id; Trusted_Mode : Boolean) is
|
||||
Data : Project_Data;
|
||||
Imported_Project_List : Project_List := Empty_Project_List;
|
||||
|
||||
|
|
@ -1838,14 +1776,15 @@ package body Prj.Proc is
|
|||
-- Call itself for a possible extended project.
|
||||
-- (if there is no extended project, then nothing happens).
|
||||
|
||||
Recursive_Check (Data.Extends);
|
||||
Recursive_Check (Data.Extends, Trusted_Mode);
|
||||
|
||||
-- Call itself for all imported projects
|
||||
|
||||
Imported_Project_List := Data.Imported_Projects;
|
||||
while Imported_Project_List /= Empty_Project_List loop
|
||||
Recursive_Check
|
||||
(Project_Lists.Table (Imported_Project_List).Project);
|
||||
(Project_Lists.Table (Imported_Project_List).Project,
|
||||
Trusted_Mode);
|
||||
Imported_Project_List :=
|
||||
Project_Lists.Table (Imported_Project_List).Next;
|
||||
end loop;
|
||||
|
|
@ -1856,7 +1795,7 @@ package body Prj.Proc is
|
|||
Write_Line ("""");
|
||||
end if;
|
||||
|
||||
Prj.Nmsc.Ada_Check (Project, Error_Report);
|
||||
Prj.Nmsc.Ada_Check (Project, Error_Report, Trusted_Mode);
|
||||
end if;
|
||||
end Recursive_Check;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2001-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- --
|
||||
|
|
@ -36,9 +36,14 @@ package Prj.Proc is
|
|||
(Project : out Project_Id;
|
||||
Success : out Boolean;
|
||||
From_Project_Node : Project_Node_Id;
|
||||
Report_Error : Put_Line_Access);
|
||||
Report_Error : Put_Line_Access;
|
||||
Trusted_Mode : Boolean := False);
|
||||
-- Process a project file tree into project file data structures.
|
||||
-- If Report_Error is null, use the error reporting mechanism.
|
||||
-- Otherwise, report errors using Report_Error.
|
||||
-- If Trusted_Mode is True, it is assumed that the project doesn't contain
|
||||
-- any file duplicated through symbolic links (although the latter are
|
||||
-- still valid if they point to a file which is outside of the project),
|
||||
-- and that no directory has a name which is a valid source name.
|
||||
|
||||
end Prj.Proc;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2001-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- --
|
||||
|
|
@ -370,6 +370,7 @@ package body Prj is
|
|||
String_Elements.Init;
|
||||
Prj.Com.Units.Init;
|
||||
Prj.Com.Units_Htable.Reset;
|
||||
Prj.Com.Files_Htable.Reset;
|
||||
end Reset;
|
||||
|
||||
------------------------
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1999-2004 Free Software Foundation, 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- --
|
||||
|
|
@ -31,235 +31,5 @@
|
|||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Exceptions;
|
||||
|
||||
with System.Storage_Elements; use System.Storage_Elements;
|
||||
with System.Parameters; use System.Parameters;
|
||||
with System.Soft_Links;
|
||||
with System.CRTL;
|
||||
|
||||
package body System.Stack_Checking is
|
||||
|
||||
Kilobyte : constant := 1024;
|
||||
|
||||
function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
|
||||
|
||||
-- The function Set_Stack_Info is the actual function that updates
|
||||
-- the cache containing a pointer to the Stack_Info. It may also
|
||||
-- be used for detecting asynchronous abort in combination with
|
||||
-- Invalidate_Self_Cache.
|
||||
|
||||
-- Set_Stack_Info should do the following things in order:
|
||||
-- 1) Get the Stack_Access value for the current task
|
||||
-- 2) Set Stack.all to the value obtained in 1)
|
||||
-- 3) Optionally Poll to check for asynchronous abort
|
||||
|
||||
-- This order is important because if at any time a write to
|
||||
-- the stack cache is pending, that write should be followed
|
||||
-- by a Poll to prevent loosing signals.
|
||||
|
||||
-- Note: This function must be compiled with Polling turned off
|
||||
|
||||
-- Note: on systems like VxWorks and OS/2 with real thread-local storage,
|
||||
-- Set_Stack_Info should return an access value for such local
|
||||
-- storage. In those cases the cache will always be up-to-date.
|
||||
|
||||
-- The following constants should be imported from some system-specific
|
||||
-- constants package. The constants must be static for performance reasons.
|
||||
|
||||
----------------------------
|
||||
-- Invalidate_Stack_Cache --
|
||||
----------------------------
|
||||
|
||||
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
|
||||
pragma Warnings (Off, Any_Stack);
|
||||
begin
|
||||
Cache := Null_Stack;
|
||||
end Invalidate_Stack_Cache;
|
||||
|
||||
--------------------
|
||||
-- Set_Stack_Info --
|
||||
--------------------
|
||||
|
||||
function Set_Stack_Info
|
||||
(Stack : access Stack_Access) return Stack_Access
|
||||
is
|
||||
type Frame_Mark is null record;
|
||||
Frame_Location : Frame_Mark;
|
||||
Frame_Address : constant Address := Frame_Location'Address;
|
||||
|
||||
My_Stack : Stack_Access;
|
||||
Limit_Chars : System.Address;
|
||||
Limit : Integer;
|
||||
|
||||
begin
|
||||
-- The order of steps 1 .. 3 is important, see specification.
|
||||
|
||||
-- 1) Get the Stack_Access value for the current task
|
||||
|
||||
My_Stack := Soft_Links.Get_Stack_Info.all;
|
||||
|
||||
if My_Stack.Base = Null_Address then
|
||||
|
||||
-- First invocation, initialize based on the assumption that
|
||||
-- there are Environment_Stack_Size bytes available beyond
|
||||
-- the current frame address.
|
||||
|
||||
if My_Stack.Size = 0 then
|
||||
My_Stack.Size := Storage_Offset (Default_Env_Stack_Size);
|
||||
|
||||
-- When the environment variable GNAT_STACK_LIMIT is set,
|
||||
-- set Environment_Stack_Size to that number of kB.
|
||||
|
||||
Limit_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
|
||||
|
||||
if Limit_Chars /= Null_Address then
|
||||
Limit := System.CRTL.atoi (Limit_Chars);
|
||||
|
||||
if Limit >= 0 then
|
||||
My_Stack.Size := Storage_Offset (Limit) * Kilobyte;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
My_Stack.Base := Frame_Address;
|
||||
|
||||
if Stack_Grows_Down then
|
||||
|
||||
-- Prevent wrap-around on too big stack sizes
|
||||
|
||||
My_Stack.Limit := My_Stack.Base - My_Stack.Size;
|
||||
|
||||
if My_Stack.Limit > My_Stack.Base then
|
||||
My_Stack.Limit := Address'First;
|
||||
end if;
|
||||
|
||||
else
|
||||
My_Stack.Limit := My_Stack.Base + My_Stack.Size;
|
||||
|
||||
-- Prevent wrap-around on too big stack sizes
|
||||
|
||||
if My_Stack.Limit < My_Stack.Base then
|
||||
My_Stack.Limit := Address'Last;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- 2) Set Stack.all to the value obtained in 1)
|
||||
|
||||
Stack.all := My_Stack;
|
||||
|
||||
-- 3) Optionally Poll to check for asynchronous abort
|
||||
|
||||
if Soft_Links.Check_Abort_Status.all /= 0 then
|
||||
raise Standard'Abort_Signal;
|
||||
end if;
|
||||
|
||||
return My_Stack; -- Never trust the cached value, but return local copy!
|
||||
end Set_Stack_Info;
|
||||
|
||||
--------------------
|
||||
-- Set_Stack_Size --
|
||||
--------------------
|
||||
|
||||
-- Specify the stack size for the current frame.
|
||||
|
||||
procedure Set_Stack_Size
|
||||
(Stack_Size : System.Storage_Elements.Storage_Offset)
|
||||
is
|
||||
My_Stack : Stack_Access;
|
||||
Frame_Address : constant System.Address := My_Stack'Address;
|
||||
|
||||
begin
|
||||
My_Stack := Stack_Check (Frame_Address);
|
||||
|
||||
if Stack_Grows_Down then
|
||||
My_Stack.Limit := My_Stack.Base - Stack_Size;
|
||||
else
|
||||
My_Stack.Limit := My_Stack.Base + Stack_Size;
|
||||
end if;
|
||||
end Set_Stack_Size;
|
||||
|
||||
-----------------
|
||||
-- Stack_Check --
|
||||
-----------------
|
||||
|
||||
function Stack_Check
|
||||
(Stack_Address : System.Address) return Stack_Access
|
||||
is
|
||||
type Frame_Marker is null record;
|
||||
Marker : Frame_Marker;
|
||||
Cached_Stack : constant Stack_Access := Cache;
|
||||
Frame_Address : constant System.Address := Marker'Address;
|
||||
|
||||
begin
|
||||
-- This function first does a "cheap" check which is correct
|
||||
-- if it succeeds. In case of failure, the full check is done.
|
||||
-- Ideally the cheap check should be done in an optimized manner,
|
||||
-- or be inlined.
|
||||
|
||||
if (Stack_Grows_Down and then
|
||||
(Frame_Address <= Cached_Stack.Base
|
||||
and
|
||||
Stack_Address > Cached_Stack.Limit))
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
(Frame_Address >= Cached_Stack.Base
|
||||
and
|
||||
Stack_Address < Cached_Stack.Limit))
|
||||
then
|
||||
-- Cached_Stack is valid as it passed the stack check
|
||||
return Cached_Stack;
|
||||
end if;
|
||||
|
||||
Full_Check :
|
||||
declare
|
||||
My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
|
||||
-- At this point Stack.all might already be invalid, so
|
||||
-- it is essential to use our local copy of Stack!
|
||||
|
||||
begin
|
||||
if (Stack_Grows_Down and then
|
||||
(not (Frame_Address <= My_Stack.Base)))
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
(not (Frame_Address >= My_Stack.Base)))
|
||||
then
|
||||
-- The returned Base is lower than the stored one,
|
||||
-- so assume that the original one wasn't right and use the
|
||||
-- current Frame_Address as new one. This allows initializing
|
||||
-- Base with the Frame_Address as approximation.
|
||||
-- During initialization the Frame_Address will be close to
|
||||
-- the stack base anyway: the difference should be compensated
|
||||
-- for in the stack reserve.
|
||||
|
||||
My_Stack.Base := Frame_Address;
|
||||
end if;
|
||||
|
||||
if (Stack_Grows_Down and then
|
||||
Stack_Address < My_Stack.Limit)
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
Stack_Address > My_Stack.Limit)
|
||||
then
|
||||
Ada.Exceptions.Raise_Exception
|
||||
(E => Storage_Error'Identity,
|
||||
Message => "stack overflow detected");
|
||||
end if;
|
||||
|
||||
return My_Stack;
|
||||
end Full_Check;
|
||||
end Stack_Check;
|
||||
|
||||
------------------------
|
||||
-- Update_Stack_Cache --
|
||||
------------------------
|
||||
|
||||
procedure Update_Stack_Cache (Stack : Stack_Access) is
|
||||
begin
|
||||
if not Multi_Processor then
|
||||
Cache := Stack;
|
||||
end if;
|
||||
end Update_Stack_Cache;
|
||||
|
||||
end System.Stack_Checking;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1999-2004 Free Software Foundation, 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- --
|
||||
|
|
@ -33,14 +33,16 @@
|
|||
|
||||
-- This package provides a system-independent implementation of stack
|
||||
-- checking using comparison with stack base and limit.
|
||||
-- This package defines basic types and objects. Operations related
|
||||
-- to stack checking can be found in package
|
||||
-- System.Stack_Checking.Operations.
|
||||
|
||||
with System.Storage_Elements;
|
||||
|
||||
pragma Polling (Off);
|
||||
-- Turn off polling, we do not want polling to take place during stack
|
||||
-- checking operations. It causes infinite loops and other problems.
|
||||
|
||||
package System.Stack_Checking is
|
||||
|
||||
pragma Elaborate_Body;
|
||||
|
||||
type Stack_Info is record
|
||||
Limit : System.Address := System.Null_Address;
|
||||
Base : System.Address := System.Null_Address;
|
||||
|
|
@ -59,30 +61,7 @@ package System.Stack_Checking is
|
|||
-- upgrowing stack) may contain any address that is part of another stack.
|
||||
-- The Stack_Access may be part of a larger data structure.
|
||||
|
||||
Multi_Processor : constant Boolean := False; -- Not supported yet
|
||||
|
||||
----------------------
|
||||
-- Client Interface --
|
||||
----------------------
|
||||
|
||||
procedure Set_Stack_Size
|
||||
(Stack_Size : System.Storage_Elements.Storage_Offset);
|
||||
-- Specify the stack size for the current task.
|
||||
|
||||
procedure Update_Stack_Cache (Stack : Stack_Access);
|
||||
-- Set the stack cache for the current task. Note that this is only
|
||||
-- for optimization purposes, nothing can be assumed about the
|
||||
-- contents of the cache at any time, see Set_Stack_Info.
|
||||
|
||||
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access);
|
||||
-- Invalidate cache entries for the task T that owns Any_Stack.
|
||||
-- This causes the Set_Stack_Info function to be called during
|
||||
-- the next stack check done by T. This can be used to interrupt
|
||||
-- task T asynchronously.
|
||||
-- Stack_Check should be called in loops for this to work reliably.
|
||||
|
||||
function Stack_Check (Stack_Address : System.Address) return Stack_Access;
|
||||
-- This version of Stack_Check should not be inlined.
|
||||
Multi_Processor : constant Boolean := False; -- Not supported yet
|
||||
|
||||
private
|
||||
|
||||
|
|
@ -92,14 +71,8 @@ private
|
|||
Size => 0);
|
||||
-- Use explicit assignment to avoid elaboration code (call to init proc).
|
||||
|
||||
Null_Stack : constant Stack_Access := Null_Stack_Info'Access;
|
||||
Null_Stack : constant Stack_Access := Null_Stack_Info'Access;
|
||||
-- Stack_Access value that will return a Stack_Base and Stack_Limit
|
||||
-- that fail any stack check.
|
||||
|
||||
Cache : aliased Stack_Access := Null_Stack;
|
||||
|
||||
pragma Export (C, Cache, "_gnat_stack_cache");
|
||||
pragma Export (C, Stack_Check, "_gnat_stack_check");
|
||||
pragma Export (C, Set_Stack_Size, "__gnat_set_stack_size");
|
||||
|
||||
end System.Stack_Checking;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,273 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2004 Free Software Foundation, 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. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the general implementation of this package. There is a VxWorks
|
||||
-- specific version of this package (5zstchop.adb). This file should
|
||||
-- be kept synchronized with it.
|
||||
|
||||
pragma Restrictions (No_Elaboration_Code);
|
||||
-- We want to guarantee the absence of elaboration code because the
|
||||
-- binder does not handle references to this package.
|
||||
|
||||
with Ada.Exceptions;
|
||||
|
||||
with System.Storage_Elements; use System.Storage_Elements;
|
||||
with System.Parameters; use System.Parameters;
|
||||
with System.Soft_Links;
|
||||
with System.CRTL;
|
||||
|
||||
package body System.Stack_Checking.Operations is
|
||||
|
||||
Kilobyte : constant := 1024;
|
||||
|
||||
function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
|
||||
|
||||
-- The function Set_Stack_Info is the actual function that updates
|
||||
-- the cache containing a pointer to the Stack_Info. It may also
|
||||
-- be used for detecting asynchronous abort in combination with
|
||||
-- Invalidate_Self_Cache.
|
||||
|
||||
-- Set_Stack_Info should do the following things in order:
|
||||
-- 1) Get the Stack_Access value for the current task
|
||||
-- 2) Set Stack.all to the value obtained in 1)
|
||||
-- 3) Optionally Poll to check for asynchronous abort
|
||||
|
||||
-- This order is important because if at any time a write to
|
||||
-- the stack cache is pending, that write should be followed
|
||||
-- by a Poll to prevent loosing signals.
|
||||
|
||||
-- Note: This function must be compiled with Polling turned off
|
||||
|
||||
-- Note: on systems like VxWorks and OS/2 with real thread-local storage,
|
||||
-- Set_Stack_Info should return an access value for such local
|
||||
-- storage. In those cases the cache will always be up-to-date.
|
||||
|
||||
-- The following constants should be imported from some system-specific
|
||||
-- constants package. The constants must be static for performance reasons.
|
||||
|
||||
----------------------------
|
||||
-- Invalidate_Stack_Cache --
|
||||
----------------------------
|
||||
|
||||
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
|
||||
pragma Warnings (Off, Any_Stack);
|
||||
begin
|
||||
Cache := Null_Stack;
|
||||
end Invalidate_Stack_Cache;
|
||||
|
||||
--------------------
|
||||
-- Set_Stack_Info --
|
||||
--------------------
|
||||
|
||||
function Set_Stack_Info
|
||||
(Stack : access Stack_Access) return Stack_Access
|
||||
is
|
||||
type Frame_Mark is null record;
|
||||
Frame_Location : Frame_Mark;
|
||||
Frame_Address : constant Address := Frame_Location'Address;
|
||||
|
||||
My_Stack : Stack_Access;
|
||||
Limit_Chars : System.Address;
|
||||
Limit : Integer;
|
||||
|
||||
begin
|
||||
-- The order of steps 1 .. 3 is important, see specification.
|
||||
|
||||
-- 1) Get the Stack_Access value for the current task
|
||||
|
||||
My_Stack := Soft_Links.Get_Stack_Info.all;
|
||||
|
||||
if My_Stack.Base = Null_Address then
|
||||
|
||||
-- First invocation, initialize based on the assumption that
|
||||
-- there are Environment_Stack_Size bytes available beyond
|
||||
-- the current frame address.
|
||||
|
||||
if My_Stack.Size = 0 then
|
||||
My_Stack.Size := Storage_Offset (Default_Env_Stack_Size);
|
||||
|
||||
-- When the environment variable GNAT_STACK_LIMIT is set,
|
||||
-- set Environment_Stack_Size to that number of kB.
|
||||
|
||||
Limit_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
|
||||
|
||||
if Limit_Chars /= Null_Address then
|
||||
Limit := System.CRTL.atoi (Limit_Chars);
|
||||
|
||||
if Limit >= 0 then
|
||||
My_Stack.Size := Storage_Offset (Limit) * Kilobyte;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
My_Stack.Base := Frame_Address;
|
||||
|
||||
if Stack_Grows_Down then
|
||||
|
||||
-- Prevent wrap-around on too big stack sizes
|
||||
|
||||
My_Stack.Limit := My_Stack.Base - My_Stack.Size;
|
||||
|
||||
if My_Stack.Limit > My_Stack.Base then
|
||||
My_Stack.Limit := Address'First;
|
||||
end if;
|
||||
|
||||
else
|
||||
My_Stack.Limit := My_Stack.Base + My_Stack.Size;
|
||||
|
||||
-- Prevent wrap-around on too big stack sizes
|
||||
|
||||
if My_Stack.Limit < My_Stack.Base then
|
||||
My_Stack.Limit := Address'Last;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- 2) Set Stack.all to the value obtained in 1)
|
||||
|
||||
Stack.all := My_Stack;
|
||||
|
||||
-- 3) Optionally Poll to check for asynchronous abort
|
||||
|
||||
if Soft_Links.Check_Abort_Status.all /= 0 then
|
||||
raise Standard'Abort_Signal;
|
||||
end if;
|
||||
|
||||
return My_Stack; -- Never trust the cached value, but return local copy!
|
||||
end Set_Stack_Info;
|
||||
|
||||
--------------------
|
||||
-- Set_Stack_Size --
|
||||
--------------------
|
||||
|
||||
-- Specify the stack size for the current frame.
|
||||
|
||||
procedure Set_Stack_Size
|
||||
(Stack_Size : System.Storage_Elements.Storage_Offset)
|
||||
is
|
||||
My_Stack : Stack_Access;
|
||||
Frame_Address : constant System.Address := My_Stack'Address;
|
||||
|
||||
begin
|
||||
My_Stack := Stack_Check (Frame_Address);
|
||||
|
||||
if Stack_Grows_Down then
|
||||
My_Stack.Limit := My_Stack.Base - Stack_Size;
|
||||
else
|
||||
My_Stack.Limit := My_Stack.Base + Stack_Size;
|
||||
end if;
|
||||
end Set_Stack_Size;
|
||||
|
||||
-----------------
|
||||
-- Stack_Check --
|
||||
-----------------
|
||||
|
||||
function Stack_Check
|
||||
(Stack_Address : System.Address) return Stack_Access
|
||||
is
|
||||
type Frame_Marker is null record;
|
||||
Marker : Frame_Marker;
|
||||
Cached_Stack : constant Stack_Access := Cache;
|
||||
Frame_Address : constant System.Address := Marker'Address;
|
||||
|
||||
begin
|
||||
-- This function first does a "cheap" check which is correct
|
||||
-- if it succeeds. In case of failure, the full check is done.
|
||||
-- Ideally the cheap check should be done in an optimized manner,
|
||||
-- or be inlined.
|
||||
|
||||
if (Stack_Grows_Down and then
|
||||
(Frame_Address <= Cached_Stack.Base
|
||||
and
|
||||
Stack_Address > Cached_Stack.Limit))
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
(Frame_Address >= Cached_Stack.Base
|
||||
and
|
||||
Stack_Address < Cached_Stack.Limit))
|
||||
then
|
||||
-- Cached_Stack is valid as it passed the stack check
|
||||
return Cached_Stack;
|
||||
end if;
|
||||
|
||||
Full_Check :
|
||||
declare
|
||||
My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
|
||||
-- At this point Stack.all might already be invalid, so
|
||||
-- it is essential to use our local copy of Stack!
|
||||
|
||||
begin
|
||||
if (Stack_Grows_Down and then
|
||||
(not (Frame_Address <= My_Stack.Base)))
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
(not (Frame_Address >= My_Stack.Base)))
|
||||
then
|
||||
-- The returned Base is lower than the stored one,
|
||||
-- so assume that the original one wasn't right and use the
|
||||
-- current Frame_Address as new one. This allows initializing
|
||||
-- Base with the Frame_Address as approximation.
|
||||
-- During initialization the Frame_Address will be close to
|
||||
-- the stack base anyway: the difference should be compensated
|
||||
-- for in the stack reserve.
|
||||
|
||||
My_Stack.Base := Frame_Address;
|
||||
end if;
|
||||
|
||||
if (Stack_Grows_Down and then
|
||||
Stack_Address < My_Stack.Limit)
|
||||
or else
|
||||
(not Stack_Grows_Down and then
|
||||
Stack_Address > My_Stack.Limit)
|
||||
then
|
||||
Ada.Exceptions.Raise_Exception
|
||||
(E => Storage_Error'Identity,
|
||||
Message => "stack overflow detected");
|
||||
end if;
|
||||
|
||||
return My_Stack;
|
||||
end Full_Check;
|
||||
end Stack_Check;
|
||||
|
||||
------------------------
|
||||
-- Update_Stack_Cache --
|
||||
------------------------
|
||||
|
||||
procedure Update_Stack_Cache (Stack : Stack_Access) is
|
||||
begin
|
||||
if not Multi_Processor then
|
||||
Cache := Stack;
|
||||
end if;
|
||||
end Update_Stack_Cache;
|
||||
|
||||
end System.Stack_Checking.Operations;
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2004 Free Software Foundation, 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. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides a implementation of stack checking operations
|
||||
-- using comparison with stack base and limit.
|
||||
|
||||
pragma Restrictions (No_Elaboration_Code);
|
||||
-- We want to guarantee the absence of elaboration code because the
|
||||
-- binder does not handle references to this package.
|
||||
|
||||
with System.Storage_Elements;
|
||||
|
||||
pragma Polling (Off);
|
||||
-- Turn off polling, we do not want polling to take place during stack
|
||||
-- checking operations. It causes infinite loops and other problems.
|
||||
|
||||
package System.Stack_Checking.Operations is
|
||||
procedure Set_Stack_Size
|
||||
(Stack_Size : System.Storage_Elements.Storage_Offset);
|
||||
-- Specify the stack size for the current task.
|
||||
|
||||
procedure Update_Stack_Cache (Stack : Stack_Access);
|
||||
-- Set the stack cache for the current task. Note that this is only
|
||||
-- for optimization purposes, nothing can be assumed about the
|
||||
-- contents of the cache at any time, see Set_Stack_Info.
|
||||
|
||||
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access);
|
||||
-- Invalidate cache entries for the task T that owns Any_Stack.
|
||||
-- This causes the Set_Stack_Info function to be called during
|
||||
-- the next stack check done by T. This can be used to interrupt
|
||||
-- task T asynchronously.
|
||||
-- Stack_Check should be called in loops for this to work reliably.
|
||||
|
||||
function Stack_Check (Stack_Address : System.Address) return Stack_Access;
|
||||
-- This version of Stack_Check should not be inlined.
|
||||
|
||||
private
|
||||
|
||||
Cache : aliased Stack_Access := Null_Stack;
|
||||
|
||||
pragma Export (C, Cache, "_gnat_stack_cache");
|
||||
pragma Export (C, Stack_Check, "_gnat_stack_check");
|
||||
|
||||
end System.Stack_Checking.Operations;
|
||||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
|
|
@ -170,6 +170,7 @@ package body Scn is
|
|||
begin
|
||||
while Source (Scan_Ptr) /= CR
|
||||
and then Source (Scan_Ptr) /= LF
|
||||
and then Source (Scan_Ptr) /= EOF
|
||||
loop
|
||||
Scan_Ptr := Scan_Ptr + 1;
|
||||
end loop;
|
||||
|
|
@ -210,21 +211,27 @@ package body Scn is
|
|||
|
||||
Check_End_Of_Line;
|
||||
|
||||
declare
|
||||
Physical : Boolean;
|
||||
if Source (Scan_Ptr) /= EOF then
|
||||
|
||||
begin
|
||||
Skip_Line_Terminators (Scan_Ptr, Physical);
|
||||
-- We have to take into account a degenerate case when the source
|
||||
-- file contains only comments and no Ada code.
|
||||
|
||||
-- If we are at start of physical line, update scan pointers
|
||||
-- to reflect the start of the new line.
|
||||
declare
|
||||
Physical : Boolean;
|
||||
|
||||
if Physical then
|
||||
Current_Line_Start := Scan_Ptr;
|
||||
Start_Column := Scanner.Set_Start_Column;
|
||||
First_Non_Blank_Location := Scan_Ptr;
|
||||
end if;
|
||||
end;
|
||||
begin
|
||||
Skip_Line_Terminators (Scan_Ptr, Physical);
|
||||
|
||||
-- If we are at start of physical line, update scan pointers
|
||||
-- to reflect the start of the new line.
|
||||
|
||||
if Physical then
|
||||
Current_Line_Start := Scan_Ptr;
|
||||
Start_Column := Scanner.Set_Start_Column;
|
||||
First_Non_Blank_Location := Scan_Ptr;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end loop;
|
||||
end Determine_License;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1999-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- --
|
||||
|
|
@ -472,9 +472,38 @@ package body Sem_Warn is
|
|||
end loop;
|
||||
|
||||
-- Here we issue the warning, all checks completed
|
||||
-- If the unset reference is prefix of a selected
|
||||
-- component that comes from source, mention the
|
||||
-- component as well. If the selected component comes
|
||||
-- from expansion, all we know is that the entity is
|
||||
-- not fully initialized at the point of the reference.
|
||||
-- Locate an unintialized component to get a better
|
||||
-- error message.
|
||||
|
||||
if Nkind (Parent (UR)) = N_Selected_Component then
|
||||
Error_Msg_Node_2 := Selector_Name (Parent (UR));
|
||||
|
||||
if not Comes_From_Source (Parent (UR)) then
|
||||
declare
|
||||
Comp : Entity_Id;
|
||||
|
||||
begin
|
||||
Comp := First_Entity (Etype (E1));
|
||||
while Present (Comp) loop
|
||||
if Ekind (Comp) = E_Component
|
||||
and then Nkind (Parent (Comp)) =
|
||||
N_Component_Declaration
|
||||
and then No (Expression (Parent (Comp)))
|
||||
then
|
||||
Error_Msg_Node_2 := Comp;
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next_Entity (Comp);
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Error_Msg_N
|
||||
("`&.&` may be referenced before it has a value?",
|
||||
UR);
|
||||
|
|
|
|||
Loading…
Reference in New Issue