diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 34 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 73 | ||||
| -rw-r--r-- | gcc/ada/adaint.h | 5 | ||||
| -rw-r--r-- | gcc/ada/atree.adb | 972 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 40 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/initialize.c | 18 | ||||
| -rw-r--r-- | gcc/ada/mingw32.h | 13 | ||||
| -rw-r--r-- | gcc/ada/mkdir.c | 2 | ||||
| -rw-r--r-- | gcc/ada/s-crtl.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/s-fileio.adb | 2 |
11 files changed, 115 insertions, 1058 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b30c6349d2a..5f3d5c56257 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2009-04-17 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_Concatenation): Do not use calls at -Os. + +2009-04-17 Pascal Obry <obry@adacore.com> + + * mingw32.h: Add S2WSC and WS2SC macros to convert to/from + CurrentCodePage. + + * adaint.h: Encoding_Unspecified is now defined. Corresponds to the + value when no encoding form paramter is set on Text_IO services. + + * adaint.c: CurrentCodePage new variable on Windows. + Use new macros S2WSC and WS2SC instead of the UTF-8 oriented + ones. + + * mkdir.c: Use new macros S2WSC and WS2SC instead of the UTF-8 oriented + ones. + + * initialize.c: Initialize CurrentCodePage depending on GNAT_CODE_PAGE + environment variable value. Default is UTF-8. + + * s-crtl.ads: Filename_Encoding add Unspecified in the enumeration type. + fopen and freopen encoding parameter is now set to Unspecified. + The default value is in this case UTF-8 (as it was before) but + use the new macros that convert to/from the code page set + at runtime (CurrentCodePage). + + * s-fileio.adb: When no encoding specified use Unspecified value. + +2009-04-17 Ed Schonberg <schonberg@adacore.com> + + * atree.adb, atree.ads: Remove dead code. + 2009-04-17 Arnaud Charlet <charlet@adacore.com> * gcc-interface/Make-lang.in: Update dependencies. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 43ec6543ea5..1b6bb7ff67b 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -82,6 +82,9 @@ #include <Rtapi.h> #else #include "mingw32.h" + +/* Current code page to use, set in initialize.c. */ +UINT CurrentCodePage; #endif #include <sys/utime.h> @@ -482,8 +485,8 @@ __gnat_try_lock (char *dir, char *file) 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); @@ -585,7 +588,7 @@ __gnat_get_current_dir (char *dir, int *length) _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. */ @@ -662,7 +665,7 @@ __gnat_os_filename (char *filename, char *w_filename ATTRIBUTE_UNUSED, 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); @@ -682,7 +685,7 @@ __gnat_unlink (char *path) { TCHAR wpath[GNAT_MAX_PATH_LEN]; - S2WSU (wpath, path, GNAT_MAX_PATH_LEN); + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); return _tunlink (wpath); } #else @@ -699,8 +702,8 @@ __gnat_rename (char *from, char *to) { 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 @@ -717,7 +720,7 @@ __gnat_chdir (char *path) { TCHAR wpath[GNAT_MAX_PATH_LEN]; - S2WSU (wpath, path, GNAT_MAX_PATH_LEN); + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); return _tchdir (wpath); } #else @@ -734,7 +737,7 @@ __gnat_rmdir (char *path) { TCHAR wpath[GNAT_MAX_PATH_LEN]; - S2WSU (wpath, path, GNAT_MAX_PATH_LEN); + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); return _trmdir (wpath); } #else @@ -751,7 +754,9 @@ __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED) 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); @@ -773,7 +778,9 @@ __gnat_freopen (char *path, char *mode, FILE *stream, int encoding ATTRIBUTE_UNU 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); @@ -805,7 +812,7 @@ __gnat_open_read (char *path, int fmode) { 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 @@ -846,7 +853,7 @@ __gnat_open_rw (char *path, int fmode) { 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 @@ -872,7 +879,7 @@ __gnat_open_create (char *path, int fmode) { 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 @@ -894,7 +901,7 @@ __gnat_create_output_file (char *path) { 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 @@ -920,7 +927,7 @@ __gnat_open_append (char *path, int fmode) { 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 @@ -948,7 +955,7 @@ __gnat_open_new (char *path, int fmode) { 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 @@ -1101,7 +1108,7 @@ DIR* __gnat_opendir (char *name) #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 @@ -1125,7 +1132,7 @@ __gnat_readdir (DIR *dirp, char *buffer, int *len) 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; @@ -1231,7 +1238,7 @@ __gnat_file_time_name (char *name) 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, @@ -1368,7 +1375,7 @@ __gnat_set_file_time_name (char *name, time_t time_stamp) } 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, @@ -1631,7 +1638,7 @@ __gnat_stat (char *name, struct stat *statbuf) 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) @@ -1667,7 +1674,7 @@ __gnat_file_exists (char *name) 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; @@ -1851,7 +1858,7 @@ __gnat_is_readable_file (char *name) 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; @@ -1875,7 +1882,7 @@ __gnat_is_writable_file (char *name) 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; @@ -1901,7 +1908,7 @@ __gnat_is_executable_file (char *name) 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; @@ -1924,7 +1931,7 @@ __gnat_set_writable (char *name) #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 @@ -1946,7 +1953,7 @@ __gnat_set_executable (char *name) #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__) @@ -1966,7 +1973,7 @@ __gnat_set_non_writable (char *name) #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, @@ -1991,7 +1998,7 @@ __gnat_set_readable (char *name) #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__) @@ -2010,7 +2017,7 @@ __gnat_set_non_readable (char *name) #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__) @@ -2285,7 +2292,7 @@ win32_no_block_spawn (char *command, char *args[]) int wsize = csize * 2; TCHAR *wcommand = (TCHAR *) xmalloc (wsize); - S2WSU (wcommand, full_command, wsize); + S2WSC (wcommand, full_command, wsize); free (full_command); @@ -2581,7 +2588,7 @@ __gnat_locate_exec_on_path (char *exec_name) 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 diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 5ed4d76a91b..2ecaf730528 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -39,8 +39,9 @@ #include <dirent.h> /* Constants used for the form parameter encoding values */ -#define Encoding_UTF8 0 -#define Encoding_8bits 1 +#define Encoding_UTF8 0 /* UTF-8 */ +#define Encoding_8bits 1 /* Standard 8bits, CP_ACP on Windows. */ +#define Encoding_Unspecified 2 /* Based on GNAT_CODE_PAGE env variable. */ typedef long OS_Time; /* Type corresponding to GNAT.OS_Lib.OS_Time */ diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 3745b384938..79f2ffda5b5 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -38,13 +38,10 @@ pragma Style_Checks (All_Checks); 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 --------------- @@ -414,35 +411,6 @@ 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 -- -------------------------- @@ -986,12 +954,6 @@ package body Atree is 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; -------------------------- @@ -1067,940 +1029,6 @@ package body Atree is 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 -- ---------------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 8807638f862..ae6a1ac7588 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -430,46 +430,6 @@ package Atree is -- Source to be Empty, in which case Relocate_Node simply returns -- Empty as the result. - 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; - -- Given a node that is the root of a subtree, Copy_Tree copies the entire - -- syntactic subtree, including recursively any descendents whose parent - -- field references a copied node (descendents not linked to a copied node - -- by the parent field are not copied, instead the copied tree references - -- the same descendent as the original in this case, which is appropriate - -- for non-syntactic fields such as Etype). The parent pointers in the - -- copy are properly set. Copy_Tree (Empty/Error) returns Empty/Error. - -- The one exception to the rule of not copying semantic fields is that - -- any implicit types attached to the subtree are duplicated, so that - -- the copy contains a distinct set of implicit type entities. The Map - -- argument, if set to a non-empty Elist, specifies a set of mappings - -- to be applied to entities in the tree. The map has the form: - -- - -- old entity 1 - -- new entity to replace references to entity 1 - -- old entity 2 - -- new entity to replace references to entity 2 - -- ... - -- - -- The call destroys the contents of Map in this case - -- - -- The parameter New_Sloc, if set to a value other than No_Location, is - -- used as the Sloc value for all nodes in the new copy. If New_Sloc is - -- set to its default value No_Location, then the Sloc values of the - -- nodes in the copy are simply copied from the corresponding original. - -- - -- The Comes_From_Source indication is unchanged if New_Sloc is set to - -- the default No_Location value, but is reset if New_Sloc is given, since - -- in this case the result clearly is neither a source node or an exact - -- copy of a source node. - -- - -- The parameter New_Scope, if set to a value other than Empty, is the - -- value to use as the Scope for any Itypes that are copied. The most - -- typical value for this parameter, if given, is Current_Scope. - function Copy_Separate_Tree (Source : Node_Id) return Node_Id; -- Given a node that is the root of a subtree, Copy_Separate_Tree copies -- the entire syntactic subtree, including recursively any descendants diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 489e5a998cb..874350bc07d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2822,7 +2822,7 @@ package body Exp_Ch4 is -- There are nine or fewer retained (non-null) operands - -- The optimization level is -O0 or -Os + -- The optimization level is -O0 -- The corresponding System.Concat_n.Str_Concat_n routine is -- available in the run time. @@ -2835,9 +2835,7 @@ package body Exp_Ch4 is if Atyp = Standard_String and then NN in 2 .. 9 - and then (Opt.Optimization_Level = 0 - or else Opt.Optimize_Size /= 0 - or else Debug_Flag_Dot_CC) + and then (Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC) and then not Debug_Flag_Dot_C then declare diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index 5e7b2ff133a..ef51f709857 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -81,6 +81,22 @@ __gnat_initialize (void *eh) given that we have set Max_Digits etc with this in mind */ __gnat_init_float (); +#ifdef GNAT_UNICODE_SUPPORT + /* Set current code page for filenames handling. */ + { + char *codepage = getenv ("GNAT_CODE_PAGE"); + + /* Default code page is UTF-8. */ + CurrentCodePage = CP_UTF8; + + if (codepage != NULL) + if (strcmp (codepage, "CP_ACP") == 0) + CurrentCodePage = CP_ACP; + else if (strcmp (codepage, "CP_UTF8") == 0) + CurrentCodePage = CP_UTF8; + } +#endif + /* Adjust gnat_argv to support Unicode characters. */ { char arg_utf8[MAX_PATH]; @@ -97,7 +113,7 @@ __gnat_initialize (void *eh) for (k=0; k<wargc; k++) { - WS2SU (arg_utf8, wargv[k], MAX_PATH); + WS2SC (arg_utf8, wargv[k], MAX_PATH); gnat_argv[k] = (char *) xmalloc (strlen (arg_utf8) + 1); strcpy (gnat_argv[k], arg_utf8); } diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h index 46e271dcbca..c4034c0033d 100644 --- a/gcc/ada/mingw32.h +++ b/gcc/ada/mingw32.h @@ -62,6 +62,7 @@ #endif #include <tchar.h> +#include <windows.h> /* After including this file it is possible to use the character t as prefix to routines. If GNAT_UNICODE_SUPPORT is defined then the unicode enabled @@ -71,10 +72,22 @@ the proper translations using the UTF-8 encoding. */ #ifdef GNAT_UNICODE_SUPPORT + +extern UINT CurrentCodePage; + +/* Macros to convert to/from the code page speficied in CurrentCodePage. */ +#define S2WSC(wstr,str,len) \ + MultiByteToWideChar (CurrentCodePage,0,str,-1,wstr,len) +#define WS2SC(str,wstr,len) \ + WideCharToMultiByte (CurrentCodePage,0,wstr,-1,str,len,NULL,NULL) + +/* Macros to convert to/from UTF-8 code page. */ #define S2WSU(wstr,str,len) \ MultiByteToWideChar (CP_UTF8,0,str,-1,wstr,len) #define WS2SU(str,wstr,len) \ WideCharToMultiByte (CP_UTF8,0,wstr,-1,str,len,NULL,NULL) + +/* Macros to convert to/from Windows default code page. */ #define S2WS(wstr,str,len) \ MultiByteToWideChar (CP_ACP,0,str,-1,wstr,len) #define WS2S(str,wstr,len) \ diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c index cd458c5266d..debd8067779 100644 --- a/gcc/ada/mkdir.c +++ b/gcc/ada/mkdir.c @@ -65,7 +65,7 @@ __gnat_mkdir (char *dir_name) #elif defined (__MINGW32__) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - S2WSU (wname, dir_name, GNAT_MAX_PATH_LEN + 2); + S2WSC (wname, dir_name, GNAT_MAX_PATH_LEN + 2); return _tmkdir (wname); #else return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index aa4a8b57086..5a9902dd657 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -55,8 +55,8 @@ package System.CRTL is type size_t is mod 2 ** Standard'Address_Size; - type Filename_Encoding is (UTF8, ASCII_8bits); - for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1); + type Filename_Encoding is (UTF8, ASCII_8bits, Unspecified); + for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1, Unspecified => 2); pragma Convention (C, Filename_Encoding); -- Describes the filename's encoding @@ -90,7 +90,7 @@ package System.CRTL is function fopen (filename : chars; mode : chars; - encoding : Filename_Encoding := UTF8) return FILEs; + encoding : Filename_Encoding := Unspecified) return FILEs; pragma Import (C, fopen, "__gnat_fopen"); function fputc (C : int; stream : FILEs) return int; @@ -106,7 +106,7 @@ package System.CRTL is (filename : chars; mode : chars; stream : FILEs; - encoding : Filename_Encoding := UTF8) return FILEs; + encoding : Filename_Encoding := Unspecified) return FILEs; pragma Import (C, freopen, "__gnat_freopen"); function fseek diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 15c70f97d80..b3084775ff1 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -809,7 +809,7 @@ package body System.File_IO is Form_Parameter (Formstr, "encoding", V1, V2); if V1 = 0 then - Encoding := System.CRTL.UTF8; + Encoding := System.CRTL.Unspecified; elsif Formstr (V1 .. V2) = "utf8" then Encoding := System.CRTL.UTF8; |