[multiple changes]
2011-11-23 Robert Dewar <dewar@adacore.com> * exp_util.adb, par-ch6.adb, sem_res.adb, par-util.adb: Minor reformatting. 2011-11-23 Yannick Moy <moy@adacore.com> * sem_ch13.adb (Analyze_Aspect_Specifications): Place error on line of precondition/ postcondition/invariant. 2011-11-23 Pascal Obry <obry@adacore.com> * g-exptty.ads, g-exptty.adb, g-tty.ads, g-tty.adb, terminals.c: New files. Makefile.rtl: Add these new files. * gnat_rm.texi: Add documentation for GNAT.Expect.TTY. * gcc-interface/Makefile.in: Add g-exptty, g-tty, terminals.o * gcc-interface/Make-lang.in: Update dependencies. From-SVN: r181655
This commit is contained in:
Arnaud Charlet
parent
bd8aaa863d
commit
95160516ff
@ -1,7 +1,24 @@
|
||||
2011-11-23 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* exp_util.adb, par-ch6.adb, sem_res.adb, par-util.adb: Minor
|
||||
reformatting.
|
||||
|
||||
2011-11-23 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* sem_ch13.adb (Analyze_Aspect_Specifications): Place error on
|
||||
line of precondition/ postcondition/invariant.
|
||||
2011-11-23 Pascal Obry <obry@adacore.com>
|
||||
|
||||
* g-exptty.ads, g-exptty.adb, g-tty.ads, g-tty.adb,
|
||||
terminals.c: New files.
|
||||
Makefile.rtl: Add these new files.
|
||||
* gnat_rm.texi: Add documentation for GNAT.Expect.TTY.
|
||||
* gcc-interface/Makefile.in: Add g-exptty, g-tty, terminals.o
|
||||
* gcc-interface/Make-lang.in: Update dependencies.
|
||||
|
||||
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* exp_imgv.adb (Expand_Width_Attribute): Handle case of
|
||||
Discard_Names.
|
||||
* exp_imgv.adb (Expand_Width_Attribute): Handle case of Discard_Names.
|
||||
* sem_attr.adb (Eval_Attribute, case Width): Ditto.
|
||||
|
||||
2011-11-21 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
@ -404,6 +404,7 @@ GNATRTL_NONTASKING_OBJS= \
|
||||
g-except$(objext) \
|
||||
g-exctra$(objext) \
|
||||
g-expect$(objext) \
|
||||
g-exptty$(objext) \
|
||||
g-flocon$(objext) \
|
||||
g-heasor$(objext) \
|
||||
g-hesora$(objext) \
|
||||
@ -450,6 +451,7 @@ GNATRTL_NONTASKING_OBJS= \
|
||||
g-timsta$(objext) \
|
||||
g-traceb$(objext) \
|
||||
g-trasym$(objext) \
|
||||
g-tty$(objext) \
|
||||
g-u3spch$(objext) \
|
||||
g-utf_32$(objext) \
|
||||
g-wispch$(objext) \
|
||||
|
||||
@ -6425,13 +6425,12 @@ package body Exp_Util is
|
||||
-- a run-time issue, and the removal is required only to get proper
|
||||
-- behavior at run-time.
|
||||
|
||||
-- In the Alfa case, we don't need to remove side effects because we
|
||||
-- only perform formal verification is performed only on expressions
|
||||
-- that are provably side-effect free. If we tried to remove side
|
||||
-- effects in the Alfa case, we would get into a mess since in the case
|
||||
-- of limited types in particular, removal of side effects involves the
|
||||
-- use of access types or references which are not permitted in Alfa
|
||||
-- mode.
|
||||
-- In the Alfa case, we don't need to remove side effects because formal
|
||||
-- verification is performed only on expressions that are provably
|
||||
-- side-effect free. If we tried to remove side effects in the Alfa
|
||||
-- case, we would get into a mess since in the case of limited types in
|
||||
-- particular, removal of side effects involves the use of access types
|
||||
-- or references which are not permitted in Alfa mode.
|
||||
|
||||
if not Full_Expander_Active then
|
||||
return;
|
||||
|
||||
309
gcc/ada/g-exptty.adb
Normal file
309
gcc/ada/g-exptty.adb
Normal file
@ -0,0 +1,309 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . E X P E C T . T T Y --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2000-2011, AdaCore --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
||||
|
||||
with System; use System;
|
||||
|
||||
package body GNAT.Expect.TTY is
|
||||
|
||||
On_Windows : constant Boolean := Directory_Separator = '\';
|
||||
-- True when on Windows
|
||||
|
||||
-----------
|
||||
-- Close --
|
||||
-----------
|
||||
|
||||
overriding procedure Close
|
||||
(Descriptor : in out TTY_Process_Descriptor;
|
||||
Status : out Integer)
|
||||
is
|
||||
procedure Terminate_Process (Process : System.Address);
|
||||
pragma Import (C, Terminate_Process, "__gnat_terminate_process");
|
||||
|
||||
function Waitpid (Process : System.Address) return Integer;
|
||||
pragma Import (C, Waitpid, "__gnat_waitpid");
|
||||
-- Wait for a specific process id, and return its exit code
|
||||
|
||||
procedure Free_Process (Process : System.Address);
|
||||
pragma Import (C, Free_Process, "__gnat_free_process");
|
||||
|
||||
procedure Close_TTY (Process : System.Address);
|
||||
pragma Import (C, Close_TTY, "__gnat_close_tty");
|
||||
|
||||
begin
|
||||
-- If we haven't already closed the process
|
||||
|
||||
if Descriptor.Process = System.Null_Address then
|
||||
Status := -1;
|
||||
|
||||
else
|
||||
if Descriptor.Input_Fd /= Invalid_FD then
|
||||
Close (Descriptor.Input_Fd);
|
||||
end if;
|
||||
|
||||
if Descriptor.Error_Fd /= Descriptor.Output_Fd
|
||||
and then Descriptor.Error_Fd /= Invalid_FD
|
||||
then
|
||||
Close (Descriptor.Error_Fd);
|
||||
end if;
|
||||
|
||||
if Descriptor.Output_Fd /= Invalid_FD then
|
||||
Close (Descriptor.Output_Fd);
|
||||
end if;
|
||||
|
||||
-- Send a Ctrl-C to the process first. This way, if the
|
||||
-- launched process is a "sh" or "cmd", the child processes
|
||||
-- will get terminated as well. Otherwise, terminating the
|
||||
-- main process brutally will leave the children running.
|
||||
|
||||
Interrupt (Descriptor);
|
||||
delay 0.05;
|
||||
|
||||
Terminate_Process (Descriptor.Process);
|
||||
Status := Waitpid (Descriptor.Process);
|
||||
|
||||
if not On_Windows then
|
||||
Close_TTY (Descriptor.Process);
|
||||
end if;
|
||||
|
||||
Free_Process (Descriptor.Process'Address);
|
||||
Descriptor.Process := System.Null_Address;
|
||||
|
||||
GNAT.OS_Lib.Free (Descriptor.Buffer);
|
||||
Descriptor.Buffer_Size := 0;
|
||||
end if;
|
||||
end Close;
|
||||
|
||||
overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is
|
||||
Status : Integer;
|
||||
begin
|
||||
Close (Descriptor, Status);
|
||||
end Close;
|
||||
|
||||
-----------------------------
|
||||
-- Close_Pseudo_Descriptor --
|
||||
-----------------------------
|
||||
|
||||
procedure Close_Pseudo_Descriptor
|
||||
(Descriptor : in out TTY_Process_Descriptor)
|
||||
is
|
||||
begin
|
||||
Descriptor.Buffer_Size := 0;
|
||||
GNAT.OS_Lib.Free (Descriptor.Buffer);
|
||||
end Close_Pseudo_Descriptor;
|
||||
|
||||
---------------
|
||||
-- Interrupt --
|
||||
---------------
|
||||
|
||||
overriding procedure Interrupt
|
||||
(Descriptor : in out TTY_Process_Descriptor)
|
||||
is
|
||||
procedure Internal (Process : System.Address);
|
||||
pragma Import (C, Internal, "__gnat_interrupt_process");
|
||||
begin
|
||||
if Descriptor.Process /= System.Null_Address then
|
||||
Internal (Descriptor.Process);
|
||||
end if;
|
||||
end Interrupt;
|
||||
|
||||
procedure Interrupt (Pid : Integer) is
|
||||
procedure Internal (Pid : Integer);
|
||||
pragma Import (C, Internal, "__gnat_interrupt_pid");
|
||||
begin
|
||||
Internal (Pid);
|
||||
end Interrupt;
|
||||
|
||||
-----------------------
|
||||
-- Pseudo_Descriptor --
|
||||
-----------------------
|
||||
|
||||
procedure Pseudo_Descriptor
|
||||
(Descriptor : out TTY_Process_Descriptor'Class;
|
||||
TTY : GNAT.TTY.TTY_Handle;
|
||||
Buffer_Size : Natural := 4096) is
|
||||
begin
|
||||
Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY);
|
||||
Descriptor.Output_Fd := Descriptor.Input_Fd;
|
||||
|
||||
-- Create the buffer
|
||||
|
||||
Descriptor.Buffer_Size := Buffer_Size;
|
||||
|
||||
if Buffer_Size /= 0 then
|
||||
Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
|
||||
end if;
|
||||
end Pseudo_Descriptor;
|
||||
|
||||
----------
|
||||
-- Send --
|
||||
----------
|
||||
|
||||
overriding procedure Send
|
||||
(Descriptor : in out TTY_Process_Descriptor;
|
||||
Str : String;
|
||||
Add_LF : Boolean := True;
|
||||
Empty_Buffer : Boolean := False)
|
||||
is
|
||||
Header : String (1 .. 5);
|
||||
Length : Natural;
|
||||
Ret : Natural;
|
||||
|
||||
procedure Internal
|
||||
(Process : System.Address;
|
||||
S : in out String;
|
||||
Length : Natural;
|
||||
Ret : out Natural);
|
||||
pragma Import (C, Internal, "__gnat_send_header");
|
||||
|
||||
begin
|
||||
Length := Str'Length;
|
||||
|
||||
if Add_LF then
|
||||
Length := Length + 1;
|
||||
end if;
|
||||
|
||||
Internal (Descriptor.Process, Header, Length, Ret);
|
||||
|
||||
if Ret = 1 then
|
||||
|
||||
-- Need to use the header
|
||||
|
||||
GNAT.Expect.Send
|
||||
(Process_Descriptor (Descriptor),
|
||||
Header & Str, Add_LF, Empty_Buffer);
|
||||
|
||||
else
|
||||
GNAT.Expect.Send
|
||||
(Process_Descriptor (Descriptor),
|
||||
Str, Add_LF, Empty_Buffer);
|
||||
end if;
|
||||
end Send;
|
||||
|
||||
--------------
|
||||
-- Set_Size --
|
||||
--------------
|
||||
|
||||
procedure Set_Size
|
||||
(Descriptor : in out TTY_Process_Descriptor'Class;
|
||||
Rows : Natural;
|
||||
Columns : Natural)
|
||||
is
|
||||
procedure Internal (Process : System.Address; R, C : Integer);
|
||||
pragma Import (C, Internal, "__gnat_setup_winsize");
|
||||
begin
|
||||
if Descriptor.Process /= System.Null_Address then
|
||||
Internal (Descriptor.Process, Rows, Columns);
|
||||
end if;
|
||||
end Set_Size;
|
||||
|
||||
---------------------------
|
||||
-- Set_Up_Communications --
|
||||
---------------------------
|
||||
|
||||
overriding procedure Set_Up_Communications
|
||||
(Pid : in out TTY_Process_Descriptor;
|
||||
Err_To_Out : Boolean;
|
||||
Pipe1 : access Pipe_Type;
|
||||
Pipe2 : access Pipe_Type;
|
||||
Pipe3 : access Pipe_Type)
|
||||
is
|
||||
pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
|
||||
|
||||
function Internal (Process : System.Address) return Integer;
|
||||
pragma Import (C, Internal, "__gnat_setup_communication");
|
||||
|
||||
begin
|
||||
if Internal (Pid.Process'Address) /= 0 then
|
||||
raise Invalid_Process with "cannot setup communication.";
|
||||
end if;
|
||||
end Set_Up_Communications;
|
||||
|
||||
---------------------------------
|
||||
-- Set_Up_Child_Communications --
|
||||
---------------------------------
|
||||
|
||||
overriding procedure Set_Up_Child_Communications
|
||||
(Pid : in out TTY_Process_Descriptor;
|
||||
Pipe1 : in out Pipe_Type;
|
||||
Pipe2 : in out Pipe_Type;
|
||||
Pipe3 : in out Pipe_Type;
|
||||
Cmd : String;
|
||||
Args : System.Address)
|
||||
is
|
||||
pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);
|
||||
function Internal
|
||||
(Process : System.Address; Argv : System.Address; Use_Pipes : Integer)
|
||||
return Process_Id;
|
||||
pragma Import (C, Internal, "__gnat_setup_child_communication");
|
||||
|
||||
begin
|
||||
Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));
|
||||
end Set_Up_Child_Communications;
|
||||
|
||||
----------------------------------
|
||||
-- Set_Up_Parent_Communications --
|
||||
----------------------------------
|
||||
|
||||
overriding procedure Set_Up_Parent_Communications
|
||||
(Pid : in out TTY_Process_Descriptor;
|
||||
Pipe1 : in out Pipe_Type;
|
||||
Pipe2 : in out Pipe_Type;
|
||||
Pipe3 : in out Pipe_Type)
|
||||
is
|
||||
pragma Unreferenced (Pipe1, Pipe2, Pipe3);
|
||||
|
||||
procedure Internal
|
||||
(Process : System.Address;
|
||||
Inputfp : out File_Descriptor;
|
||||
Outputfp : out File_Descriptor;
|
||||
Errorfp : out File_Descriptor;
|
||||
Pid : out Process_Id);
|
||||
pragma Import (C, Internal, "__gnat_setup_parent_communication");
|
||||
|
||||
begin
|
||||
Internal
|
||||
(Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);
|
||||
end Set_Up_Parent_Communications;
|
||||
|
||||
-------------------
|
||||
-- Set_Use_Pipes --
|
||||
-------------------
|
||||
|
||||
procedure Set_Use_Pipes
|
||||
(Descriptor : in out TTY_Process_Descriptor;
|
||||
Use_Pipes : Boolean) is
|
||||
begin
|
||||
Descriptor.Use_Pipes := Use_Pipes;
|
||||
end Set_Use_Pipes;
|
||||
|
||||
end GNAT.Expect.TTY;
|
||||
128
gcc/ada/g-exptty.ads
Normal file
128
gcc/ada/g-exptty.ads
Normal file
@ -0,0 +1,128 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . E X P E C T . T T Y --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2000-2011, AdaCore --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with GNAT.TTY;
|
||||
|
||||
with System;
|
||||
|
||||
package GNAT.Expect.TTY is
|
||||
|
||||
------------------
|
||||
-- TTY_Process --
|
||||
------------------
|
||||
|
||||
type TTY_Process_Descriptor is new Process_Descriptor with private;
|
||||
-- Similar to Process_Descriptor, with the parent set up as a full terminal
|
||||
-- (Unix sense, see tty(4)).
|
||||
|
||||
procedure Pseudo_Descriptor
|
||||
(Descriptor : out TTY_Process_Descriptor'Class;
|
||||
TTY : GNAT.TTY.TTY_Handle;
|
||||
Buffer_Size : Natural := 4096);
|
||||
-- Given a terminal descriptor (TTY), create a pseudo process descriptor
|
||||
-- to be used with GNAT.Expect.
|
||||
--
|
||||
-- Note that it is invalid to call Close, Interrupt, Send_Signal on the
|
||||
-- resulting descriptor. To deallocate memory associated with Process,
|
||||
-- call Close_Pseudo_Descriptor instead.
|
||||
|
||||
procedure Close_Pseudo_Descriptor
|
||||
(Descriptor : in out TTY_Process_Descriptor);
|
||||
-- Free memory and ressources associated with Descriptor. Will *not*
|
||||
-- close the associated TTY, it is the caller's responsibility to call
|
||||
-- GNAT.TTY.Close_TTY.
|
||||
|
||||
procedure Interrupt (Pid : Integer);
|
||||
-- Interrupt a process given its pid
|
||||
|
||||
overriding procedure Send
|
||||
(Descriptor : in out TTY_Process_Descriptor;
|
||||
Str : String;
|
||||
Add_LF : Boolean := True;
|
||||
Empty_Buffer : Boolean := False);
|
||||
-- See parent
|
||||
-- What does that comment mean??? what is "parent" here
|
||||
|
||||
procedure Set_Use_Pipes
|
||||
(Descriptor : in out TTY_Process_Descriptor;
|
||||
Use_Pipes : Boolean);
|
||||
-- Tell Expect.TTY whether to use Pipes or Console (on windows). Needs to
|
||||
-- be set before spawning the process. Default is to use Pipes.
|
||||
|
||||
procedure Set_Size
|
||||
(Descriptor : in out TTY_Process_Descriptor'Class;
|
||||
Rows : Natural;
|
||||
Columns : Natural);
|
||||
-- Sets up the size of the terminal as reported to the spawned process
|
||||
|
||||
private
|
||||
|
||||
-- All declarations in the private part must be fully commented ???
|
||||
|
||||
overriding procedure Close
|
||||
(Descriptor : in out TTY_Process_Descriptor;
|
||||
Status : out Integer);
|
||||
|
||||
overriding procedure Close
|
||||
(Descriptor : in out TTY_Process_Descriptor);
|
||||
|
||||
overriding procedure Interrupt (Descriptor : in out TTY_Process_Descriptor);
|
||||
-- When we use pseudo-terminals, we do not need to use signals to
|
||||
-- interrupt the debugger, we can simply send the appropriate character.
|
||||
-- This provides a better support for remote debugging for instance.
|
||||
|
||||
procedure Set_Up_Communications
|
||||
(Pid : in out TTY_Process_Descriptor;
|
||||
Err_To_Out : Boolean;
|
||||
Pipe1 : access Pipe_Type;
|
||||
Pipe2 : access Pipe_Type;
|
||||
Pipe3 : access Pipe_Type);
|
||||
|
||||
procedure Set_Up_Parent_Communications
|
||||
(Pid : in out TTY_Process_Descriptor;
|
||||
Pipe1 : in out Pipe_Type;
|
||||
Pipe2 : in out Pipe_Type;
|
||||
Pipe3 : in out Pipe_Type);
|
||||
|
||||
procedure Set_Up_Child_Communications
|
||||
(Pid : in out TTY_Process_Descriptor;
|
||||
Pipe1 : in out Pipe_Type;
|
||||
Pipe2 : in out Pipe_Type;
|
||||
Pipe3 : in out Pipe_Type;
|
||||
Cmd : String;
|
||||
Args : System.Address);
|
||||
|
||||
type TTY_Process_Descriptor is new Process_Descriptor with record
|
||||
Process : System.Address; -- Underlying structure used in C
|
||||
Use_Pipes : Boolean := True;
|
||||
end record;
|
||||
|
||||
end GNAT.Expect.TTY;
|
||||
134
gcc/ada/g-tty.adb
Normal file
134
gcc/ada/g-tty.adb
Normal file
@ -0,0 +1,134 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . T T Y --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2002-2011, AdaCore --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Interfaces.C.Strings; use Interfaces.C.Strings;
|
||||
|
||||
package body GNAT.TTY is
|
||||
|
||||
use System;
|
||||
|
||||
procedure Check_TTY (Handle : TTY_Handle);
|
||||
-- Check the validity of Handle. Raise Program_Error if ttys are not
|
||||
-- supported. Raise Constraint_Error if Handle is an invalid handle.
|
||||
|
||||
------------------
|
||||
-- Allocate_TTY --
|
||||
------------------
|
||||
|
||||
procedure Allocate_TTY (Handle : out TTY_Handle) is
|
||||
function Internal return System.Address;
|
||||
pragma Import (C, Internal, "__gnat_new_tty");
|
||||
|
||||
begin
|
||||
if not TTY_Supported then
|
||||
raise Program_Error;
|
||||
end if;
|
||||
|
||||
Handle.Handle := Internal;
|
||||
end Allocate_TTY;
|
||||
|
||||
---------------
|
||||
-- Check_TTY --
|
||||
---------------
|
||||
|
||||
procedure Check_TTY (Handle : TTY_Handle) is
|
||||
begin
|
||||
if not TTY_Supported then
|
||||
raise Program_Error;
|
||||
elsif Handle.Handle = System.Null_Address then
|
||||
raise Constraint_Error;
|
||||
end if;
|
||||
end Check_TTY;
|
||||
|
||||
---------------
|
||||
-- Close_TTY --
|
||||
---------------
|
||||
|
||||
procedure Close_TTY (Handle : in out TTY_Handle) is
|
||||
procedure Internal (Handle : System.Address);
|
||||
pragma Import (C, Internal, "__gnat_close_tty");
|
||||
begin
|
||||
Check_TTY (Handle);
|
||||
Internal (Handle.Handle);
|
||||
Handle.Handle := System.Null_Address;
|
||||
end Close_TTY;
|
||||
|
||||
---------------
|
||||
-- Reset_TTY --
|
||||
---------------
|
||||
|
||||
procedure Reset_TTY (Handle : TTY_Handle) is
|
||||
procedure Internal (Handle : System.Address);
|
||||
pragma Import (C, Internal, "__gnat_reset_tty");
|
||||
begin
|
||||
Check_TTY (Handle);
|
||||
Internal (Handle.Handle);
|
||||
end Reset_TTY;
|
||||
|
||||
--------------------
|
||||
-- TTY_Descriptor --
|
||||
--------------------
|
||||
|
||||
function TTY_Descriptor
|
||||
(Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor
|
||||
is
|
||||
function Internal
|
||||
(Handle : System.Address) return GNAT.OS_Lib.File_Descriptor;
|
||||
pragma Import (C, Internal, "__gnat_tty_fd");
|
||||
begin
|
||||
Check_TTY (Handle);
|
||||
return Internal (Handle.Handle);
|
||||
end TTY_Descriptor;
|
||||
|
||||
--------------
|
||||
-- TTY_Name --
|
||||
--------------
|
||||
|
||||
function TTY_Name (Handle : TTY_Handle) return String is
|
||||
function Internal (Handle : System.Address) return chars_ptr;
|
||||
pragma Import (C, Internal, "__gnat_tty_name");
|
||||
begin
|
||||
Check_TTY (Handle);
|
||||
return Value (Internal (Handle.Handle));
|
||||
end TTY_Name;
|
||||
|
||||
-------------------
|
||||
-- TTY_Supported --
|
||||
-------------------
|
||||
|
||||
function TTY_Supported return Boolean is
|
||||
function Internal return Integer;
|
||||
pragma Import (C, Internal, "__gnat_tty_supported");
|
||||
begin
|
||||
return Internal /= 0;
|
||||
end TTY_Supported;
|
||||
|
||||
end GNAT.TTY;
|
||||
73
gcc/ada/g-tty.ads
Normal file
73
gcc/ada/g-tty.ads
Normal file
@ -0,0 +1,73 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . T T Y --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2002-2011, AdaCore --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- 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 control over pseudo terminals (ttys)
|
||||
|
||||
-- This package is only supported on unix systems. See function TTY_Supported
|
||||
-- to test dynamically whether other functions of this package can be called.
|
||||
|
||||
with System;
|
||||
|
||||
with GNAT.OS_Lib;
|
||||
|
||||
package GNAT.TTY is
|
||||
|
||||
type TTY_Handle is private;
|
||||
-- Handle for a tty descriptor
|
||||
|
||||
function TTY_Supported return Boolean;
|
||||
-- If True, the other functions of this package can be called. Otherwise,
|
||||
-- all functions in this package will raise Program_Error if called.
|
||||
|
||||
procedure Allocate_TTY (Handle : out TTY_Handle);
|
||||
-- Allocate a new tty
|
||||
|
||||
procedure Reset_TTY (Handle : TTY_Handle);
|
||||
-- Reset settings of a given tty
|
||||
|
||||
procedure Close_TTY (Handle : in out TTY_Handle);
|
||||
-- Close a given tty
|
||||
|
||||
function TTY_Name (Handle : TTY_Handle) return String;
|
||||
-- Return the external name of a tty. The name depends on the tty handling
|
||||
-- on the given target. It will typically look like: "/dev/ptya1"
|
||||
|
||||
function TTY_Descriptor
|
||||
(Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor;
|
||||
-- Return the low level descriptor associated with Handle
|
||||
|
||||
private
|
||||
|
||||
type TTY_Handle is record
|
||||
Handle : System.Address := System.Null_Address;
|
||||
end record;
|
||||
|
||||
end GNAT.TTY;
|
||||
@ -2617,9 +2617,9 @@ ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
|
||||
ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
|
||||
ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \
|
||||
ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
|
||||
ada/opt.ads ada/output.ads ada/put_alfa.ads ada/restrict.ads \
|
||||
ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \
|
||||
ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \
|
||||
ada/opt.ads ada/opt.adb ada/output.ads ada/put_alfa.ads \
|
||||
ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
|
||||
ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \
|
||||
ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \
|
||||
ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \
|
||||
ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \
|
||||
|
||||
@ -2213,12 +2213,13 @@ LIBGNAT_SRCS = adadecode.c adadecode.h adaint.c adaint.h \
|
||||
argv.c cio.c cstreams.c errno.c exit.c cal.c ctrl_c.c env.c env.h \
|
||||
arit64.c raise.h raise.c sysdep.c aux-io.c init.c initialize.c \
|
||||
locales.c seh_init.c final.c tracebak.c tb-alvms.c tb-alvxw.c \
|
||||
tb-gcc.c expect.c mkdir.c socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS)
|
||||
tb-gcc.c expect.c mkdir.c socket.c gsocket.h targext.c \
|
||||
terminals.c $(EXTRA_LIBGNAT_SRCS)
|
||||
|
||||
LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \
|
||||
errno.o exit.o env.o raise.o sysdep.o aux-io.o init.o initialize.o \
|
||||
locales.o seh_init.o cal.o arit64.o final.o tracebak.o expect.o \
|
||||
mkdir.o socket.o targext.o $(EXTRA_LIBGNAT_OBJS)
|
||||
mkdir.o socket.o targext.o terminals.o $(EXTRA_LIBGNAT_OBJS)
|
||||
|
||||
# NOTE ??? - when the -I option for compiling Ada code is made to work,
|
||||
# the library installation will change and there will be a
|
||||
@ -2859,6 +2860,7 @@ socket.o : socket.c gsocket.h
|
||||
sysdep.o : sysdep.c
|
||||
raise.o : raise.c raise.h
|
||||
sigtramp-ppcvxw.o : sigtramp-ppcvxw.c sigtramp.h
|
||||
terminals.o : terminals.c
|
||||
vx_stack_info.o : vx_stack_info.c
|
||||
|
||||
raise-gcc.o : raise-gcc.c raise.h
|
||||
|
||||
@ -374,6 +374,7 @@ The GNAT Library
|
||||
* GNAT.Exception_Traces (g-exctra.ads)::
|
||||
* GNAT.Exceptions (g-except.ads)::
|
||||
* GNAT.Expect (g-expect.ads)::
|
||||
* GNAT.Expect.TTY (g-exptty.ads)::
|
||||
* GNAT.Float_Control (g-flocon.ads)::
|
||||
* GNAT.Heap_Sort (g-heasor.ads)::
|
||||
* GNAT.Heap_Sort_A (g-hesora.ads)::
|
||||
@ -14187,6 +14188,7 @@ of GNAT, and will generate a warning message.
|
||||
* GNAT.Exception_Traces (g-exctra.ads)::
|
||||
* GNAT.Exceptions (g-except.ads)::
|
||||
* GNAT.Expect (g-expect.ads)::
|
||||
* GNAT.Expect.TTY (g-exptty.ads)::
|
||||
* GNAT.Float_Control (g-flocon.ads)::
|
||||
* GNAT.Heap_Sort (g-heasor.ads)::
|
||||
* GNAT.Heap_Sort_A (g-hesora.ads)::
|
||||
@ -15054,6 +15056,16 @@ is implemented on all native GNAT ports except for OpenVMS@.
|
||||
It is not implemented for cross ports, and in particular is not
|
||||
implemented for VxWorks or LynxOS@.
|
||||
|
||||
@node GNAT.Expect.TTY (g-exptty.ads)
|
||||
@section @code{GNAT.Expect.TTY} (@file{g-exptty.ads})
|
||||
@cindex @code{GNAT.Expect.TTY} (@file{g-exptty.ads})
|
||||
|
||||
@noindent
|
||||
As GNAT.Expect but using pseudo-terminal.
|
||||
Currently @code{GNAT.Expect.TTY} is implemented on all native GNAT
|
||||
ports except for OpenVMS@. It is not implemented for cross ports, and
|
||||
in particular is not implemented for VxWorks or LynxOS@.
|
||||
|
||||
@node GNAT.Float_Control (g-flocon.ads)
|
||||
@section @code{GNAT.Float_Control} (@file{g-flocon.ads})
|
||||
@cindex @code{GNAT.Float_Control} (@file{g-flocon.ads})
|
||||
|
||||
@ -1681,7 +1681,7 @@ package body Ch6 is
|
||||
|
||||
if Ada_Version < Ada_2012 then
|
||||
Error_Msg_SC -- CODEFIX
|
||||
("ALIASED not allowed in extended return in Ada2012?");
|
||||
("ALIASED not allowed in extended return in Ada 2012?");
|
||||
else
|
||||
Error_Msg_SC -- CODEFIX
|
||||
("ALIASED not allowed in extended return");
|
||||
|
||||
@ -174,7 +174,7 @@ package body Util is
|
||||
|
||||
procedure Check_Future_Keyword is
|
||||
begin
|
||||
-- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
|
||||
-- Ada 2005 (AI-284): Compiling in Ada 95 mode we warn that INTERFACE,
|
||||
-- OVERRIDING, and SYNCHRONIZED are new reserved words.
|
||||
|
||||
if Ada_Version = Ada_95
|
||||
|
||||
@ -728,8 +728,9 @@ package body Sem_Ch13 is
|
||||
A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
|
||||
Anod : Node_Id;
|
||||
|
||||
Eloc : Source_Ptr := Sloc (Expr);
|
||||
-- Source location of expression, modified when we split PPC's
|
||||
Eloc : Source_Ptr := No_Location;
|
||||
-- Source location of expression, modified when we split PPC's. It
|
||||
-- is set below when Expr is present.
|
||||
|
||||
procedure Check_False_Aspect_For_Derived_Type;
|
||||
-- This procedure checks for the case of a false aspect for a
|
||||
@ -804,6 +805,18 @@ package body Sem_Ch13 is
|
||||
goto Continue;
|
||||
end if;
|
||||
|
||||
-- Set the source location of expression, used in the case of
|
||||
-- a failed precondition/postcondition or invariant. Note that
|
||||
-- the source location of the expression is not usually the best
|
||||
-- choice here. For example, it gets located on the last AND
|
||||
-- keyword in a chain of boolean expressiond AND'ed together.
|
||||
-- It is best to put the message on the first character of the
|
||||
-- assertion, which is the effect of the First_Node call here.
|
||||
|
||||
if Present (Expr) then
|
||||
Eloc := Sloc (First_Node (Expr));
|
||||
end if;
|
||||
|
||||
-- Check restriction No_Implementation_Aspect_Specifications
|
||||
|
||||
if Impl_Defined_Aspects (A_Id) then
|
||||
|
||||
@ -2811,7 +2811,7 @@ package body Sem_Res is
|
||||
-- default expression mode (the Freeze_Expression routine tests this
|
||||
-- flag and only freezes static types if it is set).
|
||||
|
||||
-- AI05-177 (Ada2012): Expression functions do not freeze. Only
|
||||
-- Ada 2012 (AI05-177): Expression functions do not freeze. Only
|
||||
-- their use (in an expanded call) freezes.
|
||||
|
||||
if Ekind (Current_Scope) /= E_Function
|
||||
|
||||
1551
gcc/ada/terminals.c
Normal file
1551
gcc/ada/terminals.c
Normal file
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user