#include <Rtapi.h>
#else
#include "mingw32.h"
+
+/* Current code page to use, set in initialize.c. */
+UINT CurrentCodePage;
#endif
#include <sys/utime.h>
TCHAR wfile[GNAT_MAX_PATH_LEN];
TCHAR wdir[GNAT_MAX_PATH_LEN];
- S2WSU (wdir, dir, GNAT_MAX_PATH_LEN);
- S2WSU (wfile, file, GNAT_MAX_PATH_LEN);
+ S2WSC (wdir, dir, GNAT_MAX_PATH_LEN);
+ S2WSC (wfile, file, GNAT_MAX_PATH_LEN);
_stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
_tgetcwd (wdir, *length);
- WS2SU (dir, wdir, GNAT_MAX_PATH_LEN);
+ WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
#elif defined (VMS)
/* Force Unix style, which is what GNAT uses internally. */
char *encoding ATTRIBUTE_UNUSED, int *e_length)
{
#if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
- WS2SU (os_name, (TCHAR *)w_filename, o_length);
+ WS2SC (os_name, (TCHAR *)w_filename, o_length);
*o_length = strlen (os_name);
strcpy (encoding, "encoding=utf8");
*e_length = strlen (encoding);
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
return _tunlink (wpath);
}
#else
{
TCHAR wfrom[GNAT_MAX_PATH_LEN], wto[GNAT_MAX_PATH_LEN];
- S2WSU (wfrom, from, GNAT_MAX_PATH_LEN);
- S2WSU (wto, to, GNAT_MAX_PATH_LEN);
+ S2WSC (wfrom, from, GNAT_MAX_PATH_LEN);
+ S2WSC (wto, to, GNAT_MAX_PATH_LEN);
return _trename (wfrom, wto);
}
#else
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
return _tchdir (wpath);
}
#else
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
return _trmdir (wpath);
}
#else
S2WS (wmode, mode, 10);
- if (encoding == Encoding_UTF8)
+ if (encoding == Encoding_Unspecified)
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
+ else if (encoding == Encoding_UTF8)
S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
else
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
S2WS (wmode, mode, 10);
- if (encoding == Encoding_UTF8)
+ if (encoding == Encoding_Unspecified)
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
+ else if (encoding == Encoding_UTF8)
S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
else
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
}
#else
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_RDWR | o_fmode, PERM);
}
#else
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
}
#else
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
}
#else
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
}
#else
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
- S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
+ S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
}
#else
#elif defined (__MINGW32__)
TCHAR wname[GNAT_MAX_PATH_LEN];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN);
return (DIR*)_topendir (wname);
#else
if (dirent != NULL)
{
- WS2SU (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
+ WS2SC (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
*len = strlen (buffer);
return buffer;
time_t ret = -1;
TCHAR wname[GNAT_MAX_PATH_LEN];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN);
HANDLE h = CreateFile
(wname, GENERIC_READ, FILE_SHARE_READ, 0,
} t_write;
TCHAR wname[GNAT_MAX_PATH_LEN];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN);
HANDLE h = CreateFile
(wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
int name_len;
TCHAR last_char;
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
name_len = _tcslen (wname);
if (name_len > GNAT_MAX_PATH_LEN)
offset the _stat() routine fails on specific files like CON: */
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
#else
struct stat statbuf;
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
GENERIC_MAPPING GenericMapping;
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
GenericMapping.GenericRead = GENERIC_READ;
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
GENERIC_MAPPING GenericMapping;
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
GenericMapping.GenericWrite = GENERIC_WRITE;
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
GENERIC_MAPPING GenericMapping;
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
GenericMapping.GenericExecute = GENERIC_EXECUTE;
#if defined (_WIN32) && !defined (RTX)
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
__gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE);
SetFileAttributes
#if defined (_WIN32) && !defined (RTX)
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
__gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE);
#elif ! defined (__vxworks) && ! defined(__nucleus__)
#if defined (_WIN32) && !defined (RTX)
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
__gnat_set_OWNER_ACL
(wname, DENY_ACCESS,
#if defined (_WIN32) && !defined (RTX)
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
__gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ);
#elif ! defined (__vxworks) && ! defined(__nucleus__)
#if defined (_WIN32) && !defined (RTX)
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
__gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ);
#elif ! defined (__vxworks) && ! defined(__nucleus__)
int wsize = csize * 2;
TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
- S2WSU (wcommand, full_command, wsize);
+ S2WSC (wcommand, full_command, wsize);
free (full_command);
apath_val = alloca (EXPAND_BUFFER_SIZE);
- WS2SU (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
+ WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
return __gnat_locate_exec (exec_name, apath_val);
#else
with Debug; use Debug;
with Nlists; use Nlists;
-with Elists; use Elists;
with Output; use Output;
with Sinput; use Sinput;
with Tree_IO; use Tree_IO;
-with GNAT.HTable; use GNAT.HTable;
-
package body Atree is
---------------
Table_Increment => Alloc.Orig_Nodes_Increment,
Table_Name => "Orig_Nodes");
- ----------------------------------------
- -- Global_Variables for New_Copy_Tree --
- ----------------------------------------
-
- -- These global variables are used by New_Copy_Tree. See description
- -- of the body of this subprogram for details. Global variables can be
- -- safely used by New_Copy_Tree, since there is no case of a recursive
- -- call from the processing inside New_Copy_Tree.
-
- NCT_Hash_Threshhold : constant := 20;
- -- If there are more than this number of pairs of entries in the
- -- map, then Hash_Tables_Used will be set, and the hash tables will
- -- be initialized and used for the searches.
-
- NCT_Hash_Tables_Used : Boolean := False;
- -- Set to True if hash tables are in use
-
- NCT_Table_Entries : Nat;
- -- Count entries in table to see if threshhold is reached
-
- NCT_Hash_Table_Setup : Boolean := False;
- -- Set to True if hash table contains data. We set this True if we
- -- setup the hash table with data, and leave it set permanently
- -- from then on, this is a signal that second and subsequent users
- -- of the hash table must clear the old entries before reuse.
-
- subtype NCT_Header_Num is Int range 0 .. 511;
- -- Defines range of headers in hash tables (512 headers)
-
--------------------------
-- Paren_Count Handling --
--------------------------
Dummy := New_Node (N_Error, No_Location);
Set_Name1 (Error, Error_Name);
Set_Error_Posted (Error, True);
-
- -- Set global variables for New_Copy_Tree
-
- NCT_Hash_Tables_Used := False;
- NCT_Table_Entries := 0;
- NCT_Hash_Table_Setup := False;
end Initialize;
--------------------------
return New_Id;
end New_Copy;
- -------------------
- -- New_Copy_Tree --
- -------------------
-
- -- Our approach here requires a two pass traversal of the tree. The
- -- first pass visits all nodes that eventually will be copied looking
- -- for defining Itypes. If any defining Itypes are found, then they are
- -- copied, and an entry is added to the replacement map. In the second
- -- phase, the tree is copied, using the replacement map to replace any
- -- Itype references within the copied tree.
-
- -- The following hash tables are used if the Map supplied has more
- -- than hash threshhold entries to speed up access to the map. If
- -- there are fewer entries, then the map is searched sequentially
- -- (because setting up a hash table for only a few entries takes
- -- more time than it saves.
-
- function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
- -- Hash function used for hash operations
-
- -------------------
- -- New_Copy_Hash --
- -------------------
-
- function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
- begin
- return Nat (E) mod (NCT_Header_Num'Last + 1);
- end New_Copy_Hash;
-
- ---------------
- -- NCT_Assoc --
- ---------------
-
- -- The hash table NCT_Assoc associates old entities in the table
- -- with their corresponding new entities (i.e. the pairs of entries
- -- presented in the original Map argument are Key-Element pairs).
-
- package NCT_Assoc is new Simple_HTable (
- Header_Num => NCT_Header_Num,
- Element => Entity_Id,
- No_Element => Empty,
- Key => Entity_Id,
- Hash => New_Copy_Hash,
- Equal => Types."=");
-
- ---------------------
- -- NCT_Itype_Assoc --
- ---------------------
-
- -- The hash table NCT_Itype_Assoc contains entries only for those
- -- old nodes which have a non-empty Associated_Node_For_Itype set.
- -- The key is the associated node, and the element is the new node
- -- itself (NOT the associated node for the new node).
-
- package NCT_Itype_Assoc is new Simple_HTable (
- Header_Num => NCT_Header_Num,
- Element => Entity_Id,
- No_Element => Empty,
- Key => Entity_Id,
- Hash => New_Copy_Hash,
- Equal => Types."=");
-
- -- Start of processing for New_Copy_Tree function
-
- function New_Copy_Tree1
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
- is
- Actual_Map : Elist_Id := Map;
- -- This is the actual map for the copy. It is initialized with the
- -- given elements, and then enlarged as required for Itypes that are
- -- copied during the first phase of the copy operation. The visit
- -- procedures add elements to this map as Itypes are encountered.
- -- The reason we cannot use Map directly, is that it may well be
- -- (and normally is) initialized to No_Elist, and if we have mapped
- -- entities, we have to reset it to point to a real Elist.
-
- function Assoc (N : Node_Or_Entity_Id) return Node_Id;
- -- Called during second phase to map entities into their corresponding
- -- copies using Actual_Map. If the argument is not an entity, or is not
- -- in Actual_Map, then it is returned unchanged.
-
- procedure Build_NCT_Hash_Tables;
- -- Builds hash tables (number of elements >= threshold value)
-
- function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id) return Elist_Id;
- -- Called during second phase to copy element list doing replacements
-
- procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
- -- Called during the second phase to process a copied Itype. The actual
- -- copy happened during the first phase (so that we could make the entry
- -- in the mapping), but we still have to deal with the descendents of
- -- the copied Itype and copy them where necessary.
-
- function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
- -- Called during second phase to copy list doing replacements
-
- function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
- -- Called during second phase to copy node doing replacements
-
- procedure Visit_Elist (E : Elist_Id);
- -- Called during first phase to visit all elements of an Elist
-
- procedure Visit_Field (F : Union_Id; N : Node_Id);
- -- Visit a single field, recursing to call Visit_Node or Visit_List
- -- if the field is a syntactic descendent of the current node (i.e.
- -- its parent is Node N).
-
- procedure Visit_Itype (Old_Itype : Entity_Id);
- -- Called during first phase to visit subsidiary fields of a defining
- -- Itype, and also create a copy and make an entry in the replacement
- -- map for the new copy.
-
- procedure Visit_List (L : List_Id);
- -- Called during first phase to visit all elements of a List
-
- procedure Visit_Node (N : Node_Or_Entity_Id);
- -- Called during first phase to visit a node and all its subtrees
-
- -----------
- -- Assoc --
- -----------
-
- function Assoc (N : Node_Or_Entity_Id) return Node_Id is
- E : Elmt_Id;
- Ent : Entity_Id;
-
- begin
- if not Has_Extension (N) or else No (Actual_Map) then
- return N;
-
- elsif NCT_Hash_Tables_Used then
- Ent := NCT_Assoc.Get (Entity_Id (N));
-
- if Present (Ent) then
- return Ent;
- else
- return N;
- end if;
-
- -- No hash table used, do serial search
-
- else
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Node (E) = N then
- return Node (Next_Elmt (E));
- else
- E := Next_Elmt (Next_Elmt (E));
- end if;
- end loop;
- end if;
-
- return N;
- end Assoc;
-
- ---------------------------
- -- Build_NCT_Hash_Tables --
- ---------------------------
-
- procedure Build_NCT_Hash_Tables is
- Elmt : Elmt_Id;
- Ent : Entity_Id;
- begin
- if NCT_Hash_Table_Setup then
- NCT_Assoc.Reset;
- NCT_Itype_Assoc.Reset;
- end if;
-
- Elmt := First_Elmt (Actual_Map);
- while Present (Elmt) loop
- Ent := Node (Elmt);
-
- -- Get new entity, and associate old and new
-
- Next_Elmt (Elmt);
- NCT_Assoc.Set (Ent, Node (Elmt));
-
- if Is_Type (Ent) then
- declare
- Anode : constant Entity_Id :=
- Associated_Node_For_Itype (Ent);
-
- begin
- if Present (Anode) then
-
- -- Enter a link between the associated node of the
- -- old Itype and the new Itype, for updating later
- -- when node is copied.
-
- NCT_Itype_Assoc.Set (Anode, Node (Elmt));
- end if;
- end;
- end if;
-
- Next_Elmt (Elmt);
- end loop;
-
- NCT_Hash_Tables_Used := True;
- NCT_Hash_Table_Setup := True;
- end Build_NCT_Hash_Tables;
-
- ---------------------------------
- -- Copy_Elist_With_Replacement --
- ---------------------------------
-
- function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id) return Elist_Id
- is
- M : Elmt_Id;
- New_Elist : Elist_Id;
-
- begin
- if No (Old_Elist) then
- return No_Elist;
-
- else
- New_Elist := New_Elmt_List;
-
- M := First_Elmt (Old_Elist);
- while Present (M) loop
- Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
- Next_Elmt (M);
- end loop;
- end if;
-
- return New_Elist;
- end Copy_Elist_With_Replacement;
-
- ---------------------------------
- -- Copy_Itype_With_Replacement --
- ---------------------------------
-
- -- This routine exactly parallels its phase one analog Visit_Itype,
- -- and like that routine, knows far too many semantic details about
- -- the descendents of Itypes and whether they need copying or not.
-
- procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
- begin
- -- Translate Next_Entity, Scope and Etype fields, in case they
- -- reference entities that have been mapped into copies.
-
- Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
- Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
-
- if Present (New_Scope) then
- Set_Scope (New_Itype, New_Scope);
- else
- Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
- end if;
-
- -- Copy referenced fields
-
- if Is_Discrete_Type (New_Itype) then
- Set_Scalar_Range (New_Itype,
- Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
-
- elsif Has_Discriminants (Base_Type (New_Itype)) then
- Set_Discriminant_Constraint (New_Itype,
- Copy_Elist_With_Replacement
- (Discriminant_Constraint (New_Itype)));
-
- elsif Is_Array_Type (New_Itype) then
- if Present (First_Index (New_Itype)) then
- Set_First_Index (New_Itype,
- First (Copy_List_With_Replacement
- (List_Containing (First_Index (New_Itype)))));
- end if;
-
- if Is_Packed (New_Itype) then
- Set_Packed_Array_Type (New_Itype,
- Copy_Node_With_Replacement
- (Packed_Array_Type (New_Itype)));
- end if;
- end if;
- end Copy_Itype_With_Replacement;
-
- --------------------------------
- -- Copy_List_With_Replacement --
- --------------------------------
-
- function Copy_List_With_Replacement
- (Old_List : List_Id) return List_Id
- is
- New_List : List_Id;
- E : Node_Id;
-
- begin
- if Old_List = No_List then
- return No_List;
-
- else
- New_List := Empty_List;
-
- E := First (Old_List);
- while Present (E) loop
- Append (Copy_Node_With_Replacement (E), New_List);
- Next (E);
- end loop;
-
- return New_List;
- end if;
- end Copy_List_With_Replacement;
-
- --------------------------------
- -- Copy_Node_With_Replacement --
- --------------------------------
-
- function Copy_Node_With_Replacement
- (Old_Node : Node_Id) return Node_Id
- is
- New_Node : Node_Id;
-
- procedure Adjust_Named_Associations
- (Old_Node : Node_Id;
- New_Node : Node_Id);
- -- If a call node has named associations, these are chained through
- -- the First_Named_Actual, Next_Named_Actual links. These must be
- -- propagated separately to the new parameter list, because these
- -- are not syntactic fields.
-
- function Copy_Field_With_Replacement
- (Field : Union_Id) return Union_Id;
- -- Given Field, which is a field of Old_Node, return a copy of it
- -- if it is a syntactic field (i.e. its parent is Node), setting
- -- the parent of the copy to poit to New_Node. Otherwise returns
- -- the field (possibly mapped if it is an entity).
-
- -------------------------------
- -- Adjust_Named_Associations --
- -------------------------------
-
- procedure Adjust_Named_Associations
- (Old_Node : Node_Id;
- New_Node : Node_Id)
- is
- Old_E : Node_Id;
- New_E : Node_Id;
-
- Old_Next : Node_Id;
- New_Next : Node_Id;
-
- begin
- Old_E := First (Parameter_Associations (Old_Node));
- New_E := First (Parameter_Associations (New_Node));
- while Present (Old_E) loop
- if Nkind (Old_E) = N_Parameter_Association
- and then Present (Next_Named_Actual (Old_E))
- then
- if First_Named_Actual (Old_Node)
- = Explicit_Actual_Parameter (Old_E)
- then
- Set_First_Named_Actual
- (New_Node, Explicit_Actual_Parameter (New_E));
- end if;
-
- -- Now scan parameter list from the beginning,to locate
- -- next named actual, which can be out of order.
-
- Old_Next := First (Parameter_Associations (Old_Node));
- New_Next := First (Parameter_Associations (New_Node));
-
- while Nkind (Old_Next) /= N_Parameter_Association
- or else Explicit_Actual_Parameter (Old_Next)
- /= Next_Named_Actual (Old_E)
- loop
- Next (Old_Next);
- Next (New_Next);
- end loop;
-
- Set_Next_Named_Actual
- (New_E, Explicit_Actual_Parameter (New_Next));
- end if;
-
- Next (Old_E);
- Next (New_E);
- end loop;
- end Adjust_Named_Associations;
-
- ---------------------------------
- -- Copy_Field_With_Replacement --
- ---------------------------------
-
- function Copy_Field_With_Replacement
- (Field : Union_Id) return Union_Id
- is
- begin
- if Field = Union_Id (Empty) then
- return Field;
-
- elsif Field in Node_Range then
- declare
- Old_N : constant Node_Id := Node_Id (Field);
- New_N : Node_Id;
-
- begin
- -- If syntactic field, as indicated by the parent pointer
- -- being set, then copy the referenced node recursively.
-
- if Parent (Old_N) = Old_Node then
- New_N := Copy_Node_With_Replacement (Old_N);
-
- if New_N /= Old_N then
- Set_Parent (New_N, New_Node);
- end if;
-
- -- For semantic fields, update possible entity reference
- -- from the replacement map.
-
- else
- New_N := Assoc (Old_N);
- end if;
-
- return Union_Id (New_N);
- end;
-
- elsif Field in List_Range then
- declare
- Old_L : constant List_Id := List_Id (Field);
- New_L : List_Id;
-
- begin
- -- If syntactic field, as indicated by the parent pointer,
- -- then recursively copy the entire referenced list.
-
- if Parent (Old_L) = Old_Node then
- New_L := Copy_List_With_Replacement (Old_L);
- Set_Parent (New_L, New_Node);
-
- -- For semantic list, just returned unchanged
-
- else
- New_L := Old_L;
- end if;
-
- return Union_Id (New_L);
- end;
-
- -- Anything other than a list or a node is returned unchanged
-
- else
- return Field;
- end if;
- end Copy_Field_With_Replacement;
-
- -- Start of processing for Copy_Node_With_Replacement
-
- begin
- if Old_Node <= Empty_Or_Error then
- return Old_Node;
-
- elsif Has_Extension (Old_Node) then
- return Assoc (Old_Node);
-
- else
- New_Node := New_Copy (Old_Node);
-
- -- If the node we are copying is the associated node of a
- -- previously copied Itype, then adjust the associated node
- -- of the copy of that Itype accordingly.
-
- if Present (Actual_Map) then
- declare
- E : Elmt_Id;
- Ent : Entity_Id;
-
- begin
- -- Case of hash table used
-
- if NCT_Hash_Tables_Used then
- Ent := NCT_Itype_Assoc.Get (Old_Node);
-
- if Present (Ent) then
- Set_Associated_Node_For_Itype (Ent, New_Node);
- end if;
-
- -- Case of no hash table used
-
- else
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Is_Itype (Node (E))
- and then
- Old_Node = Associated_Node_For_Itype (Node (E))
- then
- Set_Associated_Node_For_Itype
- (Node (Next_Elmt (E)), New_Node);
- end if;
-
- E := Next_Elmt (Next_Elmt (E));
- end loop;
- end if;
- end;
- end if;
-
- -- Recursively copy descendents
-
- Set_Field1
- (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
- Set_Field2
- (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
- Set_Field3
- (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
- Set_Field4
- (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
- Set_Field5
- (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
-
- -- Adjust Sloc of new node if necessary
-
- if New_Sloc /= No_Location then
- Set_Sloc (New_Node, New_Sloc);
-
- -- If we adjust the Sloc, then we are essentially making
- -- a completely new node, so the Comes_From_Source flag
- -- should be reset to the proper default value.
-
- Nodes.Table (New_Node).Comes_From_Source :=
- Default_Node.Comes_From_Source;
- end if;
-
- -- If the node is call and has named associations,
- -- set the corresponding links in the copy.
-
- if (Nkind (Old_Node) = N_Function_Call
- or else Nkind (Old_Node) = N_Entry_Call_Statement
- or else
- Nkind (Old_Node) = N_Procedure_Call_Statement)
- and then Present (First_Named_Actual (Old_Node))
- then
- Adjust_Named_Associations (Old_Node, New_Node);
- end if;
-
- -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
- -- The replacement mechanism applies to entities, and is not used
- -- here. Eventually we may need a more general graph-copying
- -- routine. For now, do a sequential search to find desired node.
-
- if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
- and then Present (First_Real_Statement (Old_Node))
- then
- declare
- Old_F : constant Node_Id := First_Real_Statement (Old_Node);
- N1, N2 : Node_Id;
-
- begin
- N1 := First (Statements (Old_Node));
- N2 := First (Statements (New_Node));
-
- while N1 /= Old_F loop
- Next (N1);
- Next (N2);
- end loop;
-
- Set_First_Real_Statement (New_Node, N2);
- end;
- end if;
- end if;
-
- -- All done, return copied node
-
- return New_Node;
- end Copy_Node_With_Replacement;
-
- -----------------
- -- Visit_Elist --
- -----------------
-
- procedure Visit_Elist (E : Elist_Id) is
- Elmt : Elmt_Id;
- begin
- if Present (E) then
- Elmt := First_Elmt (E);
-
- while Elmt /= No_Elmt loop
- Visit_Node (Node (Elmt));
- Next_Elmt (Elmt);
- end loop;
- end if;
- end Visit_Elist;
-
- -----------------
- -- Visit_Field --
- -----------------
-
- procedure Visit_Field (F : Union_Id; N : Node_Id) is
- begin
- if F = Union_Id (Empty) then
- return;
-
- elsif F in Node_Range then
-
- -- Copy node if it is syntactic, i.e. its parent pointer is
- -- set to point to the field that referenced it (certain
- -- Itypes will also meet this criterion, which is fine, since
- -- these are clearly Itypes that do need to be copied, since
- -- we are copying their parent.)
-
- if Parent (Node_Id (F)) = N then
- Visit_Node (Node_Id (F));
- return;
-
- -- Another case, if we are pointing to an Itype, then we want
- -- to copy it if its associated node is somewhere in the tree
- -- being copied.
-
- -- Note: the exclusion of self-referential copies is just an
- -- optimization, since the search of the already copied list
- -- would catch it, but it is a common case (Etype pointing
- -- to itself for an Itype that is a base type).
-
- elsif Has_Extension (Node_Id (F))
- and then Is_Itype (Entity_Id (F))
- and then Node_Id (F) /= N
- then
- declare
- P : Node_Id;
-
- begin
- P := Associated_Node_For_Itype (Node_Id (F));
- while Present (P) loop
- if P = Source then
- Visit_Node (Node_Id (F));
- return;
- else
- P := Parent (P);
- end if;
- end loop;
-
- -- An Itype whose parent is not being copied definitely
- -- should NOT be copied, since it does not belong in any
- -- sense to the copied subtree.
-
- return;
- end;
- end if;
-
- elsif F in List_Range
- and then Parent (List_Id (F)) = N
- then
- Visit_List (List_Id (F));
- return;
- end if;
- end Visit_Field;
-
- -----------------
- -- Visit_Itype --
- -----------------
-
- -- Note: we are relying on far too much semantic knowledge in this
- -- routine, it really should just do a blind replacement of all
- -- fields, or at least a more blind replacement. For example, we
- -- do not deal with corresponding record types, and that works
- -- because we have no Itypes of task types, but nowhere is there
- -- a guarantee that this will always be the case. ???
-
- procedure Visit_Itype (Old_Itype : Entity_Id) is
- New_Itype : Entity_Id;
- E : Elmt_Id;
- Ent : Entity_Id;
-
- begin
- -- Itypes that describe the designated type of access to subprograms
- -- have the structure of subprogram declarations, with signatures,
- -- etc. Either we duplicate the signatures completely, or choose to
- -- share such itypes, which is fine because their elaboration will
- -- have no side effects. In any case, this is additional semantic
- -- information that seems awkward to have in atree.
-
- if Ekind (Old_Itype) = E_Subprogram_Type then
- return;
- end if;
-
- New_Itype := New_Copy (Old_Itype);
-
- -- The new Itype has all the attributes of the old one, and
- -- we just copy the contents of the entity. However, the back-end
- -- needs different names for debugging purposes, so we create a
- -- new internal name for it in all cases.
-
- -- Set_Chars (New_Itype, New_Internal_Name ('T'));
-
- -- If our associated node is an entity that has already been copied,
- -- then set the associated node of the copy to point to the right
- -- copy. If we have copied an Itype that is itself the associated
- -- node of some previously copied Itype, then we set the right
- -- pointer in the other direction.
-
- if Present (Actual_Map) then
-
- -- Case of hash tables used
-
- if NCT_Hash_Tables_Used then
-
- Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
-
- if Present (Ent) then
- Set_Associated_Node_For_Itype (New_Itype, Ent);
- end if;
-
- Ent := NCT_Itype_Assoc.Get (Old_Itype);
- if Present (Ent) then
- Set_Associated_Node_For_Itype (Ent, New_Itype);
-
- -- If the hash table has no association for this Itype and
- -- its associated node, enter one now.
-
- else
- NCT_Itype_Assoc.Set
- (Associated_Node_For_Itype (Old_Itype), New_Itype);
- end if;
-
- -- Case of hash tables not used
-
- else
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Associated_Node_For_Itype (Old_Itype) = Node (E) then
- Set_Associated_Node_For_Itype
- (New_Itype, Node (Next_Elmt (E)));
- end if;
-
- if Is_Type (Node (E))
- and then
- Old_Itype = Associated_Node_For_Itype (Node (E))
- then
- Set_Associated_Node_For_Itype
- (Node (Next_Elmt (E)), New_Itype);
- end if;
-
- E := Next_Elmt (Next_Elmt (E));
- end loop;
- end if;
- end if;
-
- if Present (Freeze_Node (New_Itype)) then
- Set_Is_Frozen (New_Itype, False);
- Set_Freeze_Node (New_Itype, Empty);
- end if;
-
- -- Add new association to map
-
- if No (Actual_Map) then
- Actual_Map := New_Elmt_List;
- end if;
-
- Append_Elmt (Old_Itype, Actual_Map);
- Append_Elmt (New_Itype, Actual_Map);
-
- if NCT_Hash_Tables_Used then
- NCT_Assoc.Set (Old_Itype, New_Itype);
-
- else
- NCT_Table_Entries := NCT_Table_Entries + 1;
-
- if NCT_Table_Entries > NCT_Hash_Threshhold then
- Build_NCT_Hash_Tables;
- end if;
- end if;
-
- -- If a record subtype is simply copied, the entity list will be
- -- shared. Thus cloned_Subtype must be set to indicate the sharing.
-
- if Ekind (Old_Itype) = E_Record_Subtype
- or else Ekind (Old_Itype) = E_Class_Wide_Subtype
- then
- Set_Cloned_Subtype (New_Itype, Old_Itype);
- end if;
-
- -- Visit descendents that eventually get copied
-
- Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
-
- if Is_Discrete_Type (Old_Itype) then
- Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
-
- elsif Has_Discriminants (Base_Type (Old_Itype)) then
- -- ??? This should involve call to Visit_Field
- Visit_Elist (Discriminant_Constraint (Old_Itype));
-
- elsif Is_Array_Type (Old_Itype) then
- if Present (First_Index (Old_Itype)) then
- Visit_Field (Union_Id (List_Containing
- (First_Index (Old_Itype))),
- Old_Itype);
- end if;
-
- if Is_Packed (Old_Itype) then
- Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
- Old_Itype);
- end if;
- end if;
- Get_Name_String (Chars (Old_Itype));
- Add_Char_To_Name_Buffer ('c');
- Add_Nat_To_Name_Buffer (Int (Associated_Node_For_Itype (New_Itype)));
- Set_Chars (New_Itype, Name_Enter);
- end Visit_Itype;
-
- ----------------
- -- Visit_List --
- ----------------
-
- procedure Visit_List (L : List_Id) is
- N : Node_Id;
- begin
- if L /= No_List then
- N := First (L);
-
- while Present (N) loop
- Visit_Node (N);
- Next (N);
- end loop;
- end if;
- end Visit_List;
-
- ----------------
- -- Visit_Node --
- ----------------
-
- procedure Visit_Node (N : Node_Or_Entity_Id) is
-
- -- Start of processing for Visit_Node
-
- begin
- -- Handle case of an Itype, which must be copied
-
- if Has_Extension (N)
- and then Is_Itype (N)
- then
- -- Nothing to do if already in the list. This can happen with an
- -- Itype entity that appears more than once in the tree.
- -- Note that we do not want to visit descendents in this case.
-
- -- Test for already in list when hash table is used
-
- if NCT_Hash_Tables_Used then
- if Present (NCT_Assoc.Get (Entity_Id (N))) then
- return;
- end if;
-
- -- Test for already in list when hash table not used
-
- else
- declare
- E : Elmt_Id;
- begin
- if Present (Actual_Map) then
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Node (E) = N then
- return;
- else
- E := Next_Elmt (Next_Elmt (E));
- end if;
- end loop;
- end if;
- end;
- end if;
-
- Visit_Itype (N);
- end if;
-
- -- Visit descendents
-
- Visit_Field (Field1 (N), N);
- Visit_Field (Field2 (N), N);
- Visit_Field (Field3 (N), N);
- Visit_Field (Field4 (N), N);
- Visit_Field (Field5 (N), N);
- end Visit_Node;
-
- -- Start of processing for New_Copy_Tree
-
- begin
- Actual_Map := Map;
-
- -- See if we should use hash table
-
- if No (Actual_Map) then
- NCT_Hash_Tables_Used := False;
-
- else
- declare
- Elmt : Elmt_Id;
-
- begin
- NCT_Table_Entries := 0;
-
- Elmt := First_Elmt (Actual_Map);
- while Present (Elmt) loop
- NCT_Table_Entries := NCT_Table_Entries + 1;
- Next_Elmt (Elmt);
- Next_Elmt (Elmt);
- end loop;
-
- if NCT_Table_Entries > NCT_Hash_Threshhold then
- Build_NCT_Hash_Tables;
- else
- NCT_Hash_Tables_Used := False;
- end if;
- end;
- end if;
-
- -- Hash table set up if required, now start phase one by visiting
- -- top node (we will recursively visit the descendents).
-
- Visit_Node (Source);
-
- -- Now the second phase of the copy can start. First we process
- -- all the mapped entities, copying their descendents.
-
- if Present (Actual_Map) then
- declare
- Elmt : Elmt_Id;
- New_Itype : Entity_Id;
- begin
- Elmt := First_Elmt (Actual_Map);
- while Present (Elmt) loop
- Next_Elmt (Elmt);
- New_Itype := Node (Elmt);
- Copy_Itype_With_Replacement (New_Itype);
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
-
- -- Now we can copy the actual tree
-
- return Copy_Node_With_Replacement (Source);
- end New_Copy_Tree1;
-
----------------
-- New_Entity --
----------------
projects / thirdparty / gcc.git / commitdiff
