[Ada] Clean up handling of "big" pointers
Arnaud Charlet
charlet@adacore.com
Thu Apr 10 07:27:00 GMT 2008
Tested on i686-linux, committed on trunk
Big pointers are pointers to giant array types, where we never actually
allocate an object of the type, but instead obtain pointers externally,
e.g. via unchecked conversion, and want to make sure the bounds are big
enough. Such types are used throughout the compiler and run time.
This patch does two cleanups:
Add storage_size of 0 to all such big pointer types, since it is
never right to try to allocate, and it is nice to get warnings.
Move Big_String declarations to types.ads, since this declaration
was repeated in several compiler units.
The following program generates a useful warning as a result of
this change:
1. with GNAT.Table;
2. procedure Bigptr is
3. package T is new GNAT.Table (Natural, Natural, 1, 100, 100);
4. use T;
5.
6. R : Table_Ptr := new Big_Table_Type;
|
>>> warning: allocation from empty storage pool
>>> warning: Storage_Error will be raised at run time
7. begin
8. null;
9. end;
Also, never delete/re-create a temporary file:
There were cases when the compiler was deleting a temporary mapping file
to immediately recreate it with no content. This gave a short window for
another process to create a temporary file with the same name, leading
to the two processes to share the same file, with damaging consequences.
This fix ensures that the mapping file is not deleted, but reopened
truncated.
There is no easy test for this, as the conditions are extremely time
sensitive.
2008-04-08 Robert Dewar <dewar@adacore.com>
* back_end.adb: Remove Big_String_Ptr declarations (now in Types)
* errout.adb: Remove Big_String_Ptr declarations (now in Types)
Change name Is_Style_Msg to Is_Style_Or_Info_Msg
* fmap.adb: Remove Big_String declarations (now in Types)
(No_Mapping_File): New Boolean global variable
(Initialize): When mapping file cannot be read, set No_Mapping_File to
False.
(Update_Mapping_File): Do nothing if No_Mapping_File is True. If the
tables were empty before adding entries, open the mapping file
with Truncate = True, instead of delete/re-create.
* fname-sf.adb: Remove Big_String declarations (now in Types)
* s-strcom.adb, g-dyntab.ads, g-table.ads, s-carsi8.adb,
s-stalib.ads, s-carun8.adb: Add zero size Storage_Size clauses for big
pointer types
* table.ads: Add for Table_Ptr'Storage_Size use 0
* types.ads: Add Big_String declarations
Add Size_Clause of zero for big pointer types
-------------- next part --------------
Index: back_end.adb
===================================================================
--- back_end.adb (revision 133957)
+++ back_end.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -125,10 +125,7 @@ package body Back_End is
procedure Scan_Compiler_Arguments is
Next_Arg : Pos := 1;
- subtype Big_String is String (Positive);
- type BSP is access Big_String;
-
- type Arg_Array is array (Nat) of BSP;
+ type Arg_Array is array (Nat) of Big_String_Ptr;
type Arg_Array_Ptr is access Arg_Array;
flag_stack_check : Int;
@@ -235,9 +232,10 @@ package body Back_End is
while Next_Arg < save_argc loop
Look_At_Arg : declare
- Argv_Ptr : constant BSP := save_argv (Next_Arg);
- Argv_Len : constant Nat := Len_Arg (Next_Arg);
- Argv : constant String := Argv_Ptr (1 .. Natural (Argv_Len));
+ Argv_Ptr : constant Big_String_Ptr := save_argv (Next_Arg);
+ Argv_Len : constant Nat := Len_Arg (Next_Arg);
+ Argv : constant String :=
+ Argv_Ptr (1 .. Natural (Argv_Len));
begin
-- If the previous switch has set the Output_File_Name_Present
Index: errout.adb
===================================================================
--- errout.adb (revision 133957)
+++ errout.adb (working copy)
@@ -50,8 +50,6 @@ with Stand; use Stand;
with Style;
with Uname; use Uname;
-with Unchecked_Conversion;
-
package body Errout is
Errors_Must_Be_Ignored : Boolean := False;
@@ -797,7 +795,8 @@ package body Errout is
-- If error message line length set, and this is a continuation message
-- then all we do is to append the text to the text of the last message
- -- with a comma space separator.
+ -- with a comma space separator (eliminating a possible (style) or
+ -- info prefix).
if Error_Msg_Line_Length /= 0
and then Continuation
@@ -808,6 +807,7 @@ package body Errout is
Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
Newm : String (1 .. Oldm'Last + 2 + Msglen);
Newl : Natural;
+ M : Natural;
begin
-- First copy old message to new one and free it
@@ -816,6 +816,16 @@ package body Errout is
Newl := Oldm'Length;
Free (Oldm);
+ -- Remove (style) or info: at start of message
+
+ if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
+ M := 9;
+ elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
+ M := 7;
+ else
+ M := 1;
+ end if;
+
-- Now deal with separation between messages. Normally this
-- is simply comma space, but there are some special cases.
@@ -830,16 +840,16 @@ package body Errout is
-- successive parenthetical remarks into a single one with
-- separating commas).
- elsif Msg_Buffer (1) = '(' and then Msg_Buffer (Msglen) = ')' then
+ elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then
-- Case where existing message ends in right paren, remove
-- and separate parenthetical remarks with a comma.
if Newm (Newl) = ')' then
Newm (Newl) := ',';
- Msg_Buffer (1) := ' ';
+ Msg_Buffer (M) := ' ';
- -- Case where we are adding new parenthetical comment
+ -- Case where we are adding new parenthetical comment
else
Newl := Newl + 1;
@@ -855,8 +865,9 @@ package body Errout is
-- Append new message
- Newm (Newl + 1 .. Newl + Msglen) := Msg_Buffer (1 .. Msglen);
- Newl := Newl + Msglen;
+ Newm (Newl + 1 .. Newl + Msglen - M + 1) :=
+ Msg_Buffer (M .. Msglen);
+ Newl := Newl + Msglen - M + 1;
Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
end;
@@ -956,9 +967,9 @@ package body Errout is
and then Compiler_State = Parsing
and then not All_Errors_Mode
then
- -- Don't delete unconditional messages and at this stage,
- -- don't delete continuation lines (we attempted to delete
- -- those earlier if the parent message was deleted.
+ -- Don't delete unconditional messages and at this stage, don't
+ -- delete continuation lines (we attempted to delete those earlier
+ -- if the parent message was deleted.
if not Errors.Table (Cur_Msg).Uncond
and then not Continuation
@@ -1011,10 +1022,9 @@ package body Errout is
-- Bump appropriate statistics count
- if Errors.Table (Cur_Msg).Warn
- or else Errors.Table (Cur_Msg).Style
- then
+ if Errors.Table (Cur_Msg).Warn or Errors.Table (Cur_Msg).Style then
Warnings_Detected := Warnings_Detected + 1;
+
else
Total_Errors_Detected := Total_Errors_Detected + 1;
@@ -1113,7 +1123,7 @@ package body Errout is
Last_Killed := True;
end if;
- if not Is_Warning_Msg and then not Is_Style_Msg then
+ if not (Is_Warning_Msg or Is_Style_Msg) then
Set_Posted (N);
end if;
end Error_Msg_NEL;
@@ -1927,9 +1937,9 @@ package body Errout is
and then Errors.Table (E).Optr = Loc
- -- Don't remove if not warning message. Note that we do not
- -- remove style messages here. They are warning messages but
- -- not ones we want removed in this context.
+ -- Don't remove if not warning/info message. Note that we do
+ -- not remove style messages here. They are warning messages
+ -- but not ones we want removed in this context.
and then Errors.Table (E).Warn
@@ -1976,12 +1986,11 @@ package body Errout is
and then Original_Node (N) /= N
and then No (Condition (N))
then
- -- Warnings may have been posted on subexpressions of
- -- the original tree. We place the original node back
- -- on the tree to remove those warnings, whose sloc
- -- do not match those of any node in the current tree.
- -- Given that we are in unreachable code, this modification
- -- to the tree is harmless.
+ -- Warnings may have been posted on subexpressions of the original
+ -- tree. We place the original node back on the tree to remove
+ -- those warnings, whose sloc do not match those of any node in
+ -- the current tree. Given that we are in unreachable code, this
+ -- modification to the tree is harmless.
declare
Status : Traverse_Final_Result;
@@ -2022,7 +2031,6 @@ package body Errout is
begin
if Is_Non_Empty_List (L) then
Stat := First (L);
-
while Present (Stat) loop
Remove_Warning_Messages (Stat);
Next (Stat);
@@ -2038,12 +2046,6 @@ package body Errout is
(Identifier_Name : System.Address;
File_Name : System.Address)
is
- type Big_String is array (Positive) of Character;
- type Big_String_Ptr is access all Big_String;
-
- function To_Big_String_Ptr is new Unchecked_Conversion
- (System.Address, Big_String_Ptr);
-
Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
Flen : Natural;
@@ -2083,7 +2085,7 @@ package body Errout is
for J in Name_Buffer'Range loop
Name_Buffer (J) := Ident (J);
- if Name_Buffer (J) = ASCII.Nul then
+ if Name_Buffer (J) = ASCII.NUL then
Name_Len := J - 1;
exit;
end if;
Index: fmap.adb
===================================================================
--- fmap.adb (revision 133957)
+++ fmap.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2008, 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- --
@@ -37,8 +37,10 @@ with GNAT.HTable;
package body Fmap is
- subtype Big_String is String (Positive);
- type Big_String_Ptr is access all Big_String;
+ No_Mapping_File : Boolean := False;
+ -- Set to True when the specified mapping file cannot be read in
+ -- procedure Initialize, so that no attempt is made to oopen the mapping
+ -- file in procedure Update_Mapping_File.
function To_Big_String_Ptr is new Unchecked_Conversion
(Source_Buffer_Ptr, Big_String_Ptr);
@@ -301,6 +303,7 @@ package body Fmap is
Write_Str ("warning: could not read mapping file """);
Write_Str (File_Name);
Write_Line ("""");
+ No_Mapping_File := True;
else
BS := To_Big_String_Ptr (Src);
@@ -479,27 +482,17 @@ package body Fmap is
-- Start of Update_Mapping_File
begin
+ -- If the mapping file could not be read, then it will not be possible
+ -- to update it.
+ if No_Mapping_File then
+ return;
+ end if;
-- Only Update if there are new entries in the mappings
if Last_In_Table < File_Mapping.Last then
- -- If the tables have been emptied, recreate the file.
- -- Otherwise, append to it.
-
- if Last_In_Table = 0 then
- declare
- Discard : Boolean;
- pragma Warnings (Off, Discard);
- begin
- Delete_File (File_Name, Discard);
- end;
-
- File := Create_File (File_Name, Binary);
-
- else
- File := Open_Read_Write (Name => File_Name, Fmode => Binary);
- end if;
+ File := Open_Read_Write (Name => File_Name, Fmode => Binary);
if File /= Invalid_FD then
if Last_In_Table > 0 then
Index: fname-sf.adb
===================================================================
--- fname-sf.adb (revision 133957)
+++ fname-sf.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -34,9 +34,6 @@ with Unchecked_Conversion;
package body Fname.SF is
- subtype Big_String is String (Positive);
- type Big_String_Ptr is access all Big_String;
-
function To_Big_String_Ptr is new Unchecked_Conversion
(Source_Buffer_Ptr, Big_String_Ptr);
Index: s-strcom.adb
===================================================================
--- s-strcom.adb (revision 133957)
+++ s-strcom.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2008, 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- --
@@ -44,6 +44,7 @@ package body System.String_Compare is
type Big_Words is array (Natural) of Word;
type Big_Words_Ptr is access Big_Words;
+ for Big_Words_Ptr'Storage_Size use 0;
-- Array type used to access by words
type Byte is mod 2 ** 8;
@@ -51,6 +52,7 @@ package body System.String_Compare is
type Big_Bytes is array (Natural) of Byte;
type Big_Bytes_Ptr is access Big_Bytes;
+ for Big_Bytes_Ptr'Storage_Size use 0;
-- Array type used to access by bytes
function To_Big_Words is new
Index: g-dyntab.ads
===================================================================
--- g-dyntab.ads (revision 133957)
+++ g-dyntab.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2006, AdaCore --
+-- Copyright (C) 2000-2008, AdaCore --
-- --
-- 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- --
@@ -91,17 +91,19 @@ package GNAT.Dynamic_Tables is
type Table_Type is
array (Table_Index_Type range <>) of Table_Component_Type;
-
subtype Big_Table_Type is
Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
- -- We work with pointers to a bogus array type that is constrained
- -- with the maximum possible range bound. This means that the pointer
- -- is a thin pointer, which is more efficient. Since subscript checks
- -- in any case must be on the logical, rather than physical bounds,
- -- safety is not compromised by this approach.
+ -- We work with pointers to a bogus array type that is constrained with
+ -- the maximum possible range bound. This means that the pointer is a thin
+ -- pointer, which is more efficient. Since subscript checks in any case
+ -- must be on the logical, rather than physical bounds, safety is not
+ -- compromised by this approach. These types should not be used by the
+ -- client.
type Table_Ptr is access all Big_Table_Type;
- -- The table is actually represented as a pointer to allow reallocation
+ for Table_Ptr'Storage_Size use 0;
+ -- The table is actually represented as a pointer to allow reallocation.
+ -- This type should not be used by the client.
type Table_Private is private;
-- Table private data that is not exported in Instance
Index: g-table.ads
===================================================================
--- g-table.ads (revision 133957)
+++ g-table.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2007, AdaCore --
+-- Copyright (C) 1998-2008, AdaCore --
-- --
-- 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- --
@@ -105,17 +105,19 @@ package GNAT.Table is
type Table_Type is
array (Table_Index_Type range <>) of Table_Component_Type;
-
subtype Big_Table_Type is
Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
-- We work with pointers to a bogus array type that is constrained
-- with the maximum possible range bound. This means that the pointer
-- is a thin pointer, which is more efficient. Since subscript checks
-- in any case must be on the logical, rather than physical bounds,
- -- safety is not compromised by this approach.
+ -- safety is not compromised by this approach. These types should never
+ -- be used by the client.
type Table_Ptr is access all Big_Table_Type;
- -- The table is actually represented as a pointer to allow reallocation
+ for Table_Ptr'Storage_Size use 0;
+ -- The table is actually represented as a pointer to allow reallocation.
+ -- This type should never be used by the client.
Table : aliased Table_Ptr := null;
-- The table itself. The lower bound is the value of Low_Bound.
Index: s-carsi8.adb
===================================================================
--- s-carsi8.adb (revision 133957)
+++ s-carsi8.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2008, 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- --
@@ -42,6 +42,7 @@ package body System.Compare_Array_Signed
type Big_Words is array (Natural) of Word;
type Big_Words_Ptr is access Big_Words;
+ for Big_Words_Ptr'Storage_Size use 0;
-- Array type used to access by words
type Byte is range -128 .. +127;
@@ -50,6 +51,7 @@ package body System.Compare_Array_Signed
type Big_Bytes is array (Natural) of Byte;
type Big_Bytes_Ptr is access Big_Bytes;
+ for Big_Bytes_Ptr'Storage_Size use 0;
-- Array type used to access by bytes
function To_Big_Words is new
Index: s-carun8.adb
===================================================================
--- s-carun8.adb (revision 133957)
+++ s-carun8.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2008, 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- --
@@ -46,6 +46,7 @@ package body System.Compare_Array_Unsign
type Big_Words is array (Natural) of Word;
type Big_Words_Ptr is access Big_Words;
+ for Big_Words_Ptr'Storage_Size use 0;
-- Array type used to access by words
type Byte is mod 2 ** 8;
@@ -53,6 +54,7 @@ package body System.Compare_Array_Unsign
type Big_Bytes is array (Natural) of Byte;
type Big_Bytes_Ptr is access Big_Bytes;
+ for Big_Bytes_Ptr'Storage_Size use 0;
-- Array type used to access by bytes
function To_Big_Words is new
Index: table.ads
===================================================================
--- table.ads (revision 133957)
+++ table.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -117,6 +117,7 @@ package Table is
-- safety is not compromised by this approach.
type Table_Ptr is access all Big_Table_Type;
+ for Table_Ptr'Storage_Size use 0;
-- The table is actually represented as a pointer to allow reallocation
Table : aliased Table_Ptr := null;
Index: types.ads
===================================================================
--- types.ads (revision 133957)
+++ types.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -47,6 +47,8 @@
-- 2s-complement. If there are any machines for which this is not a correct
-- assumption, a significant number of changes will be required!
+with System;
+with Unchecked_Conversion;
with Unchecked_Deallocation;
package Types is
@@ -123,6 +125,15 @@ package Types is
procedure Free is new Unchecked_Deallocation (String, String_Ptr);
-- Procedure for freeing dynamically allocated String values
+ subtype Big_String is String (Positive);
+ type Big_String_Ptr is access all Big_String;
+ for Big_String_Ptr'Storage_Size use 0;
+ -- Virtual type for handling imported big strings
+
+ function To_Big_String_Ptr is
+ new Unchecked_Conversion (System.Address, Big_String_Ptr);
+ -- Used to obtain Big_String_Ptr values from external addresses
+
subtype Word_Hex_String is String (1 .. 8);
-- Type used to represent Word value as 8 hex digits, with lower case
-- letters for the alphabetic cases.
@@ -191,6 +202,7 @@ package Types is
-- type Source_Buffer_Ptr, see Osint.Read_Source_File for details.
type Source_Buffer_Ptr is access all Big_Source_Buffer;
+ for Source_Buffer_Ptr'Storage_Size use 0;
-- Pointer to source buffer. We use virtual origin addressing for source
-- buffers, with thin pointers. The pointer points to a virtual instance
-- of type Big_Source_Buffer, where the actual type is in fact of type
More information about the Gcc-patches
mailing list