+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.
a-timoau$(objext) \
a-timoio$(objext) \
a-tiocst$(objext) \
+ a-tirsfi$(objext) \
a-titest$(objext) \
a-tiunio$(objext) \
a-unccon$(objext) \
a-wichun$(objext) \
a-widcha$(objext) \
a-witeio$(objext) \
+ a-wrstfi$(objext) \
a-wtcoau$(objext) \
a-wtcoio$(objext) \
a-wtcstr$(objext) \
a-wwunio$(objext) \
a-zchara$(objext) \
a-zchuni$(objext) \
+ a-zrstfi$(objext) \
a-ztcoau$(objext) \
a-ztcoio$(objext) \
a-ztcstr$(objext) \
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;
-- 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 --
-------------------
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 --
-----------
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 --
-------------
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
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;
with Ada.IO_Exceptions;
with Ada.Streams;
+
with System;
with System.File_Control_Block;
with System.WCh_Con;
-- 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;
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;
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
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)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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
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 --
-------------------
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 --
-------------
-- 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
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
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;
with Ada.IO_Exceptions;
with Ada.Streams;
+
+with Interfaces.C_Streams;
+
with System;
with System.File_Control_Block;
with System.WCh_Con;
-- 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;
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
-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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
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 --
-------------------
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 --
-------------
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
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;
with Ada.IO_Exceptions;
with Ada.Streams;
+
+with Interfaces.C_Streams;
+
with System;
with System.File_Control_Block;
with System.WCh_Con;
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;
-- 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;
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;
-- 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;
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,
-- 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
* 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)::
* 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)::
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})
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})
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})
-- 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 --
-------------------------
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) --
--------------------------
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;
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;
-- 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
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;
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;
Scan; -- past operator
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Term);
- Set_Op_Name (Node2);
Node1 := Node2;
end loop;
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;
Scan; -- past operator
Set_Right_Opnd (Node1, P_Term);
- Set_Op_Name (Node1);
else
Node1 := P_Term;
end if;
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
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;
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;
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;
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;
------------------------
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
-- 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
-- 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);
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);
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);
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
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);
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)
-- 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))
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
-- 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
-- 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
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);
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.
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
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 --
-- 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
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;
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;
-- 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.
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);
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;
-- 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;
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
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
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
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;
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 --
----------------------
-- building specific types of tree nodes.
with Namet; use Namet;
+with Sinfo; use Sinfo;
with Types; use Types;
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 := ' ';
OSDN Git Service
