diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-10-28 14:31:51 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-10-28 14:31:51 +0100 |
commit | b87971f33ef5446f674fb9f80c6ff16e82145ee1 (patch) | |
tree | 148343d7b85f6796a501d41f02588446c25abfd8 | |
parent | 1307c758a3aad3df3e7af66f6ec68b4cb599b054 (diff) | |
download | gcc-b87971f33ef5446f674fb9f80c6ff16e82145ee1.zip gcc-b87971f33ef5446f674fb9f80c6ff16e82145ee1.tar.gz gcc-b87971f33ef5446f674fb9f80c6ff16e82145ee1.tar.bz2 |
[multiple changes]
2009-10-28 Robert Dewar <dewar@adacore.com>
* a-ztexio.adb, a-ztexio.ads, a-witeio.ads, a-witeio.adb,
a-textio.ads, a-textio.adb: Reorganize (moving specs from private part
to body).
(Initialize_Standard_Files): New procedure.
* a-tienau.adb: Minor change to make EOF directly visible
* a-tirsfi.ads, a-wrstfi.adb, a-wrstfi.ads, a-zrstfi.adb,
a-zrstfi.ads, a-tirsfi.adb: New unit, initial version.
* gnat_rm.texi: Add documentation for
Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files.
* Makefile.rtl: Add entries for
Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files
2009-10-28 Thomas Quinot <quinot@adacore.com>
* exp_ch9.ads: Minor reformatting
* sem_ch3.adb: Minor reformatting
* sem_aggr.adb: Minor reformatting.
* sem_attr.adb: Minor reformatting
* tbuild.adb, tbuild.ads, par-ch4.adb, exp_ch4.adb (Tbuild.New_Op_Node):
New subprogram.
Minor code reorganization/factoring.
From-SVN: r153656
-rw-r--r-- | gcc/ada/ChangeLog | 24 | ||||
-rw-r--r-- | gcc/ada/Makefile.rtl | 3 | ||||
-rw-r--r-- | gcc/ada/a-textio.adb | 165 | ||||
-rw-r--r-- | gcc/ada/a-textio.ads | 50 | ||||
-rw-r--r-- | gcc/ada/a-tienau.adb | 4 | ||||
-rwxr-xr-x | gcc/ada/a-tirsfi.adb | 39 | ||||
-rwxr-xr-x | gcc/ada/a-tirsfi.ads | 40 | ||||
-rw-r--r-- | gcc/ada/a-witeio.adb | 153 | ||||
-rw-r--r-- | gcc/ada/a-witeio.ads | 53 | ||||
-rw-r--r-- | gcc/ada/a-wrstfi.adb | 39 | ||||
-rw-r--r-- | gcc/ada/a-wrstfi.ads | 41 | ||||
-rwxr-xr-x | gcc/ada/a-zrstfi.adb | 39 | ||||
-rwxr-xr-x | gcc/ada/a-zrstfi.ads | 41 | ||||
-rw-r--r-- | gcc/ada/a-ztexio.adb | 147 | ||||
-rw-r--r-- | gcc/ada/a-ztexio.ads | 68 | ||||
-rw-r--r-- | gcc/ada/exp_ch4.adb | 17 | ||||
-rw-r--r-- | gcc/ada/exp_ch9.ads | 4 | ||||
-rw-r--r-- | gcc/ada/gnat_rm.texi | 42 | ||||
-rw-r--r-- | gcc/ada/par-ch4.adb | 84 | ||||
-rw-r--r-- | gcc/ada/sem_aggr.adb | 141 | ||||
-rw-r--r-- | gcc/ada/sem_attr.adb | 11 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 12 | ||||
-rw-r--r-- | gcc/ada/tbuild.adb | 51 | ||||
-rw-r--r-- | gcc/ada/tbuild.ads | 7 |
24 files changed, 787 insertions, 488 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5c269d1..b7e7448 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2009-10-28 Robert Dewar <dewar@adacore.com> + + * a-ztexio.adb, a-ztexio.ads, a-witeio.ads, a-witeio.adb, + a-textio.ads, a-textio.adb: Reorganize (moving specs from private part + to body). + (Initialize_Standard_Files): New procedure. + * a-tienau.adb: Minor change to make EOF directly visible + * a-tirsfi.ads, a-wrstfi.adb, a-wrstfi.ads, a-zrstfi.adb, + a-zrstfi.ads, a-tirsfi.adb: New unit, initial version. + * gnat_rm.texi: Add documentation for + Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files. + * Makefile.rtl: Add entries for + Ada.[Wide_[Wide_]]Text_IO.Reset_Standard_Files + +2009-10-28 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.ads: Minor reformatting + * sem_ch3.adb: Minor reformatting + * sem_aggr.adb: Minor reformatting. + * sem_attr.adb: Minor reformatting + * tbuild.adb, tbuild.ads, par-ch4.adb, exp_ch4.adb (Tbuild.New_Op_Node): + New subprogram. + Minor code reorganization/factoring. + 2009-10-27 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (purpose_member_field): New static function. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 5f06d1c..4f26f15 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -258,6 +258,7 @@ GNATRTL_NONTASKING_OBJS= \ a-timoau$(objext) \ a-timoio$(objext) \ a-tiocst$(objext) \ + a-tirsfi$(objext) \ a-titest$(objext) \ a-tiunio$(objext) \ a-unccon$(objext) \ @@ -265,6 +266,7 @@ GNATRTL_NONTASKING_OBJS= \ a-wichun$(objext) \ a-widcha$(objext) \ a-witeio$(objext) \ + a-wrstfi$(objext) \ a-wtcoau$(objext) \ a-wtcoio$(objext) \ a-wtcstr$(objext) \ @@ -286,6 +288,7 @@ GNATRTL_NONTASKING_OBJS= \ a-wwunio$(objext) \ a-zchara$(objext) \ a-zchuni$(objext) \ + a-zrstfi$(objext) \ a-ztcoau$(objext) \ a-ztcoio$(objext) \ a-ztcstr$(objext) \ diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index b3a98fc..417efb5 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -57,15 +57,30 @@ package body Ada.Text_IO is WC_Encoding : Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files ----------------------- -- Local Subprograms -- ----------------------- - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - function Get_Upper_Half_Char (C : Character; File : File_Type) return Character; @@ -82,18 +97,48 @@ package body Ada.Text_IO is -- This routine is identical to Get_Upper_Half_Char, except that the reads -- are done in Get_Immediate mode (i.e. without waiting for a line return). + function Getc (File : File_Type) return int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + function Has_Upper_Half_Character (Item : String) return Boolean; -- Returns True if any of the characters is in the range 16#80#-16#FF# + function Nextc (File : File_Type) return int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). + procedure Put_Encoded (File : File_Type; Char : Character); -- Called to output a character Char to the given File, when the encoding -- method for the file is other than brackets, and Char is upper half. + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + procedure Set_WCEM (File : in out File_Type); -- Called by Open and Create to set the wide character encoding method for -- the file, processing a WCEM form parameter if one is present. File is -- IN OUT because it may be closed in case of an error. + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + ------------------- -- AFCB_Allocate -- ------------------- @@ -392,15 +437,6 @@ package body Ada.Text_IO is return End_Of_Page (Current_In); end End_Of_Page; - -------------- - -- EOF_Char -- - -------------- - - function EOF_Char return Integer is - begin - return EOF; - end EOF_Char; - ----------- -- Flush -- ----------- @@ -965,6 +1001,52 @@ package body Ada.Text_IO is return False; end Has_Upper_Half_Character; + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + ------------- -- Is_Open -- ------------- @@ -2198,20 +2280,8 @@ package body Ada.Text_IO is end if; end Write; - -- Use "preallocated" strings to avoid calling "new" during the - -- elaboration of the run time. This is needed in the tasking case to - -- avoid calling Task_Lock too early. A filename is expected to end with a - -- null character in the runtime, here the null characters are added just - -- to have a correct filename length. - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - begin - ------------------------------- - -- Initialize Standard Files -- - ------------------------------- + -- Initialize Standard Files for J in WC_Encoding_Method loop if WC_Encoding = WC_Encoding_Letters (J) then @@ -2219,51 +2289,10 @@ begin end if; end loop; - -- Note: the names in these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC test insist! - -- We use names that are bound to fail in open etc. - - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Is_Text_File := True; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Is_Text_File := True; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Is_Text_File := True; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; + Initialize_Standard_Files; FIO.Chain_File (AP (Standard_In)); FIO.Chain_File (AP (Standard_Out)); FIO.Chain_File (AP (Standard_Err)); - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Ada.Text_IO; diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads index 9277ccb..44fe496 100644 --- a/gcc/ada/a-textio.ads +++ b/gcc/ada/a-textio.ads @@ -41,6 +41,7 @@ with Ada.IO_Exceptions; with Ada.Streams; + with System; with System.File_Control_Block; with System.WCh_Con; @@ -443,9 +444,6 @@ private -- The Standard Files -- ------------------------ - Null_Str : aliased constant String := ""; - -- Used as name and form of standard files - Standard_In_AFCB : aliased Text_AFCB; Standard_Out_AFCB : aliased Text_AFCB; Standard_Err_AFCB : aliased Text_AFCB; @@ -460,47 +458,9 @@ private Current_Err : aliased File_Type := Standard_Err; -- Current files - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- These subprograms are in the private part of the spec so that they can - -- be shared by the routines in the body of Ada.Text_IO.Wide_Text_IO. - - -- Note: we use Integer in these declarations instead of the more accurate - -- Interfaces.C_Streams.int, because we do not want to drag in the spec of - -- this interfaces package with the spec of Ada.Text_IO, and we know that - -- in fact these types are identical - - function EOF_Char return Integer; - -- Returns the system-specific character indicating the end of a text file. - -- This is exported for use by child packages such as Enumeration_Aux to - -- eliminate their needing to depend directly on Interfaces.C_Streams. - - function Getc (File : File_Type) return Integer; - -- Gets next character from file, which has already been checked for - -- being in read status, and returns the character read if no error - -- occurs. The result is EOF if the end of file was read. - - function Nextc (File : File_Type) return Integer; - -- Returns next character from file without skipping past it (i.e. it - -- is a combination of Getc followed by an Ungetc). - - procedure Putc (ch : Integer; File : File_Type); - -- Outputs the given character to the file, which has already been - -- checked for being in output status. Device_Error is raised if the - -- character cannot be written. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current - -- line is not terminated, then a line terminator is written using - -- New_Line. Note that there is no Terminate_Page routine, because - -- the page mark at the end of the file is implied if necessary. - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- and end of file character (EOF) is ignored. + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Text_IO.Reset_Standard_Files. end Ada.Text_IO; diff --git a/gcc/ada/a-tienau.adb b/gcc/ada/a-tienau.adb index f0c1800..e04a342 100644 --- a/gcc/ada/a-tienau.adb +++ b/gcc/ada/a-tienau.adb @@ -32,6 +32,8 @@ with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; with Ada.Characters.Handling; use Ada.Characters.Handling; +with Interfaces.C_Streams; use Interfaces.C_Streams; + -- Note: this package does not yet deal properly with wide characters ??? package body Ada.Text_IO.Enumeration_Aux is @@ -98,7 +100,7 @@ package body Ada.Text_IO.Enumeration_Aux is Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen); ch := Getc (File); - exit when ch = EOF_Char; + exit when ch = EOF; C := Character'Val (ch); exit when not Is_Letter (C) diff --git a/gcc/ada/a-tirsfi.adb b/gcc/ada/a-tirsfi.adb new file mode 100755 index 0000000..791c066 --- /dev/null +++ b/gcc/ada/a-tirsfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-------------------------------------- +-- Ada.Text_IO.Reset_Standard_Files -- +-------------------------------------- + +procedure Ada.Text_IO.Reset_Standard_Files is +begin + Ada.Text_IO.Initialize_Standard_Files; +end Ada.Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-tirsfi.ads b/gcc/ada/a-tirsfi.ads new file mode 100755 index 0000000..b3d4ab0 --- /dev/null +++ b/gcc/ada/a-tirsfi.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a reset routine that resets the standard files used +-- by Text_IO. This is useful in systems such as VxWorks where Ada.Text_IO is +-- elaborated at the program start, but a system restart may alter the status +-- of these files, resulting in incorrect operation of Text_IO (in particular +-- if the standard input file is changed to be interactive, then Get_Line may +-- hang looking for an extra character after the end of the line. + +procedure Ada.Text_IO.Reset_Standard_Files; +-- Reset standard Text_IO files as described above diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index e877405..efd5021 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -57,26 +57,62 @@ package body Ada.Wide_Text_IO is WC_Encoding : Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files ----------------------- -- Local Subprograms -- ----------------------- - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - function Get_Wide_Char_Immed (C : Character; File : File_Type) return Wide_Character; -- This routine is identical to Get_Wide_Char, except that the reads are -- done in Get_Immediate mode (i.e. without waiting for a line return). + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + procedure Set_WCEM (File : in out File_Type); -- Called by Open and Create to set the wide character encoding method for -- the file, processing a WCEM form parameter if one is present. File is -- IN OUT because it may be closed in case of an error. + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + ------------------- -- AFCB_Allocate -- ------------------- @@ -843,6 +879,52 @@ package body Ada.Wide_Text_IO is return ch; end Getc_Immed; + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + ------------- -- Is_Open -- ------------- @@ -856,9 +938,9 @@ package body Ada.Wide_Text_IO is -- Line -- ---------- - -- Note: we assume that it is impossible in practice for the line - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. + -- Note: we assume that it is impossible in practice for the line to exceed + -- the value of Count'Last, i.e. no check is required for overflow raising + -- layout error. function Line (File : File_Type) return Positive_Count is begin @@ -1840,20 +1922,8 @@ package body Ada.Wide_Text_IO is set_text_mode (fileno (File.Stream)); end Write; - -- Use "preallocated" strings to avoid calling "new" during the - -- elaboration of the run time. This is needed in the tasking case to - -- avoid calling Task_Lock too early. A filename is expected to end with - -- a null character in the runtime, here the null characters are added - -- just to have a correct filename length. - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - begin - ------------------------------- - -- Initialize Standard Files -- - ------------------------------- + -- Initialize Standard Files for J in WC_Encoding_Method loop if WC_Encoding = WC_Encoding_Letters (J) then @@ -1861,51 +1931,10 @@ begin end if; end loop; - -- Note: the names in these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC test insist! - -- We use names that are bound to fail in open etc. - - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Is_Text_File := True; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Is_Text_File := True; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Is_Text_File := True; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; + Initialize_Standard_Files; FIO.Chain_File (AP (Standard_In)); FIO.Chain_File (AP (Standard_Out)); FIO.Chain_File (AP (Standard_Err)); - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Ada.Wide_Text_IO; diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads index 0af805e..2cf02b6 100644 --- a/gcc/ada/a-witeio.ads +++ b/gcc/ada/a-witeio.ads @@ -42,6 +42,9 @@ with Ada.IO_Exceptions; with Ada.Streams; + +with Interfaces.C_Streams; + with System; with System.File_Control_Block; with System.WCh_Con; @@ -441,9 +444,6 @@ private -- The Standard Files -- ------------------------ - Null_Str : aliased constant String := ""; - -- Used as name and form of standard files - Standard_Err_AFCB : aliased Wide_Text_AFCB; Standard_In_AFCB : aliased Wide_Text_AFCB; Standard_Out_AFCB : aliased Wide_Text_AFCB; @@ -458,26 +458,24 @@ private Current_Err : aliased File_Type := Standard_Err; -- Current files + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Wide_Text_IO.Reset_Standard_Files. + ----------------------- -- Local Subprograms -- ----------------------- -- These subprograms are in the private part of the spec so that they can - -- be shared by the routines in the body of Ada.Text_IO.Wide_Text_IO. - - -- Note: we use Integer in these declarations instead of the more accurate - -- Interfaces.C_Streams.int, because we do not want to drag in the spec of - -- this interfaces package with the spec of Ada.Text_IO, and we know that - -- in fact these types are identical + -- be shared by the children of Ada.Wide_Text_IO. - function Getc (File : File_Type) return Integer; - -- Gets next character from file, which has already been checked for - -- being in read status, and returns the character read if no error - -- occurs. The result is EOF if the end of file was read. + function Getc (File : File_Type) return Interfaces.C_Streams.int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. - procedure Get_Character - (File : File_Type; - Item : out Character); + procedure Get_Character (File : File_Type; Item : out Character); -- This is essentially a copy of the normal Get routine from Text_IO. It -- obtains a single character from the input file File, and places it in -- Item. This character may be the leading character of a Wide_Character @@ -491,25 +489,8 @@ private -- read and is passed in C. The wide character value is returned as the -- result, and the file pointer is bumped past the character. - function Nextc (File : File_Type) return Integer; - -- Returns next character from file without skipping past it (i.e. it - -- is a combination of Getc followed by an Ungetc). - - procedure Putc (ch : Integer; File : File_Type); - -- Outputs the given character to the file, which has already been - -- checked for being in output status. Device_Error is raised if the - -- character cannot be written. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current - -- line is not terminated, then a line terminator is written using - -- New_Line. Note that there is no Terminate_Page routine, because - -- the page mark at the end of the file is implied if necessary. - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- and end of file character (EOF) is ignored. + function Nextc (File : File_Type) return Interfaces.C_Streams.int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). end Ada.Wide_Text_IO; diff --git a/gcc/ada/a-wrstfi.adb b/gcc/ada/a-wrstfi.adb new file mode 100644 index 0000000..6b3f656 --- /dev/null +++ b/gcc/ada/a-wrstfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------- +-- Ada.Wide_Text_IO.Reset_Standard_Files -- +------------------------------------------- + +procedure Ada.Wide_Text_IO.Reset_Standard_Files is +begin + Ada.Wide_Text_IO.Initialize_Standard_Files; +end Ada.Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-wrstfi.ads b/gcc/ada/a-wrstfi.ads new file mode 100644 index 0000000..5d6548e --- /dev/null +++ b/gcc/ada/a-wrstfi.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a reset routine that resets the standard files used +-- by Ada.Wide_Text_IO. This is useful in systems such as VxWorks where +-- Ada.Wide_Text_IO is elaborated at the program start, but a system restart +-- may alter the status of these files, resulting in incorrect operation of +-- Wide_Text_IO (in particular if the standard input file is changed to be +-- interactive, then Get_Line may hang looking for an extra character after +-- the end of the line. + +procedure Ada.Wide_Text_IO.Reset_Standard_Files; +-- Reset standard Wide_Text_IO files as described above diff --git a/gcc/ada/a-zrstfi.adb b/gcc/ada/a-zrstfi.adb new file mode 100755 index 0000000..e0a7f64 --- /dev/null +++ b/gcc/ada/a-zrstfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------------ +-- Ada.Wide_Wide_Text_IO.Reset_Standard_Files -- +------------------------------------------------ + +procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files is +begin + Ada.Wide_Wide_Text_IO.Initialize_Standard_Files; +end Ada.Wide_Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-zrstfi.ads b/gcc/ada/a-zrstfi.ads new file mode 100755 index 0000000..80f2b1f --- /dev/null +++ b/gcc/ada/a-zrstfi.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a reset routine that resets the standard files used +-- by Ada.Wide_Wide_Text_IO. This is useful in systems such as VxWorks where +-- Ada.Wide_Wide_Text_IO is elaborated at the program start, but a system +-- restart may alter the status of these files, resulting in incorrect +-- operation of Wide_Wide_Text_IO (in particular if the standard input file +-- is changed to be interactive, then Get_Line may hang looking for an extra +-- character after the end of the line. + +procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files; +-- Reset standard Wide_Wide_Text_IO files as described above diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb index 64ad872..8be8a91 100644 --- a/gcc/ada/a-ztexio.adb +++ b/gcc/ada/a-ztexio.adb @@ -57,26 +57,62 @@ package body Ada.Wide_Wide_Text_IO is WC_Encoding : Character; pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist! + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files ----------------------- -- Local Subprograms -- ----------------------- - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - function Get_Wide_Wide_Char_Immed (C : Character; File : File_Type) return Wide_Wide_Character; -- This routine is identical to Get_Wide_Wide_Char, except that the reads -- are done in Get_Immediate mode (i.e. without waiting for a line return). + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + procedure Set_WCEM (File : in out File_Type); -- Called by Open and Create to set the wide character encoding method for -- the file, processing a WCEM form parameter if one is present. File is -- IN OUT because it may be closed in case of an error. + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + ------------------- -- AFCB_Allocate -- ------------------- @@ -843,6 +879,52 @@ package body Ada.Wide_Wide_Text_IO is return ch; end Getc_Immed; + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + ------------- -- Is_Open -- ------------- @@ -1840,20 +1922,8 @@ package body Ada.Wide_Wide_Text_IO is set_text_mode (fileno (File.Stream)); end Write; - -- Use "preallocated" strings to avoid calling "new" during the - -- elaboration of the run time. This is needed in the tasking case to - -- avoid calling Task_Lock too early. A filename is expected to end with - -- a null character in the runtime, here the null characters are added - -- just to have a correct filename length. - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - begin - ------------------------------- - -- Initialize Standard Files -- - ------------------------------- + -- Initialize Standard Files for J in WC_Encoding_Method loop if WC_Encoding = WC_Encoding_Letters (J) then @@ -1861,51 +1931,10 @@ begin end if; end loop; - -- Note: the names in these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC test insist! - -- We use names that are bound to fail in open etc. - - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Is_Text_File := True; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Is_Text_File := True; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Is_Text_File := True; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; + Initialize_Standard_Files; FIO.Chain_File (AP (Standard_In)); FIO.Chain_File (AP (Standard_Out)); FIO.Chain_File (AP (Standard_Err)); - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-ztexio.ads b/gcc/ada/a-ztexio.ads index 81ab992..6c75acd 100644 --- a/gcc/ada/a-ztexio.ads +++ b/gcc/ada/a-ztexio.ads @@ -42,6 +42,9 @@ with Ada.IO_Exceptions; with Ada.Streams; + +with Interfaces.C_Streams; + with System; with System.File_Control_Block; with System.WCh_Con; @@ -357,13 +360,13 @@ private PM : constant := Character'Pos (ASCII.FF); -- Used as page mark, except at end of file where it is implied - ------------------------------------- + ------------------------------------------ -- Wide_Wide_Text_IO File Control Block -- - ------------------------------------- + ------------------------------------------ Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8; - -- This gets modified during initialization (see body) using - -- the default value established in the call to Set_Globals. + -- This gets modified during initialization (see body) using the default + -- value established in the call to Set_Globals. package FCB renames System.File_Control_Block; @@ -443,9 +446,6 @@ private -- The Standard Files -- ------------------------ - Null_Str : aliased constant String := ""; - -- Used as name and form of standard files - Standard_Err_AFCB : aliased Wide_Wide_Text_AFCB; Standard_In_AFCB : aliased Wide_Wide_Text_AFCB; Standard_Out_AFCB : aliased Wide_Wide_Text_AFCB; @@ -460,31 +460,28 @@ private Current_Err : aliased File_Type := Standard_Err; -- Current files + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Wide_Wide_Text_IO.Reset_Standard_Files. + ----------------------- -- Local Subprograms -- ----------------------- -- These subprograms are in the private part of the spec so that they can - -- be shared by the routines in the body of Ada.Text_IO.Wide_Wide_Text_IO. - - -- Note: we use Integer in these declarations instead of the more accurate - -- Interfaces.C_Streams.int, because we do not want to drag in the spec of - -- this interfaces package with the spec of Ada.Text_IO, and we know that - -- in fact these types are identical + -- be shared by the children of Ada.Text_IO.Wide_Wide_Text_IO. - function Getc (File : File_Type) return Integer; - -- Gets next character from file, which has already been checked for - -- being in read status, and returns the character read if no error - -- occurs. The result is EOF if the end of file was read. + function Getc (File : File_Type) return Interfaces.C_Streams.int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. - procedure Get_Character - (File : File_Type; - Item : out Character); - -- This is essentially a copy of the normal Get routine from Text_IO. It + procedure Get_Character (File : File_Type; Item : out Character); + -- This is essentially copy of Wide_Wide_Text_IO.Get. It obtains a single -- obtains a single character from the input file File, and places it in - -- Item. This character may be the leading character of a - -- Wide_Wide_Character sequence, but that is up to the caller to deal - -- with. + -- Item. This result may be the leading character of a Wide_Wide_Character + -- sequence, but that is up to the caller to deal with. function Get_Wide_Wide_Char (C : Character; @@ -494,25 +491,8 @@ private -- read and is passed in C. The wide character value is returned as the -- result, and the file pointer is bumped past the character. - function Nextc (File : File_Type) return Integer; - -- Returns next character from file without skipping past it (i.e. it - -- is a combination of Getc followed by an Ungetc). - - procedure Putc (ch : Integer; File : File_Type); - -- Outputs the given character to the file, which has already been - -- checked for being in output status. Device_Error is raised if the - -- character cannot be written. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current - -- line is not terminated, then a line terminator is written using - -- New_Line. Note that there is no Terminate_Page routine, because - -- the page mark at the end of the file is implied if necessary. - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- and end of file character (EOF) is ignored. + function Nextc (File : File_Type) return Interfaces.C_Streams.int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b72b810..c98e982 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -8065,20 +8065,9 @@ package body Exp_Ch4 is Subtype_Mark => New_Reference_To (Standard_Integer, Loc), Expression => Relocate_Node (Left_Opnd (Operand))); - case Nkind (Operand) is - when N_Op_Add => - Opnd := Make_Op_Add (Loc, L, R); - when N_Op_Divide => - Opnd := Make_Op_Divide (Loc, L, R); - when N_Op_Expon => - Opnd := Make_Op_Expon (Loc, L, R); - when N_Op_Multiply => - Opnd := Make_Op_Multiply (Loc, L, R); - when N_Op_Subtract => - Opnd := Make_Op_Subtract (Loc, L, R); - when others => - raise Program_Error; - end case; + Opnd := New_Op_Node (Nkind (Operand), Loc); + Set_Left_Opnd (Opnd, L); + Set_Right_Opnd (Opnd, R); Rewrite (N, Make_Type_Conversion (Loc, diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 8e795e1..61279d4 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -173,8 +173,8 @@ package Exp_Ch9 is -- meaning is to get the Task_Id for the currently executing task. function Convert_Concurrent - (N : Node_Id; - Typ : Entity_Id) return Node_Id; + (N : Node_Id; + Typ : Entity_Id) return Node_Id; -- N is an expression of type Typ. If the type is not a concurrent type -- then it is returned unchanged. If it is a task or protected reference, -- Convert_Concurrent creates an unchecked conversion node from this diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index e25400d..4b906fe 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -307,10 +307,13 @@ The GNAT Library * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: * Ada.Text_IO.C_Streams (a-tiocst.ads):: +* Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads):: * Ada.Wide_Characters.Unicode (a-wichun.ads):: * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: +* Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads):: * Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: * Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: +* Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads):: * GNAT.Altivec (g-altive.ads):: * GNAT.Altivec.Conversions (g-altcon.ads):: * GNAT.Altivec.Vector_Operations (g-alveop.ads):: @@ -13496,10 +13499,13 @@ of GNAT, and will generate a warning message. * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads):: * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads):: * Ada.Text_IO.C_Streams (a-tiocst.ads):: +* Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads):: * Ada.Wide_Characters.Unicode (a-wichun.ads):: * Ada.Wide_Text_IO.C_Streams (a-wtcstr.ads):: +* Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads):: * Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads):: * Ada.Wide_Wide_Text_IO.C_Streams (a-ztcstr.ads):: +* Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads):: * GNAT.Altivec (g-altive.ads):: * GNAT.Altivec.Conversions (g-altcon.ads):: * GNAT.Altivec.Vector_Operations (g-alveop.ads):: @@ -13819,6 +13825,18 @@ C streams and @code{Text_IO}. The stream identifier can be extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. +@node Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads) +@section @code{Ada.Text_IO.Reset_Standard_Files} (@file{a-tirsfi.ads}) +@cindex @code{Ada.Text_IO.Reset_Standard_Files} (@file{a-tirsfi.ads}) +@cindex @code{Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Text_IO. This is useful in a situation (such as a restart in an +embedded application) where the status of the files may change during +execution (for example a standard input file may be redefined to be +interactive). + @node Ada.Wide_Characters.Unicode (a-wichun.ads) @section @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) @cindex @code{Ada.Wide_Characters.Unicode} (@file{a-wichun.ads}) @@ -13839,6 +13857,18 @@ C streams and @code{Wide_Text_IO}. The stream identifier can be extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. +@node Ada.Wide_Text_IO.Reset_Standard_Files (a-wrstfi.ads) +@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@file{a-wrstfi.ads}) +@cindex @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@file{a-wrstfi.ads}) +@cindex @code{Wide_Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Wide_Text_IO. This is useful in a situation (such as a restart in an +embedded application) where the status of the files may change during +execution (for example a standard input file may be redefined to be +interactive). + @node Ada.Wide_Wide_Characters.Unicode (a-zchuni.ads) @section @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) @cindex @code{Ada.Wide_Wide_Characters.Unicode} (@file{a-zchuni.ads}) @@ -13859,6 +13889,18 @@ C streams and @code{Wide_Wide_Text_IO}. The stream identifier can be extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. +@node Ada.Wide_Wide_Text_IO.Reset_Standard_Files (a-zrstfi.ads) +@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@file{a-zrstfi.ads}) +@cindex @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@file{a-zrstfi.ads}) +@cindex @code{Wide_Wide_Text_IO} resetting standard files + +@noindent +This procedure is used to reset the status of the standard files used +by Ada.Wide_Wide_Text_IO. This is useful in a situation (such as a +restart in an embedded application) where the status of the files may +change during execution (for example a standard input file may be +redefined to be interactive). + @node GNAT.Altivec (g-altive.ads) @section @code{GNAT.Altivec} (@file{g-altive.ads}) @cindex @code{GNAT.Altivec} (@file{g-altive.ads}) diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index f07f54e..2bb9d25 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -89,9 +89,6 @@ package body Ch4 is -- prefix. The current token is known to be an apostrophe and the -- following token is known to be RANGE. - procedure Set_Op_Name (Node : Node_Id); - -- Procedure to set name field (Chars) in operator node - ------------------------- -- Bad_Range_Attribute -- ------------------------- @@ -102,51 +99,6 @@ package body Ch4 is Resync_Expression; end Bad_Range_Attribute; - ------------------ - -- Set_Op_Name -- - ------------------ - - procedure Set_Op_Name (Node : Node_Id) is - type Name_Of_Type is array (N_Op) of Name_Id; - Name_Of : constant Name_Of_Type := Name_Of_Type'( - N_Op_And => Name_Op_And, - N_Op_Or => Name_Op_Or, - N_Op_Xor => Name_Op_Xor, - N_Op_Eq => Name_Op_Eq, - N_Op_Ne => Name_Op_Ne, - N_Op_Lt => Name_Op_Lt, - N_Op_Le => Name_Op_Le, - N_Op_Gt => Name_Op_Gt, - N_Op_Ge => Name_Op_Ge, - N_Op_Add => Name_Op_Add, - N_Op_Subtract => Name_Op_Subtract, - N_Op_Concat => Name_Op_Concat, - N_Op_Multiply => Name_Op_Multiply, - N_Op_Divide => Name_Op_Divide, - N_Op_Mod => Name_Op_Mod, - N_Op_Rem => Name_Op_Rem, - N_Op_Expon => Name_Op_Expon, - N_Op_Plus => Name_Op_Add, - N_Op_Minus => Name_Op_Subtract, - N_Op_Abs => Name_Op_Abs, - N_Op_Not => Name_Op_Not, - - -- We don't really need these shift operators, since they never - -- appear as operators in the source, but the path of least - -- resistance is to put them in (the aggregate must be complete) - - N_Op_Rotate_Left => Name_Rotate_Left, - N_Op_Rotate_Right => Name_Rotate_Right, - N_Op_Shift_Left => Name_Shift_Left, - N_Op_Shift_Right => Name_Shift_Right, - N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); - - begin - if Nkind (Node) in N_Op then - Set_Chars (Node, Name_Of (Nkind (Node))); - end if; - end Set_Op_Name; - -------------------------- -- 4.1 Name (also 6.4) -- -------------------------- @@ -1600,10 +1552,9 @@ package body Ch4 is end if; Node2 := Node1; - Node1 := New_Node (Logical_Op, Op_Location); + Node1 := New_Op_Node (Logical_Op, Op_Location); Set_Left_Opnd (Node1, Node2); Set_Right_Opnd (Node1, P_Relation); - Set_Op_Name (Node1); exit when Token not in Token_Class_Logop; end loop; @@ -1704,10 +1655,9 @@ package body Ch4 is end if; Node2 := Node1; - Node1 := New_Node (Logical_Op, Op_Location); + Node1 := New_Op_Node (Logical_Op, Op_Location); Set_Left_Opnd (Node1, Node2); Set_Right_Opnd (Node1, P_Relation); - Set_Op_Name (Node1); exit when Token not in Token_Class_Logop; end loop; @@ -1768,9 +1718,8 @@ package body Ch4 is -- P_Relational_Operator also parses the IN and NOT IN operations. Optok := Token_Ptr; - Node2 := New_Node (P_Relational_Operator, Optok); + Node2 := New_Op_Node (P_Relational_Operator, Optok); Set_Left_Opnd (Node2, Node1); - Set_Op_Name (Node2); -- Case of IN or NOT IN @@ -1881,18 +1830,17 @@ package body Ch4 is Style.Check_Exponentiation_Operator; end if; - Node2 := New_Node (N_Op_Expon, Token_Ptr); + Node2 := New_Op_Node (N_Op_Expon, Token_Ptr); Scan; -- past ** Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Primary); - Set_Op_Name (Node2); Node1 := Node2; end if; loop exit when Token not in Token_Class_Mulop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Multiplying_Operator, Tokptr); + Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr); if Style_Check then Style.Check_Binary_Operator; @@ -1901,14 +1849,13 @@ package body Ch4 is Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Factor); - Set_Op_Name (Node2); Node1 := Node2; end loop; loop exit when Token not in Token_Class_Binary_Addop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Binary_Adding_Operator, Tokptr); + Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr); if Style_Check then Style.Check_Binary_Operator; @@ -1917,7 +1864,6 @@ package body Ch4 is Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Term); - Set_Op_Name (Node2); Node1 := Node2; end loop; @@ -1931,7 +1877,7 @@ package body Ch4 is if Token in Token_Class_Unary_Addop then Tokptr := Token_Ptr; - Node1 := New_Node (P_Unary_Adding_Operator, Tokptr); + Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr); if Style_Check then Style.Check_Unary_Plus_Or_Minus; @@ -1939,7 +1885,6 @@ package body Ch4 is Scan; -- past operator Set_Right_Opnd (Node1, P_Term); - Set_Op_Name (Node1); else Node1 := P_Term; end if; @@ -1981,12 +1926,11 @@ package body Ch4 is loop exit when Token not in Token_Class_Binary_Addop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Binary_Adding_Operator, Tokptr); + Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Node1 := P_Term; Set_Right_Opnd (Node2, Node1); - Set_Op_Name (Node2); -- Check if we're still concatenating string literals @@ -2214,11 +2158,10 @@ package body Ch4 is loop exit when Token not in Token_Class_Mulop; Tokptr := Token_Ptr; - Node2 := New_Node (P_Multiplying_Operator, Tokptr); + Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Factor); - Set_Op_Name (Node2); Node1 := Node2; end loop; @@ -2239,7 +2182,7 @@ package body Ch4 is begin if Token = Tok_Abs then - Node1 := New_Node (N_Op_Abs, Token_Ptr); + Node1 := New_Op_Node (N_Op_Abs, Token_Ptr); if Style_Check then Style.Check_Abs_Not; @@ -2247,11 +2190,10 @@ package body Ch4 is Scan; -- past ABS Set_Right_Opnd (Node1, P_Primary); - Set_Op_Name (Node1); return Node1; elsif Token = Tok_Not then - Node1 := New_Node (N_Op_Not, Token_Ptr); + Node1 := New_Op_Node (N_Op_Not, Token_Ptr); if Style_Check then Style.Check_Abs_Not; @@ -2259,18 +2201,16 @@ package body Ch4 is Scan; -- past NOT Set_Right_Opnd (Node1, P_Primary); - Set_Op_Name (Node1); return Node1; else Node1 := P_Primary; if Token = Tok_Double_Asterisk then - Node2 := New_Node (N_Op_Expon, Token_Ptr); + Node2 := New_Op_Node (N_Op_Expon, Token_Ptr); Scan; -- past ** Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Primary); - Set_Op_Name (Node2); return Node2; else return Node1; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index af29d9a..ad01bd1 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -509,9 +509,8 @@ package body Sem_Aggr is ------------------------ function Array_Aggr_Subtype - (N : Node_Id; - Typ : Entity_Id) - return Entity_Id + (N : Node_Id; + Typ : Entity_Id) return Entity_Id is Aggr_Dimension : constant Pos := Number_Dimensions (Typ); -- Number of aggregate index dimensions @@ -618,7 +617,7 @@ package body Sem_Aggr is -- Array_Aggr_Subtype variables Itype : Entity_Id; - -- the final itype of the overall aggregate + -- The final itype of the overall aggregate Index_Constraints : constant List_Id := New_List; -- The list of index constraints of the aggregate itype @@ -626,8 +625,8 @@ package body Sem_Aggr is -- Start of processing for Array_Aggr_Subtype begin - -- Make sure that the list of index constraints is properly attached - -- to the tree, and then collect the aggregate bounds. + -- Make sure that the list of index constraints is properly attached to + -- the tree, and then collect the aggregate bounds. Set_Parent (Index_Constraints, N); Collect_Aggr_Bounds (N, 1); @@ -672,13 +671,13 @@ package body Sem_Aggr is Itype := Create_Itype (E_Array_Subtype, N); - Set_First_Rep_Item (Itype, First_Rep_Item (Typ)); - Set_Convention (Itype, Convention (Typ)); - Set_Depends_On_Private (Itype, Has_Private_Component (Typ)); - Set_Etype (Itype, Base_Type (Typ)); - Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ)); - Set_Is_Aliased (Itype, Is_Aliased (Typ)); - Set_Depends_On_Private (Itype, Depends_On_Private (Typ)); + Set_First_Rep_Item (Itype, First_Rep_Item (Typ)); + Set_Convention (Itype, Convention (Typ)); + Set_Depends_On_Private (Itype, Has_Private_Component (Typ)); + Set_Etype (Itype, Base_Type (Typ)); + Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ)); + Set_Is_Aliased (Itype, Is_Aliased (Typ)); + Set_Depends_On_Private (Itype, Depends_On_Private (Typ)); Copy_Suppress_Status (Index_Check, Typ, Itype); Copy_Suppress_Status (Length_Check, Typ, Itype); @@ -688,22 +687,23 @@ package body Sem_Aggr is Set_Is_Internal (Itype, True); -- A simple optimization: purely positional aggregates of static - -- components should be passed to gigi unexpanded whenever possible, - -- and regardless of the staticness of the bounds themselves. Subse- - -- quent checks in exp_aggr verify that type is not packed, etc. + -- components should be passed to gigi unexpanded whenever possible, and + -- regardless of the staticness of the bounds themselves. Subsequent + -- checks in exp_aggr verify that type is not packed, etc. Set_Size_Known_At_Compile_Time (Itype, Is_Fully_Positional and then Comes_From_Source (N) and then Size_Known_At_Compile_Time (Component_Type (Typ))); - -- We always need a freeze node for a packed array subtype, so that - -- we can build the Packed_Array_Type corresponding to the subtype. - -- If expansion is disabled, the packed array subtype is not built, - -- and we must not generate a freeze node for the type, or else it - -- will appear incomplete to gigi. + -- We always need a freeze node for a packed array subtype, so that we + -- can build the Packed_Array_Type corresponding to the subtype. If + -- expansion is disabled, the packed array subtype is not built, and we + -- must not generate a freeze node for the type, or else it will appear + -- incomplete to gigi. - if Is_Packed (Itype) and then not In_Spec_Expression + if Is_Packed (Itype) + and then not In_Spec_Expression and then Expander_Active then Freeze_Itype (Itype, N); @@ -728,11 +728,10 @@ package body Sem_Aggr is Component_Elmt : Elmt_Id; begin - -- All the components of List are matched against Component and - -- a count is maintained of possible misspellings. When at the - -- end of the analysis there are one or two (not more!) possible - -- misspellings, these misspellings will be suggested as - -- possible correction. + -- All the components of List are matched against Component and a count + -- is maintained of possible misspellings. When at the end of the + -- the analysis there are one or two (not more!) possible misspellings, + -- these misspellings will be suggested as possible correction. Component_Elmt := First_Elmt (Elements); while Nr_Of_Suggestions <= Max_Suggestions @@ -872,7 +871,7 @@ package body Sem_Aggr is Append_To (Exprs, C_Node); P := P + 1; - -- something special for wide strings ??? + -- Something special for wide strings??? end loop; New_N := Make_Aggregate (Loc, Expressions => Exprs); @@ -904,9 +903,9 @@ package body Sem_Aggr is end if; -- Check for aggregates not allowed in configurable run-time mode. - -- We allow all cases of aggregates that do not come from source, - -- since these are all assumed to be small (e.g. bounds of a string - -- literal). We also allow aggregates of types we know to be small. + -- We allow all cases of aggregates that do not come from source, since + -- these are all assumed to be small (e.g. bounds of a string literal). + -- We also allow aggregates of types we know to be small. if not Support_Aggregates_On_Target and then Comes_From_Source (N) @@ -941,10 +940,10 @@ package body Sem_Aggr is -- First a special test, for the case of a positional aggregate -- of characters which can be replaced by a string literal. - -- Do not perform this transformation if this was a string literal - -- to start with, whose components needed constraint checks, or if - -- the component type is non-static, because it will require those - -- checks and be transformed back into an aggregate. + -- Do not perform this transformation if this was a string literal to + -- start with, whose components needed constraint checks, or if the + -- component type is non-static, because it will require those checks + -- and be transformed back into an aggregate. if Number_Dimensions (Typ) = 1 and then Is_Standard_Character_Type (Component_Type (Typ)) @@ -989,10 +988,10 @@ package body Sem_Aggr is Aggr_Resolved : Boolean; Aggr_Typ : constant Entity_Id := Etype (Typ); - -- This is the unconstrained array type, which is the type - -- against which the aggregate is to be resolved. Typ itself - -- is the array type of the context which may not be the same - -- subtype as the subtype for the final aggregate. + -- This is the unconstrained array type, which is the type against + -- which the aggregate is to be resolved. Typ itself is the array + -- type of the context which may not be the same subtype as the + -- subtype for the final aggregate. begin -- In the following we determine whether an others choice is @@ -1002,11 +1001,11 @@ package body Sem_Aggr is -- choice is not allowed. -- If expansion is disabled (generic context, or semantics-only - -- mode) actual subtypes cannot be constructed, and the type of - -- an object may be its unconstrained nominal type. However, if - -- the context is an assignment, we assume that "others" is - -- allowed, because the target of the assignment will have a - -- constrained subtype when fully compiled. + -- mode) actual subtypes cannot be constructed, and the type of an + -- object may be its unconstrained nominal type. However, if the + -- context is an assignment, we assume that "others" is allowed, + -- because the target of the assignment will have a constrained + -- subtype when fully compiled. -- Note that there is no node for Explicit_Actual_Parameter. -- To test for this context we therefore have to test for node @@ -1014,7 +1013,7 @@ package body Sem_Aggr is -- formal parameter. Consequently we also need to test for -- N_Procedure_Call_Statement or N_Function_Call. - Set_Etype (N, Aggr_Typ); -- may be overridden later on + Set_Etype (N, Aggr_Typ); -- May be overridden later on if Is_Constrained (Typ) and then (Pkind = N_Assignment_Statement or else @@ -1080,10 +1079,10 @@ package body Sem_Aggr is Error_Msg_N ("illegal context for aggregate", N); end if; - -- If we can determine statically that the evaluation of the - -- aggregate raises Constraint_Error, then replace the - -- aggregate with an N_Raise_Constraint_Error node, but set the - -- Etype to the right aggregate subtype. Gigi needs this. + -- If we can determine statically that the evaluation of the aggregate + -- raises Constraint_Error, then replace the aggregate with an + -- N_Raise_Constraint_Error node, but set the Etype to the right + -- aggregate subtype. Gigi needs this. if Raises_Constraint_Error (N) then Aggr_Subtyp := Etype (N); @@ -1115,13 +1114,13 @@ package body Sem_Aggr is Index_Typ : constant Entity_Id := Etype (Index); Index_Typ_Low : constant Node_Id := Type_Low_Bound (Index_Typ); Index_Typ_High : constant Node_Id := Type_High_Bound (Index_Typ); - -- The type of the index corresponding to the array sub-aggregate - -- along with its low and upper bounds + -- The type of the index corresponding to the array sub-aggregate along + -- with its low and upper bounds. Index_Base : constant Entity_Id := Base_Type (Index_Typ); Index_Base_Low : constant Node_Id := Type_Low_Bound (Index_Base); Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base); - -- ditto for the base type + -- Ditto for the base type function Add (Val : Uint; To : Node_Id) return Node_Id; -- Creates a new expression node where Val is added to expression To. @@ -1131,16 +1130,16 @@ package body Sem_Aggr is procedure Check_Bound (BH : Node_Id; AH : in out Node_Id); -- Checks that AH (the upper bound of an array aggregate) is <= BH -- (the upper bound of the index base type). If the check fails a - -- warning is emitted, the Raises_Constraint_Error Flag of N is set, + -- warning is emitted, the Raises_Constraint_Error flag of N is set, -- and AH is replaced with a duplicate of BH. procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id); -- Checks that range AL .. AH is compatible with range L .. H. Emits a - -- warning if not and sets the Raises_Constraint_Error Flag in N. + -- warning if not and sets the Raises_Constraint_Error flag in N. procedure Check_Length (L, H : Node_Id; Len : Uint); -- Checks that range L .. H contains at least Len elements. Emits a - -- warning if not and sets the Raises_Constraint_Error Flag in N. + -- warning if not and sets the Raises_Constraint_Error flag in N. function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean; -- Returns True if range L .. H is dynamic or null @@ -1155,11 +1154,10 @@ package body Sem_Aggr is Single_Elmt : Boolean) return Boolean; -- Resolves aggregate expression Expr. Returns False if resolution -- fails. If Single_Elmt is set to False, the expression Expr may be - -- used to initialize several array aggregate elements (this can - -- happen for discrete choices such as "L .. H => Expr" or the others - -- choice). In this event we do not resolve Expr unless expansion is - -- disabled. To know why, see the DELAYED COMPONENT RESOLUTION - -- note above. + -- used to initialize several array aggregate elements (this can happen + -- for discrete choices such as "L .. H => Expr" or the others choice). + -- In this event we do not resolve Expr unless expansion is disabled. + -- To know why, see the DELAYED COMPONENT RESOLUTION note above. --------- -- Add -- @@ -1642,8 +1640,8 @@ package body Sem_Aggr is -- discrete association Prev_Nb_Discrete_Choices : Nat; - -- Used to keep track of the number of discrete choices - -- in the current association. + -- Used to keep track of the number of discrete choices in the + -- current association. begin -- STEP 2 (A): Check discrete choices validity @@ -1690,9 +1688,8 @@ package body Sem_Aggr is Check_Non_Static_Context (Choice); -- Do not range check a choice. This check is redundant - -- since this test is already performed when we check - -- that the bounds of the array aggregate are within - -- range. + -- since this test is already done when we check that the + -- bounds of the array aggregate are within range. Set_Do_Range_Check (Choice, False); end if; @@ -1754,13 +1751,13 @@ package body Sem_Aggr is end if; -- Ada 2005 (AI-287): In case of default initialized component - -- we delay the resolution to the expansion phase + -- we delay the resolution to the expansion phase. if Box_Present (Assoc) then - -- Ada 2005 (AI-287): In case of default initialization - -- of a component the expander will generate calls to - -- the corresponding initialization subprogram. + -- Ada 2005 (AI-287): In case of default initialization of a + -- component the expander will generate calls to the + -- corresponding initialization subprogram. null; @@ -1773,8 +1770,8 @@ package body Sem_Aggr is -- We differentiate here two cases because the expression may -- not be decorated. For example, the analysis and resolution - -- of the expression associated with the others choice will - -- be done later with the full aggregate. In such case we + -- of the expression associated with the others choice will be + -- done later with the full aggregate. In such case we -- duplicate the expression tree to analyze the copy and -- perform the required check. @@ -1810,7 +1807,7 @@ package body Sem_Aggr is end loop; -- If aggregate contains more than one choice then these must be - -- static. Sort them and check that they are contiguous + -- static. Sort them and check that they are contiguous. if Nb_Discrete_Choices > 1 then Sort_Case_Table (Table); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d4f4f51..e37b216 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -667,8 +667,8 @@ package body Sem_Attr is end loop; if Present (Q) then - Set_Has_Per_Object_Constraint ( - Defining_Identifier (Q), True); + Set_Has_Per_Object_Constraint + (Defining_Identifier (Q), True); end if; end; @@ -1991,9 +1991,10 @@ package body Sem_Attr is -- entry wrappers, the attributes Count, Caller and AST_Entry require -- a context check - if Aname = Name_Count - or else Aname = Name_Caller - or else Aname = Name_AST_Entry + if Ada_Version >= Ada_05 + and then (Aname = Name_Count + or else Aname = Name_Caller + or else Aname = Name_AST_Entry) then declare Count : Natural := 0; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index c514206..7dd9629 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -784,7 +784,7 @@ package body Sem_Ch3 is Anon_Type := Create_Itype - (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); + (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); if All_Present (N) and then Ada_Version >= Ada_05 @@ -825,8 +825,7 @@ package body Sem_Ch3 is Find_Type (Subtype_Mark (N)); Desig_Type := Entity (Subtype_Mark (N)); - Set_Directly_Designated_Type - (Anon_Type, Desig_Type); + Set_Directly_Designated_Type (Anon_Type, Desig_Type); Set_Etype (Anon_Type, Anon_Type); -- Make sure the anonymous access type has size and alignment fields @@ -2883,12 +2882,11 @@ package body Sem_Ch3 is Apply_Length_Check (E, T); end if; - -- If the type is limited unconstrained with defaulted discriminants - -- and there is no expression, then the object is constrained by the + -- If the type is limited unconstrained with defaulted discriminants and + -- there is no expression, then the object is constrained by the -- defaults, so it is worthwhile building the corresponding subtype. - elsif (Is_Limited_Record (T) - or else Is_Concurrent_Type (T)) + elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) and then not Is_Constrained (T) and then Has_Discriminants (T) then diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 7273fde..f1004d5 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -33,7 +33,6 @@ with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Sem_Aux; use Sem_Aux; -with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -626,6 +625,56 @@ package body Tbuild is return Occurrence; end New_Occurrence_Of; + ----------------- + -- New_Op_Node -- + ----------------- + + function New_Op_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id + is + type Name_Of_Type is array (N_Op) of Name_Id; + Name_Of : constant Name_Of_Type := Name_Of_Type'( + N_Op_And => Name_Op_And, + N_Op_Or => Name_Op_Or, + N_Op_Xor => Name_Op_Xor, + N_Op_Eq => Name_Op_Eq, + N_Op_Ne => Name_Op_Ne, + N_Op_Lt => Name_Op_Lt, + N_Op_Le => Name_Op_Le, + N_Op_Gt => Name_Op_Gt, + N_Op_Ge => Name_Op_Ge, + N_Op_Add => Name_Op_Add, + N_Op_Subtract => Name_Op_Subtract, + N_Op_Concat => Name_Op_Concat, + N_Op_Multiply => Name_Op_Multiply, + N_Op_Divide => Name_Op_Divide, + N_Op_Mod => Name_Op_Mod, + N_Op_Rem => Name_Op_Rem, + N_Op_Expon => Name_Op_Expon, + N_Op_Plus => Name_Op_Add, + N_Op_Minus => Name_Op_Subtract, + N_Op_Abs => Name_Op_Abs, + N_Op_Not => Name_Op_Not, + + -- We don't really need these shift operators, since they never + -- appear as operators in the source, but the path of least + -- resistance is to put them in (the aggregate must be complete) + + N_Op_Rotate_Left => Name_Rotate_Left, + N_Op_Rotate_Right => Name_Rotate_Right, + N_Op_Shift_Left => Name_Shift_Left, + N_Op_Shift_Right => Name_Shift_Right, + N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); + + Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc); + begin + if New_Node_Kind in Name_Of'Range then + Set_Chars (Nod, Name_Of (New_Node_Kind)); + end if; + return Nod; + end New_Op_Node; + ---------------------- -- New_Reference_To -- ---------------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 261776d..0b73a53 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -27,6 +27,7 @@ -- building specific types of tree nodes. with Namet; use Namet; +with Sinfo; use Sinfo; with Types; use Types; package Tbuild is @@ -196,6 +197,12 @@ package Tbuild is -- "raise Constraint_Error" and returns the root of this tree, -- the N_Raise_Statement node. + function New_Op_Node + (New_Node_Kind : Node_Kind; + New_Sloc : Source_Ptr) return Node_Id; + -- Create node using New_Node and, if its kind is in N_Op, set its Chars + -- field accordingly. + function New_External_Name (Related_Id : Name_Id; Suffix : Character := ' '; |