diff options
| -rw-r--r-- | gcc/ada/5ataprop.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/5atpopsp.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/5ftaprop.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/5htaprop.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/5itaprop.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/5qsystem.ads | 236 | ||||
| -rw-r--r-- | gcc/ada/5staprop.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/5vtaprop.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/5wtaprop.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/5xcrtl.ads | 159 | ||||
| -rw-r--r-- | gcc/ada/5zstchop.adb | 255 | ||||
| -rw-r--r-- | gcc/ada/7staprop.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/ChangeLog | 85 | ||||
| -rw-r--r-- | gcc/ada/Make-lang.in | 2 | ||||
| -rw-r--r-- | gcc/ada/Makefile.in | 54 | ||||
| -rw-r--r-- | gcc/ada/Makefile.rtl | 1 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 1 | ||||
| -rw-r--r-- | gcc/ada/init.c | 14 | ||||
| -rw-r--r-- | gcc/ada/prj-env.adb | 266 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/prj-proc.adb | 105 | ||||
| -rw-r--r-- | gcc/ada/prj-proc.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/prj.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/s-stache.adb | 232 | ||||
| -rw-r--r-- | gcc/ada/s-stache.ads | 45 | ||||
| -rw-r--r-- | gcc/ada/s-stchop.adb | 273 | ||||
| -rw-r--r-- | gcc/ada/s-stchop.ads | 74 | ||||
| -rw-r--r-- | gcc/ada/scn.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 31 |
30 files changed, 1425 insertions, 548 deletions
diff --git a/gcc/ada/5ataprop.adb b/gcc/ada/5ataprop.adb index 20821fda298..1fa1c22fa4b 100644 --- a/gcc/ada/5ataprop.adb +++ b/gcc/ada/5ataprop.adb @@ -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; --------------- diff --git a/gcc/ada/5atpopsp.adb b/gcc/ada/5atpopsp.adb index d80cf0464d7..c1c0815c790 100644 --- a/gcc/ada/5atpopsp.adb +++ b/gcc/ada/5atpopsp.adb @@ -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 diff --git a/gcc/ada/5ftaprop.adb b/gcc/ada/5ftaprop.adb index acedd7151ef..6eb6e2ad52a 100644 --- a/gcc/ada/5ftaprop.adb +++ b/gcc/ada/5ftaprop.adb @@ -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; --------------- diff --git a/gcc/ada/5htaprop.adb b/gcc/ada/5htaprop.adb index d917dda1070..1aaf3c26c56 100644 --- a/gcc/ada/5htaprop.adb +++ b/gcc/ada/5htaprop.adb @@ -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; --------------- diff --git a/gcc/ada/5itaprop.adb b/gcc/ada/5itaprop.adb index 84eb3514f83..6ab670f9722 100644 --- a/gcc/ada/5itaprop.adb +++ b/gcc/ada/5itaprop.adb @@ -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; --------------- diff --git a/gcc/ada/5qsystem.ads b/gcc/ada/5qsystem.ads new file mode 100644 index 00000000000..4d17cdacde5 --- /dev/null +++ b/gcc/ada/5qsystem.ads @@ -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; diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb index dcabcd12135..0242b0aefa8 100644 --- a/gcc/ada/5staprop.adb +++ b/gcc/ada/5staprop.adb @@ -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; --------------- diff --git a/gcc/ada/5vtaprop.adb b/gcc/ada/5vtaprop.adb index 8603f8bdf95..fd6c98baefa 100644 --- a/gcc/ada/5vtaprop.adb +++ b/gcc/ada/5vtaprop.adb @@ -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; diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb index 755872bcd84..1e24de0c6ec 100644 --- a/gcc/ada/5wtaprop.adb +++ b/gcc/ada/5wtaprop.adb @@ -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; diff --git a/gcc/ada/5xcrtl.ads b/gcc/ada/5xcrtl.ads new file mode 100644 index 00000000000..dd3292e384a --- /dev/null +++ b/gcc/ada/5xcrtl.ads @@ -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; diff --git a/gcc/ada/5zstchop.adb b/gcc/ada/5zstchop.adb new file mode 100644 index 00000000000..b19bb56f274 --- /dev/null +++ b/gcc/ada/5zstchop.adb @@ -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; diff --git a/gcc/ada/7staprop.adb b/gcc/ada/7staprop.adb index e79d39db189..f5bc6174ccb 100644 --- a/gcc/ada/7staprop.adb +++ b/gcc/ada/7staprop.adb @@ -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; --------------- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1b923c69e19..5e2af3e2533 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 3b0c016d624..3c0f95bef7b 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -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 \ diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 48b16e45a0a..910411058e7 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -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,32 +1150,28 @@ 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 = \ a-caldel.adb<4vcaldel.adb \ @@ -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) \ diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 512310aa88f..f2499814421 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -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) \ diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index c99c1f0fbec..0b27ada7ef4 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -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__)) \ diff --git a/gcc/ada/init.c b/gcc/ada/init.c index c3742563299..61981725eaa 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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 */ } /********************************/ diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index d7a47b0a601..f974e0f3c12 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -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); - Current := Source_Dir.Next; - end loop; - end Add_To_Path_File; + Add_It := True; - procedure Add_To_Path_File - (Path : String; - Path_File : File_Descriptor) - is - Line : String (1 .. Path'Length + 1); - Len : Natural; + -- Check if the source directory is already in the table - begin - Line (1 .. Path'Length) := Path; - Line (Line'Last) := ASCII.LF; - Len := Write (Path_File, Line (1)'Address, Line'Length); + for Index in 1 .. Source_Paths.Last loop + -- If it is already, no need to add it - if Len /= Line'Length then - Prj.Com.Fail ("disk full"); - end if; - end Add_To_Path_File; + 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_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); + declare + Data : constant Project_Data := Projects.Table (Project); + List : Project_List := Data.Imported_Projects; + + begin + if Process_Source_Dirs then + + -- Add to path all source directories of this project + -- if there are Ada sources. + + if Projects.Table (Project).Sources_Present then + Add_To_Source_Path (Data.Source_Dirs); + end if; end if; - end if; - if Process_Object_Dirs then + if Process_Object_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 the object directory of this project + -- except if we don't include library project and + -- this is a library project. - 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 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); + if Data.Library then + Add_To_Object_Path (Data.Library_Dir); - begin - Add_To_Path_File (New_Path, Object_FD); - end; + else + -- For a non library project, add the object + -- directory. - 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; + Add_To_Object_Path (Data.Object_Directory); + end if; end if; end if; - end if; - -- Call Add to the project being extended, if any + -- Call Add to the project being extended, if any - if Data.Extends /= No_Project then - Add (Data.Extends); - end if; + if Data.Extends /= No_Project then + Recursive_Add (Data.Extends); + end if; - -- Call Add for each imported project, if any + -- Call Add for each imported project, if any - while List /= Empty_Project_List loop - Add (Project_Lists.Table (List).Project); - List := Project_Lists.Table (List).Next; - end loop; - end; - end if; + 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 diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 7ad849b1a4c..51d5e0e8253 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -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, diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index 63e0f35c707..56ee59fa61f 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/gcc/ada/prj-nmsc.ads @@ -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; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index bb550b1b538..1258e244ee4 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -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; diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads index 0f8ae66446e..99a329f5dff 100644 --- a/gcc/ada/prj-proc.ads +++ b/gcc/ada/prj-proc.ads @@ -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; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 6594b8782ac..0f09236fd8f 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -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; ------------------------ diff --git a/gcc/ada/s-stache.adb b/gcc/ada/s-stache.adb index a784ed154cb..738e3eeb67b 100644 --- a/gcc/ada/s-stache.adb +++ b/gcc/ada/s-stache.adb @@ -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; diff --git a/gcc/ada/s-stache.ads b/gcc/ada/s-stache.ads index f253eb2ac88..932ecf1b3a9 100644 --- a/gcc/ada/s-stache.ads +++ b/gcc/ada/s-stache.ads @@ -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; diff --git a/gcc/ada/s-stchop.adb b/gcc/ada/s-stchop.adb new file mode 100644 index 00000000000..3a1b1e91a07 --- /dev/null +++ b/gcc/ada/s-stchop.adb @@ -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; diff --git a/gcc/ada/s-stchop.ads b/gcc/ada/s-stchop.ads new file mode 100644 index 00000000000..10217204d6f --- /dev/null +++ b/gcc/ada/s-stchop.ads @@ -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; diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index ff0792c2cf0..b1e57079bbf 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -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; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 0d57ac00f66..c6aa3599d5d 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -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); |