-- with CONDITION_HANDLING, STARLET, system; use system; -- package body CONTROL_INTERCEPTION is --+---------------------------------------------------------------------- -- -- Unit Type : package body type -- Unit Name : CONTROL_INTERCEPTION.ADA -- Version : V01.00 -- -- Author : Stephen R. Rainier -- Date : 09/03/85 -- -- -- Purpose : To provide the ability for an Ada program to control -- the use of control characters (i.e., C and Y). -- -- Parameters : -- -- Name Mode(I,O,IO) Type/Subtype Description -- ---- ------------ ------------ ------------ -- -- -- -- -- Modifications : -- -- Name Date Description of Change -- ---- ---- --------------------- -- -- -- Packages "WITH"ed : condition_handling, starlet, system -- -- -- Procedure/Function "CALL"s : -- -- -- Exceptions : -- -- Name Handled/Raised Description -- ---- -------------- ----------- -- -- -- -- Side Effects : -- -- -- Comments : -- --%---------------------------------------------------------------------- -- -- Declarations -- subtype TERM_LINE is string (1..80); type SHORT_FORM_TERMINATOR is record L1 : unsigned_longword := 0; MASK : unsigned_longword := 2**character'pos(ascii.etx); end record; FUNC_CODE : STARLET.FUNCTION_CODE_TYPE; TT_CHAN : STARLET.CHANNEL_TYPE; TT_NAME : constant string := "TT:"; STATUS : CONDITION_HANDLING.COND_VALUE_TYPE; TERMINATOR_MASK_C : SHORT_FORM_TERMINATOR; TERMINATOR_MASK_Y : SHORT_FORM_TERMINATOR := (L1 => 0, MASK => starlet.lib_m_cli_ctrly); IOSB : STARLET.IOSB_TYPE; -- Import LIB$ Routines. -- procedure DO_COMMAND(COMMAND : in STRING); pragma interface(VAXRTL, DO_COMMAND); pragma import_procedure(DO_COMMAND, "LIB$DO_COMMAND", mechanism => (DESCRIPTOR(S))); procedure SIGNAL(STATUS : in condition_handling.cond_value_type); pragma interface(VAXRTL, SIGNAL); pragma import_procedure(SIGNAL, "LIB$SIGNAL", mechanism =>(VALUE)); procedure DISABLE_CTRL_Y(VAL : in unsigned_longword := starlet.lib_m_cli_ctrly); pragma interface(VAXRTL, DISABLE_CTRL_Y); pragma import_procedure(DISABLE_CTRL_Y, "LIB$DISABLE_CTRL", mechanism => (reference)); procedure ENABLE_CTRL_Y(VAL : in unsigned_longword := starlet.lib_m_cli_ctrly); pragma interface(VAXRTL, ENABLE_CTRL_Y); pragma import_procedure(ENABLE_CTRL_Y, "LIB$ENABLE_CTRL", mechanism => (reference)); procedure CONTROL_C_HANDLER is -- Control C AST handler procedure TT_CARRIAGE_CONTROL : constant := 16#20#; -- single space LINE : TERM_LINE; CHAR_COUNT : integer; BANNER : constant STRING := ascii.esc&"[24;1f"&"Transfer to DEBUG?"; PROMPT : constant STRING := "[Y/N]> "; LEN : integer := 0; MASTER_PID, PID : system.unsigned_longword := 0; ITEM_LIST : STARLET.ITEM_LIST_TYPE(1..3) := (1 => (BUF_LEN => 4, ITEM_CODE => STARLET.JPI_MASTER_PID, BUF_ADDRESS => MASTER_PID'address, RET_ADDRESS => LEN'address), 2 => (BUF_LEN => 4, ITEM_CODE => STARLET.JPI_PID, BUF_ADDRESS => PID'address, RET_ADDRESS => LEN'address), 3 => (BUF_LEN => 0, ITEM_CODE => 0, BUF_ADDRESS => system.address_zero, RET_ADDRESS => system.address_zero)); begin -- Put out info and prompt for a command -- FUNC_CODE := starlet.io_writelblk or starlet.io_m_newline; STARLET.QIOW(STATUS => STATUS, CHAN => TT_CHAN, FUNC => FUNC_CODE, IOSB => IOSB, P1 => to_unsigned_longword(BANNER'address), P2 => BANNER'length, P3 => 0, P4 => TT_CARRIAGE_CONTROL); if not CONDITION_HANDLING.SUCCESS(STATUS) then SIGNAL(STATUS); end if; loop STARLET.QIOW(STATUS => STATUS, CHAN => TT_CHAN, FUNC => starlet.io_readprompt, IOSB => IOSB, P1 => to_unsigned_longword(LINE'address), P2 => 1, P3 => 0, P4 => 0, P5 => to_unsigned_longword(PROMPT'address), P6 => PROMPT'length); CHAR_COUNT := integer(IOSB.COUNT); if CHAR_COUNT /= 0 then exit; end if; end loop; -- Check for DEBUG, and perform the desired action -- if LINE(1) = 'Y' or LINE(1) = 'y' then -- enter debug -- SIGNAL(starlet.ss_debug); return; else STARLET.GETJPI(STATUS => STATUS, ITMLST => ITEM_LIST); if integer(MASTER_PID) /= integer(PID) then -- exit from subprocesses STARLET.EXI(STATUS => STATUS, CODE => STARLET.SS_NORMAL); end if; return; end if; exception when OTHERS=> raise; end CONTROL_C_HANDLER; procedure CONTROL_Y_HANDLER is -- Control Y AST handler procedure TT_CARRIAGE_CONTROL : constant := 16#20#; -- single space LINE : TERM_LINE; CHAR_COUNT : integer; BANNER : constant STRING := ascii.esc&"[24;1f"&"Transfer to DEBUG?"; PROMPT : constant STRING := "[Y/N]> "; LEN : integer := 0; MASTER_PID, PID : system.unsigned_longword := 0; ITEM_LIST : STARLET.ITEM_LIST_TYPE(1..3) := (1 => (BUF_LEN => 4, ITEM_CODE => STARLET.JPI_MASTER_PID, BUF_ADDRESS => MASTER_PID'address, RET_ADDRESS => LEN'address), 2 => (BUF_LEN => 4, ITEM_CODE => STARLET.JPI_PID, BUF_ADDRESS => PID'address, RET_ADDRESS => LEN'address), 3 => (BUF_LEN => 0, ITEM_CODE => 0, BUF_ADDRESS => system.address_zero, RET_ADDRESS => system.address_zero)); begin -- Put out info and prompt for a command -- FUNC_CODE := starlet.io_writelblk or starlet.io_m_newline; STARLET.QIOW(STATUS => STATUS, CHAN => TT_CHAN, FUNC => FUNC_CODE, IOSB => IOSB, P1 => to_unsigned_longword(BANNER'address), P2 => BANNER'length, P3 => 0, P4 => TT_CARRIAGE_CONTROL); if not CONDITION_HANDLING.SUCCESS(STATUS) then SIGNAL(STATUS); end if; loop STARLET.QIOW(STATUS => STATUS, CHAN => TT_CHAN, FUNC => starlet.io_readprompt, IOSB => IOSB, P1 => to_unsigned_longword(LINE'address), P2 => 1, P3 => 0, P4 => 0, P5 => to_unsigned_longword(PROMPT'address), P6 => PROMPT'length); CHAR_COUNT := integer(IOSB.COUNT); if CHAR_COUNT /= 0 then exit; end if; end loop; -- Check for DEBUG, and perform the desired action -- if LINE(1) = 'Y' or LINE(1) = 'y' then -- enter debug -- ENABLE_CTRL_Y; SIGNAL(starlet.ss_debug); DISABLE_CTRL_Y; return; else STARLET.GETJPI(STATUS => STATUS, ITMLST => ITEM_LIST); if integer(MASTER_PID) /= integer(PID) then -- exit from subprocesses STARLET.EXI(STATUS => STATUS, CODE => STARLET.SS_NORMAL); end if; return; end if; exception when OTHERS=> raise; end CONTROL_Y_HANDLER; -- Export CONTROL_x_HANDLER so 'ADDRESS is non-zero -- pragma export_procedure (CONTROL_C_HANDLER, "ADA$CONTROL_C_HANDLER"); pragma export_procedure (CONTROL_Y_HANDLER, "ADA$CONTROL_Y_HANDLER"); begin -- body of package CONTROL_INTERCEPTION begin -- Establish a ^C/^Y handler -- DISABLE_CTRL_Y; STARLET.ASSIGN(STATUS => STATUS, DEVNAM => TT_NAME, CHAN => TT_CHAN); if not CONDITION_HANDLING.SUCCESS(STATUS) then SIGNAL(STATUS); end if; STARLET.QIOW (STATUS => STATUS, CHAN => TT_CHAN, FUNC => STARLET.IO_SETMODE or STARLET.IO_M_OUTBAND, IOSB => IOSB, P1 => to_unsigned_longword(CONTROL_C_HANDLER'address), P2 => to_unsigned_longword(TERMINATOR_MASK_C'address)); if not CONDITION_HANDLING.SUCCESS(STATUS) then SIGNAL(STATUS); end if; STARLET.QIOW(STATUS => STATUS, CHAN => TT_CHAN, FUNC => STARLET.IO_SETMODE or STARLET.IO_M_OUTBAND, IOSB => IOSB, P1 => to_unsigned_longword(CONTROL_Y_HANDLER'address), P2 => to_unsigned_longword(TERMINATOR_MASK_Y'address)); if not CONDITION_HANDLING.SUCCESS(STATUS) then SIGNAL(STATUS); end if; exception when others => null; end; end CONTROL_INTERCEPTION;